Index: /palm/trunk/SOURCE/Makefile
===================================================================
--- /palm/trunk/SOURCE/Makefile	(revision 1849)
+++ /palm/trunk/SOURCE/Makefile	(revision 1850)
@@ -21,4 +21,6 @@
 # ------------------
 # Adapted for modularization of microphysics 
+# Several files renamed --> _mod
+# Bugfix for previous commit
 # 
 # Former revisions:
@@ -259,19 +261,19 @@
 PROG =  palm
 
-SOURCES = advec_s_bc.f90 advec_s_pw.f90 advec_s_up.f90 advec_ws.f90 \
-	advec_u_pw.f90 advec_u_up.f90 advec_v_pw.f90 advec_v_up.f90 \
-	advec_w_pw.f90 advec_w_up.f90 average_3d_data.f90 boundary_conds.f90 \
-	buoyancy.f90 calc_liquid_water_content.f90 calc_mean_profile.f90 \
-	calc_radiation.f90 \
+SOURCES = advec_s_bc_mod.f90 advec_s_pw_mod.f90 advec_s_up_mod.f90 advec_ws_mod.f90 \
+	advec_u_pw_mod.f90 advec_u_up_mod.f90 advec_v_pw_mod.f90 advec_v_up_mod.f90 \
+	advec_w_pw_mod.f90 advec_w_up_mod.f90 average_3d_data.f90 boundary_conds.f90 \
+	buoyancy_mod.f90 calc_liquid_water_content.f90 calc_mean_profile_mod.f90 \
+	calc_radiation_mod.f90 \
 	check_for_restart.f90 check_open.f90 check_parameters.f90 \
-	close_file.f90 compute_vpt.f90 coriolis.f90 cpulog.f90 \
-	cuda_fft_interfaces.f90 data_log.f90 data_output_dvrp.f90 \
+	close_file.f90 compute_vpt.f90 coriolis_mod.f90 cpulog_mod.f90 \
+	cuda_fft_interfaces_mod.f90 data_log.f90 data_output_dvrp_mod.f90 \
 	data_output_mask.f90 data_output_profiles.f90 \
 	data_output_ptseries.f90 data_output_spectra.f90 \
 	data_output_tseries.f90 data_output_2d.f90 data_output_3d.f90 \
-	diffusion_e.f90 diffusion_s.f90 diffusion_u.f90 diffusion_v.f90 \
-	diffusion_w.f90 diffusivities.f90 disturb_field.f90 \
-	disturb_heatflux.f90 eqn_state_seawater.f90 exchange_horiz.f90 \
-	exchange_horiz_2d.f90 fft_xy.f90 flow_statistics.f90 \
+	diffusion_e_mod.f90 diffusion_s_mod.f90 diffusion_u_mod.f90 diffusion_v_mod.f90 \
+	diffusion_w_mod.f90 diffusivities.f90 disturb_field.f90 \
+	disturb_heatflux.f90 eqn_state_seawater_mod.f90 exchange_horiz.f90 \
+	exchange_horiz_2d.f90 fft_xy_mod.f90 flow_statistics.f90 \
 	global_min_max.f90 header.f90 \
 	inflow_turbulence.f90 init_1d_model.f90 init_3d_model.f90 \
@@ -279,31 +281,31 @@
 	init_grid.f90 init_masks.f90 init_ocean.f90 \
 	init_pegrid.f90 init_pt_anomaly.f90 init_rankine.f90 init_slope.f90 \
-	interaction_droplets_ptq.f90 land_surface_model_mod.f90 \
+	interaction_droplets_ptq_mod.f90 land_surface_model_mod.f90 \
 	local_stop.f90 local_system.f90 local_tremain.f90 \
 	local_tremain_ini.f90 lpm.f90 lpm_advec.f90 lpm_boundary_conds.f90 \
-	lpm_calc_liquid_water_content.f90 lpm_collision_kernels.f90 \
+	lpm_calc_liquid_water_content.f90 lpm_collision_kernels_mod.f90 \
 	lpm_data_output_particles.f90 lpm_droplet_collision.f90 \
-	lpm_droplet_condensation.f90 lpm_exchange_horiz.f90 \
-	lpm_init.f90 lpm_init_sgs_tke.f90 \
+	lpm_droplet_condensation.f90 lpm_exchange_horiz_mod.f90 \
+	lpm_init_mod.f90 lpm_init_sgs_tke.f90 \
 	lpm_pack_arrays.f90 lpm_read_restart_file.f90 \
 	lpm_set_attributes.f90 \
 	lpm_write_exchange_statistics.f90 lpm_write_restart_file.f90 \
-	ls_forcing.f90 message.f90 microphysics.f90 modules.f90 mod_kinds.f90 \
-	mod_particle_attributes.f90 netcdf_interface.f90 nudging.f90 \
-	package_parin.f90 palm.f90 parin.f90 plant_canopy_model_mod.f90 pmc_interface.f90 \
-	pmc_client.f90 pmc_general.f90 pmc_handle_communicator.f90 pmc_mpi_wrapper.f90 \
-	pmc_server.f90 \
-	poisfft.f90 poismg.f90 \
-	poismg_fast.f90 pres.f90 print_1d.f90 production_e.f90 \
-	prognostic_equations.f90 progress_bar.f90 radiation_model_mod.f90 \
-	random_function.f90 random_gauss.f90 random_generator_parallel.f90 \
+	ls_forcing_mod.f90 message.f90 microphysics_mod.f90 modules.f90 mod_kinds.f90 \
+	mod_particle_attributes.f90 netcdf_interface_mod.f90 nudging_mod.f90 \
+	package_parin.f90 palm.f90 parin.f90 plant_canopy_model_mod.f90 pmc_interface_mod.f90 \
+	pmc_client_mod.f90 pmc_general.f90 pmc_handle_communicator_mod.f90 pmc_mpi_wrapper_mod.f90 \
+	pmc_server_mod.f90 \
+	poisfft_mod.f90 poismg.f90 \
+	poismg_fast_mod.f90 pres.f90 print_1d.f90 production_e_mod.f90 \
+	prognostic_equations_mod.f90 progress_bar_mod.f90 radiation_model_mod.f90 \
+	random_function_mod.f90 random_gauss.f90 random_generator_parallel_mod.f90 \
 	read_3d_binary.f90 read_var_list.f90 run_control.f90 \
-	set_slicer_attributes_dvrp.f90 singleton.f90 sor.f90 spectra_mod.f90 \
-	subsidence.f90 sum_up_3d_data.f90 \
-	surface_coupler.f90 surface_layer_fluxes.f90 swap_timelevel.f90 temperton_fft.f90 \
+	set_slicer_attributes_dvrp.f90 singleton_mod.f90 sor.f90 spectra_mod.f90 \
+	subsidence_mod.f90 sum_up_3d_data.f90 \
+	surface_coupler.f90 surface_layer_fluxes_mod.f90 swap_timelevel.f90 temperton_fft_mod.f90 \
 	time_integration.f90 time_to_string.f90 timestep.f90 \
-	timestep_scheme_steering.f90 transpose.f90 tridia_solver.f90 \
+	timestep_scheme_steering.f90 transpose.f90 tridia_solver_mod.f90 \
 	user_3d_data_averaging.f90 \
-	user_actions.f90 user_additional_routines.f90 \
+	user_actions_mod.f90 user_additional_routines.f90 \
 	user_check_data_output.f90 user_check_data_output_pr.f90 \
 	user_check_parameters.f90 user_data_output_2d.f90 \
@@ -314,7 +316,7 @@
 	user_init_plant_canopy.f90 user_init_radiation.f90 \
 	user_last_actions.f90 user_lpm_advec.f90 \
-	user_lpm_init.f90 user_lpm_set_attributes.f90 user_module.f90 \
+	user_lpm_init.f90 user_lpm_set_attributes.f90 user_module_mod.f90 \
 	user_parin.f90 user_read_restart_data.f90 \
-	user_spectra.f90 user_statistics.f90 wall_fluxes.f90 \
+	user_spectra.f90 user_statistics.f90 wall_fluxes_mod.f90 \
 	write_3d_binary.f90 write_var_list.f90
 
@@ -349,71 +351,71 @@
 
 
-advec_s_bc.o: modules.o cpulog.o mod_kinds.o
-advec_s_pw.o: modules.o mod_kinds.o
-advec_s_up.o: modules.o mod_kinds.o
-advec_u_pw.o: modules.o mod_kinds.o
-advec_u_up.o: modules.o mod_kinds.o
-advec_v_pw.o: modules.o mod_kinds.o
-advec_v_up.o: modules.o mod_kinds.o
-advec_ws.o: modules.o mod_kinds.o
-advec_w_pw.o: modules.o mod_kinds.o
-advec_w_up.o: modules.o mod_kinds.o
-average_3d_data.o: modules.o cpulog.o mod_kinds.o land_surface_model_mod.o\
+advec_s_bc_mod.o: modules.o cpulog_mod.o mod_kinds.o
+advec_s_pw_mod.o: modules.o mod_kinds.o
+advec_s_up_mod.o: modules.o mod_kinds.o
+advec_u_pw_mod.o: modules.o mod_kinds.o
+advec_u_up_mod.o: modules.o mod_kinds.o
+advec_v_pw_mod.o: modules.o mod_kinds.o
+advec_v_up_mod.o: modules.o mod_kinds.o
+advec_ws_mod.o: modules.o mod_kinds.o
+advec_w_pw_mod.o: modules.o mod_kinds.o
+advec_w_up_mod.o: modules.o mod_kinds.o
+average_3d_data.o: modules.o cpulog_mod.o mod_kinds.o land_surface_model_mod.o\
                    radiation_model_mod.o
 boundary_conds.o: modules.o mod_kinds.o
-buoyancy.o: modules.o mod_kinds.o
-calc_mean_profile.o: modules.o mod_kinds.o
+buoyancy_mod.o: modules.o mod_kinds.o
+calc_mean_profile_mod.o: modules.o mod_kinds.o
 calc_liquid_water_content.o: modules.o mod_kinds.o
-calc_radiation.o: modules.o mod_kinds.o
-check_for_restart.o: modules.o mod_kinds.o pmc_interface.o
-check_open.o: modules.o mod_kinds.o mod_particle_attributes.o netcdf_interface.o
+calc_radiation_mod.o: modules.o mod_kinds.o
+check_for_restart.o: modules.o mod_kinds.o pmc_interface_mod.o
+check_open.o: modules.o mod_kinds.o mod_particle_attributes.o netcdf_interface_mod.o
 check_parameters.o: modules.o mod_kinds.o land_surface_model_mod.o \
-	netcdf_interface.o plant_canopy_model_mod.o pmc_interface.o radiation_model_mod.o \
-	spectra_mod.o subsidence.o microphysics.o
-close_file.o: modules.o mod_kinds.o netcdf_interface.o
+	netcdf_interface_mod.o plant_canopy_model_mod.o pmc_interface_mod.o radiation_model_mod.o \
+	spectra_mod.o subsidence_mod.o microphysics_mod.o
+close_file.o: modules.o mod_kinds.o netcdf_interface_mod.o
 compute_vpt.o: modules.o mod_kinds.o
-coriolis.o: modules.o mod_kinds.o
-cpulog.o: modules.o mod_kinds.o
+coriolis_mod.o: modules.o mod_kinds.o
+cpulog_mod.o: modules.o mod_kinds.o
 cpu_statistics.o: modules.o mod_kinds.o
-cuda_fft_interfaces.o: cuda_fft_interfaces.f90 modules.o mod_kinds.o
+cuda_fft_interfaces_mod.o: cuda_fft_interfaces_mod.f90 modules.o mod_kinds.o
 data_log.o: modules.o mod_kinds.o
-data_output_dvrp.o: modules.o cpulog.o mod_kinds.o
-data_output_mask.o: modules.o cpulog.o mod_kinds.o mod_particle_attributes.o \
-   netcdf_interface.o
-data_output_profiles.o: modules.o cpulog.o mod_kinds.o netcdf_interface.o
-data_output_ptseries.o: modules.o cpulog.o mod_kinds.o \
-   netcdf_interface.o mod_particle_attributes.o
-data_output_spectra.o: modules.o cpulog.o mod_kinds.o netcdf_interface.o \
+data_output_dvrp_mod.o: modules.o cpulog_mod.o mod_kinds.o
+data_output_mask.o: modules.o cpulog_mod.o mod_kinds.o mod_particle_attributes.o \
+   netcdf_interface_mod.o
+data_output_profiles.o: modules.o cpulog_mod.o mod_kinds.o netcdf_interface_mod.o
+data_output_ptseries.o: modules.o cpulog_mod.o mod_kinds.o \
+   netcdf_interface_mod.o mod_particle_attributes.o
+data_output_spectra.o: modules.o cpulog_mod.o mod_kinds.o netcdf_interface_mod.o \
    spectra_mod.o
-data_output_tseries.o: modules.o cpulog.o mod_kinds.o netcdf_interface.o
-data_output_2d.o: modules.o cpulog.o mod_kinds.o mod_particle_attributes.o\
-   netcdf_interface.o land_surface_model_mod.o radiation_model_mod.o
-data_output_3d.o: modules.o cpulog.o mod_kinds.o mod_particle_attributes.o\
-   netcdf_interface.o land_surface_model_mod.o
-diffusion_e.o: modules.o mod_kinds.o microphysics.o
-diffusion_s.o: modules.o mod_kinds.o
-diffusion_u.o: modules.o mod_kinds.o wall_fluxes.o
-diffusion_v.o: modules.o mod_kinds.o wall_fluxes.o
-diffusion_w.o: modules.o mod_kinds.o wall_fluxes.o
+data_output_tseries.o: modules.o cpulog_mod.o mod_kinds.o netcdf_interface_mod.o
+data_output_2d.o: modules.o cpulog_mod.o mod_kinds.o mod_particle_attributes.o\
+   netcdf_interface_mod.o land_surface_model_mod.o radiation_model_mod.o
+data_output_3d.o: modules.o cpulog_mod.o mod_kinds.o mod_particle_attributes.o\
+   netcdf_interface_mod.o land_surface_model_mod.o
+diffusion_e_mod.o: modules.o mod_kinds.o microphysics_mod.o
+diffusion_s_mod.o: modules.o mod_kinds.o
+diffusion_u_mod.o: modules.o mod_kinds.o wall_fluxes_mod.o
+diffusion_v_mod.o: modules.o mod_kinds.o wall_fluxes_mod.o
+diffusion_w_mod.o: modules.o mod_kinds.o wall_fluxes_mod.o
 diffusivities.o: modules.o mod_kinds.o
-disturb_field.o: modules.o cpulog.o mod_kinds.o random_function.o\
-                 random_generator_parallel.o
-disturb_heatflux.o: modules.o cpulog.o mod_kinds.o
-eqn_state_seawater.o: modules.o mod_kinds.o
-exchange_horiz.o: modules.o cpulog.o mod_kinds.o
-exchange_horiz_2d.o: modules.o cpulog.o mod_kinds.o
-fft_xy.o: cuda_fft_interfaces.o modules.o mod_kinds.o singleton.o temperton_fft.o
-flow_statistics.o: modules.o cpulog.o mod_kinds.o land_surface_model_mod.o\
-   netcdf_interface.o radiation_model_mod.o
+disturb_field.o: modules.o cpulog_mod.o mod_kinds.o random_function_mod.o\
+                 random_generator_parallel_mod.o
+disturb_heatflux.o: modules.o cpulog_mod.o mod_kinds.o
+eqn_state_seawater_mod.o: modules.o mod_kinds.o
+exchange_horiz.o: modules.o cpulog_mod.o mod_kinds.o
+exchange_horiz_2d.o: modules.o cpulog_mod.o mod_kinds.o
+fft_xy_mod.o: cuda_fft_interfaces_mod.o modules.o mod_kinds.o singleton_mod.o temperton_fft_mod.o
+flow_statistics.o: modules.o cpulog_mod.o mod_kinds.o land_surface_model_mod.o\
+   netcdf_interface_mod.o radiation_model_mod.o
 global_min_max.o: modules.o mod_kinds.o
-header.o: modules.o cpulog.o mod_kinds.o netcdf_interface.o land_surface_model_mod.o\
-   microphysics.o plant_canopy_model_mod.o: pmc_handle_communicator.o pmc_interface.o \
-   radiation_model_mod.o spectra_mod.o subsidence.o
-inflow_turbulence.o: modules.o cpulog.o mod_kinds.o
+header.o: modules.o cpulog_mod.o mod_kinds.o netcdf_interface_mod.o land_surface_model_mod.o\
+   microphysics_mod.o plant_canopy_model_mod.o pmc_handle_communicator_mod.o pmc_interface_mod.o \
+   radiation_model_mod.o spectra_mod.o subsidence_mod.o
+inflow_turbulence.o: modules.o cpulog_mod.o mod_kinds.o
 init_1d_model.o: modules.o mod_kinds.o
-init_3d_model.o: modules.o mod_kinds.o advec_ws.o cpulog.o land_surface_model_mod.o \
-   lpm_init.o ls_forcing.o netcdf_interface.o plant_canopy_model_mod.o \
-   radiation_model_mod.o random_function.o random_generator_parallel.o \
-   surface_layer_fluxes.o microphysics.o
+init_3d_model.o: modules.o mod_kinds.o advec_ws_mod.o cpulog_mod.o land_surface_model_mod.o \
+   lpm_init_mod.o ls_forcing_mod.o netcdf_interface_mod.o plant_canopy_model_mod.o \
+   radiation_model_mod.o random_function_mod.o random_generator_parallel_mod.o \
+   surface_layer_fluxes_mod.o microphysics_mod.o
 init_advec.o: modules.o mod_kinds.o
 init_cloud_physics.o: modules.o mod_kinds.o
@@ -421,144 +423,144 @@
 init_dvrp.o: modules.o mod_kinds.o
 init_grid.o: modules.o mod_kinds.o
-init_masks.o: modules.o mod_kinds.o netcdf_interface.o
-init_ocean.o: modules.o eqn_state_seawater.o mod_kinds.o
+init_masks.o: modules.o mod_kinds.o netcdf_interface_mod.o
+init_ocean.o: modules.o eqn_state_seawater_mod.o mod_kinds.o
 init_pegrid.o: modules.o mod_kinds.o spectra_mod.o
 init_pt_anomaly.o: modules.o mod_kinds.o
 init_rankine.o: modules.o mod_kinds.o
 init_slope.o: modules.o mod_kinds.o
-interaction_droplets_ptq.o: modules.o mod_kinds.o
+interaction_droplets_ptq_mod.o: modules.o mod_kinds.o
 land_surface_model_mod.o: modules.o mod_kinds.o radiation_model_mod.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
-lpm.o: modules.o cpulog.o lpm_exchange_horiz.o lpm_init.o lpm_pack_arrays.o \
+local_stop.o: modules.o mod_kinds.o pmc_interface_mod.o
+local_tremain.o: modules.o cpulog_mod.o mod_kinds.o
+local_tremain_ini.o: modules.o cpulog_mod.o mod_kinds.o
+lpm.o: modules.o cpulog_mod.o lpm_exchange_horiz_mod.o lpm_init_mod.o lpm_pack_arrays.o \
 	mod_kinds.o mod_particle_attributes.o
-lpm_advec.o: modules.o cpulog.o mod_kinds.o mod_particle_attributes.o
-lpm_boundary_conds.o: modules.o cpulog.o mod_kinds.o mod_particle_attributes.o
-lpm_calc_liquid_water_content.o: modules.o cpulog.o mod_kinds.o \
+lpm_advec.o: modules.o cpulog_mod.o mod_kinds.o mod_particle_attributes.o
+lpm_boundary_conds.o: modules.o cpulog_mod.o mod_kinds.o mod_particle_attributes.o
+lpm_calc_liquid_water_content.o: modules.o cpulog_mod.o mod_kinds.o \
 	mod_particle_attributes.o
-lpm_collision_kernels.o: modules.o cpulog.o user_module.o mod_kinds.o \
+lpm_collision_kernels_mod.o: modules.o cpulog_mod.o user_module_mod.o mod_kinds.o \
 	mod_particle_attributes.o
-lpm_data_output_particles.o: modules.o cpulog.o mod_kinds.o \
-	mod_particle_attributes.o netcdf_interface.o
-lpm_droplet_collision.o: modules.o cpulog.o lpm_collision_kernels.o \
+lpm_data_output_particles.o: modules.o cpulog_mod.o mod_kinds.o \
+	mod_particle_attributes.o netcdf_interface_mod.o
+lpm_droplet_collision.o: modules.o cpulog_mod.o lpm_collision_kernels_mod.o \
 	mod_kinds.o mod_particle_attributes.o
-lpm_droplet_condensation.o: modules.o cpulog.o lpm_collision_kernels.o \
+lpm_droplet_condensation.o: modules.o cpulog_mod.o lpm_collision_kernels_mod.o \
 	mod_kinds.o mod_particle_attributes.o
-lpm_exchange_horiz.o: modules.o cpulog.o lpm_pack_arrays.o mod_kinds.o \
-	mod_particle_attributes.o netcdf_interface.o
-lpm_init.o: modules.o lpm_collision_kernels.o mod_kinds.o \
-	netcdf_interface.o random_function.o mod_particle_attributes.o \
-	lpm_exchange_horiz.o lpm_pack_arrays.o random_generator_parallel.o
+lpm_exchange_horiz_mod.o: modules.o cpulog_mod.o lpm_pack_arrays.o mod_kinds.o \
+	mod_particle_attributes.o netcdf_interface_mod.o
+lpm_init_mod.o: modules.o lpm_collision_kernels_mod.o mod_kinds.o \
+	netcdf_interface_mod.o random_function_mod.o mod_particle_attributes.o \
+	lpm_exchange_horiz_mod.o lpm_pack_arrays.o random_generator_parallel_mod.o
 lpm_init_sgs_tke.o: modules.o mod_kinds.o mod_particle_attributes.o
-lpm_pack_arrays.o: modules.o cpulog.o mod_kinds.o mod_particle_attributes.o
+lpm_pack_arrays.o: modules.o cpulog_mod.o mod_kinds.o mod_particle_attributes.o
 lpm_read_restart_file.o: modules.o mod_kinds.o mod_particle_attributes.o \
 	lpm_pack_arrays.o
-lpm_set_attributes.o: modules.o cpulog.o mod_kinds.o mod_particle_attributes.o
+lpm_set_attributes.o: modules.o cpulog_mod.o mod_kinds.o mod_particle_attributes.o
 lpm_write_exchange_statistics.o: modules.o mod_kinds.o mod_particle_attributes.o
 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 pmc_interface.o
-microphysics.o: modules.o cpulog.o mod_kinds.o
+ls_forcing_mod.o: modules.o cpulog_mod.o mod_kinds.o
+message.o: modules.o mod_kinds.o pmc_interface_mod.o
+microphysics_mod.o: modules.o cpulog_mod.o mod_kinds.o
 modules.o: modules.f90 mod_kinds.o
 mod_kinds.o: mod_kinds.f90
 mod_particle_attributes.o: mod_particle_attributes.f90 mod_kinds.o
-netcdf_interface.o: netcdf_interface.f90 modules.o mod_kinds.o \
+netcdf_interface_mod.o: netcdf_interface_mod.f90 modules.o mod_kinds.o \
    land_surface_model_mod.o spectra_mod.o
-nudging.o: modules.o cpulog.o mod_kinds.o
+nudging_mod.o: modules.o cpulog_mod.o mod_kinds.o
 package_parin.o: modules.o mod_kinds.o
-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 land_surface_model_mod.o mod_kinds.o netcdf_interface.o \
-   plant_canopy_model_mod.o pmc_interface.o progress_bar.o spectra_mod.o \
-   radiation_model_mod.o microphysics.o
+palm.o: modules.o cpulog_mod.o ls_forcing_mod.o mod_kinds.o nudging_mod.o\
+	pmc_interface_mod.o surface_layer_fluxes_mod.o
+parin.o: modules.o cpulog_mod.o land_surface_model_mod.o mod_kinds.o netcdf_interface_mod.o \
+   plant_canopy_model_mod.o pmc_interface_mod.o progress_bar_mod.o spectra_mod.o \
+   radiation_model_mod.o microphysics_mod.o
 plant_canopy_model_mod.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: mod_kinds.o pmc_general.o pmc_handle_communicator.o\
-   pmc_mpi_wrapper.o
+pmc_interface_mod.o: modules.o mod_kinds.o pmc_client_mod.o pmc_general.o\
+	pmc_handle_communicator_mod.o pmc_mpi_wrapper_mod.o pmc_server_mod.o
+pmc_client_mod.o: mod_kinds.o pmc_general.o pmc_handle_communicator_mod.o\
+   pmc_mpi_wrapper_mod.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
-poisfft.o: modules.o cpulog.o fft_xy.o mod_kinds.o tridia_solver.o
-poismg.o: modules.o cpulog.o mod_kinds.o
-poismg_fast.o: modules.o cpulog.o mod_kinds.o
-pres.o: modules.o cpulog.o mod_kinds.o poisfft.o poismg_fast.o
-print_1d.o: modules.o cpulog.o mod_kinds.o
-production_e.o: modules.o mod_kinds.o wall_fluxes.o
-prognostic_equations.o: modules.o advec_s_pw.o advec_s_up.o advec_s_bc.o advec_u_pw.o \
-	advec_u_up.o advec_v_pw.o advec_v_up.o advec_w_pw.o advec_w_up.o \
-	advec_ws.o buoyancy.o calc_radiation.o coriolis.o \
-	cpulog.o diffusion_e.o diffusion_s.o diffusion_u.o diffusion_v.o diffusion_w.o \
-	eqn_state_seawater.o mod_kinds.o microphysics.o \
-	nudging.o plant_canopy_model_mod.o production_e.o radiation_model_mod.o \
-	subsidence.o user_actions.o
-progress_bar.o: modules.o mod_kinds.o
-radiation_model_mod.o : modules.o mod_particle_attributes.o microphysics.o
-random_function.o: mod_kinds.o
-random_gauss.o: mod_kinds.o random_function.o random_generator_parallel.o
-random_generator_parallel.o: mod_kinds.o
-read_3d_binary.o: modules.o cpulog.o mod_kinds.o land_surface_model_mod.o \
-   radiation_model_mod.o random_function.o random_generator_parallel.o \
+pmc_handle_communicator_mod.o: modules.o mod_kinds.o pmc_general.o
+pmc_mpi_wrapper_mod.o: pmc_handle_communicator_mod.o
+pmc_server_mod.o: pmc_general.o pmc_handle_communicator_mod.o pmc_mpi_wrapper_mod.o
+poisfft_mod.o: modules.o cpulog_mod.o fft_xy_mod.o mod_kinds.o tridia_solver_mod.o
+poismg.o: modules.o cpulog_mod.o mod_kinds.o
+poismg_fast_mod.o: modules.o cpulog_mod.o mod_kinds.o
+pres.o: modules.o cpulog_mod.o mod_kinds.o poisfft_mod.o poismg_fast_mod.o
+print_1d.o: modules.o cpulog_mod.o mod_kinds.o
+production_e_mod.o: modules.o mod_kinds.o wall_fluxes_mod.o
+prognostic_equations_mod.o: modules.o advec_s_pw_mod.o advec_s_up_mod.o advec_s_bc_mod.o advec_u_pw_mod.o \
+	advec_u_up_mod.o advec_v_pw_mod.o advec_v_up_mod.o advec_w_pw_mod.o advec_w_up_mod.o \
+	advec_ws_mod.o buoyancy_mod.o calc_radiation_mod.o coriolis_mod.o \
+	cpulog_mod.o diffusion_e_mod.o diffusion_s_mod.o diffusion_u_mod.o diffusion_v_mod.o diffusion_w_mod.o \
+	eqn_state_seawater_mod.o mod_kinds.o microphysics_mod.o \
+	nudging_mod.o plant_canopy_model_mod.o production_e_mod.o radiation_model_mod.o \
+	subsidence_mod.o user_actions_mod.o
+progress_bar_mod.o: modules.o mod_kinds.o
+radiation_model_mod.o : modules.o mod_particle_attributes.o microphysics_mod.o
+random_function_mod.o: mod_kinds.o
+random_gauss.o: mod_kinds.o random_function_mod.o random_generator_parallel_mod.o
+random_generator_parallel_mod.o: mod_kinds.o
+read_3d_binary.o: modules.o cpulog_mod.o mod_kinds.o land_surface_model_mod.o \
+   radiation_model_mod.o random_function_mod.o random_generator_parallel_mod.o \
    spectra_mod.o
-read_var_list.o: modules.o mod_kinds.o netcdf_interface.o plant_canopy_model_mod.o \
-   spectra_mod.o microphysics.o
-run_control.o: modules.o cpulog.o mod_kinds.o
+read_var_list.o: modules.o mod_kinds.o netcdf_interface_mod.o plant_canopy_model_mod.o \
+   spectra_mod.o microphysics_mod.o
+run_control.o: modules.o cpulog_mod.o mod_kinds.o
 set_slicer_attributes_dvrp.o: modules.o mod_kinds.o
-singleton.o: mod_kinds.o singleton.f90
+singleton_mod.o: mod_kinds.o singleton_mod.f90
 sor.o: modules.o mod_kinds.o
-spectra_mod.o: spectra_mod.f90 modules.o mod_kinds.o cpulog.o fft_xy.o
-subsidence.o: modules.o mod_kinds.o
-sum_up_3d_data.o: modules.o cpulog.o mod_kinds.o land_surface_model_mod.o\
+spectra_mod.o: spectra_mod.f90 modules.o mod_kinds.o cpulog_mod.o fft_xy_mod.o
+subsidence_mod.o: modules.o mod_kinds.o
+sum_up_3d_data.o: modules.o cpulog_mod.o mod_kinds.o land_surface_model_mod.o\
                   radiation_model_mod.o 
-surface_coupler.o: modules.o cpulog.o mod_kinds.o
-surface_layer_fluxes.o: modules.o mod_kinds.o land_surface_model_mod.o
-swap_timelevel.o: modules.o cpulog.o mod_kinds.o land_surface_model_mod.o\
-   pmc_interface.o
-temperton_fft.o: modules.o mod_kinds.o
-time_integration.o: modules.o advec_ws.o buoyancy.o calc_mean_profile.o \
-	cpulog.o interaction_droplets_ptq.o land_surface_model_mod.o \
-	ls_forcing.o mod_kinds.o nudging.o pmc_interface.o production_e.o \
-	prognostic_equations.o progress_bar.o radiation_model_mod.o \
-	spectra_mod.o user_actions.o surface_layer_fluxes.o microphysics.o
+surface_coupler.o: modules.o cpulog_mod.o mod_kinds.o
+surface_layer_fluxes_mod.o: modules.o mod_kinds.o land_surface_model_mod.o
+swap_timelevel.o: modules.o cpulog_mod.o mod_kinds.o land_surface_model_mod.o\
+   pmc_interface_mod.o
+temperton_fft_mod.o: modules.o mod_kinds.o
+time_integration.o: modules.o advec_ws_mod.o buoyancy_mod.o calc_mean_profile_mod.o \
+	cpulog_mod.o interaction_droplets_ptq_mod.o land_surface_model_mod.o \
+	ls_forcing_mod.o mod_kinds.o nudging_mod.o pmc_interface_mod.o production_e_mod.o \
+	prognostic_equations_mod.o progress_bar_mod.o radiation_model_mod.o \
+	spectra_mod.o user_actions_mod.o surface_layer_fluxes_mod.o microphysics_mod.o
 time_to_string.o: mod_kinds.o
-timestep.o: modules.o cpulog.o mod_kinds.o microphysics.o
+timestep.o: modules.o cpulog_mod.o mod_kinds.o microphysics_mod.o
 timestep_scheme_steering.o: modules.o mod_kinds.o
-transpose.o: modules.o cpulog.o mod_kinds.o
-tridia_solver.o: modules.o mod_kinds.o
-user_3d_data_averaging.o: modules.o mod_kinds.o user_module.o
-user_actions.o: modules.o cpulog.o mod_kinds.o user_module.o
-user_additional_routines.o: modules.o mod_kinds.o user_module.o
-user_check_data_output.o: modules.o mod_kinds.o user_module.o
-user_check_data_output_pr.o: modules.o mod_kinds.o user_module.o \
-   netcdf_interface.o
-user_check_parameters.o: modules.o mod_kinds.o user_module.o
-user_data_output_2d.o: modules.o mod_kinds.o user_module.o
-user_data_output_3d.o: modules.o mod_kinds.o user_module.o
-user_data_output_mask.o: modules.o mod_kinds.o user_module.o
-user_data_output_dvrp.o: modules.o mod_kinds.o user_module.o
-user_define_netcdf_grid.o: modules.o mod_kinds.o user_module.o
-user_dvrp_coltab.o: modules.o mod_kinds.o user_module.o
-user_header.o: modules.o mod_kinds.o user_module.o
-user_init.o: modules.o mod_kinds.o netcdf_interface.o user_module.o
-user_init_3d_model.o: modules.o mod_kinds.o user_module.o
-user_init_grid.o: modules.o mod_kinds.o user_module.o
-user_init_land_surface.o: modules.o mod_kinds.o user_module.o land_surface_model_mod.o
-user_init_plant_canopy.o: modules.o mod_kinds.o user_module.o plant_canopy_model_mod.o
-user_init_radiation.o: modules.o mod_kinds.o user_module.o radiation_model_mod.o
-user_last_actions.o: modules.o mod_kinds.o user_module.o
-user_lpm_advec.o: modules.o mod_kinds.o user_module.o
-user_lpm_init.o: modules.o mod_kinds.o user_module.o
-user_lpm_set_attributes.o: modules.o mod_kinds.o user_module.o
-user_module.o: mod_kinds.o user_module.f90
-user_parin.o: modules.o mod_kinds.o user_module.o
-user_read_restart_data.o: modules.o mod_kinds.o user_module.o
-user_spectra.o: modules.o mod_kinds.o spectra_mod.o user_module.o
-user_statistics.o: modules.o mod_kinds.o netcdf_interface.o user_module.o
-wall_fluxes.o: modules.o mod_kinds.o
-write_3d_binary.o: modules.o cpulog.o mod_kinds.o land_surface_model_mod.o \
-	radiation_model_mod.o random_function.o random_generator_parallel.o \
+transpose.o: modules.o cpulog_mod.o mod_kinds.o
+tridia_solver_mod.o: modules.o mod_kinds.o
+user_3d_data_averaging.o: modules.o mod_kinds.o user_module_mod.o
+user_actions_mod.o: modules.o cpulog_mod.o mod_kinds.o user_module_mod.o
+user_additional_routines.o: modules.o mod_kinds.o user_module_mod.o
+user_check_data_output.o: modules.o mod_kinds.o user_module_mod.o
+user_check_data_output_pr.o: modules.o mod_kinds.o user_module_mod.o \
+   netcdf_interface_mod.o
+user_check_parameters.o: modules.o mod_kinds.o user_module_mod.o
+user_data_output_2d.o: modules.o mod_kinds.o user_module_mod.o
+user_data_output_3d.o: modules.o mod_kinds.o user_module_mod.o
+user_data_output_mask.o: modules.o mod_kinds.o user_module_mod.o
+user_data_output_dvrp.o: modules.o mod_kinds.o user_module_mod.o
+user_define_netcdf_grid.o: modules.o mod_kinds.o user_module_mod.o
+user_dvrp_coltab.o: modules.o mod_kinds.o user_module_mod.o
+user_header.o: modules.o mod_kinds.o user_module_mod.o
+user_init.o: modules.o mod_kinds.o netcdf_interface_mod.o user_module_mod.o
+user_init_3d_model.o: modules.o mod_kinds.o user_module_mod.o
+user_init_grid.o: modules.o mod_kinds.o user_module_mod.o
+user_init_land_surface.o: modules.o mod_kinds.o user_module_mod.o land_surface_model_mod.o
+user_init_plant_canopy.o: modules.o mod_kinds.o user_module_mod.o plant_canopy_model_mod.o
+user_init_radiation.o: modules.o mod_kinds.o user_module_mod.o radiation_model_mod.o
+user_last_actions.o: modules.o mod_kinds.o user_module_mod.o
+user_lpm_advec.o: modules.o mod_kinds.o user_module_mod.o
+user_lpm_init.o: modules.o mod_kinds.o user_module_mod.o
+user_lpm_set_attributes.o: modules.o mod_kinds.o user_module_mod.o
+user_module_mod.o: mod_kinds.o user_module_mod.f90
+user_parin.o: modules.o mod_kinds.o user_module_mod.o
+user_read_restart_data.o: modules.o mod_kinds.o user_module_mod.o
+user_spectra.o: modules.o mod_kinds.o spectra_mod.o user_module_mod.o
+user_statistics.o: modules.o mod_kinds.o netcdf_interface_mod.o user_module_mod.o
+wall_fluxes_mod.o: modules.o mod_kinds.o
+write_3d_binary.o: modules.o cpulog_mod.o mod_kinds.o land_surface_model_mod.o \
+	radiation_model_mod.o random_function_mod.o random_generator_parallel_mod.o \
 	spectra_mod.o
-write_var_list.o: modules.o mod_kinds.o netcdf_interface.o plant_canopy_model_mod.o\
-   spectra_mod.o microphysics.o
+write_var_list.o: modules.o mod_kinds.o netcdf_interface_mod.o plant_canopy_model_mod.o\
+   spectra_mod.o microphysics_mod.o
Index: lm/trunk/SOURCE/advec_s_bc.f90
===================================================================
--- /palm/trunk/SOURCE/advec_s_bc.f90	(revision 1849)
+++ 	(revision )
@@ -1,1323 +1,0 @@
-!> @file advec_s_bc.f90
-!--------------------------------------------------------------------------------!
-! This file is part of PALM.
-!
-! PALM is free software: you can redistribute it and/or modify it under the terms
-! of the GNU General Public License as published by the Free Software Foundation,
-! either version 3 of the License, or (at your option) any later version.
-!
-! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
-! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
-! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along with
-! PALM. If not, see <http://www.gnu.org/licenses/>.
-!
-! Copyright 1997-2016 Leibniz Universitaet Hannover
-!--------------------------------------------------------------------------------!
-!
-! Current revisions:
-! -----------------
-! 
-!
-! Former revisions:
-! -----------------
-! $Id$
-!
-! 1815 2016-04-06 13:49:59Z raasch
-! comment change
-!
-! 1691 2015-10-26 16:17:44Z maronga
-! Formatting corrections
-! 
-! 1682 2015-10-07 23:56:08Z knoop
-! Code annotations made doxygen readable
-! 
-! 1517 2015-01-07 19:12:25Z hoffmann
-! interface added to advec_s_bc
-!
-! 1374 2014-04-25 12:55:07Z raasch
-! missing variables added to ONLY list
-! 
-! 1361 2014-04-16 15:17:48Z hoffmann
-! nr and qr added
-! 
-! 1353 2014-04-08 15:21:23Z heinze
-! REAL constants provided with KIND-attribute
-!
-! 1346 2014-03-27 13:18:20Z heinze
-! Bugfix: REAL constants provided with KIND-attribute especially in call of 
-! intrinsic function like MAX, MIN, SIGN
-!
-! 1320 2014-03-20 08:40:49Z raasch
-! ONLY-attribute added to USE-statements,
-! kind-parameters added to all INTEGER and REAL declaration statements,
-! kinds are defined in new module kinds,
-! revision history before 2012 removed,
-! comment fields (!:) to be used for variable explanations added to
-! all variable declaration statements
-!
-! 1318 2014-03-17 13:35:16Z raasch
-! module interfaces removed
-!
-! 1092 2013-02-02 11:24:22Z raasch
-! unused variables removed
-!
-! 1036 2012-10-22 13:43:42Z raasch
-! code put under GPL (PALM 3.9)
-!
-! 1010 2012-09-20 07:59:54Z raasch
-! cpp switch __nopointer added for pointer free version
-!
-! Revision 1.1  1997/08/29 08:53:46  raasch
-! Initial revision
-!
-!
-! Description:
-! ------------
-!> Advection term for scalar quantities using the Bott-Chlond scheme.
-!> Computation in individual steps for each of the three dimensions.
-!> Limiting assumptions:
-!> So far the scheme has been assuming equidistant grid spacing. As this is not
-!> the case in the stretched portion of the z-direction, there dzw(k) is used as
-!> a substitute for a constant grid length. This certainly causes incorrect
-!> results; however, it is hoped that they are not too apparent for weakly 
-!> stretched grids.
-!> NOTE: This is a provisional, non-optimised version!
-!------------------------------------------------------------------------------!
-MODULE advec_s_bc_mod
- 
-
-    PRIVATE
-    PUBLIC advec_s_bc
-
-    INTERFACE advec_s_bc
-       MODULE PROCEDURE advec_s_bc
-    END INTERFACE advec_s_bc
-
- CONTAINS
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> @todo Missing subroutine description.
-!------------------------------------------------------------------------------!
-    SUBROUTINE advec_s_bc( sk, sk_char )
-
-       USE advection,                                                             &
-           ONLY:  aex, bex, dex, eex
-
-       USE arrays_3d,                                                             &
-           ONLY:  d, ddzw, dzu, dzw, tend, u, v, w
-
-       USE control_parameters,                                                    &
-           ONLY:  dt_3d, bc_pt_t_val, bc_q_t_val, ibc_pt_b, ibc_pt_t, ibc_q_t,    &
-                  message_string, pt_slope_offset, sloping_surface, u_gtrans,     &
-                  v_gtrans
-
-       USE cpulog,                                                                &
-           ONLY:  cpu_log, log_point_s
-
-       USE grid_variables,                                                        &
-           ONLY:  ddx, ddy
-
-       USE indices,                                                               &
-           ONLY:  nx, nxl, nxlg, nxr, nxrg, nyn, nyng, nys, nysg, nzb, nzt
-
-       USE kinds
-
-       USE pegrid
-
-       USE statistics,                                                            &
-           ONLY:  rmask, statistic_regions, sums_wsts_bc_l
-
-
-       IMPLICIT NONE
-
-       CHARACTER (LEN=*) ::  sk_char !<
-
-       INTEGER(iwp) ::  i         !<
-       INTEGER(iwp) ::  ix        !<
-       INTEGER(iwp) ::  j         !<
-       INTEGER(iwp) ::  k         !<
-       INTEGER(iwp) ::  ngp       !<
-       INTEGER(iwp) ::  sr        !<
-       INTEGER(iwp) ::  type_xz_2 !<
-
-       REAL(wp) ::  cim    !<
-       REAL(wp) ::  cimf   !<
-       REAL(wp) ::  cip    !<
-       REAL(wp) ::  cipf   !<
-       REAL(wp) ::  d_new  !<
-       REAL(wp) ::  denomi !< denominator
-       REAL(wp) ::  fminus !<
-       REAL(wp) ::  fplus  !<
-       REAL(wp) ::  f2     !<
-       REAL(wp) ::  f4     !<
-       REAL(wp) ::  f8     !<
-       REAL(wp) ::  f12    !<
-       REAL(wp) ::  f24    !<
-       REAL(wp) ::  f48    !<
-       REAL(wp) ::  f1920  !<
-       REAL(wp) ::  im     !<
-       REAL(wp) ::  ip     !<
-       REAL(wp) ::  m2     !<
-       REAL(wp) ::  m3     !<
-       REAL(wp) ::  numera !< numerator
-       REAL(wp) ::  snenn  !<
-       REAL(wp) ::  sterm  !<
-       REAL(wp) ::  tendcy !<
-       REAL(wp) ::  t1     !<
-       REAL(wp) ::  t2     !<
-
-       REAL(wp) ::  fmax(2)   !<
-       REAL(wp) ::  fmax_l(2) !<
-       
-#if defined( __nopointer )
-       REAL(wp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ::  sk !<
-#else
-       REAL(wp), DIMENSION(:,:,:), POINTER ::  sk
-#endif
-
-       REAL(wp), DIMENSION(:,:), ALLOCATABLE ::  a0   !<
-       REAL(wp), DIMENSION(:,:), ALLOCATABLE ::  a1   !<
-       REAL(wp), DIMENSION(:,:), ALLOCATABLE ::  a12  !<
-       REAL(wp), DIMENSION(:,:), ALLOCATABLE ::  a2   !<
-       REAL(wp), DIMENSION(:,:), ALLOCATABLE ::  a22  !<
-       REAL(wp), DIMENSION(:,:), ALLOCATABLE ::  immb !<
-       REAL(wp), DIMENSION(:,:), ALLOCATABLE ::  imme !<
-       REAL(wp), DIMENSION(:,:), ALLOCATABLE ::  impb !<
-       REAL(wp), DIMENSION(:,:), ALLOCATABLE ::  impe !<
-       REAL(wp), DIMENSION(:,:), ALLOCATABLE ::  ipmb !<
-       REAL(wp), DIMENSION(:,:), ALLOCATABLE ::  ipme !<
-       REAL(wp), DIMENSION(:,:), ALLOCATABLE ::  ippb !<
-       REAL(wp), DIMENSION(:,:), ALLOCATABLE ::  ippe !<
-       
-       REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::  sk_p !<
-
-#if defined( __nec )
-       REAL(sp) ::  m1n, m1z  !< important for optimisation of division
-       REAL(sp), DIMENSION(:,:), ALLOCATABLE :: m1, sw !<
-#else
-       REAL(wp) ::  m1n, m1z 
-       REAL(wp), DIMENSION(:,:), ALLOCATABLE :: m1, sw
-#endif
-
-
-!
-!--    Array sk_p requires 2 extra elements for each dimension
-       ALLOCATE( sk_p(nzb-2:nzt+3,nys-3:nyn+3,nxl-3:nxr+3) )
-       sk_p = 0.0_wp
-
-!
-!--    Assign reciprocal values in order to avoid divisions later
-       f2    = 0.5_wp
-       f4    = 0.25_wp
-       f8    = 0.125_wp
-       f12   = 0.8333333333333333E-01_wp
-       f24   = 0.4166666666666666E-01_wp
-       f48   = 0.2083333333333333E-01_wp
-       f1920 = 0.5208333333333333E-03_wp
-
-!
-!--    Advection in x-direction:
-
-!
-!--    Save the quantity to be advected in a local array
-!--    add an enlarged boundary in x-direction
-       DO  i = nxl-1, nxr+1
-          DO  j = nys, nyn
-             DO  k = nzb, nzt+1
-                sk_p(k,j,i) = sk(k,j,i)
-             ENDDO
-          ENDDO
-       ENDDO
-#if defined( __parallel )
-       ngp = 2 * ( nzt - nzb + 6 ) * ( nyn - nys + 7 )
-       CALL cpu_log( log_point_s(11), 'advec_s_bc:sendrecv', 'start' )
-!
-!--    Send left boundary, receive right boundary
-       CALL MPI_SENDRECV( sk_p(nzb-2,nys-3,nxl+1), ngp, MPI_REAL, pleft,  0,      &
-                          sk_p(nzb-2,nys-3,nxr+2), ngp, MPI_REAL, pright, 0,      &
-                          comm2d, status, ierr )
-!
-!--    Send right boundary, receive left boundary
-       CALL MPI_SENDRECV( sk_p(nzb-2,nys-3,nxr-2), ngp, MPI_REAL, pright, 1,      &
-                          sk_p(nzb-2,nys-3,nxl-3), ngp, MPI_REAL, pleft,  1,      &
-                          comm2d, status, ierr )
-       CALL cpu_log( log_point_s(11), 'advec_s_bc:sendrecv', 'pause' )
-#else
-
-!
-!--    Cyclic boundary conditions
-       sk_p(:,nys:nyn,nxl-3) = sk_p(:,nys:nyn,nxr-2)
-       sk_p(:,nys:nyn,nxl-2) = sk_p(:,nys:nyn,nxr-1)
-       sk_p(:,nys:nyn,nxr+2) = sk_p(:,nys:nyn,nxl+1)
-       sk_p(:,nys:nyn,nxr+3) = sk_p(:,nys:nyn,nxl+2)
-#endif
-
-!
-!--    In case of a sloping surface, the additional gridpoints in x-direction
-!--    of the temperature field at the left and right boundary of the total
-!--    domain must be adjusted by the temperature difference between this distance
-       IF ( sloping_surface  .AND.  sk_char == 'pt' )  THEN
-          IF ( nxl ==  0 )  THEN
-             sk_p(:,nys:nyn,nxl-3) = sk_p(:,nys:nyn,nxl-3) - pt_slope_offset
-             sk_p(:,nys:nyn,nxl-2) = sk_p(:,nys:nyn,nxl-2) - pt_slope_offset
-          ENDIF
-          IF ( nxr == nx )  THEN
-             sk_p(:,nys:nyn,nxr+2) = sk_p(:,nys:nyn,nxr+2) + pt_slope_offset
-             sk_p(:,nys:nyn,nxr+3) = sk_p(:,nys:nyn,nxr+3) + pt_slope_offset
-          ENDIF
-       ENDIF
-
-!
-!--    Initialise control density
-       d = 0.0_wp
-
-!
-!--    Determine maxima of the first and second derivative in x-direction
-       fmax_l = 0.0_wp
-       DO  i = nxl, nxr
-          DO  j = nys, nyn
-             DO  k = nzb+1, nzt
-                numera = ABS( sk_p(k,j,i+1) - 2.0_wp * sk_p(k,j,i) + sk_p(k,j,i-1) )
-                denomi  = ABS( sk_p(k,j,i+1) - sk_p(k,j,i-1) )
-                fmax_l(1) = MAX( fmax_l(1) , numera )
-                fmax_l(2) = MAX( fmax_l(2) , denomi  )
-             ENDDO
-          ENDDO
-       ENDDO
-#if defined( __parallel )
-       IF ( collective_wait )  CALL MPI_BARRIER( comm2d, ierr )
-       CALL MPI_ALLREDUCE( fmax_l, fmax, 2, MPI_REAL, MPI_MAX, comm2d, ierr )
-#else
-       fmax = fmax_l
-#endif
-
-       fmax = 0.04_wp * fmax
-
-!
-!--    Allocate temporary arrays
-       ALLOCATE( a0(nzb+1:nzt,nxl-1:nxr+1),   a1(nzb+1:nzt,nxl-1:nxr+1),          &
-                 a2(nzb+1:nzt,nxl-1:nxr+1),   a12(nzb+1:nzt,nxl-1:nxr+1),         &
-                 a22(nzb+1:nzt,nxl-1:nxr+1),  immb(nzb+1:nzt,nxl-1:nxr+1),        &
-                 imme(nzb+1:nzt,nxl-1:nxr+1), impb(nzb+1:nzt,nxl-1:nxr+1),        &
-                 impe(nzb+1:nzt,nxl-1:nxr+1), ipmb(nzb+1:nzt,nxl-1:nxr+1),        &
-                 ipme(nzb+1:nzt,nxl-1:nxr+1), ippb(nzb+1:nzt,nxl-1:nxr+1),        &
-                 ippe(nzb+1:nzt,nxl-1:nxr+1), m1(nzb+1:nzt,nxl-2:nxr+2),          &
-                 sw(nzb+1:nzt,nxl-1:nxr+1)                                        &
-               )
-       imme = 0.0_wp; impe = 0.0_wp; ipme = 0.0_wp; ippe = 0.0_wp
-
-!
-!--    Initialise point of time measuring of the exponential portion (this would
-!--    not work if done locally within the loop)
-       CALL cpu_log( log_point_s(12), 'advec_s_bc:exp', 'start' )
-       CALL cpu_log( log_point_s(12), 'advec_s_bc:exp', 'pause' )
-
-!
-!--    Outer loop of all j
-       DO  j = nys, nyn
-
-!
-!--       Compute polynomial coefficients
-          DO  i = nxl-1, nxr+1
-             DO  k = nzb+1, nzt
-                a12(k,i) = 0.5_wp * ( sk_p(k,j,i+1) - sk_p(k,j,i-1) )
-                a22(k,i) = 0.5_wp * ( sk_p(k,j,i+1) - 2.0_wp * sk_p(k,j,i)        &
-                                                    + sk_p(k,j,i-1) )
-                a0(k,i) = ( 9.0_wp * sk_p(k,j,i+2)    - 116.0_wp * sk_p(k,j,i+1)  &
-                            + 2134.0_wp * sk_p(k,j,i) - 116.0_wp * sk_p(k,j,i-1)  &
-                            + 9.0_wp * sk_p(k,j,i-2) ) * f1920
-                a1(k,i) = ( -5.0_wp * sk_p(k,j,i+2)   + 34.0_wp * sk_p(k,j,i+1)   &
-                            - 34.0_wp * sk_p(k,j,i-1) + 5.0_wp * sk_p(k,j,i-2)    &
-                          ) * f48
-                a2(k,i) = ( -3.0_wp * sk_p(k,j,i+2) + 36.0_wp * sk_p(k,j,i+1)     &
-                            - 66.0_wp * sk_p(k,j,i) + 36.0_wp * sk_p(k,j,i-1)     &
-                            - 3.0_wp * sk_p(k,j,i-2) ) * f48
-             ENDDO
-          ENDDO
-
-!
-!--       Fluxes using the Bott scheme
-!--       *VOCL LOOP,UNROLL(2)
-          DO  i = nxl, nxr
-             DO  k = nzb+1, nzt
-                cip  =  MAX( 0.0_wp, ( u(k,j,i+1) - u_gtrans ) * dt_3d * ddx )
-                cim  = -MIN( 0.0_wp, ( u(k,j,i+1) - u_gtrans ) * dt_3d * ddx )
-                cipf = 1.0_wp - 2.0_wp * cip
-                cimf = 1.0_wp - 2.0_wp * cim
-                ip   =   a0(k,i)   * f2  * ( 1.0_wp - cipf )                      &
-                       + a1(k,i)   * f8  * ( 1.0_wp - cipf*cipf )                 &
-                       + a2(k,i)   * f24 * ( 1.0_wp - cipf*cipf*cipf )
-                im   =   a0(k,i+1) * f2  * ( 1.0_wp - cimf )                      &
-                       - a1(k,i+1) * f8  * ( 1.0_wp - cimf*cimf )                 &
-                       + a2(k,i+1) * f24 * ( 1.0_wp - cimf*cimf*cimf )
-                ip   = MAX( ip, 0.0_wp )
-                im   = MAX( im, 0.0_wp )
-                ippb(k,i) = ip * MIN( 1.0_wp, sk_p(k,j,i)   / (ip+im+1E-15_wp) )
-                impb(k,i) = im * MIN( 1.0_wp, sk_p(k,j,i+1) / (ip+im+1E-15_wp) )
-
-                cip  =  MAX( 0.0_wp, ( u(k,j,i) - u_gtrans ) * dt_3d * ddx )
-                cim  = -MIN( 0.0_wp, ( u(k,j,i) - u_gtrans ) * dt_3d * ddx )
-                cipf = 1.0_wp - 2.0_wp * cip
-                cimf = 1.0_wp - 2.0_wp * cim
-                ip   =   a0(k,i-1) * f2  * ( 1.0_wp - cipf )                      &
-                       + a1(k,i-1) * f8  * ( 1.0_wp - cipf*cipf )                 &
-                       + a2(k,i-1) * f24 * ( 1.0_wp - cipf*cipf*cipf )
-                im   =   a0(k,i)   * f2  * ( 1.0_wp - cimf )                      &
-                       - a1(k,i)   * f8  * ( 1.0_wp - cimf*cimf )                 &
-                       + a2(k,i)   * f24 * ( 1.0_wp - cimf*cimf*cimf )
-                ip   = MAX( ip, 0.0_wp )
-                im   = MAX( im, 0.0_wp )
-                ipmb(k,i) = ip * MIN( 1.0_wp, sk_p(k,j,i-1) / (ip+im+1E-15_wp) )
-                immb(k,i) = im * MIN( 1.0_wp, sk_p(k,j,i)   / (ip+im+1E-15_wp) )
-             ENDDO
-          ENDDO
-
-!
-!--       Compute monitor function m1
-          DO  i = nxl-2, nxr+2
-             DO  k = nzb+1, nzt
-                m1z = ABS( sk_p(k,j,i+1) - 2.0_wp * sk_p(k,j,i) + sk_p(k,j,i-1) )
-                m1n = ABS( sk_p(k,j,i+1) - sk_p(k,j,i-1) )
-                IF ( m1n /= 0.0_wp  .AND.  m1n >= m1z )  THEN
-                   m1(k,i) = m1z / m1n
-                   IF ( m1(k,i) /= 2.0_wp  .AND.  m1n < fmax(2) )  m1(k,i) = 0.0_wp
-                ELSEIF ( m1n < m1z )  THEN
-                   m1(k,i) = -1.0_wp
-                ELSE
-                   m1(k,i) = 0.0_wp
-                ENDIF
-             ENDDO
-          ENDDO
-
-!
-!--       Compute switch sw
-          sw = 0.0_wp
-          DO  i = nxl-1, nxr+1
-             DO  k = nzb+1, nzt
-                m2 = 2.0_wp * ABS( a1(k,i) - a12(k,i) ) /                         &
-                     MAX( ABS( a1(k,i) + a12(k,i) ), 1E-35_wp )
-                IF ( ABS( a1(k,i) + a12(k,i) ) < fmax(2) )  m2 = 0.0_wp
-
-                m3 = 2.0_wp * ABS( a2(k,i) - a22(k,i) ) /                         &
-                     MAX( ABS( a2(k,i) + a22(k,i) ), 1E-35_wp )
-                IF ( ABS( a2(k,i) + a22(k,i) ) < fmax(1) )  m3 = 0.0_wp
-
-                t1 = 0.35_wp
-                t2 = 0.35_wp
-                IF ( m1(k,i) == -1.0_wp )  t2 = 0.12_wp
-
-!--             *VOCL STMT,IF(10)
-                IF ( m1(k,i-1) == 1.0_wp .OR. m1(k,i) == 1.0_wp                   &
-                     .OR. m1(k,i+1) == 1.0_wp .OR.  m2 > t2  .OR.  m3 > t2  .OR.  &
-                     ( m1(k,i) > t1  .AND.  m1(k,i-1) /= -1.0_wp  .AND.           &
-                       m1(k,i) /= -1.0_wp  .AND.  m1(k,i+1) /= -1.0_wp )          &
-                   )  sw(k,i) = 1.0_wp
-             ENDDO
-          ENDDO
-
-!
-!--       Fluxes using the exponential scheme
-          CALL cpu_log( log_point_s(12), 'advec_s_bc:exp', 'continue' )
-          DO  i = nxl, nxr
-             DO  k = nzb+1, nzt
-
-!--             *VOCL STMT,IF(10)
-                IF ( sw(k,i) == 1.0_wp )  THEN
-                   snenn = sk_p(k,j,i+1) - sk_p(k,j,i-1)
-                   IF ( ABS( snenn ) < 1E-9_wp )  snenn = 1E-9_wp
-                   sterm = ( sk_p(k,j,i) - sk_p(k,j,i-1) ) / snenn
-                   sterm = MIN( sterm, 0.9999_wp )
-                   sterm = MAX( sterm, 0.0001_wp )
-
-                   ix = INT( sterm * 1000 ) + 1
-
-                   cip =  MAX( 0.0_wp, ( u(k,j,i+1) - u_gtrans ) * dt_3d * ddx )
-
-                   ippe(k,i) = sk_p(k,j,i-1) * cip + snenn * (                    &
-                               aex(ix) * cip + bex(ix) / dex(ix) * (              &
-                               eex(ix) -                                          &
-                               EXP( dex(ix)*0.5_wp * ( 1.0_wp - 2.0_wp * cip ) )  &
-                                                                   )              &
-                                                             )
-                   IF ( sterm == 0.0001_wp )  ippe(k,i) = sk_p(k,j,i) * cip
-                   IF ( sterm == 0.9999_wp )  ippe(k,i) = sk_p(k,j,i) * cip
-
-                   snenn = sk_p(k,j,i-1) - sk_p(k,j,i+1)
-                   IF ( ABS( snenn ) < 1E-9_wp )  snenn = 1E-9_wp
-                   sterm = ( sk_p(k,j,i) - sk_p(k,j,i+1) ) / snenn
-                   sterm = MIN( sterm, 0.9999_wp )
-                   sterm = MAX( sterm, 0.0001_wp )
-
-                   ix = INT( sterm * 1000 ) + 1
-
-                   cim = -MIN( 0.0_wp, ( u(k,j,i) - u_gtrans ) * dt_3d * ddx )
-
-                   imme(k,i) = sk_p(k,j,i+1) * cim + snenn * (                    &
-                               aex(ix) * cim + bex(ix) / dex(ix) * (              &
-                               eex(ix) -                                          &
-                               EXP( dex(ix)*0.5_wp * ( 1.0_wp - 2.0_wp * cim ) )  &
-                                                                   )              &
-                                                             )
-                   IF ( sterm == 0.0001_wp )  imme(k,i) = sk_p(k,j,i) * cim
-                   IF ( sterm == 0.9999_wp )  imme(k,i) = sk_p(k,j,i) * cim
-                ENDIF
-
-!--             *VOCL STMT,IF(10)
-                IF ( sw(k,i+1) == 1.0_wp )  THEN
-                   snenn = sk_p(k,j,i) - sk_p(k,j,i+2)
-                   IF ( ABS( snenn ) < 1E-9_wp )  snenn = 1E-9_wp
-                   sterm = ( sk_p(k,j,i+1) - sk_p(k,j,i+2) ) / snenn
-                   sterm = MIN( sterm, 0.9999_wp )
-                   sterm = MAX( sterm, 0.0001_wp )
-
-                   ix = INT( sterm * 1000 ) + 1
-
-                   cim = -MIN( 0.0_wp, ( u(k,j,i+1) - u_gtrans ) * dt_3d * ddx )
-
-                   impe(k,i) = sk_p(k,j,i+2) * cim + snenn * (                    &
-                               aex(ix) * cim + bex(ix) / dex(ix) * (              &
-                               eex(ix) -                                          &
-                               EXP( dex(ix)*0.5_wp * ( 1.0_wp - 2.0_wp * cim ) )  &
-                                                                   )              &
-                                                             )
-                   IF ( sterm == 0.0001_wp )  impe(k,i) = sk_p(k,j,i+1) * cim
-                   IF ( sterm == 0.9999_wp )  impe(k,i) = sk_p(k,j,i+1) * cim
-                ENDIF
-
-!--             *VOCL STMT,IF(10)
-                IF ( sw(k,i-1) == 1.0_wp )  THEN
-                   snenn = sk_p(k,j,i) - sk_p(k,j,i-2)
-                   IF ( ABS( snenn ) < 1E-9_wp )  snenn = 1E-9_wp
-                   sterm = ( sk_p(k,j,i-1) - sk_p(k,j,i-2) ) / snenn
-                   sterm = MIN( sterm, 0.9999_wp )
-                   sterm = MAX( sterm, 0.0001_wp )
-
-                   ix = INT( sterm * 1000 ) + 1
-
-                   cip = MAX( 0.0_wp, ( u(k,j,i) - u_gtrans ) * dt_3d * ddx )
-
-                   ipme(k,i) = sk_p(k,j,i-2) * cip + snenn * (                    &
-                               aex(ix) * cip + bex(ix) / dex(ix) * (              &
-                               eex(ix) -                                          &
-                               EXP( dex(ix)*0.5_wp * ( 1.0_wp - 2.0_wp * cip ) )  &
-                                                                   )              &
-                                                             )
-                   IF ( sterm == 0.0001_wp )  ipme(k,i) = sk_p(k,j,i-1) * cip
-                   IF ( sterm == 0.9999_wp )  ipme(k,i) = sk_p(k,j,i-1) * cip
-                ENDIF
-
-             ENDDO
-          ENDDO
-          CALL cpu_log( log_point_s(12), 'advec_s_bc:exp', 'pause' )
-
-!
-!--       Prognostic equation
-          DO  i = nxl, nxr
-             DO  k = nzb+1, nzt
-                fplus  = ( 1.0_wp - sw(k,i)   ) * ippb(k,i) + sw(k,i)   * ippe(k,i)  &
-                       - ( 1.0_wp - sw(k,i+1) ) * impb(k,i) - sw(k,i+1) * impe(k,i)
-                fminus = ( 1.0_wp - sw(k,i-1) ) * ipmb(k,i) + sw(k,i-1) * ipme(k,i)  &
-                       - ( 1.0_wp - sw(k,i)   ) * immb(k,i) - sw(k,i)   * imme(k,i)
-                tendcy = fplus - fminus
-!
-!--             Removed in order to optimize speed
-!                ffmax   = MAX( ABS( fplus ), ABS( fminus ), 1E-35_wp )
-!                IF ( ( ABS( tendcy ) / ffmax ) < 1E-7_wp )  tendcy = 0.0
-!
-!--             Density correction because of possible remaining divergences
-                d_new = d(k,j,i) - ( u(k,j,i+1) - u(k,j,i) ) * dt_3d * ddx
-                sk_p(k,j,i) = ( ( 1.0_wp + d(k,j,i) ) * sk_p(k,j,i) - tendcy ) /    &
-                              ( 1.0_wp + d_new )
-                d(k,j,i)  = d_new
-             ENDDO
-          ENDDO
-
-       ENDDO   ! End of the advection in x-direction
-
-!
-!--    Deallocate temporary arrays
-       DEALLOCATE( a0, a1, a2, a12, a22, immb, imme, impb, impe, ipmb, ipme,      &
-                   ippb, ippe, m1, sw )
-
-
-!
-!--    Enlarge boundary of local array cyclically in y-direction
-#if defined( __parallel )
-       ngp = ( nzt - nzb + 6 ) * ( nyn - nys + 7 )
-       CALL MPI_TYPE_VECTOR( nxr-nxl+7, 3*(nzt-nzb+6), ngp, MPI_REAL,             &
-                             type_xz_2, ierr )
-       CALL MPI_TYPE_COMMIT( type_xz_2, ierr )
-!
-!--    Send front boundary, receive rear boundary
-       CALL cpu_log( log_point_s(11), 'advec_s_bc:sendrecv', 'continue' )
-       CALL MPI_SENDRECV( sk_p(nzb-2,nys,nxl-3),   1, type_xz_2, psouth, 0,       &
-                          sk_p(nzb-2,nyn+1,nxl-3), 1, type_xz_2, pnorth, 0,       &
-                          comm2d, status, ierr )
-!
-!--    Send rear boundary, receive front boundary
-       CALL MPI_SENDRECV( sk_p(nzb-2,nyn-2,nxl-3), 1, type_xz_2, pnorth, 1,       &
-                          sk_p(nzb-2,nys-3,nxl-3), 1, type_xz_2, psouth, 1,       &
-                          comm2d, status, ierr )
-       CALL MPI_TYPE_FREE( type_xz_2, ierr )
-       CALL cpu_log( log_point_s(11), 'advec_s_bc:sendrecv', 'pause' )
-#else
-       DO  i = nxl, nxr
-          DO  k = nzb+1, nzt
-             sk_p(k,nys-1,i) = sk_p(k,nyn,i)
-             sk_p(k,nys-2,i) = sk_p(k,nyn-1,i)
-             sk_p(k,nys-3,i) = sk_p(k,nyn-2,i)
-             sk_p(k,nyn+1,i) = sk_p(k,nys,i)
-             sk_p(k,nyn+2,i) = sk_p(k,nys+1,i)
-             sk_p(k,nyn+3,i) = sk_p(k,nys+2,i)
-          ENDDO
-       ENDDO
-#endif
-
-!
-!--    Determine the maxima of the first and second derivative in y-direction
-       fmax_l = 0.0_wp
-       DO  i = nxl, nxr
-          DO  j = nys, nyn
-             DO  k = nzb+1, nzt
-                numera = ABS( sk_p(k,j+1,i) - 2.0_wp * sk_p(k,j,i) + sk_p(k,j-1,i) )
-                denomi  = ABS( sk_p(k,j+1,i) - sk_p(k,j-1,i) )
-                fmax_l(1) = MAX( fmax_l(1) , numera )
-                fmax_l(2) = MAX( fmax_l(2) , denomi  )
-             ENDDO
-          ENDDO
-       ENDDO
-#if defined( __parallel )
-       IF ( collective_wait )  CALL MPI_BARRIER( comm2d, ierr )
-       CALL MPI_ALLREDUCE( fmax_l, fmax, 2, MPI_REAL, MPI_MAX, comm2d, ierr )
-#else
-       fmax = fmax_l
-#endif
-
-       fmax = 0.04_wp * fmax
-
-!
-!--    Allocate temporary arrays
-       ALLOCATE( a0(nzb+1:nzt,nys-1:nyn+1),   a1(nzb+1:nzt,nys-1:nyn+1),          &
-                 a2(nzb+1:nzt,nys-1:nyn+1),   a12(nzb+1:nzt,nys-1:nyn+1),         &
-                 a22(nzb+1:nzt,nys-1:nyn+1),  immb(nzb+1:nzt,nys-1:nyn+1),        &
-                 imme(nzb+1:nzt,nys-1:nyn+1), impb(nzb+1:nzt,nys-1:nyn+1),        &
-                 impe(nzb+1:nzt,nys-1:nyn+1), ipmb(nzb+1:nzt,nys-1:nyn+1),        &
-                 ipme(nzb+1:nzt,nys-1:nyn+1), ippb(nzb+1:nzt,nys-1:nyn+1),        &
-                 ippe(nzb+1:nzt,nys-1:nyn+1), m1(nzb+1:nzt,nys-2:nyn+2),          &
-                 sw(nzb+1:nzt,nys-1:nyn+1)                                        &
-               )
-       imme = 0.0_wp; impe = 0.0_wp; ipme = 0.0_wp; ippe = 0.0_wp
-
-!
-!--    Outer loop of all i
-       DO  i = nxl, nxr
-
-!
-!--       Compute polynomial coefficients
-          DO  j = nys-1, nyn+1
-             DO  k = nzb+1, nzt
-                a12(k,j) = 0.5_wp * ( sk_p(k,j+1,i) - sk_p(k,j-1,i) )
-                a22(k,j) = 0.5_wp * ( sk_p(k,j+1,i) - 2.0_wp * sk_p(k,j,i)        &
-                                                    + sk_p(k,j-1,i) )
-                a0(k,j) = ( 9.0_wp * sk_p(k,j+2,i)    - 116.0_wp * sk_p(k,j+1,i)  &
-                            + 2134.0_wp * sk_p(k,j,i) - 116.0_wp * sk_p(k,j-1,i)  &
-                            + 9.0_wp * sk_p(k,j-2,i) ) * f1920
-                a1(k,j) = ( -5.0_wp   * sk_p(k,j+2,i) + 34.0_wp * sk_p(k,j+1,i)   &
-                            - 34.0_wp * sk_p(k,j-1,i) + 5.0_wp  * sk_p(k,j-2,i)   &
-                          ) * f48
-                a2(k,j) = ( -3.0_wp * sk_p(k,j+2,i) + 36.0_wp * sk_p(k,j+1,i)     &
-                            - 66.0_wp * sk_p(k,j,i) + 36.0_wp * sk_p(k,j-1,i)     &
-                            - 3.0_wp * sk_p(k,j-2,i) ) * f48
-             ENDDO
-          ENDDO
-
-!
-!--       Fluxes using the Bott scheme
-!--       *VOCL LOOP,UNROLL(2)
-          DO  j = nys, nyn
-             DO  k = nzb+1, nzt
-                cip  =  MAX( 0.0_wp, ( v(k,j+1,i) - v_gtrans ) * dt_3d * ddy )
-                cim  = -MIN( 0.0_wp, ( v(k,j+1,i) - v_gtrans ) * dt_3d * ddy )
-                cipf = 1.0_wp - 2.0_wp * cip
-                cimf = 1.0_wp - 2.0_wp * cim
-                ip   =   a0(k,j)   * f2  * ( 1.0_wp - cipf )                      &
-                       + a1(k,j)   * f8  * ( 1.0_wp - cipf*cipf )                 &
-                       + a2(k,j)   * f24 * ( 1.0_wp - cipf*cipf*cipf )
-                im   =   a0(k,j+1) * f2  * ( 1.0_wp - cimf )                      &
-                       - a1(k,j+1) * f8  * ( 1.0_wp - cimf*cimf )                 &
-                       + a2(k,j+1) * f24 * ( 1.0_wp - cimf*cimf*cimf )
-                ip   = MAX( ip, 0.0_wp )
-                im   = MAX( im, 0.0_wp )
-                ippb(k,j) = ip * MIN( 1.0_wp, sk_p(k,j,i)   / (ip+im+1E-15_wp) )
-                impb(k,j) = im * MIN( 1.0_wp, sk_p(k,j+1,i) / (ip+im+1E-15_wp) )
-
-                cip  =  MAX( 0.0_wp, ( v(k,j,i) - v_gtrans ) * dt_3d * ddy )
-                cim  = -MIN( 0.0_wp, ( v(k,j,i) - v_gtrans ) * dt_3d * ddy )
-                cipf = 1.0_wp - 2.0_wp * cip
-                cimf = 1.0_wp - 2.0_wp * cim
-                ip   =   a0(k,j-1) * f2  * ( 1.0_wp - cipf )                      &
-                       + a1(k,j-1) * f8  * ( 1.0_wp - cipf*cipf )                 &
-                       + a2(k,j-1) * f24 * ( 1.0_wp - cipf*cipf*cipf )
-                im   =   a0(k,j)   * f2  * ( 1.0_wp - cimf )                      &
-                       - a1(k,j)   * f8  * ( 1.0_wp - cimf*cimf )                 &
-                       + a2(k,j)   * f24 * ( 1.0_wp - cimf*cimf*cimf )
-                ip   = MAX( ip, 0.0_wp )
-                im   = MAX( im, 0.0_wp )
-                ipmb(k,j) = ip * MIN( 1.0_wp, sk_p(k,j-1,i) / (ip+im+1E-15_wp) )
-                immb(k,j) = im * MIN( 1.0_wp, sk_p(k,j,i)   / (ip+im+1E-15_wp) )
-             ENDDO
-          ENDDO
-
-!
-!--       Compute monitor function m1
-          DO  j = nys-2, nyn+2
-             DO  k = nzb+1, nzt
-                m1z = ABS( sk_p(k,j+1,i) - 2.0_wp * sk_p(k,j,i) + sk_p(k,j-1,i) )
-                m1n = ABS( sk_p(k,j+1,i) - sk_p(k,j-1,i) )
-                IF ( m1n /= 0.0_wp  .AND.  m1n >= m1z )  THEN
-                   m1(k,j) = m1z / m1n
-                   IF ( m1(k,j) /= 2.0_wp  .AND.  m1n < fmax(2) )  m1(k,j) = 0.0_wp
-                ELSEIF ( m1n < m1z )  THEN
-                   m1(k,j) = -1.0_wp
-                ELSE
-                   m1(k,j) = 0.0_wp
-                ENDIF
-             ENDDO
-          ENDDO
-
-!
-!--       Compute switch sw
-          sw = 0.0_wp
-          DO  j = nys-1, nyn+1
-             DO  k = nzb+1, nzt
-                m2 = 2.0_wp * ABS( a1(k,j) - a12(k,j) ) /                            &
-                     MAX( ABS( a1(k,j) + a12(k,j) ), 1E-35_wp )
-                IF ( ABS( a1(k,j) + a12(k,j) ) < fmax(2) )  m2 = 0.0_wp
-
-                m3 = 2.0_wp * ABS( a2(k,j) - a22(k,j) ) /                            &
-                     MAX( ABS( a2(k,j) + a22(k,j) ), 1E-35_wp )
-                IF ( ABS( a2(k,j) + a22(k,j) ) < fmax(1) )  m3 = 0.0_wp
-
-                t1 = 0.35_wp
-                t2 = 0.35_wp
-                IF ( m1(k,j) == -1.0_wp )  t2 = 0.12_wp
-
-!--             *VOCL STMT,IF(10)
-                IF ( m1(k,j-1) == 1.0_wp .OR. m1(k,j) == 1.0_wp                   &
-                     .OR. m1(k,j+1) == 1.0_wp .OR.  m2 > t2  .OR.  m3 > t2  .OR.  &
-                     ( m1(k,j) > t1  .AND.  m1(k,j-1) /= -1.0_wp  .AND.           &
-                       m1(k,j) /= -1.0_wp  .AND.  m1(k,j+1) /= -1.0_wp )          &
-                   )  sw(k,j) = 1.0_wp
-             ENDDO
-          ENDDO
-
-!
-!--       Fluxes using exponential scheme
-          CALL cpu_log( log_point_s(12), 'advec_s_bc:exp', 'continue' )
-          DO  j = nys, nyn
-             DO  k = nzb+1, nzt
-
-!--             *VOCL STMT,IF(10)
-                IF ( sw(k,j) == 1.0_wp )  THEN
-                   snenn = sk_p(k,j+1,i) - sk_p(k,j-1,i)
-                   IF ( ABS( snenn ) < 1E-9_wp )  snenn = 1E-9_wp
-                   sterm = ( sk_p(k,j,i) - sk_p(k,j-1,i) ) / snenn
-                   sterm = MIN( sterm, 0.9999_wp )
-                   sterm = MAX( sterm, 0.0001_wp )
-
-                   ix = INT( sterm * 1000 ) + 1
-
-                   cip =  MAX( 0.0_wp, ( v(k,j+1,i) - v_gtrans ) * dt_3d * ddy )
-
-                   ippe(k,j) = sk_p(k,j-1,i) * cip + snenn * (                    &
-                               aex(ix) * cip + bex(ix) / dex(ix) * (              &
-                               eex(ix) -                                          &
-                               EXP( dex(ix)*0.5_wp * ( 1.0_wp - 2.0_wp * cip ) )  &
-                                                                   )              &
-                                                             )
-                   IF ( sterm == 0.0001_wp )  ippe(k,j) = sk_p(k,j,i) * cip
-                   IF ( sterm == 0.9999_wp )  ippe(k,j) = sk_p(k,j,i) * cip
-
-                   snenn = sk_p(k,j-1,i) - sk_p(k,j+1,i)
-                   IF ( ABS( snenn ) < 1E-9_wp )  snenn = 1E-9_wp
-                   sterm = ( sk_p(k,j,i) - sk_p(k,j+1,i) ) / snenn
-                   sterm = MIN( sterm, 0.9999_wp )
-                   sterm = MAX( sterm, 0.0001_wp )
-
-                   ix = INT( sterm * 1000 ) + 1
-
-                   cim = -MIN( 0.0_wp, ( v(k,j,i) - v_gtrans ) * dt_3d * ddy )
-
-                   imme(k,j) = sk_p(k,j+1,i) * cim + snenn * (                    &
-                               aex(ix) * cim + bex(ix) / dex(ix) * (              &
-                               eex(ix) -                                          &
-                               EXP( dex(ix)*0.5_wp * ( 1.0_wp - 2.0_wp * cim ) )  &
-                                                                   )              &
-                                                             )
-                   IF ( sterm == 0.0001_wp )  imme(k,j) = sk_p(k,j,i) * cim
-                   IF ( sterm == 0.9999_wp )  imme(k,j) = sk_p(k,j,i) * cim
-                ENDIF
-
-!--             *VOCL STMT,IF(10)
-                IF ( sw(k,j+1) == 1.0_wp )  THEN
-                   snenn = sk_p(k,j,i) - sk_p(k,j+2,i)
-                   IF ( ABS( snenn ) < 1E-9_wp )  snenn = 1E-9_wp
-                   sterm = ( sk_p(k,j+1,i) - sk_p(k,j+2,i) ) / snenn
-                   sterm = MIN( sterm, 0.9999_wp )
-                   sterm = MAX( sterm, 0.0001_wp )
-
-                   ix = INT( sterm * 1000 ) + 1
-
-                   cim = -MIN( 0.0_wp, ( v(k,j+1,i) - v_gtrans ) * dt_3d * ddy )
-
-                   impe(k,j) = sk_p(k,j+2,i) * cim + snenn * (                    &
-                               aex(ix) * cim + bex(ix) / dex(ix) * (              &
-                               eex(ix) -                                          &
-                               EXP( dex(ix)*0.5_wp * ( 1.0_wp - 2.0_wp * cim ) )  &
-                                                                   )              &
-                                                             )
-                   IF ( sterm == 0.0001_wp )  impe(k,j) = sk_p(k,j+1,i) * cim
-                   IF ( sterm == 0.9999_wp )  impe(k,j) = sk_p(k,j+1,i) * cim
-                ENDIF
-
-!--             *VOCL STMT,IF(10)
-                IF ( sw(k,j-1) == 1.0_wp )  THEN
-                   snenn = sk_p(k,j,i) - sk_p(k,j-2,i)
-                   IF ( ABS( snenn ) < 1E-9_wp )  snenn = 1E-9_wp
-                   sterm = ( sk_p(k,j-1,i) - sk_p(k,j-2,i) ) / snenn
-                   sterm = MIN( sterm, 0.9999_wp )
-                   sterm = MAX( sterm, 0.0001_wp )
-
-                   ix = INT( sterm * 1000 ) + 1
-
-                   cip = MAX( 0.0_wp, ( v(k,j,i) - v_gtrans ) * dt_3d * ddy )
-
-                   ipme(k,j) = sk_p(k,j-2,i) * cip + snenn * (                    &
-                               aex(ix) * cip + bex(ix) / dex(ix) * (              &
-                               eex(ix) -                                          &
-                               EXP( dex(ix)*0.5_wp * ( 1.0_wp - 2.0_wp * cip ) )  &
-                                                                   )              &
-                                                             )
-                   IF ( sterm == 0.0001_wp )  ipme(k,j) = sk_p(k,j-1,i) * cip
-                   IF ( sterm == 0.9999_wp )  ipme(k,j) = sk_p(k,j-1,i) * cip
-                ENDIF
-
-             ENDDO
-          ENDDO
-          CALL cpu_log( log_point_s(12), 'advec_s_bc:exp', 'pause' )
-
-!
-!--       Prognostic equation
-          DO  j = nys, nyn
-             DO  k = nzb+1, nzt
-                fplus  = ( 1.0_wp - sw(k,j)   ) * ippb(k,j) + sw(k,j)   * ippe(k,j) &
-                       - ( 1.0_wp - sw(k,j+1) ) * impb(k,j) - sw(k,j+1) * impe(k,j)
-                fminus = ( 1.0_wp - sw(k,j-1) ) * ipmb(k,j) + sw(k,j-1) * ipme(k,j) &
-                       - ( 1.0_wp - sw(k,j)   ) * immb(k,j) - sw(k,j)   * imme(k,j)
-                tendcy = fplus - fminus
-!
-!--             Removed in order to optimise speed
-!                ffmax   = MAX( ABS( fplus ), ABS( fminus ), 1E-35_wp )
-!                 IF ( ( ABS( tendcy ) / ffmax ) < 1E-7_wp )  tendcy = 0.0
-!
-!--             Density correction because of possible remaining divergences
-                d_new = d(k,j,i) - ( v(k,j+1,i) - v(k,j,i) ) * dt_3d * ddy
-                sk_p(k,j,i) = ( ( 1.0_wp + d(k,j,i) ) * sk_p(k,j,i) - tendcy ) /  &
-                              ( 1.0_wp + d_new )
-                d(k,j,i)  = d_new
-             ENDDO
-          ENDDO
-
-       ENDDO   ! End of the advection in y-direction
-       CALL cpu_log( log_point_s(11), 'advec_s_bc:sendrecv', 'continue' )
-       CALL cpu_log( log_point_s(11), 'advec_s_bc:sendrecv', 'stop' )
-
-!
-!--    Deallocate temporary arrays
-       DEALLOCATE( a0, a1, a2, a12, a22, immb, imme, impb, impe, ipmb, ipme,      &
-                   ippb, ippe, m1, sw )
-
-
-!
-!--    Initialise for the computation of heat fluxes (see below; required in
-!--    UP flow_statistics)
-       IF ( sk_char == 'pt' )  sums_wsts_bc_l = 0.0_wp
-
-!
-!--    Add top and bottom boundaries according to the relevant boundary conditions
-       IF ( sk_char == 'pt' )  THEN
-
-!
-!--       Temperature boundary condition at the bottom boundary
-          IF ( ibc_pt_b == 0 )  THEN
-!
-!--       Dirichlet (fixed surface temperature)
-             DO  i = nxl, nxr
-                DO  j = nys, nyn
-                   sk_p(nzb-1,j,i) = sk_p(nzb,j,i)
-                   sk_p(nzb-2,j,i) = sk_p(nzb,j,i)
-                ENDDO
-             ENDDO
-
-          ELSE
-!
-!--          Neumann (i.e. here zero gradient)
-             DO  i = nxl, nxr
-                DO  j = nys, nyn
-                   sk_p(nzb,j,i)   = sk_p(nzb+1,j,i)
-                   sk_p(nzb-1,j,i) = sk_p(nzb,j,i)
-                   sk_p(nzb-2,j,i) = sk_p(nzb,j,i)
-                ENDDO
-             ENDDO
-
-          ENDIF
-
-!
-!--       Temperature boundary condition at the top boundary
-          IF ( ibc_pt_t == 0  .OR.  ibc_pt_t == 1 )  THEN
-!
-!--          Dirichlet or Neumann (zero gradient)
-             DO  i = nxl, nxr
-                DO  j = nys, nyn
-                   sk_p(nzt+2,j,i)   = sk_p(nzt+1,j,i)
-                   sk_p(nzt+3,j,i)   = sk_p(nzt+1,j,i)
-                ENDDO
-             ENDDO
-
-          ELSEIF ( ibc_pt_t == 2 )  THEN
-!
-!--          Neumann: dzu(nzt+2:3) are not defined, dzu(nzt+1) is used instead
-             DO  i = nxl, nxr
-                DO  j = nys, nyn
-                   sk_p(nzt+2,j,i)   = sk_p(nzt+1,j,i) + bc_pt_t_val * dzu(nzt+1)
-                   sk_p(nzt+3,j,i)   = sk_p(nzt+2,j,i) + bc_pt_t_val * dzu(nzt+1)
-                ENDDO
-             ENDDO
-
-          ENDIF
-
-       ELSEIF ( sk_char == 'sa' )  THEN
-
-!
-!--       Salinity boundary condition at the bottom boundary.
-!--       So far, always Neumann (i.e. here zero gradient) is used
-          DO  i = nxl, nxr
-             DO  j = nys, nyn
-                sk_p(nzb,j,i)   = sk_p(nzb+1,j,i)
-                sk_p(nzb-1,j,i) = sk_p(nzb,j,i)
-                sk_p(nzb-2,j,i) = sk_p(nzb,j,i)
-             ENDDO
-          ENDDO
-
-!
-!--       Salinity boundary condition at the top boundary.
-!--       Dirichlet or Neumann (zero gradient)
-          DO  i = nxl, nxr
-             DO  j = nys, nyn
-                sk_p(nzt+2,j,i)   = sk_p(nzt+1,j,i)
-                sk_p(nzt+3,j,i)   = sk_p(nzt+1,j,i)
-             ENDDO
-          ENDDO
-
-       ELSEIF ( sk_char == 'q' )  THEN
-
-!
-!--       Specific humidity boundary condition at the bottom boundary.
-!--       Dirichlet (fixed surface humidity) or Neumann (i.e. zero gradient)
-          DO  i = nxl, nxr
-             DO  j = nys, nyn
-                sk_p(nzb,j,i)   = sk_p(nzb+1,j,i)
-                sk_p(nzb-1,j,i) = sk_p(nzb,j,i)
-                sk_p(nzb-2,j,i) = sk_p(nzb,j,i)
-             ENDDO
-          ENDDO
-
-!
-!--       Specific humidity boundary condition at the top boundary
-          IF ( ibc_q_t == 0 )  THEN
-!
-!--          Dirichlet
-             DO  i = nxl, nxr
-                DO  j = nys, nyn
-                   sk_p(nzt+2,j,i)   = sk_p(nzt+1,j,i)
-                   sk_p(nzt+3,j,i)   = sk_p(nzt+1,j,i)
-                ENDDO
-             ENDDO
-
-          ELSE
-!
-!--          Neumann: dzu(nzt+2:3) are not defined, dzu(nzt+1) is used instead
-             DO  i = nxl, nxr
-                DO  j = nys, nyn
-                   sk_p(nzt+2,j,i)   = sk_p(nzt+1,j,i) + bc_q_t_val * dzu(nzt+1)
-                   sk_p(nzt+3,j,i)   = sk_p(nzt+2,j,i) + bc_q_t_val * dzu(nzt+1)
-                ENDDO
-             ENDDO
-
-          ENDIF
-
-       ELSEIF ( sk_char == 'qr' )  THEN
-
-!
-!--       Rain water content boundary condition at the bottom boundary:
-!--       Dirichlet (fixed surface rain water content).
-          DO  i = nxl, nxr
-             DO  j = nys, nyn
-                sk_p(nzb,j,i)   = sk_p(nzb+1,j,i)
-                sk_p(nzb-1,j,i) = sk_p(nzb,j,i)
-                sk_p(nzb-2,j,i) = sk_p(nzb,j,i)
-             ENDDO
-          ENDDO
-
-!
-!--       Rain water content boundary condition at the top boundary: Dirichlet
-          DO  i = nxl, nxr
-             DO  j = nys, nyn
-                sk_p(nzt+2,j,i)   = sk_p(nzt+1,j,i)
-                sk_p(nzt+3,j,i)   = sk_p(nzt+1,j,i)
-             ENDDO
-          ENDDO
-
-       ELSEIF ( sk_char == 'nr' )  THEN
-
-!
-!--       Rain drop concentration boundary condition at the bottom boundary:
-!--       Dirichlet (fixed surface rain drop concentration).
-          DO  i = nxl, nxr
-             DO  j = nys, nyn
-                sk_p(nzb,j,i)   = sk_p(nzb+1,j,i)
-                sk_p(nzb-1,j,i) = sk_p(nzb,j,i)
-                sk_p(nzb-2,j,i) = sk_p(nzb,j,i)
-             ENDDO
-          ENDDO
-
-!
-!--       Rain drop concentration boundary condition at the top boundary: Dirichlet
-          DO  i = nxl, nxr
-             DO  j = nys, nyn
-                sk_p(nzt+2,j,i)   = sk_p(nzt+1,j,i)
-                sk_p(nzt+3,j,i)   = sk_p(nzt+1,j,i)
-             ENDDO
-          ENDDO
-
-       ELSEIF ( sk_char == 'e' )  THEN
-
-!
-!--       TKE boundary condition at bottom and top boundary (generally Neumann)
-          DO  i = nxl, nxr
-             DO  j = nys, nyn
-                sk_p(nzb,j,i)   = sk_p(nzb+1,j,i)
-                sk_p(nzb-1,j,i) = sk_p(nzb,j,i)
-                sk_p(nzb-2,j,i) = sk_p(nzb,j,i)
-                sk_p(nzt+2,j,i) = sk_p(nzt+1,j,i)
-                sk_p(nzt+3,j,i) = sk_p(nzt+1,j,i)
-             ENDDO
-          ENDDO
-
-       ELSE
-
-          WRITE( message_string, * ) 'no vertical boundary condi',                &
-                                   'tion for variable "', sk_char, '"'
-          CALL message( 'advec_s_bc', 'PA0158', 1, 2, 0, 6, 0 )
-         
-       ENDIF
-
-!
-!--    Determine the maxima of the first and second derivative in z-direction
-       fmax_l = 0.0_wp
-       DO  i = nxl, nxr
-          DO  j = nys, nyn
-             DO  k = nzb, nzt+1
-                numera = ABS( sk_p(k+1,j,i) - 2.0_wp * sk_p(k,j,i) + sk_p(k-1,j,i) )
-                denomi  = ABS( sk_p(k+1,j,i+1) - sk_p(k-1,j,i) )
-                fmax_l(1) = MAX( fmax_l(1) , numera )
-                fmax_l(2) = MAX( fmax_l(2) , denomi  )
-             ENDDO
-          ENDDO
-       ENDDO
-#if defined( __parallel )
-       IF ( collective_wait )  CALL MPI_BARRIER( comm2d, ierr )
-       CALL MPI_ALLREDUCE( fmax_l, fmax, 2, MPI_REAL, MPI_MAX, comm2d, ierr )
-#else
-       fmax = fmax_l
-#endif
-
-       fmax = 0.04_wp * fmax
-
-!
-!--    Allocate temporary arrays
-       ALLOCATE( a0(nzb:nzt+1,nys:nyn),   a1(nzb:nzt+1,nys:nyn),                  &
-                 a2(nzb:nzt+1,nys:nyn),   a12(nzb:nzt+1,nys:nyn),                 &
-                 a22(nzb:nzt+1,nys:nyn),  immb(nzb+1:nzt,nys:nyn),                &
-                 imme(nzb+1:nzt,nys:nyn), impb(nzb+1:nzt,nys:nyn),                &
-                 impe(nzb+1:nzt,nys:nyn), ipmb(nzb+1:nzt,nys:nyn),                &
-                 ipme(nzb+1:nzt,nys:nyn), ippb(nzb+1:nzt,nys:nyn),                &
-                 ippe(nzb+1:nzt,nys:nyn), m1(nzb-1:nzt+2,nys:nyn),                &
-                 sw(nzb:nzt+1,nys:nyn)                                            &
-               )
-       imme = 0.0_wp; impe = 0.0_wp; ipme = 0.0_wp; ippe = 0.0_wp
-
-!
-!--    Outer loop of all i
-       DO  i = nxl, nxr
-
-!
-!--       Compute polynomial coefficients
-          DO  j = nys, nyn
-             DO  k = nzb, nzt+1
-                a12(k,j) = 0.5_wp * ( sk_p(k+1,j,i) - sk_p(k-1,j,i) )
-                a22(k,j) = 0.5_wp * ( sk_p(k+1,j,i) - 2.0_wp * sk_p(k,j,i)        &
-                                                    + sk_p(k-1,j,i) )
-                a0(k,j) = ( 9.0_wp * sk_p(k+2,j,i)    - 116.0_wp * sk_p(k+1,j,i)  &
-                            + 2134.0_wp * sk_p(k,j,i) - 116.0_wp * sk_p(k-1,j,i)  &
-                            + 9.0_wp * sk_p(k-2,j,i) ) * f1920
-                a1(k,j) = ( -5.0_wp   * sk_p(k+2,j,i) + 34.0_wp * sk_p(k+1,j,i)   &
-                            - 34.0_wp * sk_p(k-1,j,i) + 5.0_wp  * sk_p(k-2,j,i)   &
-                          ) * f48
-                a2(k,j) = ( -3.0_wp * sk_p(k+2,j,i) + 36.0_wp * sk_p(k+1,j,i)     &
-                            - 66.0_wp * sk_p(k,j,i) + 36.0_wp * sk_p(k-1,j,i)     &
-                            - 3.0_wp * sk_p(k-2,j,i) ) * f48
-             ENDDO
-          ENDDO
-
-!
-!--       Fluxes using the Bott scheme
-!--       *VOCL LOOP,UNROLL(2)
-          DO  j = nys, nyn
-             DO  k = nzb+1, nzt
-                cip  =  MAX( 0.0_wp, w(k,j,i) * dt_3d * ddzw(k) )
-                cim  = -MIN( 0.0_wp, w(k,j,i) * dt_3d * ddzw(k) )
-                cipf = 1.0_wp - 2.0_wp * cip
-                cimf = 1.0_wp - 2.0_wp * cim
-                ip   =   a0(k,j)   * f2  * ( 1.0_wp - cipf )                      &
-                       + a1(k,j)   * f8  * ( 1.0_wp - cipf*cipf )                 &
-                       + a2(k,j)   * f24 * ( 1.0_wp - cipf*cipf*cipf )
-                im   =   a0(k+1,j) * f2  * ( 1.0_wp - cimf )                      &
-                       - a1(k+1,j) * f8  * ( 1.0_wp - cimf*cimf )                 &
-                       + a2(k+1,j) * f24 * ( 1.0_wp - cimf*cimf*cimf )
-                ip   = MAX( ip, 0.0_wp )
-                im   = MAX( im, 0.0_wp )
-                ippb(k,j) = ip * MIN( 1.0_wp, sk_p(k,j,i)   / (ip+im+1E-15_wp) )
-                impb(k,j) = im * MIN( 1.0_wp, sk_p(k+1,j,i) / (ip+im+1E-15_wp) )
-
-                cip  =  MAX( 0.0_wp, w(k-1,j,i) * dt_3d * ddzw(k) )
-                cim  = -MIN( 0.0_wp, w(k-1,j,i) * dt_3d * ddzw(k) )
-                cipf = 1.0_wp - 2.0_wp * cip
-                cimf = 1.0_wp - 2.0_wp * cim
-                ip   =   a0(k-1,j) * f2  * ( 1.0_wp - cipf )                      &
-                       + a1(k-1,j) * f8  * ( 1.0_wp - cipf*cipf )                 &
-                       + a2(k-1,j) * f24 * ( 1.0_wp - cipf*cipf*cipf )
-                im   =   a0(k,j)   * f2  * ( 1.0_wp - cimf )                      &
-                       - a1(k,j)   * f8  * ( 1.0_wp - cimf*cimf )                 &
-                       + a2(k,j)   * f24 * ( 1.0_wp - cimf*cimf*cimf )
-                ip   = MAX( ip, 0.0_wp )
-                im   = MAX( im, 0.0_wp )
-                ipmb(k,j) = ip * MIN( 1.0_wp, sk_p(k-1,j,i) / (ip+im+1E-15_wp) )
-                immb(k,j) = im * MIN( 1.0_wp, sk_p(k,j,i)   / (ip+im+1E-15_wp) )
-             ENDDO
-          ENDDO
-
-!
-!--       Compute monitor function m1
-          DO  j = nys, nyn
-             DO  k = nzb-1, nzt+2
-                m1z = ABS( sk_p(k+1,j,i) - 2.0_wp * sk_p(k,j,i) + sk_p(k-1,j,i) )
-                m1n = ABS( sk_p(k+1,j,i) - sk_p(k-1,j,i) )
-                IF ( m1n /= 0.0_wp  .AND.  m1n >= m1z )  THEN
-                   m1(k,j) = m1z / m1n
-                   IF ( m1(k,j) /= 2.0_wp  .AND.  m1n < fmax(2) )  m1(k,j) = 0.0_wp
-                ELSEIF ( m1n < m1z )  THEN
-                   m1(k,j) = -1.0_wp
-                ELSE
-                   m1(k,j) = 0.0_wp
-                ENDIF
-             ENDDO
-          ENDDO
-
-!
-!--       Compute switch sw
-          sw = 0.0_wp
-          DO  j = nys, nyn
-             DO  k = nzb, nzt+1
-                m2 = 2.0_wp * ABS( a1(k,j) - a12(k,j) ) /                         &
-                     MAX( ABS( a1(k,j) + a12(k,j) ), 1E-35_wp )
-                IF ( ABS( a1(k,j) + a12(k,j) ) < fmax(2) )  m2 = 0.0_wp
-
-                m3 = 2.0_wp * ABS( a2(k,j) - a22(k,j) ) /                         &
-                     MAX( ABS( a2(k,j) + a22(k,j) ), 1E-35_wp )
-                IF ( ABS( a2(k,j) + a22(k,j) ) < fmax(1) )  m3 = 0.0_wp
-
-                t1 = 0.35_wp
-                t2 = 0.35_wp
-                IF ( m1(k,j) == -1.0_wp )  t2 = 0.12_wp
-
-!--             *VOCL STMT,IF(10)
-                IF ( m1(k-1,j) == 1.0_wp .OR. m1(k,j) == 1.0_wp                   &
-                     .OR. m1(k+1,j) == 1.0_wp .OR.  m2 > t2  .OR.  m3 > t2  .OR.  &
-                     ( m1(k,j) > t1  .AND.  m1(k-1,j) /= -1.0_wp  .AND.           &
-                       m1(k,j) /= -1.0_wp  .AND.  m1(k+1,j) /= -1.0_wp )          &
-                   )  sw(k,j) = 1.0_wp
-             ENDDO
-          ENDDO
-
-!
-!--       Fluxes using exponential scheme
-          CALL cpu_log( log_point_s(12), 'advec_s_bc:exp', 'continue' )
-          DO  j = nys, nyn
-             DO  k = nzb+1, nzt
-
-!--             *VOCL STMT,IF(10)
-                IF ( sw(k,j) == 1.0_wp )  THEN
-                   snenn = sk_p(k+1,j,i) - sk_p(k-1,j,i)
-                   IF ( ABS( snenn ) < 1E-9_wp )  snenn = 1E-9_wp
-                   sterm = ( sk_p(k,j,i) - sk_p(k-1,j,i) ) / snenn
-                   sterm = MIN( sterm, 0.9999_wp )
-                   sterm = MAX( sterm, 0.0001_wp )
-
-                   ix = INT( sterm * 1000 ) + 1
-
-                   cip =  MAX( 0.0_wp, w(k,j,i) * dt_3d * ddzw(k) )
-
-                   ippe(k,j) = sk_p(k-1,j,i) * cip + snenn * (                    &
-                               aex(ix) * cip + bex(ix) / dex(ix) * (              &
-                               eex(ix) -                                          &
-                               EXP( dex(ix)*0.5_wp * ( 1.0_wp - 2.0_wp * cip ) )  &
-                                                                   )              &
-                                                             )
-                   IF ( sterm == 0.0001_wp )  ippe(k,j) = sk_p(k,j,i) * cip
-                   IF ( sterm == 0.9999_wp )  ippe(k,j) = sk_p(k,j,i) * cip
-
-                   snenn = sk_p(k-1,j,i) - sk_p(k+1,j,i)
-                   IF ( ABS( snenn ) < 1E-9_wp )  snenn = 1E-9_wp
-                   sterm = ( sk_p(k,j,i) - sk_p(k+1,j,i) ) / snenn
-                   sterm = MIN( sterm, 0.9999_wp )
-                   sterm = MAX( sterm, 0.0001_wp )
-
-                   ix = INT( sterm * 1000 ) + 1
-
-                   cim = -MIN( 0.0_wp, w(k-1,j,i) * dt_3d * ddzw(k) )
-
-                   imme(k,j) = sk_p(k+1,j,i) * cim + snenn * (                    &
-                               aex(ix) * cim + bex(ix) / dex(ix) * (              &
-                               eex(ix) -                                          &
-                               EXP( dex(ix)*0.5_wp * ( 1.0_wp - 2.0_wp * cim ) ) &
-                                                                   )              &
-                                                             )
-                   IF ( sterm == 0.0001_wp )  imme(k,j) = sk_p(k,j,i) * cim
-                   IF ( sterm == 0.9999_wp )  imme(k,j) = sk_p(k,j,i) * cim
-                ENDIF
-
-!--             *VOCL STMT,IF(10)
-                IF ( sw(k+1,j) == 1.0_wp )  THEN
-                   snenn = sk_p(k,j,i) - sk_p(k+2,j,i)
-                   IF ( ABS( snenn ) < 1E-9_wp )  snenn = 1E-9_wp
-                   sterm = ( sk_p(k+1,j,i) - sk_p(k+2,j,i) ) / snenn
-                   sterm = MIN( sterm, 0.9999_wp )
-                   sterm = MAX( sterm, 0.0001_wp )
-
-                   ix = INT( sterm * 1000 ) + 1
-
-                   cim = -MIN( 0.0_wp, w(k,j,i) * dt_3d * ddzw(k) )
-
-                   impe(k,j) = sk_p(k+2,j,i) * cim + snenn * (                    &
-                               aex(ix) * cim + bex(ix) / dex(ix) * (              &
-                               eex(ix) -                                          &
-                               EXP( dex(ix)*0.5_wp * ( 1.0_wp - 2.0_wp * cim ) )  &
-                                                                   )              &
-                                                             )
-                   IF ( sterm == 0.0001_wp )  impe(k,j) = sk_p(k+1,j,i) * cim
-                   IF ( sterm == 0.9999_wp )  impe(k,j) = sk_p(k+1,j,i) * cim
-                ENDIF
-
-!--             *VOCL STMT,IF(10)
-                IF ( sw(k-1,j) == 1.0_wp )  THEN
-                   snenn = sk_p(k,j,i) - sk_p(k-2,j,i)
-                   IF ( ABS( snenn ) < 1E-9_wp )  snenn = 1E-9_wp
-                   sterm = ( sk_p(k-1,j,i) - sk_p(k-2,j,i) ) / snenn
-                   sterm = MIN( sterm, 0.9999_wp )
-                   sterm = MAX( sterm, 0.0001_wp )
-
-                   ix = INT( sterm * 1000 ) + 1
-
-                   cip = MAX( 0.0_wp, w(k-1,j,i) * dt_3d * ddzw(k) )
-
-                   ipme(k,j) = sk_p(k-2,j,i) * cip + snenn * (                    &
-                               aex(ix) * cip + bex(ix) / dex(ix) * (              &
-                               eex(ix) -                                          &
-                               EXP( dex(ix)*0.5_wp * ( 1.0_wp - 2.0_wp * cip ) )  &
-                                                                   )              &
-                                                             )
-                   IF ( sterm == 0.0001_wp )  ipme(k,j) = sk_p(k-1,j,i) * cip
-                   IF ( sterm == 0.9999_wp )  ipme(k,j) = sk_p(k-1,j,i) * cip
-                ENDIF
-
-             ENDDO
-          ENDDO
-          CALL cpu_log( log_point_s(12), 'advec_s_bc:exp', 'pause' )
-
-!
-!--       Prognostic equation
-          DO  j = nys, nyn
-             DO  k = nzb+1, nzt
-                fplus  = ( 1.0_wp - sw(k,j)   ) * ippb(k,j) + sw(k,j)   * ippe(k,j) &
-                       - ( 1.0_wp - sw(k+1,j) ) * impb(k,j) - sw(k+1,j) * impe(k,j)
-                fminus = ( 1.0_wp - sw(k-1,j) ) * ipmb(k,j) + sw(k-1,j) * ipme(k,j) &
-                       - ( 1.0_wp - sw(k,j)   ) * immb(k,j) - sw(k,j)   * imme(k,j)
-                tendcy = fplus - fminus
-!
-!--              Removed in order to optimise speed
-!                ffmax   = MAX( ABS( fplus ), ABS( fminus ), 1E-35_wp )
-!                IF ( ( ABS( tendcy ) / ffmax ) < 1E-7_wp )  tendcy = 0.0
-!
-!--             Density correction because of possible remaining divergences
-                d_new = d(k,j,i) - ( w(k,j,i) - w(k-1,j,i) ) * dt_3d * ddzw(k)
-                sk_p(k,j,i) = ( ( 1.0_wp + d(k,j,i) ) * sk_p(k,j,i) - tendcy ) /  &
-                              ( 1.0_wp + d_new )
-!
-!--             Store heat flux for subsequent statistics output.
-!--             array m1 is here used as temporary storage
-                m1(k,j) = fplus / dt_3d * dzw(k)
-             ENDDO
-          ENDDO
-
-!
-!--       Sum up heat flux in order to order to obtain horizontal averages
-          IF ( sk_char == 'pt' )  THEN
-             DO  sr = 0, statistic_regions
-                DO  j = nys, nyn
-                   DO  k = nzb+1, nzt
-                      sums_wsts_bc_l(k,sr) = sums_wsts_bc_l(k,sr) +               &
-                                             m1(k,j) * rmask(j,i,sr)
-                   ENDDO
-                ENDDO
-             ENDDO
-          ENDIF
-
-       ENDDO   ! End of the advection in z-direction
-       CALL cpu_log( log_point_s(12), 'advec_s_bc:exp', 'continue' )
-       CALL cpu_log( log_point_s(12), 'advec_s_bc:exp', 'stop' )
-
-!
-!--    Deallocate temporary arrays
-       DEALLOCATE( a0, a1, a2, a12, a22, immb, imme, impb, impe, ipmb, ipme,      &
-                   ippb, ippe, m1, sw )
-
-!
-!--    Store results as tendency and deallocate local array
-       DO  i = nxl, nxr
-          DO  j = nys, nyn
-             DO  k = nzb+1, nzt
-                tend(k,j,i) = tend(k,j,i) + ( sk_p(k,j,i) - sk(k,j,i) ) / dt_3d
-             ENDDO
-          ENDDO
-       ENDDO
-
-       DEALLOCATE( sk_p )
-
-    END SUBROUTINE advec_s_bc
-
- END MODULE advec_s_bc_mod
Index: /palm/trunk/SOURCE/advec_s_bc_mod.f90
===================================================================
--- /palm/trunk/SOURCE/advec_s_bc_mod.f90	(revision 1850)
+++ /palm/trunk/SOURCE/advec_s_bc_mod.f90	(revision 1850)
@@ -0,0 +1,1324 @@
+!> @file advec_s_bc_mod.f90
+!--------------------------------------------------------------------------------!
+! This file is part of PALM.
+!
+! PALM is free software: you can redistribute it and/or modify it under the terms
+! of the GNU General Public License as published by the Free Software Foundation,
+! either version 3 of the License, or (at your option) any later version.
+!
+! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
+! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
+! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along with
+! PALM. If not, see <http://www.gnu.org/licenses/>.
+!
+! Copyright 1997-2016 Leibniz Universitaet Hannover
+!--------------------------------------------------------------------------------!
+!
+! Current revisions:
+! -----------------
+! Module renamed
+! 
+!
+! Former revisions:
+! -----------------
+! $Id$
+!
+! 1815 2016-04-06 13:49:59Z raasch
+! comment change
+!
+! 1691 2015-10-26 16:17:44Z maronga
+! Formatting corrections
+! 
+! 1682 2015-10-07 23:56:08Z knoop
+! Code annotations made doxygen readable
+! 
+! 1517 2015-01-07 19:12:25Z hoffmann
+! interface added to advec_s_bc
+!
+! 1374 2014-04-25 12:55:07Z raasch
+! missing variables added to ONLY list
+! 
+! 1361 2014-04-16 15:17:48Z hoffmann
+! nr and qr added
+! 
+! 1353 2014-04-08 15:21:23Z heinze
+! REAL constants provided with KIND-attribute
+!
+! 1346 2014-03-27 13:18:20Z heinze
+! Bugfix: REAL constants provided with KIND-attribute especially in call of 
+! intrinsic function like MAX, MIN, SIGN
+!
+! 1320 2014-03-20 08:40:49Z raasch
+! ONLY-attribute added to USE-statements,
+! kind-parameters added to all INTEGER and REAL declaration statements,
+! kinds are defined in new module kinds,
+! revision history before 2012 removed,
+! comment fields (!:) to be used for variable explanations added to
+! all variable declaration statements
+!
+! 1318 2014-03-17 13:35:16Z raasch
+! module interfaces removed
+!
+! 1092 2013-02-02 11:24:22Z raasch
+! unused variables removed
+!
+! 1036 2012-10-22 13:43:42Z raasch
+! code put under GPL (PALM 3.9)
+!
+! 1010 2012-09-20 07:59:54Z raasch
+! cpp switch __nopointer added for pointer free version
+!
+! Revision 1.1  1997/08/29 08:53:46  raasch
+! Initial revision
+!
+!
+! Description:
+! ------------
+!> Advection term for scalar quantities using the Bott-Chlond scheme.
+!> Computation in individual steps for each of the three dimensions.
+!> Limiting assumptions:
+!> So far the scheme has been assuming equidistant grid spacing. As this is not
+!> the case in the stretched portion of the z-direction, there dzw(k) is used as
+!> a substitute for a constant grid length. This certainly causes incorrect
+!> results; however, it is hoped that they are not too apparent for weakly 
+!> stretched grids.
+!> NOTE: This is a provisional, non-optimised version!
+!------------------------------------------------------------------------------!
+MODULE advec_s_bc_mod
+ 
+
+    PRIVATE
+    PUBLIC advec_s_bc
+
+    INTERFACE advec_s_bc
+       MODULE PROCEDURE advec_s_bc
+    END INTERFACE advec_s_bc
+
+ CONTAINS
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> @todo Missing subroutine description.
+!------------------------------------------------------------------------------!
+    SUBROUTINE advec_s_bc( sk, sk_char )
+
+       USE advection,                                                             &
+           ONLY:  aex, bex, dex, eex
+
+       USE arrays_3d,                                                             &
+           ONLY:  d, ddzw, dzu, dzw, tend, u, v, w
+
+       USE control_parameters,                                                    &
+           ONLY:  dt_3d, bc_pt_t_val, bc_q_t_val, ibc_pt_b, ibc_pt_t, ibc_q_t,    &
+                  message_string, pt_slope_offset, sloping_surface, u_gtrans,     &
+                  v_gtrans
+
+       USE cpulog,                                                                &
+           ONLY:  cpu_log, log_point_s
+
+       USE grid_variables,                                                        &
+           ONLY:  ddx, ddy
+
+       USE indices,                                                               &
+           ONLY:  nx, nxl, nxlg, nxr, nxrg, nyn, nyng, nys, nysg, nzb, nzt
+
+       USE kinds
+
+       USE pegrid
+
+       USE statistics,                                                            &
+           ONLY:  rmask, statistic_regions, sums_wsts_bc_l
+
+
+       IMPLICIT NONE
+
+       CHARACTER (LEN=*) ::  sk_char !<
+
+       INTEGER(iwp) ::  i         !<
+       INTEGER(iwp) ::  ix        !<
+       INTEGER(iwp) ::  j         !<
+       INTEGER(iwp) ::  k         !<
+       INTEGER(iwp) ::  ngp       !<
+       INTEGER(iwp) ::  sr        !<
+       INTEGER(iwp) ::  type_xz_2 !<
+
+       REAL(wp) ::  cim    !<
+       REAL(wp) ::  cimf   !<
+       REAL(wp) ::  cip    !<
+       REAL(wp) ::  cipf   !<
+       REAL(wp) ::  d_new  !<
+       REAL(wp) ::  denomi !< denominator
+       REAL(wp) ::  fminus !<
+       REAL(wp) ::  fplus  !<
+       REAL(wp) ::  f2     !<
+       REAL(wp) ::  f4     !<
+       REAL(wp) ::  f8     !<
+       REAL(wp) ::  f12    !<
+       REAL(wp) ::  f24    !<
+       REAL(wp) ::  f48    !<
+       REAL(wp) ::  f1920  !<
+       REAL(wp) ::  im     !<
+       REAL(wp) ::  ip     !<
+       REAL(wp) ::  m2     !<
+       REAL(wp) ::  m3     !<
+       REAL(wp) ::  numera !< numerator
+       REAL(wp) ::  snenn  !<
+       REAL(wp) ::  sterm  !<
+       REAL(wp) ::  tendcy !<
+       REAL(wp) ::  t1     !<
+       REAL(wp) ::  t2     !<
+
+       REAL(wp) ::  fmax(2)   !<
+       REAL(wp) ::  fmax_l(2) !<
+       
+#if defined( __nopointer )
+       REAL(wp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ::  sk !<
+#else
+       REAL(wp), DIMENSION(:,:,:), POINTER ::  sk
+#endif
+
+       REAL(wp), DIMENSION(:,:), ALLOCATABLE ::  a0   !<
+       REAL(wp), DIMENSION(:,:), ALLOCATABLE ::  a1   !<
+       REAL(wp), DIMENSION(:,:), ALLOCATABLE ::  a12  !<
+       REAL(wp), DIMENSION(:,:), ALLOCATABLE ::  a2   !<
+       REAL(wp), DIMENSION(:,:), ALLOCATABLE ::  a22  !<
+       REAL(wp), DIMENSION(:,:), ALLOCATABLE ::  immb !<
+       REAL(wp), DIMENSION(:,:), ALLOCATABLE ::  imme !<
+       REAL(wp), DIMENSION(:,:), ALLOCATABLE ::  impb !<
+       REAL(wp), DIMENSION(:,:), ALLOCATABLE ::  impe !<
+       REAL(wp), DIMENSION(:,:), ALLOCATABLE ::  ipmb !<
+       REAL(wp), DIMENSION(:,:), ALLOCATABLE ::  ipme !<
+       REAL(wp), DIMENSION(:,:), ALLOCATABLE ::  ippb !<
+       REAL(wp), DIMENSION(:,:), ALLOCATABLE ::  ippe !<
+       
+       REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::  sk_p !<
+
+#if defined( __nec )
+       REAL(sp) ::  m1n, m1z  !< important for optimisation of division
+       REAL(sp), DIMENSION(:,:), ALLOCATABLE :: m1, sw !<
+#else
+       REAL(wp) ::  m1n, m1z 
+       REAL(wp), DIMENSION(:,:), ALLOCATABLE :: m1, sw
+#endif
+
+
+!
+!--    Array sk_p requires 2 extra elements for each dimension
+       ALLOCATE( sk_p(nzb-2:nzt+3,nys-3:nyn+3,nxl-3:nxr+3) )
+       sk_p = 0.0_wp
+
+!
+!--    Assign reciprocal values in order to avoid divisions later
+       f2    = 0.5_wp
+       f4    = 0.25_wp
+       f8    = 0.125_wp
+       f12   = 0.8333333333333333E-01_wp
+       f24   = 0.4166666666666666E-01_wp
+       f48   = 0.2083333333333333E-01_wp
+       f1920 = 0.5208333333333333E-03_wp
+
+!
+!--    Advection in x-direction:
+
+!
+!--    Save the quantity to be advected in a local array
+!--    add an enlarged boundary in x-direction
+       DO  i = nxl-1, nxr+1
+          DO  j = nys, nyn
+             DO  k = nzb, nzt+1
+                sk_p(k,j,i) = sk(k,j,i)
+             ENDDO
+          ENDDO
+       ENDDO
+#if defined( __parallel )
+       ngp = 2 * ( nzt - nzb + 6 ) * ( nyn - nys + 7 )
+       CALL cpu_log( log_point_s(11), 'advec_s_bc:sendrecv', 'start' )
+!
+!--    Send left boundary, receive right boundary
+       CALL MPI_SENDRECV( sk_p(nzb-2,nys-3,nxl+1), ngp, MPI_REAL, pleft,  0,      &
+                          sk_p(nzb-2,nys-3,nxr+2), ngp, MPI_REAL, pright, 0,      &
+                          comm2d, status, ierr )
+!
+!--    Send right boundary, receive left boundary
+       CALL MPI_SENDRECV( sk_p(nzb-2,nys-3,nxr-2), ngp, MPI_REAL, pright, 1,      &
+                          sk_p(nzb-2,nys-3,nxl-3), ngp, MPI_REAL, pleft,  1,      &
+                          comm2d, status, ierr )
+       CALL cpu_log( log_point_s(11), 'advec_s_bc:sendrecv', 'pause' )
+#else
+
+!
+!--    Cyclic boundary conditions
+       sk_p(:,nys:nyn,nxl-3) = sk_p(:,nys:nyn,nxr-2)
+       sk_p(:,nys:nyn,nxl-2) = sk_p(:,nys:nyn,nxr-1)
+       sk_p(:,nys:nyn,nxr+2) = sk_p(:,nys:nyn,nxl+1)
+       sk_p(:,nys:nyn,nxr+3) = sk_p(:,nys:nyn,nxl+2)
+#endif
+
+!
+!--    In case of a sloping surface, the additional gridpoints in x-direction
+!--    of the temperature field at the left and right boundary of the total
+!--    domain must be adjusted by the temperature difference between this distance
+       IF ( sloping_surface  .AND.  sk_char == 'pt' )  THEN
+          IF ( nxl ==  0 )  THEN
+             sk_p(:,nys:nyn,nxl-3) = sk_p(:,nys:nyn,nxl-3) - pt_slope_offset
+             sk_p(:,nys:nyn,nxl-2) = sk_p(:,nys:nyn,nxl-2) - pt_slope_offset
+          ENDIF
+          IF ( nxr == nx )  THEN
+             sk_p(:,nys:nyn,nxr+2) = sk_p(:,nys:nyn,nxr+2) + pt_slope_offset
+             sk_p(:,nys:nyn,nxr+3) = sk_p(:,nys:nyn,nxr+3) + pt_slope_offset
+          ENDIF
+       ENDIF
+
+!
+!--    Initialise control density
+       d = 0.0_wp
+
+!
+!--    Determine maxima of the first and second derivative in x-direction
+       fmax_l = 0.0_wp
+       DO  i = nxl, nxr
+          DO  j = nys, nyn
+             DO  k = nzb+1, nzt
+                numera = ABS( sk_p(k,j,i+1) - 2.0_wp * sk_p(k,j,i) + sk_p(k,j,i-1) )
+                denomi  = ABS( sk_p(k,j,i+1) - sk_p(k,j,i-1) )
+                fmax_l(1) = MAX( fmax_l(1) , numera )
+                fmax_l(2) = MAX( fmax_l(2) , denomi  )
+             ENDDO
+          ENDDO
+       ENDDO
+#if defined( __parallel )
+       IF ( collective_wait )  CALL MPI_BARRIER( comm2d, ierr )
+       CALL MPI_ALLREDUCE( fmax_l, fmax, 2, MPI_REAL, MPI_MAX, comm2d, ierr )
+#else
+       fmax = fmax_l
+#endif
+
+       fmax = 0.04_wp * fmax
+
+!
+!--    Allocate temporary arrays
+       ALLOCATE( a0(nzb+1:nzt,nxl-1:nxr+1),   a1(nzb+1:nzt,nxl-1:nxr+1),          &
+                 a2(nzb+1:nzt,nxl-1:nxr+1),   a12(nzb+1:nzt,nxl-1:nxr+1),         &
+                 a22(nzb+1:nzt,nxl-1:nxr+1),  immb(nzb+1:nzt,nxl-1:nxr+1),        &
+                 imme(nzb+1:nzt,nxl-1:nxr+1), impb(nzb+1:nzt,nxl-1:nxr+1),        &
+                 impe(nzb+1:nzt,nxl-1:nxr+1), ipmb(nzb+1:nzt,nxl-1:nxr+1),        &
+                 ipme(nzb+1:nzt,nxl-1:nxr+1), ippb(nzb+1:nzt,nxl-1:nxr+1),        &
+                 ippe(nzb+1:nzt,nxl-1:nxr+1), m1(nzb+1:nzt,nxl-2:nxr+2),          &
+                 sw(nzb+1:nzt,nxl-1:nxr+1)                                        &
+               )
+       imme = 0.0_wp; impe = 0.0_wp; ipme = 0.0_wp; ippe = 0.0_wp
+
+!
+!--    Initialise point of time measuring of the exponential portion (this would
+!--    not work if done locally within the loop)
+       CALL cpu_log( log_point_s(12), 'advec_s_bc:exp', 'start' )
+       CALL cpu_log( log_point_s(12), 'advec_s_bc:exp', 'pause' )
+
+!
+!--    Outer loop of all j
+       DO  j = nys, nyn
+
+!
+!--       Compute polynomial coefficients
+          DO  i = nxl-1, nxr+1
+             DO  k = nzb+1, nzt
+                a12(k,i) = 0.5_wp * ( sk_p(k,j,i+1) - sk_p(k,j,i-1) )
+                a22(k,i) = 0.5_wp * ( sk_p(k,j,i+1) - 2.0_wp * sk_p(k,j,i)        &
+                                                    + sk_p(k,j,i-1) )
+                a0(k,i) = ( 9.0_wp * sk_p(k,j,i+2)    - 116.0_wp * sk_p(k,j,i+1)  &
+                            + 2134.0_wp * sk_p(k,j,i) - 116.0_wp * sk_p(k,j,i-1)  &
+                            + 9.0_wp * sk_p(k,j,i-2) ) * f1920
+                a1(k,i) = ( -5.0_wp * sk_p(k,j,i+2)   + 34.0_wp * sk_p(k,j,i+1)   &
+                            - 34.0_wp * sk_p(k,j,i-1) + 5.0_wp * sk_p(k,j,i-2)    &
+                          ) * f48
+                a2(k,i) = ( -3.0_wp * sk_p(k,j,i+2) + 36.0_wp * sk_p(k,j,i+1)     &
+                            - 66.0_wp * sk_p(k,j,i) + 36.0_wp * sk_p(k,j,i-1)     &
+                            - 3.0_wp * sk_p(k,j,i-2) ) * f48
+             ENDDO
+          ENDDO
+
+!
+!--       Fluxes using the Bott scheme
+!--       *VOCL LOOP,UNROLL(2)
+          DO  i = nxl, nxr
+             DO  k = nzb+1, nzt
+                cip  =  MAX( 0.0_wp, ( u(k,j,i+1) - u_gtrans ) * dt_3d * ddx )
+                cim  = -MIN( 0.0_wp, ( u(k,j,i+1) - u_gtrans ) * dt_3d * ddx )
+                cipf = 1.0_wp - 2.0_wp * cip
+                cimf = 1.0_wp - 2.0_wp * cim
+                ip   =   a0(k,i)   * f2  * ( 1.0_wp - cipf )                      &
+                       + a1(k,i)   * f8  * ( 1.0_wp - cipf*cipf )                 &
+                       + a2(k,i)   * f24 * ( 1.0_wp - cipf*cipf*cipf )
+                im   =   a0(k,i+1) * f2  * ( 1.0_wp - cimf )                      &
+                       - a1(k,i+1) * f8  * ( 1.0_wp - cimf*cimf )                 &
+                       + a2(k,i+1) * f24 * ( 1.0_wp - cimf*cimf*cimf )
+                ip   = MAX( ip, 0.0_wp )
+                im   = MAX( im, 0.0_wp )
+                ippb(k,i) = ip * MIN( 1.0_wp, sk_p(k,j,i)   / (ip+im+1E-15_wp) )
+                impb(k,i) = im * MIN( 1.0_wp, sk_p(k,j,i+1) / (ip+im+1E-15_wp) )
+
+                cip  =  MAX( 0.0_wp, ( u(k,j,i) - u_gtrans ) * dt_3d * ddx )
+                cim  = -MIN( 0.0_wp, ( u(k,j,i) - u_gtrans ) * dt_3d * ddx )
+                cipf = 1.0_wp - 2.0_wp * cip
+                cimf = 1.0_wp - 2.0_wp * cim
+                ip   =   a0(k,i-1) * f2  * ( 1.0_wp - cipf )                      &
+                       + a1(k,i-1) * f8  * ( 1.0_wp - cipf*cipf )                 &
+                       + a2(k,i-1) * f24 * ( 1.0_wp - cipf*cipf*cipf )
+                im   =   a0(k,i)   * f2  * ( 1.0_wp - cimf )                      &
+                       - a1(k,i)   * f8  * ( 1.0_wp - cimf*cimf )                 &
+                       + a2(k,i)   * f24 * ( 1.0_wp - cimf*cimf*cimf )
+                ip   = MAX( ip, 0.0_wp )
+                im   = MAX( im, 0.0_wp )
+                ipmb(k,i) = ip * MIN( 1.0_wp, sk_p(k,j,i-1) / (ip+im+1E-15_wp) )
+                immb(k,i) = im * MIN( 1.0_wp, sk_p(k,j,i)   / (ip+im+1E-15_wp) )
+             ENDDO
+          ENDDO
+
+!
+!--       Compute monitor function m1
+          DO  i = nxl-2, nxr+2
+             DO  k = nzb+1, nzt
+                m1z = ABS( sk_p(k,j,i+1) - 2.0_wp * sk_p(k,j,i) + sk_p(k,j,i-1) )
+                m1n = ABS( sk_p(k,j,i+1) - sk_p(k,j,i-1) )
+                IF ( m1n /= 0.0_wp  .AND.  m1n >= m1z )  THEN
+                   m1(k,i) = m1z / m1n
+                   IF ( m1(k,i) /= 2.0_wp  .AND.  m1n < fmax(2) )  m1(k,i) = 0.0_wp
+                ELSEIF ( m1n < m1z )  THEN
+                   m1(k,i) = -1.0_wp
+                ELSE
+                   m1(k,i) = 0.0_wp
+                ENDIF
+             ENDDO
+          ENDDO
+
+!
+!--       Compute switch sw
+          sw = 0.0_wp
+          DO  i = nxl-1, nxr+1
+             DO  k = nzb+1, nzt
+                m2 = 2.0_wp * ABS( a1(k,i) - a12(k,i) ) /                         &
+                     MAX( ABS( a1(k,i) + a12(k,i) ), 1E-35_wp )
+                IF ( ABS( a1(k,i) + a12(k,i) ) < fmax(2) )  m2 = 0.0_wp
+
+                m3 = 2.0_wp * ABS( a2(k,i) - a22(k,i) ) /                         &
+                     MAX( ABS( a2(k,i) + a22(k,i) ), 1E-35_wp )
+                IF ( ABS( a2(k,i) + a22(k,i) ) < fmax(1) )  m3 = 0.0_wp
+
+                t1 = 0.35_wp
+                t2 = 0.35_wp
+                IF ( m1(k,i) == -1.0_wp )  t2 = 0.12_wp
+
+!--             *VOCL STMT,IF(10)
+                IF ( m1(k,i-1) == 1.0_wp .OR. m1(k,i) == 1.0_wp                   &
+                     .OR. m1(k,i+1) == 1.0_wp .OR.  m2 > t2  .OR.  m3 > t2  .OR.  &
+                     ( m1(k,i) > t1  .AND.  m1(k,i-1) /= -1.0_wp  .AND.           &
+                       m1(k,i) /= -1.0_wp  .AND.  m1(k,i+1) /= -1.0_wp )          &
+                   )  sw(k,i) = 1.0_wp
+             ENDDO
+          ENDDO
+
+!
+!--       Fluxes using the exponential scheme
+          CALL cpu_log( log_point_s(12), 'advec_s_bc:exp', 'continue' )
+          DO  i = nxl, nxr
+             DO  k = nzb+1, nzt
+
+!--             *VOCL STMT,IF(10)
+                IF ( sw(k,i) == 1.0_wp )  THEN
+                   snenn = sk_p(k,j,i+1) - sk_p(k,j,i-1)
+                   IF ( ABS( snenn ) < 1E-9_wp )  snenn = 1E-9_wp
+                   sterm = ( sk_p(k,j,i) - sk_p(k,j,i-1) ) / snenn
+                   sterm = MIN( sterm, 0.9999_wp )
+                   sterm = MAX( sterm, 0.0001_wp )
+
+                   ix = INT( sterm * 1000 ) + 1
+
+                   cip =  MAX( 0.0_wp, ( u(k,j,i+1) - u_gtrans ) * dt_3d * ddx )
+
+                   ippe(k,i) = sk_p(k,j,i-1) * cip + snenn * (                    &
+                               aex(ix) * cip + bex(ix) / dex(ix) * (              &
+                               eex(ix) -                                          &
+                               EXP( dex(ix)*0.5_wp * ( 1.0_wp - 2.0_wp * cip ) )  &
+                                                                   )              &
+                                                             )
+                   IF ( sterm == 0.0001_wp )  ippe(k,i) = sk_p(k,j,i) * cip
+                   IF ( sterm == 0.9999_wp )  ippe(k,i) = sk_p(k,j,i) * cip
+
+                   snenn = sk_p(k,j,i-1) - sk_p(k,j,i+1)
+                   IF ( ABS( snenn ) < 1E-9_wp )  snenn = 1E-9_wp
+                   sterm = ( sk_p(k,j,i) - sk_p(k,j,i+1) ) / snenn
+                   sterm = MIN( sterm, 0.9999_wp )
+                   sterm = MAX( sterm, 0.0001_wp )
+
+                   ix = INT( sterm * 1000 ) + 1
+
+                   cim = -MIN( 0.0_wp, ( u(k,j,i) - u_gtrans ) * dt_3d * ddx )
+
+                   imme(k,i) = sk_p(k,j,i+1) * cim + snenn * (                    &
+                               aex(ix) * cim + bex(ix) / dex(ix) * (              &
+                               eex(ix) -                                          &
+                               EXP( dex(ix)*0.5_wp * ( 1.0_wp - 2.0_wp * cim ) )  &
+                                                                   )              &
+                                                             )
+                   IF ( sterm == 0.0001_wp )  imme(k,i) = sk_p(k,j,i) * cim
+                   IF ( sterm == 0.9999_wp )  imme(k,i) = sk_p(k,j,i) * cim
+                ENDIF
+
+!--             *VOCL STMT,IF(10)
+                IF ( sw(k,i+1) == 1.0_wp )  THEN
+                   snenn = sk_p(k,j,i) - sk_p(k,j,i+2)
+                   IF ( ABS( snenn ) < 1E-9_wp )  snenn = 1E-9_wp
+                   sterm = ( sk_p(k,j,i+1) - sk_p(k,j,i+2) ) / snenn
+                   sterm = MIN( sterm, 0.9999_wp )
+                   sterm = MAX( sterm, 0.0001_wp )
+
+                   ix = INT( sterm * 1000 ) + 1
+
+                   cim = -MIN( 0.0_wp, ( u(k,j,i+1) - u_gtrans ) * dt_3d * ddx )
+
+                   impe(k,i) = sk_p(k,j,i+2) * cim + snenn * (                    &
+                               aex(ix) * cim + bex(ix) / dex(ix) * (              &
+                               eex(ix) -                                          &
+                               EXP( dex(ix)*0.5_wp * ( 1.0_wp - 2.0_wp * cim ) )  &
+                                                                   )              &
+                                                             )
+                   IF ( sterm == 0.0001_wp )  impe(k,i) = sk_p(k,j,i+1) * cim
+                   IF ( sterm == 0.9999_wp )  impe(k,i) = sk_p(k,j,i+1) * cim
+                ENDIF
+
+!--             *VOCL STMT,IF(10)
+                IF ( sw(k,i-1) == 1.0_wp )  THEN
+                   snenn = sk_p(k,j,i) - sk_p(k,j,i-2)
+                   IF ( ABS( snenn ) < 1E-9_wp )  snenn = 1E-9_wp
+                   sterm = ( sk_p(k,j,i-1) - sk_p(k,j,i-2) ) / snenn
+                   sterm = MIN( sterm, 0.9999_wp )
+                   sterm = MAX( sterm, 0.0001_wp )
+
+                   ix = INT( sterm * 1000 ) + 1
+
+                   cip = MAX( 0.0_wp, ( u(k,j,i) - u_gtrans ) * dt_3d * ddx )
+
+                   ipme(k,i) = sk_p(k,j,i-2) * cip + snenn * (                    &
+                               aex(ix) * cip + bex(ix) / dex(ix) * (              &
+                               eex(ix) -                                          &
+                               EXP( dex(ix)*0.5_wp * ( 1.0_wp - 2.0_wp * cip ) )  &
+                                                                   )              &
+                                                             )
+                   IF ( sterm == 0.0001_wp )  ipme(k,i) = sk_p(k,j,i-1) * cip
+                   IF ( sterm == 0.9999_wp )  ipme(k,i) = sk_p(k,j,i-1) * cip
+                ENDIF
+
+             ENDDO
+          ENDDO
+          CALL cpu_log( log_point_s(12), 'advec_s_bc:exp', 'pause' )
+
+!
+!--       Prognostic equation
+          DO  i = nxl, nxr
+             DO  k = nzb+1, nzt
+                fplus  = ( 1.0_wp - sw(k,i)   ) * ippb(k,i) + sw(k,i)   * ippe(k,i)  &
+                       - ( 1.0_wp - sw(k,i+1) ) * impb(k,i) - sw(k,i+1) * impe(k,i)
+                fminus = ( 1.0_wp - sw(k,i-1) ) * ipmb(k,i) + sw(k,i-1) * ipme(k,i)  &
+                       - ( 1.0_wp - sw(k,i)   ) * immb(k,i) - sw(k,i)   * imme(k,i)
+                tendcy = fplus - fminus
+!
+!--             Removed in order to optimize speed
+!                ffmax   = MAX( ABS( fplus ), ABS( fminus ), 1E-35_wp )
+!                IF ( ( ABS( tendcy ) / ffmax ) < 1E-7_wp )  tendcy = 0.0
+!
+!--             Density correction because of possible remaining divergences
+                d_new = d(k,j,i) - ( u(k,j,i+1) - u(k,j,i) ) * dt_3d * ddx
+                sk_p(k,j,i) = ( ( 1.0_wp + d(k,j,i) ) * sk_p(k,j,i) - tendcy ) /    &
+                              ( 1.0_wp + d_new )
+                d(k,j,i)  = d_new
+             ENDDO
+          ENDDO
+
+       ENDDO   ! End of the advection in x-direction
+
+!
+!--    Deallocate temporary arrays
+       DEALLOCATE( a0, a1, a2, a12, a22, immb, imme, impb, impe, ipmb, ipme,      &
+                   ippb, ippe, m1, sw )
+
+
+!
+!--    Enlarge boundary of local array cyclically in y-direction
+#if defined( __parallel )
+       ngp = ( nzt - nzb + 6 ) * ( nyn - nys + 7 )
+       CALL MPI_TYPE_VECTOR( nxr-nxl+7, 3*(nzt-nzb+6), ngp, MPI_REAL,             &
+                             type_xz_2, ierr )
+       CALL MPI_TYPE_COMMIT( type_xz_2, ierr )
+!
+!--    Send front boundary, receive rear boundary
+       CALL cpu_log( log_point_s(11), 'advec_s_bc:sendrecv', 'continue' )
+       CALL MPI_SENDRECV( sk_p(nzb-2,nys,nxl-3),   1, type_xz_2, psouth, 0,       &
+                          sk_p(nzb-2,nyn+1,nxl-3), 1, type_xz_2, pnorth, 0,       &
+                          comm2d, status, ierr )
+!
+!--    Send rear boundary, receive front boundary
+       CALL MPI_SENDRECV( sk_p(nzb-2,nyn-2,nxl-3), 1, type_xz_2, pnorth, 1,       &
+                          sk_p(nzb-2,nys-3,nxl-3), 1, type_xz_2, psouth, 1,       &
+                          comm2d, status, ierr )
+       CALL MPI_TYPE_FREE( type_xz_2, ierr )
+       CALL cpu_log( log_point_s(11), 'advec_s_bc:sendrecv', 'pause' )
+#else
+       DO  i = nxl, nxr
+          DO  k = nzb+1, nzt
+             sk_p(k,nys-1,i) = sk_p(k,nyn,i)
+             sk_p(k,nys-2,i) = sk_p(k,nyn-1,i)
+             sk_p(k,nys-3,i) = sk_p(k,nyn-2,i)
+             sk_p(k,nyn+1,i) = sk_p(k,nys,i)
+             sk_p(k,nyn+2,i) = sk_p(k,nys+1,i)
+             sk_p(k,nyn+3,i) = sk_p(k,nys+2,i)
+          ENDDO
+       ENDDO
+#endif
+
+!
+!--    Determine the maxima of the first and second derivative in y-direction
+       fmax_l = 0.0_wp
+       DO  i = nxl, nxr
+          DO  j = nys, nyn
+             DO  k = nzb+1, nzt
+                numera = ABS( sk_p(k,j+1,i) - 2.0_wp * sk_p(k,j,i) + sk_p(k,j-1,i) )
+                denomi  = ABS( sk_p(k,j+1,i) - sk_p(k,j-1,i) )
+                fmax_l(1) = MAX( fmax_l(1) , numera )
+                fmax_l(2) = MAX( fmax_l(2) , denomi  )
+             ENDDO
+          ENDDO
+       ENDDO
+#if defined( __parallel )
+       IF ( collective_wait )  CALL MPI_BARRIER( comm2d, ierr )
+       CALL MPI_ALLREDUCE( fmax_l, fmax, 2, MPI_REAL, MPI_MAX, comm2d, ierr )
+#else
+       fmax = fmax_l
+#endif
+
+       fmax = 0.04_wp * fmax
+
+!
+!--    Allocate temporary arrays
+       ALLOCATE( a0(nzb+1:nzt,nys-1:nyn+1),   a1(nzb+1:nzt,nys-1:nyn+1),          &
+                 a2(nzb+1:nzt,nys-1:nyn+1),   a12(nzb+1:nzt,nys-1:nyn+1),         &
+                 a22(nzb+1:nzt,nys-1:nyn+1),  immb(nzb+1:nzt,nys-1:nyn+1),        &
+                 imme(nzb+1:nzt,nys-1:nyn+1), impb(nzb+1:nzt,nys-1:nyn+1),        &
+                 impe(nzb+1:nzt,nys-1:nyn+1), ipmb(nzb+1:nzt,nys-1:nyn+1),        &
+                 ipme(nzb+1:nzt,nys-1:nyn+1), ippb(nzb+1:nzt,nys-1:nyn+1),        &
+                 ippe(nzb+1:nzt,nys-1:nyn+1), m1(nzb+1:nzt,nys-2:nyn+2),          &
+                 sw(nzb+1:nzt,nys-1:nyn+1)                                        &
+               )
+       imme = 0.0_wp; impe = 0.0_wp; ipme = 0.0_wp; ippe = 0.0_wp
+
+!
+!--    Outer loop of all i
+       DO  i = nxl, nxr
+
+!
+!--       Compute polynomial coefficients
+          DO  j = nys-1, nyn+1
+             DO  k = nzb+1, nzt
+                a12(k,j) = 0.5_wp * ( sk_p(k,j+1,i) - sk_p(k,j-1,i) )
+                a22(k,j) = 0.5_wp * ( sk_p(k,j+1,i) - 2.0_wp * sk_p(k,j,i)        &
+                                                    + sk_p(k,j-1,i) )
+                a0(k,j) = ( 9.0_wp * sk_p(k,j+2,i)    - 116.0_wp * sk_p(k,j+1,i)  &
+                            + 2134.0_wp * sk_p(k,j,i) - 116.0_wp * sk_p(k,j-1,i)  &
+                            + 9.0_wp * sk_p(k,j-2,i) ) * f1920
+                a1(k,j) = ( -5.0_wp   * sk_p(k,j+2,i) + 34.0_wp * sk_p(k,j+1,i)   &
+                            - 34.0_wp * sk_p(k,j-1,i) + 5.0_wp  * sk_p(k,j-2,i)   &
+                          ) * f48
+                a2(k,j) = ( -3.0_wp * sk_p(k,j+2,i) + 36.0_wp * sk_p(k,j+1,i)     &
+                            - 66.0_wp * sk_p(k,j,i) + 36.0_wp * sk_p(k,j-1,i)     &
+                            - 3.0_wp * sk_p(k,j-2,i) ) * f48
+             ENDDO
+          ENDDO
+
+!
+!--       Fluxes using the Bott scheme
+!--       *VOCL LOOP,UNROLL(2)
+          DO  j = nys, nyn
+             DO  k = nzb+1, nzt
+                cip  =  MAX( 0.0_wp, ( v(k,j+1,i) - v_gtrans ) * dt_3d * ddy )
+                cim  = -MIN( 0.0_wp, ( v(k,j+1,i) - v_gtrans ) * dt_3d * ddy )
+                cipf = 1.0_wp - 2.0_wp * cip
+                cimf = 1.0_wp - 2.0_wp * cim
+                ip   =   a0(k,j)   * f2  * ( 1.0_wp - cipf )                      &
+                       + a1(k,j)   * f8  * ( 1.0_wp - cipf*cipf )                 &
+                       + a2(k,j)   * f24 * ( 1.0_wp - cipf*cipf*cipf )
+                im   =   a0(k,j+1) * f2  * ( 1.0_wp - cimf )                      &
+                       - a1(k,j+1) * f8  * ( 1.0_wp - cimf*cimf )                 &
+                       + a2(k,j+1) * f24 * ( 1.0_wp - cimf*cimf*cimf )
+                ip   = MAX( ip, 0.0_wp )
+                im   = MAX( im, 0.0_wp )
+                ippb(k,j) = ip * MIN( 1.0_wp, sk_p(k,j,i)   / (ip+im+1E-15_wp) )
+                impb(k,j) = im * MIN( 1.0_wp, sk_p(k,j+1,i) / (ip+im+1E-15_wp) )
+
+                cip  =  MAX( 0.0_wp, ( v(k,j,i) - v_gtrans ) * dt_3d * ddy )
+                cim  = -MIN( 0.0_wp, ( v(k,j,i) - v_gtrans ) * dt_3d * ddy )
+                cipf = 1.0_wp - 2.0_wp * cip
+                cimf = 1.0_wp - 2.0_wp * cim
+                ip   =   a0(k,j-1) * f2  * ( 1.0_wp - cipf )                      &
+                       + a1(k,j-1) * f8  * ( 1.0_wp - cipf*cipf )                 &
+                       + a2(k,j-1) * f24 * ( 1.0_wp - cipf*cipf*cipf )
+                im   =   a0(k,j)   * f2  * ( 1.0_wp - cimf )                      &
+                       - a1(k,j)   * f8  * ( 1.0_wp - cimf*cimf )                 &
+                       + a2(k,j)   * f24 * ( 1.0_wp - cimf*cimf*cimf )
+                ip   = MAX( ip, 0.0_wp )
+                im   = MAX( im, 0.0_wp )
+                ipmb(k,j) = ip * MIN( 1.0_wp, sk_p(k,j-1,i) / (ip+im+1E-15_wp) )
+                immb(k,j) = im * MIN( 1.0_wp, sk_p(k,j,i)   / (ip+im+1E-15_wp) )
+             ENDDO
+          ENDDO
+
+!
+!--       Compute monitor function m1
+          DO  j = nys-2, nyn+2
+             DO  k = nzb+1, nzt
+                m1z = ABS( sk_p(k,j+1,i) - 2.0_wp * sk_p(k,j,i) + sk_p(k,j-1,i) )
+                m1n = ABS( sk_p(k,j+1,i) - sk_p(k,j-1,i) )
+                IF ( m1n /= 0.0_wp  .AND.  m1n >= m1z )  THEN
+                   m1(k,j) = m1z / m1n
+                   IF ( m1(k,j) /= 2.0_wp  .AND.  m1n < fmax(2) )  m1(k,j) = 0.0_wp
+                ELSEIF ( m1n < m1z )  THEN
+                   m1(k,j) = -1.0_wp
+                ELSE
+                   m1(k,j) = 0.0_wp
+                ENDIF
+             ENDDO
+          ENDDO
+
+!
+!--       Compute switch sw
+          sw = 0.0_wp
+          DO  j = nys-1, nyn+1
+             DO  k = nzb+1, nzt
+                m2 = 2.0_wp * ABS( a1(k,j) - a12(k,j) ) /                            &
+                     MAX( ABS( a1(k,j) + a12(k,j) ), 1E-35_wp )
+                IF ( ABS( a1(k,j) + a12(k,j) ) < fmax(2) )  m2 = 0.0_wp
+
+                m3 = 2.0_wp * ABS( a2(k,j) - a22(k,j) ) /                            &
+                     MAX( ABS( a2(k,j) + a22(k,j) ), 1E-35_wp )
+                IF ( ABS( a2(k,j) + a22(k,j) ) < fmax(1) )  m3 = 0.0_wp
+
+                t1 = 0.35_wp
+                t2 = 0.35_wp
+                IF ( m1(k,j) == -1.0_wp )  t2 = 0.12_wp
+
+!--             *VOCL STMT,IF(10)
+                IF ( m1(k,j-1) == 1.0_wp .OR. m1(k,j) == 1.0_wp                   &
+                     .OR. m1(k,j+1) == 1.0_wp .OR.  m2 > t2  .OR.  m3 > t2  .OR.  &
+                     ( m1(k,j) > t1  .AND.  m1(k,j-1) /= -1.0_wp  .AND.           &
+                       m1(k,j) /= -1.0_wp  .AND.  m1(k,j+1) /= -1.0_wp )          &
+                   )  sw(k,j) = 1.0_wp
+             ENDDO
+          ENDDO
+
+!
+!--       Fluxes using exponential scheme
+          CALL cpu_log( log_point_s(12), 'advec_s_bc:exp', 'continue' )
+          DO  j = nys, nyn
+             DO  k = nzb+1, nzt
+
+!--             *VOCL STMT,IF(10)
+                IF ( sw(k,j) == 1.0_wp )  THEN
+                   snenn = sk_p(k,j+1,i) - sk_p(k,j-1,i)
+                   IF ( ABS( snenn ) < 1E-9_wp )  snenn = 1E-9_wp
+                   sterm = ( sk_p(k,j,i) - sk_p(k,j-1,i) ) / snenn
+                   sterm = MIN( sterm, 0.9999_wp )
+                   sterm = MAX( sterm, 0.0001_wp )
+
+                   ix = INT( sterm * 1000 ) + 1
+
+                   cip =  MAX( 0.0_wp, ( v(k,j+1,i) - v_gtrans ) * dt_3d * ddy )
+
+                   ippe(k,j) = sk_p(k,j-1,i) * cip + snenn * (                    &
+                               aex(ix) * cip + bex(ix) / dex(ix) * (              &
+                               eex(ix) -                                          &
+                               EXP( dex(ix)*0.5_wp * ( 1.0_wp - 2.0_wp * cip ) )  &
+                                                                   )              &
+                                                             )
+                   IF ( sterm == 0.0001_wp )  ippe(k,j) = sk_p(k,j,i) * cip
+                   IF ( sterm == 0.9999_wp )  ippe(k,j) = sk_p(k,j,i) * cip
+
+                   snenn = sk_p(k,j-1,i) - sk_p(k,j+1,i)
+                   IF ( ABS( snenn ) < 1E-9_wp )  snenn = 1E-9_wp
+                   sterm = ( sk_p(k,j,i) - sk_p(k,j+1,i) ) / snenn
+                   sterm = MIN( sterm, 0.9999_wp )
+                   sterm = MAX( sterm, 0.0001_wp )
+
+                   ix = INT( sterm * 1000 ) + 1
+
+                   cim = -MIN( 0.0_wp, ( v(k,j,i) - v_gtrans ) * dt_3d * ddy )
+
+                   imme(k,j) = sk_p(k,j+1,i) * cim + snenn * (                    &
+                               aex(ix) * cim + bex(ix) / dex(ix) * (              &
+                               eex(ix) -                                          &
+                               EXP( dex(ix)*0.5_wp * ( 1.0_wp - 2.0_wp * cim ) )  &
+                                                                   )              &
+                                                             )
+                   IF ( sterm == 0.0001_wp )  imme(k,j) = sk_p(k,j,i) * cim
+                   IF ( sterm == 0.9999_wp )  imme(k,j) = sk_p(k,j,i) * cim
+                ENDIF
+
+!--             *VOCL STMT,IF(10)
+                IF ( sw(k,j+1) == 1.0_wp )  THEN
+                   snenn = sk_p(k,j,i) - sk_p(k,j+2,i)
+                   IF ( ABS( snenn ) < 1E-9_wp )  snenn = 1E-9_wp
+                   sterm = ( sk_p(k,j+1,i) - sk_p(k,j+2,i) ) / snenn
+                   sterm = MIN( sterm, 0.9999_wp )
+                   sterm = MAX( sterm, 0.0001_wp )
+
+                   ix = INT( sterm * 1000 ) + 1
+
+                   cim = -MIN( 0.0_wp, ( v(k,j+1,i) - v_gtrans ) * dt_3d * ddy )
+
+                   impe(k,j) = sk_p(k,j+2,i) * cim + snenn * (                    &
+                               aex(ix) * cim + bex(ix) / dex(ix) * (              &
+                               eex(ix) -                                          &
+                               EXP( dex(ix)*0.5_wp * ( 1.0_wp - 2.0_wp * cim ) )  &
+                                                                   )              &
+                                                             )
+                   IF ( sterm == 0.0001_wp )  impe(k,j) = sk_p(k,j+1,i) * cim
+                   IF ( sterm == 0.9999_wp )  impe(k,j) = sk_p(k,j+1,i) * cim
+                ENDIF
+
+!--             *VOCL STMT,IF(10)
+                IF ( sw(k,j-1) == 1.0_wp )  THEN
+                   snenn = sk_p(k,j,i) - sk_p(k,j-2,i)
+                   IF ( ABS( snenn ) < 1E-9_wp )  snenn = 1E-9_wp
+                   sterm = ( sk_p(k,j-1,i) - sk_p(k,j-2,i) ) / snenn
+                   sterm = MIN( sterm, 0.9999_wp )
+                   sterm = MAX( sterm, 0.0001_wp )
+
+                   ix = INT( sterm * 1000 ) + 1
+
+                   cip = MAX( 0.0_wp, ( v(k,j,i) - v_gtrans ) * dt_3d * ddy )
+
+                   ipme(k,j) = sk_p(k,j-2,i) * cip + snenn * (                    &
+                               aex(ix) * cip + bex(ix) / dex(ix) * (              &
+                               eex(ix) -                                          &
+                               EXP( dex(ix)*0.5_wp * ( 1.0_wp - 2.0_wp * cip ) )  &
+                                                                   )              &
+                                                             )
+                   IF ( sterm == 0.0001_wp )  ipme(k,j) = sk_p(k,j-1,i) * cip
+                   IF ( sterm == 0.9999_wp )  ipme(k,j) = sk_p(k,j-1,i) * cip
+                ENDIF
+
+             ENDDO
+          ENDDO
+          CALL cpu_log( log_point_s(12), 'advec_s_bc:exp', 'pause' )
+
+!
+!--       Prognostic equation
+          DO  j = nys, nyn
+             DO  k = nzb+1, nzt
+                fplus  = ( 1.0_wp - sw(k,j)   ) * ippb(k,j) + sw(k,j)   * ippe(k,j) &
+                       - ( 1.0_wp - sw(k,j+1) ) * impb(k,j) - sw(k,j+1) * impe(k,j)
+                fminus = ( 1.0_wp - sw(k,j-1) ) * ipmb(k,j) + sw(k,j-1) * ipme(k,j) &
+                       - ( 1.0_wp - sw(k,j)   ) * immb(k,j) - sw(k,j)   * imme(k,j)
+                tendcy = fplus - fminus
+!
+!--             Removed in order to optimise speed
+!                ffmax   = MAX( ABS( fplus ), ABS( fminus ), 1E-35_wp )
+!                 IF ( ( ABS( tendcy ) / ffmax ) < 1E-7_wp )  tendcy = 0.0
+!
+!--             Density correction because of possible remaining divergences
+                d_new = d(k,j,i) - ( v(k,j+1,i) - v(k,j,i) ) * dt_3d * ddy
+                sk_p(k,j,i) = ( ( 1.0_wp + d(k,j,i) ) * sk_p(k,j,i) - tendcy ) /  &
+                              ( 1.0_wp + d_new )
+                d(k,j,i)  = d_new
+             ENDDO
+          ENDDO
+
+       ENDDO   ! End of the advection in y-direction
+       CALL cpu_log( log_point_s(11), 'advec_s_bc:sendrecv', 'continue' )
+       CALL cpu_log( log_point_s(11), 'advec_s_bc:sendrecv', 'stop' )
+
+!
+!--    Deallocate temporary arrays
+       DEALLOCATE( a0, a1, a2, a12, a22, immb, imme, impb, impe, ipmb, ipme,      &
+                   ippb, ippe, m1, sw )
+
+
+!
+!--    Initialise for the computation of heat fluxes (see below; required in
+!--    UP flow_statistics)
+       IF ( sk_char == 'pt' )  sums_wsts_bc_l = 0.0_wp
+
+!
+!--    Add top and bottom boundaries according to the relevant boundary conditions
+       IF ( sk_char == 'pt' )  THEN
+
+!
+!--       Temperature boundary condition at the bottom boundary
+          IF ( ibc_pt_b == 0 )  THEN
+!
+!--       Dirichlet (fixed surface temperature)
+             DO  i = nxl, nxr
+                DO  j = nys, nyn
+                   sk_p(nzb-1,j,i) = sk_p(nzb,j,i)
+                   sk_p(nzb-2,j,i) = sk_p(nzb,j,i)
+                ENDDO
+             ENDDO
+
+          ELSE
+!
+!--          Neumann (i.e. here zero gradient)
+             DO  i = nxl, nxr
+                DO  j = nys, nyn
+                   sk_p(nzb,j,i)   = sk_p(nzb+1,j,i)
+                   sk_p(nzb-1,j,i) = sk_p(nzb,j,i)
+                   sk_p(nzb-2,j,i) = sk_p(nzb,j,i)
+                ENDDO
+             ENDDO
+
+          ENDIF
+
+!
+!--       Temperature boundary condition at the top boundary
+          IF ( ibc_pt_t == 0  .OR.  ibc_pt_t == 1 )  THEN
+!
+!--          Dirichlet or Neumann (zero gradient)
+             DO  i = nxl, nxr
+                DO  j = nys, nyn
+                   sk_p(nzt+2,j,i)   = sk_p(nzt+1,j,i)
+                   sk_p(nzt+3,j,i)   = sk_p(nzt+1,j,i)
+                ENDDO
+             ENDDO
+
+          ELSEIF ( ibc_pt_t == 2 )  THEN
+!
+!--          Neumann: dzu(nzt+2:3) are not defined, dzu(nzt+1) is used instead
+             DO  i = nxl, nxr
+                DO  j = nys, nyn
+                   sk_p(nzt+2,j,i)   = sk_p(nzt+1,j,i) + bc_pt_t_val * dzu(nzt+1)
+                   sk_p(nzt+3,j,i)   = sk_p(nzt+2,j,i) + bc_pt_t_val * dzu(nzt+1)
+                ENDDO
+             ENDDO
+
+          ENDIF
+
+       ELSEIF ( sk_char == 'sa' )  THEN
+
+!
+!--       Salinity boundary condition at the bottom boundary.
+!--       So far, always Neumann (i.e. here zero gradient) is used
+          DO  i = nxl, nxr
+             DO  j = nys, nyn
+                sk_p(nzb,j,i)   = sk_p(nzb+1,j,i)
+                sk_p(nzb-1,j,i) = sk_p(nzb,j,i)
+                sk_p(nzb-2,j,i) = sk_p(nzb,j,i)
+             ENDDO
+          ENDDO
+
+!
+!--       Salinity boundary condition at the top boundary.
+!--       Dirichlet or Neumann (zero gradient)
+          DO  i = nxl, nxr
+             DO  j = nys, nyn
+                sk_p(nzt+2,j,i)   = sk_p(nzt+1,j,i)
+                sk_p(nzt+3,j,i)   = sk_p(nzt+1,j,i)
+             ENDDO
+          ENDDO
+
+       ELSEIF ( sk_char == 'q' )  THEN
+
+!
+!--       Specific humidity boundary condition at the bottom boundary.
+!--       Dirichlet (fixed surface humidity) or Neumann (i.e. zero gradient)
+          DO  i = nxl, nxr
+             DO  j = nys, nyn
+                sk_p(nzb,j,i)   = sk_p(nzb+1,j,i)
+                sk_p(nzb-1,j,i) = sk_p(nzb,j,i)
+                sk_p(nzb-2,j,i) = sk_p(nzb,j,i)
+             ENDDO
+          ENDDO
+
+!
+!--       Specific humidity boundary condition at the top boundary
+          IF ( ibc_q_t == 0 )  THEN
+!
+!--          Dirichlet
+             DO  i = nxl, nxr
+                DO  j = nys, nyn
+                   sk_p(nzt+2,j,i)   = sk_p(nzt+1,j,i)
+                   sk_p(nzt+3,j,i)   = sk_p(nzt+1,j,i)
+                ENDDO
+             ENDDO
+
+          ELSE
+!
+!--          Neumann: dzu(nzt+2:3) are not defined, dzu(nzt+1) is used instead
+             DO  i = nxl, nxr
+                DO  j = nys, nyn
+                   sk_p(nzt+2,j,i)   = sk_p(nzt+1,j,i) + bc_q_t_val * dzu(nzt+1)
+                   sk_p(nzt+3,j,i)   = sk_p(nzt+2,j,i) + bc_q_t_val * dzu(nzt+1)
+                ENDDO
+             ENDDO
+
+          ENDIF
+
+       ELSEIF ( sk_char == 'qr' )  THEN
+
+!
+!--       Rain water content boundary condition at the bottom boundary:
+!--       Dirichlet (fixed surface rain water content).
+          DO  i = nxl, nxr
+             DO  j = nys, nyn
+                sk_p(nzb,j,i)   = sk_p(nzb+1,j,i)
+                sk_p(nzb-1,j,i) = sk_p(nzb,j,i)
+                sk_p(nzb-2,j,i) = sk_p(nzb,j,i)
+             ENDDO
+          ENDDO
+
+!
+!--       Rain water content boundary condition at the top boundary: Dirichlet
+          DO  i = nxl, nxr
+             DO  j = nys, nyn
+                sk_p(nzt+2,j,i)   = sk_p(nzt+1,j,i)
+                sk_p(nzt+3,j,i)   = sk_p(nzt+1,j,i)
+             ENDDO
+          ENDDO
+
+       ELSEIF ( sk_char == 'nr' )  THEN
+
+!
+!--       Rain drop concentration boundary condition at the bottom boundary:
+!--       Dirichlet (fixed surface rain drop concentration).
+          DO  i = nxl, nxr
+             DO  j = nys, nyn
+                sk_p(nzb,j,i)   = sk_p(nzb+1,j,i)
+                sk_p(nzb-1,j,i) = sk_p(nzb,j,i)
+                sk_p(nzb-2,j,i) = sk_p(nzb,j,i)
+             ENDDO
+          ENDDO
+
+!
+!--       Rain drop concentration boundary condition at the top boundary: Dirichlet
+          DO  i = nxl, nxr
+             DO  j = nys, nyn
+                sk_p(nzt+2,j,i)   = sk_p(nzt+1,j,i)
+                sk_p(nzt+3,j,i)   = sk_p(nzt+1,j,i)
+             ENDDO
+          ENDDO
+
+       ELSEIF ( sk_char == 'e' )  THEN
+
+!
+!--       TKE boundary condition at bottom and top boundary (generally Neumann)
+          DO  i = nxl, nxr
+             DO  j = nys, nyn
+                sk_p(nzb,j,i)   = sk_p(nzb+1,j,i)
+                sk_p(nzb-1,j,i) = sk_p(nzb,j,i)
+                sk_p(nzb-2,j,i) = sk_p(nzb,j,i)
+                sk_p(nzt+2,j,i) = sk_p(nzt+1,j,i)
+                sk_p(nzt+3,j,i) = sk_p(nzt+1,j,i)
+             ENDDO
+          ENDDO
+
+       ELSE
+
+          WRITE( message_string, * ) 'no vertical boundary condi',                &
+                                   'tion for variable "', sk_char, '"'
+          CALL message( 'advec_s_bc', 'PA0158', 1, 2, 0, 6, 0 )
+         
+       ENDIF
+
+!
+!--    Determine the maxima of the first and second derivative in z-direction
+       fmax_l = 0.0_wp
+       DO  i = nxl, nxr
+          DO  j = nys, nyn
+             DO  k = nzb, nzt+1
+                numera = ABS( sk_p(k+1,j,i) - 2.0_wp * sk_p(k,j,i) + sk_p(k-1,j,i) )
+                denomi  = ABS( sk_p(k+1,j,i+1) - sk_p(k-1,j,i) )
+                fmax_l(1) = MAX( fmax_l(1) , numera )
+                fmax_l(2) = MAX( fmax_l(2) , denomi  )
+             ENDDO
+          ENDDO
+       ENDDO
+#if defined( __parallel )
+       IF ( collective_wait )  CALL MPI_BARRIER( comm2d, ierr )
+       CALL MPI_ALLREDUCE( fmax_l, fmax, 2, MPI_REAL, MPI_MAX, comm2d, ierr )
+#else
+       fmax = fmax_l
+#endif
+
+       fmax = 0.04_wp * fmax
+
+!
+!--    Allocate temporary arrays
+       ALLOCATE( a0(nzb:nzt+1,nys:nyn),   a1(nzb:nzt+1,nys:nyn),                  &
+                 a2(nzb:nzt+1,nys:nyn),   a12(nzb:nzt+1,nys:nyn),                 &
+                 a22(nzb:nzt+1,nys:nyn),  immb(nzb+1:nzt,nys:nyn),                &
+                 imme(nzb+1:nzt,nys:nyn), impb(nzb+1:nzt,nys:nyn),                &
+                 impe(nzb+1:nzt,nys:nyn), ipmb(nzb+1:nzt,nys:nyn),                &
+                 ipme(nzb+1:nzt,nys:nyn), ippb(nzb+1:nzt,nys:nyn),                &
+                 ippe(nzb+1:nzt,nys:nyn), m1(nzb-1:nzt+2,nys:nyn),                &
+                 sw(nzb:nzt+1,nys:nyn)                                            &
+               )
+       imme = 0.0_wp; impe = 0.0_wp; ipme = 0.0_wp; ippe = 0.0_wp
+
+!
+!--    Outer loop of all i
+       DO  i = nxl, nxr
+
+!
+!--       Compute polynomial coefficients
+          DO  j = nys, nyn
+             DO  k = nzb, nzt+1
+                a12(k,j) = 0.5_wp * ( sk_p(k+1,j,i) - sk_p(k-1,j,i) )
+                a22(k,j) = 0.5_wp * ( sk_p(k+1,j,i) - 2.0_wp * sk_p(k,j,i)        &
+                                                    + sk_p(k-1,j,i) )
+                a0(k,j) = ( 9.0_wp * sk_p(k+2,j,i)    - 116.0_wp * sk_p(k+1,j,i)  &
+                            + 2134.0_wp * sk_p(k,j,i) - 116.0_wp * sk_p(k-1,j,i)  &
+                            + 9.0_wp * sk_p(k-2,j,i) ) * f1920
+                a1(k,j) = ( -5.0_wp   * sk_p(k+2,j,i) + 34.0_wp * sk_p(k+1,j,i)   &
+                            - 34.0_wp * sk_p(k-1,j,i) + 5.0_wp  * sk_p(k-2,j,i)   &
+                          ) * f48
+                a2(k,j) = ( -3.0_wp * sk_p(k+2,j,i) + 36.0_wp * sk_p(k+1,j,i)     &
+                            - 66.0_wp * sk_p(k,j,i) + 36.0_wp * sk_p(k-1,j,i)     &
+                            - 3.0_wp * sk_p(k-2,j,i) ) * f48
+             ENDDO
+          ENDDO
+
+!
+!--       Fluxes using the Bott scheme
+!--       *VOCL LOOP,UNROLL(2)
+          DO  j = nys, nyn
+             DO  k = nzb+1, nzt
+                cip  =  MAX( 0.0_wp, w(k,j,i) * dt_3d * ddzw(k) )
+                cim  = -MIN( 0.0_wp, w(k,j,i) * dt_3d * ddzw(k) )
+                cipf = 1.0_wp - 2.0_wp * cip
+                cimf = 1.0_wp - 2.0_wp * cim
+                ip   =   a0(k,j)   * f2  * ( 1.0_wp - cipf )                      &
+                       + a1(k,j)   * f8  * ( 1.0_wp - cipf*cipf )                 &
+                       + a2(k,j)   * f24 * ( 1.0_wp - cipf*cipf*cipf )
+                im   =   a0(k+1,j) * f2  * ( 1.0_wp - cimf )                      &
+                       - a1(k+1,j) * f8  * ( 1.0_wp - cimf*cimf )                 &
+                       + a2(k+1,j) * f24 * ( 1.0_wp - cimf*cimf*cimf )
+                ip   = MAX( ip, 0.0_wp )
+                im   = MAX( im, 0.0_wp )
+                ippb(k,j) = ip * MIN( 1.0_wp, sk_p(k,j,i)   / (ip+im+1E-15_wp) )
+                impb(k,j) = im * MIN( 1.0_wp, sk_p(k+1,j,i) / (ip+im+1E-15_wp) )
+
+                cip  =  MAX( 0.0_wp, w(k-1,j,i) * dt_3d * ddzw(k) )
+                cim  = -MIN( 0.0_wp, w(k-1,j,i) * dt_3d * ddzw(k) )
+                cipf = 1.0_wp - 2.0_wp * cip
+                cimf = 1.0_wp - 2.0_wp * cim
+                ip   =   a0(k-1,j) * f2  * ( 1.0_wp - cipf )                      &
+                       + a1(k-1,j) * f8  * ( 1.0_wp - cipf*cipf )                 &
+                       + a2(k-1,j) * f24 * ( 1.0_wp - cipf*cipf*cipf )
+                im   =   a0(k,j)   * f2  * ( 1.0_wp - cimf )                      &
+                       - a1(k,j)   * f8  * ( 1.0_wp - cimf*cimf )                 &
+                       + a2(k,j)   * f24 * ( 1.0_wp - cimf*cimf*cimf )
+                ip   = MAX( ip, 0.0_wp )
+                im   = MAX( im, 0.0_wp )
+                ipmb(k,j) = ip * MIN( 1.0_wp, sk_p(k-1,j,i) / (ip+im+1E-15_wp) )
+                immb(k,j) = im * MIN( 1.0_wp, sk_p(k,j,i)   / (ip+im+1E-15_wp) )
+             ENDDO
+          ENDDO
+
+!
+!--       Compute monitor function m1
+          DO  j = nys, nyn
+             DO  k = nzb-1, nzt+2
+                m1z = ABS( sk_p(k+1,j,i) - 2.0_wp * sk_p(k,j,i) + sk_p(k-1,j,i) )
+                m1n = ABS( sk_p(k+1,j,i) - sk_p(k-1,j,i) )
+                IF ( m1n /= 0.0_wp  .AND.  m1n >= m1z )  THEN
+                   m1(k,j) = m1z / m1n
+                   IF ( m1(k,j) /= 2.0_wp  .AND.  m1n < fmax(2) )  m1(k,j) = 0.0_wp
+                ELSEIF ( m1n < m1z )  THEN
+                   m1(k,j) = -1.0_wp
+                ELSE
+                   m1(k,j) = 0.0_wp
+                ENDIF
+             ENDDO
+          ENDDO
+
+!
+!--       Compute switch sw
+          sw = 0.0_wp
+          DO  j = nys, nyn
+             DO  k = nzb, nzt+1
+                m2 = 2.0_wp * ABS( a1(k,j) - a12(k,j) ) /                         &
+                     MAX( ABS( a1(k,j) + a12(k,j) ), 1E-35_wp )
+                IF ( ABS( a1(k,j) + a12(k,j) ) < fmax(2) )  m2 = 0.0_wp
+
+                m3 = 2.0_wp * ABS( a2(k,j) - a22(k,j) ) /                         &
+                     MAX( ABS( a2(k,j) + a22(k,j) ), 1E-35_wp )
+                IF ( ABS( a2(k,j) + a22(k,j) ) < fmax(1) )  m3 = 0.0_wp
+
+                t1 = 0.35_wp
+                t2 = 0.35_wp
+                IF ( m1(k,j) == -1.0_wp )  t2 = 0.12_wp
+
+!--             *VOCL STMT,IF(10)
+                IF ( m1(k-1,j) == 1.0_wp .OR. m1(k,j) == 1.0_wp                   &
+                     .OR. m1(k+1,j) == 1.0_wp .OR.  m2 > t2  .OR.  m3 > t2  .OR.  &
+                     ( m1(k,j) > t1  .AND.  m1(k-1,j) /= -1.0_wp  .AND.           &
+                       m1(k,j) /= -1.0_wp  .AND.  m1(k+1,j) /= -1.0_wp )          &
+                   )  sw(k,j) = 1.0_wp
+             ENDDO
+          ENDDO
+
+!
+!--       Fluxes using exponential scheme
+          CALL cpu_log( log_point_s(12), 'advec_s_bc:exp', 'continue' )
+          DO  j = nys, nyn
+             DO  k = nzb+1, nzt
+
+!--             *VOCL STMT,IF(10)
+                IF ( sw(k,j) == 1.0_wp )  THEN
+                   snenn = sk_p(k+1,j,i) - sk_p(k-1,j,i)
+                   IF ( ABS( snenn ) < 1E-9_wp )  snenn = 1E-9_wp
+                   sterm = ( sk_p(k,j,i) - sk_p(k-1,j,i) ) / snenn
+                   sterm = MIN( sterm, 0.9999_wp )
+                   sterm = MAX( sterm, 0.0001_wp )
+
+                   ix = INT( sterm * 1000 ) + 1
+
+                   cip =  MAX( 0.0_wp, w(k,j,i) * dt_3d * ddzw(k) )
+
+                   ippe(k,j) = sk_p(k-1,j,i) * cip + snenn * (                    &
+                               aex(ix) * cip + bex(ix) / dex(ix) * (              &
+                               eex(ix) -                                          &
+                               EXP( dex(ix)*0.5_wp * ( 1.0_wp - 2.0_wp * cip ) )  &
+                                                                   )              &
+                                                             )
+                   IF ( sterm == 0.0001_wp )  ippe(k,j) = sk_p(k,j,i) * cip
+                   IF ( sterm == 0.9999_wp )  ippe(k,j) = sk_p(k,j,i) * cip
+
+                   snenn = sk_p(k-1,j,i) - sk_p(k+1,j,i)
+                   IF ( ABS( snenn ) < 1E-9_wp )  snenn = 1E-9_wp
+                   sterm = ( sk_p(k,j,i) - sk_p(k+1,j,i) ) / snenn
+                   sterm = MIN( sterm, 0.9999_wp )
+                   sterm = MAX( sterm, 0.0001_wp )
+
+                   ix = INT( sterm * 1000 ) + 1
+
+                   cim = -MIN( 0.0_wp, w(k-1,j,i) * dt_3d * ddzw(k) )
+
+                   imme(k,j) = sk_p(k+1,j,i) * cim + snenn * (                    &
+                               aex(ix) * cim + bex(ix) / dex(ix) * (              &
+                               eex(ix) -                                          &
+                               EXP( dex(ix)*0.5_wp * ( 1.0_wp - 2.0_wp * cim ) ) &
+                                                                   )              &
+                                                             )
+                   IF ( sterm == 0.0001_wp )  imme(k,j) = sk_p(k,j,i) * cim
+                   IF ( sterm == 0.9999_wp )  imme(k,j) = sk_p(k,j,i) * cim
+                ENDIF
+
+!--             *VOCL STMT,IF(10)
+                IF ( sw(k+1,j) == 1.0_wp )  THEN
+                   snenn = sk_p(k,j,i) - sk_p(k+2,j,i)
+                   IF ( ABS( snenn ) < 1E-9_wp )  snenn = 1E-9_wp
+                   sterm = ( sk_p(k+1,j,i) - sk_p(k+2,j,i) ) / snenn
+                   sterm = MIN( sterm, 0.9999_wp )
+                   sterm = MAX( sterm, 0.0001_wp )
+
+                   ix = INT( sterm * 1000 ) + 1
+
+                   cim = -MIN( 0.0_wp, w(k,j,i) * dt_3d * ddzw(k) )
+
+                   impe(k,j) = sk_p(k+2,j,i) * cim + snenn * (                    &
+                               aex(ix) * cim + bex(ix) / dex(ix) * (              &
+                               eex(ix) -                                          &
+                               EXP( dex(ix)*0.5_wp * ( 1.0_wp - 2.0_wp * cim ) )  &
+                                                                   )              &
+                                                             )
+                   IF ( sterm == 0.0001_wp )  impe(k,j) = sk_p(k+1,j,i) * cim
+                   IF ( sterm == 0.9999_wp )  impe(k,j) = sk_p(k+1,j,i) * cim
+                ENDIF
+
+!--             *VOCL STMT,IF(10)
+                IF ( sw(k-1,j) == 1.0_wp )  THEN
+                   snenn = sk_p(k,j,i) - sk_p(k-2,j,i)
+                   IF ( ABS( snenn ) < 1E-9_wp )  snenn = 1E-9_wp
+                   sterm = ( sk_p(k-1,j,i) - sk_p(k-2,j,i) ) / snenn
+                   sterm = MIN( sterm, 0.9999_wp )
+                   sterm = MAX( sterm, 0.0001_wp )
+
+                   ix = INT( sterm * 1000 ) + 1
+
+                   cip = MAX( 0.0_wp, w(k-1,j,i) * dt_3d * ddzw(k) )
+
+                   ipme(k,j) = sk_p(k-2,j,i) * cip + snenn * (                    &
+                               aex(ix) * cip + bex(ix) / dex(ix) * (              &
+                               eex(ix) -                                          &
+                               EXP( dex(ix)*0.5_wp * ( 1.0_wp - 2.0_wp * cip ) )  &
+                                                                   )              &
+                                                             )
+                   IF ( sterm == 0.0001_wp )  ipme(k,j) = sk_p(k-1,j,i) * cip
+                   IF ( sterm == 0.9999_wp )  ipme(k,j) = sk_p(k-1,j,i) * cip
+                ENDIF
+
+             ENDDO
+          ENDDO
+          CALL cpu_log( log_point_s(12), 'advec_s_bc:exp', 'pause' )
+
+!
+!--       Prognostic equation
+          DO  j = nys, nyn
+             DO  k = nzb+1, nzt
+                fplus  = ( 1.0_wp - sw(k,j)   ) * ippb(k,j) + sw(k,j)   * ippe(k,j) &
+                       - ( 1.0_wp - sw(k+1,j) ) * impb(k,j) - sw(k+1,j) * impe(k,j)
+                fminus = ( 1.0_wp - sw(k-1,j) ) * ipmb(k,j) + sw(k-1,j) * ipme(k,j) &
+                       - ( 1.0_wp - sw(k,j)   ) * immb(k,j) - sw(k,j)   * imme(k,j)
+                tendcy = fplus - fminus
+!
+!--              Removed in order to optimise speed
+!                ffmax   = MAX( ABS( fplus ), ABS( fminus ), 1E-35_wp )
+!                IF ( ( ABS( tendcy ) / ffmax ) < 1E-7_wp )  tendcy = 0.0
+!
+!--             Density correction because of possible remaining divergences
+                d_new = d(k,j,i) - ( w(k,j,i) - w(k-1,j,i) ) * dt_3d * ddzw(k)
+                sk_p(k,j,i) = ( ( 1.0_wp + d(k,j,i) ) * sk_p(k,j,i) - tendcy ) /  &
+                              ( 1.0_wp + d_new )
+!
+!--             Store heat flux for subsequent statistics output.
+!--             array m1 is here used as temporary storage
+                m1(k,j) = fplus / dt_3d * dzw(k)
+             ENDDO
+          ENDDO
+
+!
+!--       Sum up heat flux in order to order to obtain horizontal averages
+          IF ( sk_char == 'pt' )  THEN
+             DO  sr = 0, statistic_regions
+                DO  j = nys, nyn
+                   DO  k = nzb+1, nzt
+                      sums_wsts_bc_l(k,sr) = sums_wsts_bc_l(k,sr) +               &
+                                             m1(k,j) * rmask(j,i,sr)
+                   ENDDO
+                ENDDO
+             ENDDO
+          ENDIF
+
+       ENDDO   ! End of the advection in z-direction
+       CALL cpu_log( log_point_s(12), 'advec_s_bc:exp', 'continue' )
+       CALL cpu_log( log_point_s(12), 'advec_s_bc:exp', 'stop' )
+
+!
+!--    Deallocate temporary arrays
+       DEALLOCATE( a0, a1, a2, a12, a22, immb, imme, impb, impe, ipmb, ipme,      &
+                   ippb, ippe, m1, sw )
+
+!
+!--    Store results as tendency and deallocate local array
+       DO  i = nxl, nxr
+          DO  j = nys, nyn
+             DO  k = nzb+1, nzt
+                tend(k,j,i) = tend(k,j,i) + ( sk_p(k,j,i) - sk(k,j,i) ) / dt_3d
+             ENDDO
+          ENDDO
+       ENDDO
+
+       DEALLOCATE( sk_p )
+
+    END SUBROUTINE advec_s_bc
+
+ END MODULE advec_s_bc_mod
Index: lm/trunk/SOURCE/advec_s_pw.f90
===================================================================
--- /palm/trunk/SOURCE/advec_s_pw.f90	(revision 1849)
+++ 	(revision )
@@ -1,183 +1,0 @@
-!> @file advec_s_pw.f90
-!--------------------------------------------------------------------------------!
-! This file is part of PALM.
-!
-! PALM is free software: you can redistribute it and/or modify it under the terms
-! of the GNU General Public License as published by the Free Software Foundation,
-! either version 3 of the License, or (at your option) any later version.
-!
-! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
-! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
-! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along with
-! PALM. If not, see <http://www.gnu.org/licenses/>.
-!
-! Copyright 1997-2016 Leibniz Universitaet Hannover
-!--------------------------------------------------------------------------------!
-!
-! Current revisions:
-! -----------------
-! 
-! 
-! Former revisions:
-! -----------------
-! $Id$
-!
-! 1682 2015-10-07 23:56:08Z knoop
-! Code annotations made doxygen readable 
-! 
-! 1374 2014-04-25 12:55:07Z raasch
-! missing variables added to ONLY list
-! 
-! 1353 2014-04-08 15:21:23Z heinze
-! REAL constants provided with KIND-attribute
-!
-! 1320 2014-03-20 08:40:49Z raasch
-! ONLY-attribute added to USE-statements,
-! kind-parameters added to all INTEGER and REAL declaration statements,
-! kinds are defined in new module kinds,
-! revision history before 2012 removed,
-! comment fields (!:) to be used for variable explanations added to
-! all variable declaration statements
-!
-! 1036 2012-10-22 13:43:42Z raasch
-! code put under GPL (PALM 3.9)
-!
-! 1010 2012-09-20 07:59:54Z raasch
-! cpp switch __nopointer added for pointer free version
-!
-! Revision 1.1  1997/08/29 08:54:20  raasch
-! Initial revision
-!
-!
-! Description:
-! ------------
-!> Advection term for scalar variables using the Piacsek and Williams scheme
-!> (form C3). Contrary to PW itself, for reasons of accuracy their scheme is
-!> slightly modified as follows: the values of those scalars that are used for
-!> the computation of the flux divergence are reduced by the value of the
-!> relevant scalar at the location where the difference is computed (sk(k,j,i)).
-!> NOTE: at the first grid point above the surface computation still takes place!
-!------------------------------------------------------------------------------!
- MODULE advec_s_pw_mod
- 
-
-    PRIVATE
-    PUBLIC advec_s_pw
-
-    INTERFACE advec_s_pw
-       MODULE PROCEDURE advec_s_pw
-       MODULE PROCEDURE advec_s_pw_ij
-    END INTERFACE
- 
- CONTAINS
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Call for all grid points
-!------------------------------------------------------------------------------!
-    SUBROUTINE advec_s_pw( sk )
-
-       USE arrays_3d,                                                          &
-           ONLY:  dd2zu, tend, u, v, w
-
-       USE control_parameters,                                                 &
-           ONLY:  u_gtrans, v_gtrans
-
-       USE grid_variables,                                                     &
-           ONLY:  ddx, ddy
-
-       USE indices,                                                            &
-           ONLY:  nxl, nxlg, nxr, nxrg, nyn, nyng, nys, nysg, nzb, nzb_s_inner,&
-                  nzt
-
-       USE kinds
-
-
-       IMPLICIT NONE
-
-       INTEGER(iwp) ::  i !<
-       INTEGER(iwp) ::  j !<
-       INTEGER(iwp) ::  k !<
-
-#if defined( __nopointer )
-       REAL(wp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ::  sk !<
-#else
-       REAL(wp), DIMENSION(:,:,:), POINTER ::  sk
-#endif
- 
-
-       DO  i = nxl, nxr
-          DO  j = nys, nyn
-             DO  k = nzb_s_inner(j,i)+1, nzt
-                tend(k,j,i) = tend(k,j,i)                                      &
-              -0.5_wp * ( ( u(k,j,i+1) - u_gtrans ) * ( sk(k,j,i+1) - sk(k,j,i) ) &
-                        - ( u(k,j,i)   - u_gtrans ) * ( sk(k,j,i-1) - sk(k,j,i) ) &
-                        ) * ddx                                                   &
-              -0.5_wp * ( ( v(k,j+1,i) - v_gtrans ) * ( sk(k,j+1,i) - sk(k,j,i) ) &
-                        - ( v(k,j,i)   - v_gtrans ) * ( sk(k,j-1,i) - sk(k,j,i) ) &
-                        ) * ddy                                                   &
-              -         (   w(k,j,i)                * ( sk(k+1,j,i) - sk(k,j,i) ) &
-                        -   w(k-1,j,i)              * ( sk(k-1,j,i) - sk(k,j,i) ) &
-                        ) * dd2zu(k)
-             ENDDO
-          ENDDO
-       ENDDO
-
-    END SUBROUTINE advec_s_pw
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Call for grid point i,j
-!------------------------------------------------------------------------------!
-    SUBROUTINE advec_s_pw_ij( i, j, sk )
-
-       USE arrays_3d,                                                          &
-           ONLY:  dd2zu, tend, u, v, w
-
-       USE control_parameters,                                                 &
-           ONLY:  u_gtrans, v_gtrans
-
-       USE grid_variables,                                                     &
-           ONLY:  ddx, ddy
-
-       USE indices,                                                            &
-           ONLY:  nxlg, nxrg, nyng, nysg, nzb, nzb_s_inner, nzt
-
-       USE kinds
-
-
-       IMPLICIT NONE
-
-       INTEGER(iwp) ::  i !<
-       INTEGER(iwp) ::  j !<
-       INTEGER(iwp) ::  k !<
-
-#if defined( __nopointer )
-       REAL(wp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ::  sk !<
-#else
-       REAL(wp), DIMENSION(:,:,:), POINTER ::  sk
-#endif
-
-
-       DO  k = nzb_s_inner(j,i)+1, nzt
-          tend(k,j,i) = tend(k,j,i)                                            &
-              -0.5_wp * ( ( u(k,j,i+1) - u_gtrans ) * ( sk(k,j,i+1) - sk(k,j,i) ) &
-                        - ( u(k,j,i)   - u_gtrans ) * ( sk(k,j,i-1) - sk(k,j,i) ) &
-                        ) * ddx                                                   &
-              -0.5_wp * ( ( v(k,j+1,i) - v_gtrans ) * ( sk(k,j+1,i) - sk(k,j,i) ) &
-                        - ( v(k,j,i)   - v_gtrans ) * ( sk(k,j-1,i) - sk(k,j,i) ) &
-                        ) * ddy                                                   &
-              -         (   w(k,j,i)                * ( sk(k+1,j,i) - sk(k,j,i) ) &
-                        -   w(k-1,j,i)              * ( sk(k-1,j,i) - sk(k,j,i) ) &
-                        ) * dd2zu(k)
-       ENDDO
-
-    END SUBROUTINE advec_s_pw_ij
-
- END MODULE advec_s_pw_mod
Index: /palm/trunk/SOURCE/advec_s_pw_mod.f90
===================================================================
--- /palm/trunk/SOURCE/advec_s_pw_mod.f90	(revision 1850)
+++ /palm/trunk/SOURCE/advec_s_pw_mod.f90	(revision 1850)
@@ -0,0 +1,184 @@
+!> @file advec_s_pw_mod.f90
+!--------------------------------------------------------------------------------!
+! This file is part of PALM.
+!
+! PALM is free software: you can redistribute it and/or modify it under the terms
+! of the GNU General Public License as published by the Free Software Foundation,
+! either version 3 of the License, or (at your option) any later version.
+!
+! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
+! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
+! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along with
+! PALM. If not, see <http://www.gnu.org/licenses/>.
+!
+! Copyright 1997-2016 Leibniz Universitaet Hannover
+!--------------------------------------------------------------------------------!
+!
+! Current revisions:
+! -----------------
+! Module renamed
+! 
+! 
+! Former revisions:
+! -----------------
+! $Id$
+!
+! 1682 2015-10-07 23:56:08Z knoop
+! Code annotations made doxygen readable 
+! 
+! 1374 2014-04-25 12:55:07Z raasch
+! missing variables added to ONLY list
+! 
+! 1353 2014-04-08 15:21:23Z heinze
+! REAL constants provided with KIND-attribute
+!
+! 1320 2014-03-20 08:40:49Z raasch
+! ONLY-attribute added to USE-statements,
+! kind-parameters added to all INTEGER and REAL declaration statements,
+! kinds are defined in new module kinds,
+! revision history before 2012 removed,
+! comment fields (!:) to be used for variable explanations added to
+! all variable declaration statements
+!
+! 1036 2012-10-22 13:43:42Z raasch
+! code put under GPL (PALM 3.9)
+!
+! 1010 2012-09-20 07:59:54Z raasch
+! cpp switch __nopointer added for pointer free version
+!
+! Revision 1.1  1997/08/29 08:54:20  raasch
+! Initial revision
+!
+!
+! Description:
+! ------------
+!> Advection term for scalar variables using the Piacsek and Williams scheme
+!> (form C3). Contrary to PW itself, for reasons of accuracy their scheme is
+!> slightly modified as follows: the values of those scalars that are used for
+!> the computation of the flux divergence are reduced by the value of the
+!> relevant scalar at the location where the difference is computed (sk(k,j,i)).
+!> NOTE: at the first grid point above the surface computation still takes place!
+!------------------------------------------------------------------------------!
+ MODULE advec_s_pw_mod
+ 
+
+    PRIVATE
+    PUBLIC advec_s_pw
+
+    INTERFACE advec_s_pw
+       MODULE PROCEDURE advec_s_pw
+       MODULE PROCEDURE advec_s_pw_ij
+    END INTERFACE
+ 
+ CONTAINS
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Call for all grid points
+!------------------------------------------------------------------------------!
+    SUBROUTINE advec_s_pw( sk )
+
+       USE arrays_3d,                                                          &
+           ONLY:  dd2zu, tend, u, v, w
+
+       USE control_parameters,                                                 &
+           ONLY:  u_gtrans, v_gtrans
+
+       USE grid_variables,                                                     &
+           ONLY:  ddx, ddy
+
+       USE indices,                                                            &
+           ONLY:  nxl, nxlg, nxr, nxrg, nyn, nyng, nys, nysg, nzb, nzb_s_inner,&
+                  nzt
+
+       USE kinds
+
+
+       IMPLICIT NONE
+
+       INTEGER(iwp) ::  i !<
+       INTEGER(iwp) ::  j !<
+       INTEGER(iwp) ::  k !<
+
+#if defined( __nopointer )
+       REAL(wp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ::  sk !<
+#else
+       REAL(wp), DIMENSION(:,:,:), POINTER ::  sk
+#endif
+ 
+
+       DO  i = nxl, nxr
+          DO  j = nys, nyn
+             DO  k = nzb_s_inner(j,i)+1, nzt
+                tend(k,j,i) = tend(k,j,i)                                      &
+              -0.5_wp * ( ( u(k,j,i+1) - u_gtrans ) * ( sk(k,j,i+1) - sk(k,j,i) ) &
+                        - ( u(k,j,i)   - u_gtrans ) * ( sk(k,j,i-1) - sk(k,j,i) ) &
+                        ) * ddx                                                   &
+              -0.5_wp * ( ( v(k,j+1,i) - v_gtrans ) * ( sk(k,j+1,i) - sk(k,j,i) ) &
+                        - ( v(k,j,i)   - v_gtrans ) * ( sk(k,j-1,i) - sk(k,j,i) ) &
+                        ) * ddy                                                   &
+              -         (   w(k,j,i)                * ( sk(k+1,j,i) - sk(k,j,i) ) &
+                        -   w(k-1,j,i)              * ( sk(k-1,j,i) - sk(k,j,i) ) &
+                        ) * dd2zu(k)
+             ENDDO
+          ENDDO
+       ENDDO
+
+    END SUBROUTINE advec_s_pw
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Call for grid point i,j
+!------------------------------------------------------------------------------!
+    SUBROUTINE advec_s_pw_ij( i, j, sk )
+
+       USE arrays_3d,                                                          &
+           ONLY:  dd2zu, tend, u, v, w
+
+       USE control_parameters,                                                 &
+           ONLY:  u_gtrans, v_gtrans
+
+       USE grid_variables,                                                     &
+           ONLY:  ddx, ddy
+
+       USE indices,                                                            &
+           ONLY:  nxlg, nxrg, nyng, nysg, nzb, nzb_s_inner, nzt
+
+       USE kinds
+
+
+       IMPLICIT NONE
+
+       INTEGER(iwp) ::  i !<
+       INTEGER(iwp) ::  j !<
+       INTEGER(iwp) ::  k !<
+
+#if defined( __nopointer )
+       REAL(wp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ::  sk !<
+#else
+       REAL(wp), DIMENSION(:,:,:), POINTER ::  sk
+#endif
+
+
+       DO  k = nzb_s_inner(j,i)+1, nzt
+          tend(k,j,i) = tend(k,j,i)                                            &
+              -0.5_wp * ( ( u(k,j,i+1) - u_gtrans ) * ( sk(k,j,i+1) - sk(k,j,i) ) &
+                        - ( u(k,j,i)   - u_gtrans ) * ( sk(k,j,i-1) - sk(k,j,i) ) &
+                        ) * ddx                                                   &
+              -0.5_wp * ( ( v(k,j+1,i) - v_gtrans ) * ( sk(k,j+1,i) - sk(k,j,i) ) &
+                        - ( v(k,j,i)   - v_gtrans ) * ( sk(k,j-1,i) - sk(k,j,i) ) &
+                        ) * ddy                                                   &
+              -         (   w(k,j,i)                * ( sk(k+1,j,i) - sk(k,j,i) ) &
+                        -   w(k-1,j,i)              * ( sk(k-1,j,i) - sk(k,j,i) ) &
+                        ) * dd2zu(k)
+       ENDDO
+
+    END SUBROUTINE advec_s_pw_ij
+
+ END MODULE advec_s_pw_mod
Index: lm/trunk/SOURCE/advec_s_up.f90
===================================================================
--- /palm/trunk/SOURCE/advec_s_up.f90	(revision 1849)
+++ 	(revision )
@@ -1,232 +1,0 @@
-!> @file advec_s_up.f90
-!--------------------------------------------------------------------------------!
-! This file is part of PALM.
-!
-! PALM is free software: you can redistribute it and/or modify it under the terms
-! of the GNU General Public License as published by the Free Software Foundation,
-! either version 3 of the License, or (at your option) any later version.
-!
-! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
-! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
-! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along with
-! PALM. If not, see <http://www.gnu.org/licenses/>.
-!
-! Copyright 1997-2016 Leibniz Universitaet Hannover
-!--------------------------------------------------------------------------------!
-!
-! Current revisions:
-! -----------------
-! 
-! 
-! Former revisions:
-! -----------------
-! $Id$
-!
-! 1682 2015-10-07 23:56:08Z knoop
-! Code annotations made doxygen readable 
-! 
-! 1374 2014-04-25 12:55:07Z raasch
-! missing variables added to ONLY list
-! 
-! 1353 2014-04-08 15:21:23Z heinze
-! REAL constants provided with KIND-attribute
-!
-! 1320 2014-03-20 08:40:49Z raasch
-! ONLY-attribute added to USE-statements,
-! kind-parameters added to all INTEGER and REAL declaration statements,
-! kinds are defined in new module kinds,
-! revision history before 2012 removed,
-! comment fields (!:) to be used for variable explanations added to
-! all variable declaration statements
-!
-! 1036 2012-10-22 13:43:42Z raasch
-! code put under GPL (PALM 3.9)
-!
-! 1010 2012-09-20 07:59:54Z raasch
-! cpp switch __nopointer added for pointer free version
-!
-! 981 2012-08-09 14:57:44Z maronga
-! Typo removed
-!
-! Revision 1.1  1997/08/29 08:54:33  raasch
-! Initial revision
-!
-!
-! Description:
-! ------------
-!> Advection term for scalar quantities using the Upstream scheme.
-!> NOTE: vertical advection at k=1 still has wrong grid spacing for w>0!
-!>       The same problem occurs for all topography boundaries!
-!------------------------------------------------------------------------------!
- MODULE advec_s_up_mod
- 
-
-    PRIVATE
-    PUBLIC advec_s_up
-
-    INTERFACE advec_s_up
-       MODULE PROCEDURE advec_s_up
-       MODULE PROCEDURE advec_s_up_ij
-    END INTERFACE advec_s_up
-
- CONTAINS
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Call for all grid points
-!------------------------------------------------------------------------------!
-    SUBROUTINE advec_s_up( sk )
-
-       USE arrays_3d,                                                          &
-           ONLY:  ddzu, tend, u, v, w
-
-       USE control_parameters,                                                 &
-           ONLY:  u_gtrans, v_gtrans
-
-       USE grid_variables,                                                     &
-           ONLY:  ddx, ddy
-
-       USE indices,                                                            &
-           ONLY:  nxl, nxlg, nxr, nxrg, nyn, nyng, nys, nysg, nzb, nzb_s_inner,&
-                  nzt
-
-       USE kinds
-
-
-       IMPLICIT NONE
-
-       INTEGER(iwp) ::  i !<
-       INTEGER(iwp) ::  j !<
-       INTEGER(iwp) ::  k !<
-
-       REAL(wp) ::  ukomp !<
-       REAL(wp) ::  vkomp !<
-       REAL(wp) ::  wkomp !<
-#if defined( __nopointer )
-       REAL(wp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ::  sk !<
-#else
-       REAL(wp), DIMENSION(:,:,:), POINTER ::  sk
-#endif
-
-
-       DO  i = nxl, nxr
-          DO  j = nys, nyn
-             DO  k = nzb_s_inner(j,i)+1, nzt
-!
-!--             x-direction
-                ukomp = 0.5_wp * ( u(k,j,i) + u(k,j,i+1) ) - u_gtrans
-                IF ( ukomp > 0.0_wp )  THEN
-                   tend(k,j,i) = tend(k,j,i) - ukomp *                         &
-                                         ( sk(k,j,i) - sk(k,j,i-1) ) * ddx
-                ELSE
-                   tend(k,j,i) = tend(k,j,i) - ukomp *                         &
-                                         ( sk(k,j,i+1) - sk(k,j,i) ) * ddx
-                ENDIF
-!
-!--             y-direction
-                vkomp = 0.5_wp * ( v(k,j,i) + v(k,j+1,i) ) - v_gtrans
-                IF ( vkomp > 0.0_wp )  THEN
-                   tend(k,j,i) = tend(k,j,i) - vkomp *                         &
-                                         ( sk(k,j,i) - sk(k,j-1,i) ) * ddy
-                ELSE
-                   tend(k,j,i) = tend(k,j,i) - vkomp *                         &
-                                         ( sk(k,j+1,i) - sk(k,j,i) ) * ddy
-                ENDIF
-!
-!--             z-direction
-                wkomp = 0.5_wp * ( w(k,j,i) + w(k-1,j,i) )
-                IF ( wkomp > 0.0_wp )  THEN
-                   tend(k,j,i) = tend(k,j,i) - wkomp *                         &
-                                         ( sk(k,j,i) - sk(k-1,j,i) ) * ddzu(k)
-                ELSE
-                   tend(k,j,i) = tend(k,j,i) - wkomp *                         &
-                                         ( sk(k+1,j,i)-sk(k,j,i) ) * ddzu(k+1)
-                ENDIF
-
-             ENDDO
-          ENDDO
-       ENDDO
-
-    END SUBROUTINE advec_s_up
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Call for grid point i,j
-!------------------------------------------------------------------------------!
-    SUBROUTINE advec_s_up_ij( i, j, sk )
-
-       USE arrays_3d,                                                          &
-           ONLY:  ddzu, tend, u, v, w
-
-       USE control_parameters,                                                 &
-           ONLY:  u_gtrans, v_gtrans
-
-       USE grid_variables,                                                     &
-           ONLY:  ddx, ddy
-
-       USE indices,                                                            &
-           ONLY:  nxlg, nxrg, nyng, nysg, nzb, nzb_s_inner, nzt
-
-       USE kinds
-
-
-       IMPLICIT NONE
-
-       INTEGER(iwp) ::  i !<
-       INTEGER(iwp) ::  j !<
-       INTEGER(iwp) ::  k !<
-
-       REAL(wp) ::  ukomp !<
-       REAL(wp) ::  vkomp !<
-       REAL(wp) ::  wkomp !<
-       
-#if defined( __nopointer )
-       REAL(wp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ::  sk !<
-#else
-       REAL(wp), DIMENSION(:,:,:), POINTER ::  sk
-#endif
-
-
-       DO  k = nzb_s_inner(j,i)+1, nzt
-!
-!--       x-direction
-          ukomp = 0.5_wp * ( u(k,j,i) + u(k,j,i+1) ) - u_gtrans
-          IF ( ukomp > 0.0_wp )  THEN
-             tend(k,j,i) = tend(k,j,i) - ukomp *                               &
-                                         ( sk(k,j,i) - sk(k,j,i-1) ) * ddx
-          ELSE
-             tend(k,j,i) = tend(k,j,i) - ukomp *                               &
-                                         ( sk(k,j,i+1) - sk(k,j,i) ) * ddx
-          ENDIF
-!
-!--       y-direction
-          vkomp = 0.5_wp * ( v(k,j,i) + v(k,j+1,i) ) - v_gtrans
-          IF ( vkomp > 0.0_wp )  THEN
-             tend(k,j,i) = tend(k,j,i) - vkomp *                               &
-                                         ( sk(k,j,i) - sk(k,j-1,i) ) * ddy
-          ELSE
-             tend(k,j,i) = tend(k,j,i) - vkomp *                               &
-                                         ( sk(k,j+1,i) - sk(k,j,i) ) * ddy
-          ENDIF
-!
-!--       z-direction
-          wkomp = 0.5_wp * ( w(k,j,i) + w(k-1,j,i) )
-          IF ( wkomp > 0.0_wp )  THEN
-             tend(k,j,i) = tend(k,j,i) - wkomp *                               &
-                                         ( sk(k,j,i) - sk(k-1,j,i) ) * ddzu(k)
-          ELSE
-             tend(k,j,i) = tend(k,j,i) - wkomp *                               &
-                                         ( sk(k+1,j,i)-sk(k,j,i) ) * ddzu(k+1)
-          ENDIF
-
-       ENDDO
-
-    END SUBROUTINE advec_s_up_ij
-
- END MODULE advec_s_up_mod
Index: /palm/trunk/SOURCE/advec_s_up_mod.f90
===================================================================
--- /palm/trunk/SOURCE/advec_s_up_mod.f90	(revision 1850)
+++ /palm/trunk/SOURCE/advec_s_up_mod.f90	(revision 1850)
@@ -0,0 +1,233 @@
+!> @file advec_s_up_mod.f90
+!--------------------------------------------------------------------------------!
+! This file is part of PALM.
+!
+! PALM is free software: you can redistribute it and/or modify it under the terms
+! of the GNU General Public License as published by the Free Software Foundation,
+! either version 3 of the License, or (at your option) any later version.
+!
+! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
+! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
+! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along with
+! PALM. If not, see <http://www.gnu.org/licenses/>.
+!
+! Copyright 1997-2016 Leibniz Universitaet Hannover
+!--------------------------------------------------------------------------------!
+!
+! Current revisions:
+! -----------------
+! Module renamed
+! 
+! 
+! Former revisions:
+! -----------------
+! $Id$
+!
+! 1682 2015-10-07 23:56:08Z knoop
+! Code annotations made doxygen readable 
+! 
+! 1374 2014-04-25 12:55:07Z raasch
+! missing variables added to ONLY list
+! 
+! 1353 2014-04-08 15:21:23Z heinze
+! REAL constants provided with KIND-attribute
+!
+! 1320 2014-03-20 08:40:49Z raasch
+! ONLY-attribute added to USE-statements,
+! kind-parameters added to all INTEGER and REAL declaration statements,
+! kinds are defined in new module kinds,
+! revision history before 2012 removed,
+! comment fields (!:) to be used for variable explanations added to
+! all variable declaration statements
+!
+! 1036 2012-10-22 13:43:42Z raasch
+! code put under GPL (PALM 3.9)
+!
+! 1010 2012-09-20 07:59:54Z raasch
+! cpp switch __nopointer added for pointer free version
+!
+! 981 2012-08-09 14:57:44Z maronga
+! Typo removed
+!
+! Revision 1.1  1997/08/29 08:54:33  raasch
+! Initial revision
+!
+!
+! Description:
+! ------------
+!> Advection term for scalar quantities using the Upstream scheme.
+!> NOTE: vertical advection at k=1 still has wrong grid spacing for w>0!
+!>       The same problem occurs for all topography boundaries!
+!------------------------------------------------------------------------------!
+ MODULE advec_s_up_mod
+ 
+
+    PRIVATE
+    PUBLIC advec_s_up
+
+    INTERFACE advec_s_up
+       MODULE PROCEDURE advec_s_up
+       MODULE PROCEDURE advec_s_up_ij
+    END INTERFACE advec_s_up
+
+ CONTAINS
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Call for all grid points
+!------------------------------------------------------------------------------!
+    SUBROUTINE advec_s_up( sk )
+
+       USE arrays_3d,                                                          &
+           ONLY:  ddzu, tend, u, v, w
+
+       USE control_parameters,                                                 &
+           ONLY:  u_gtrans, v_gtrans
+
+       USE grid_variables,                                                     &
+           ONLY:  ddx, ddy
+
+       USE indices,                                                            &
+           ONLY:  nxl, nxlg, nxr, nxrg, nyn, nyng, nys, nysg, nzb, nzb_s_inner,&
+                  nzt
+
+       USE kinds
+
+
+       IMPLICIT NONE
+
+       INTEGER(iwp) ::  i !<
+       INTEGER(iwp) ::  j !<
+       INTEGER(iwp) ::  k !<
+
+       REAL(wp) ::  ukomp !<
+       REAL(wp) ::  vkomp !<
+       REAL(wp) ::  wkomp !<
+#if defined( __nopointer )
+       REAL(wp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ::  sk !<
+#else
+       REAL(wp), DIMENSION(:,:,:), POINTER ::  sk
+#endif
+
+
+       DO  i = nxl, nxr
+          DO  j = nys, nyn
+             DO  k = nzb_s_inner(j,i)+1, nzt
+!
+!--             x-direction
+                ukomp = 0.5_wp * ( u(k,j,i) + u(k,j,i+1) ) - u_gtrans
+                IF ( ukomp > 0.0_wp )  THEN
+                   tend(k,j,i) = tend(k,j,i) - ukomp *                         &
+                                         ( sk(k,j,i) - sk(k,j,i-1) ) * ddx
+                ELSE
+                   tend(k,j,i) = tend(k,j,i) - ukomp *                         &
+                                         ( sk(k,j,i+1) - sk(k,j,i) ) * ddx
+                ENDIF
+!
+!--             y-direction
+                vkomp = 0.5_wp * ( v(k,j,i) + v(k,j+1,i) ) - v_gtrans
+                IF ( vkomp > 0.0_wp )  THEN
+                   tend(k,j,i) = tend(k,j,i) - vkomp *                         &
+                                         ( sk(k,j,i) - sk(k,j-1,i) ) * ddy
+                ELSE
+                   tend(k,j,i) = tend(k,j,i) - vkomp *                         &
+                                         ( sk(k,j+1,i) - sk(k,j,i) ) * ddy
+                ENDIF
+!
+!--             z-direction
+                wkomp = 0.5_wp * ( w(k,j,i) + w(k-1,j,i) )
+                IF ( wkomp > 0.0_wp )  THEN
+                   tend(k,j,i) = tend(k,j,i) - wkomp *                         &
+                                         ( sk(k,j,i) - sk(k-1,j,i) ) * ddzu(k)
+                ELSE
+                   tend(k,j,i) = tend(k,j,i) - wkomp *                         &
+                                         ( sk(k+1,j,i)-sk(k,j,i) ) * ddzu(k+1)
+                ENDIF
+
+             ENDDO
+          ENDDO
+       ENDDO
+
+    END SUBROUTINE advec_s_up
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Call for grid point i,j
+!------------------------------------------------------------------------------!
+    SUBROUTINE advec_s_up_ij( i, j, sk )
+
+       USE arrays_3d,                                                          &
+           ONLY:  ddzu, tend, u, v, w
+
+       USE control_parameters,                                                 &
+           ONLY:  u_gtrans, v_gtrans
+
+       USE grid_variables,                                                     &
+           ONLY:  ddx, ddy
+
+       USE indices,                                                            &
+           ONLY:  nxlg, nxrg, nyng, nysg, nzb, nzb_s_inner, nzt
+
+       USE kinds
+
+
+       IMPLICIT NONE
+
+       INTEGER(iwp) ::  i !<
+       INTEGER(iwp) ::  j !<
+       INTEGER(iwp) ::  k !<
+
+       REAL(wp) ::  ukomp !<
+       REAL(wp) ::  vkomp !<
+       REAL(wp) ::  wkomp !<
+       
+#if defined( __nopointer )
+       REAL(wp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ::  sk !<
+#else
+       REAL(wp), DIMENSION(:,:,:), POINTER ::  sk
+#endif
+
+
+       DO  k = nzb_s_inner(j,i)+1, nzt
+!
+!--       x-direction
+          ukomp = 0.5_wp * ( u(k,j,i) + u(k,j,i+1) ) - u_gtrans
+          IF ( ukomp > 0.0_wp )  THEN
+             tend(k,j,i) = tend(k,j,i) - ukomp *                               &
+                                         ( sk(k,j,i) - sk(k,j,i-1) ) * ddx
+          ELSE
+             tend(k,j,i) = tend(k,j,i) - ukomp *                               &
+                                         ( sk(k,j,i+1) - sk(k,j,i) ) * ddx
+          ENDIF
+!
+!--       y-direction
+          vkomp = 0.5_wp * ( v(k,j,i) + v(k,j+1,i) ) - v_gtrans
+          IF ( vkomp > 0.0_wp )  THEN
+             tend(k,j,i) = tend(k,j,i) - vkomp *                               &
+                                         ( sk(k,j,i) - sk(k,j-1,i) ) * ddy
+          ELSE
+             tend(k,j,i) = tend(k,j,i) - vkomp *                               &
+                                         ( sk(k,j+1,i) - sk(k,j,i) ) * ddy
+          ENDIF
+!
+!--       z-direction
+          wkomp = 0.5_wp * ( w(k,j,i) + w(k-1,j,i) )
+          IF ( wkomp > 0.0_wp )  THEN
+             tend(k,j,i) = tend(k,j,i) - wkomp *                               &
+                                         ( sk(k,j,i) - sk(k-1,j,i) ) * ddzu(k)
+          ELSE
+             tend(k,j,i) = tend(k,j,i) - wkomp *                               &
+                                         ( sk(k+1,j,i)-sk(k,j,i) ) * ddzu(k+1)
+          ENDIF
+
+       ENDDO
+
+    END SUBROUTINE advec_s_up_ij
+
+ END MODULE advec_s_up_mod
Index: lm/trunk/SOURCE/advec_u_pw.f90
===================================================================
--- /palm/trunk/SOURCE/advec_u_pw.f90	(revision 1849)
+++ 	(revision )
@@ -1,168 +1,0 @@
-!> @file advec_u_pw.f90
-!--------------------------------------------------------------------------------!
-! This file is part of PALM.
-!
-! PALM is free software: you can redistribute it and/or modify it under the terms
-! of the GNU General Public License as published by the Free Software Foundation,
-! either version 3 of the License, or (at your option) any later version.
-!
-! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
-! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
-! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along with
-! PALM. If not, see <http://www.gnu.org/licenses/>.
-!
-! Copyright 1997-2016 Leibniz Universitaet Hannover
-!--------------------------------------------------------------------------------!
-!
-! Current revisions:
-! -----------------
-! 
-! 
-! Former revisions:
-! -----------------
-! $Id$
-!
-! 1682 2015-10-07 23:56:08Z knoop
-! Code annotations made doxygen readable 
-! 
-! 1353 2014-04-08 15:21:23Z heinze
-! REAL constants provided with KIND-attribute
-!
-! 1320 2014-03-20 08:40:49Z raasch
-! ONLY-attribute added to USE-statements,
-! kind-parameters added to all INTEGER and REAL declaration statements,
-! kinds are defined in new module kinds,
-! revision history before 2012 removed,
-! comment fields (!:) to be used for variable explanations added to
-! all variable declaration statements
-!
-! 1036 2012-10-22 13:43:42Z raasch
-! code put under GPL (PALM 3.9)
-!
-! Revision 1.1  1997/08/11 06:09:21  raasch
-! Initial revision
-!
-!
-! Description:
-! ------------
-!> Advection term for u velocity-component using Piacsek and Williams.
-!> Vertical advection at the first grid point above the surface is done with
-!> normal centred differences, because otherwise no information from the surface
-!> would be communicated upwards due to w=0 at K=nzb.
-!------------------------------------------------------------------------------!
- MODULE advec_u_pw_mod
- 
-
-    PRIVATE
-    PUBLIC advec_u_pw
-
-    INTERFACE advec_u_pw
-       MODULE PROCEDURE advec_u_pw
-       MODULE PROCEDURE advec_u_pw_ij
-    END INTERFACE advec_u_pw
- 
- CONTAINS
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Call for all grid points
-!------------------------------------------------------------------------------!
-    SUBROUTINE advec_u_pw
-
-       USE arrays_3d,                                                          &
-           ONLY:  ddzw, tend, u, v, w
-
-       USE control_parameters,                                                 &
-           ONLY:  u_gtrans, v_gtrans
-
-       USE grid_variables,                                                     &
-           ONLY:  ddx, ddy
-
-       USE indices,                                                            &
-           ONLY:  nxlu, nxr, nyn, nys, nzb_u_inner, nzt
-
-       USE kinds
-
-
-       IMPLICIT NONE
-
-       INTEGER(iwp) ::  i !<
-       INTEGER(iwp) ::  j !<
-       INTEGER(iwp) ::  k !<
-       
-       REAL(wp)    ::  gu !<
-       REAL(wp)    ::  gv !<
- 
-       gu = 2.0_wp * u_gtrans
-       gv = 2.0_wp * v_gtrans
-       DO  i = nxlu, nxr
-          DO  j = nys, nyn
-             DO  k = nzb_u_inner(j,i)+1, nzt
-                tend(k,j,i) = tend(k,j,i) - 0.25_wp * (                        &
-                         ( u(k,j,i+1) * ( u(k,j,i+1) + u(k,j,i) - gu )         &
-                         - u(k,j,i-1) * ( u(k,j,i) + u(k,j,i-1) - gu ) ) * ddx &
-                       + ( u(k,j+1,i) * ( v(k,j+1,i) + v(k,j+1,i-1) - gv )     &
-                         - u(k,j-1,i) * ( v(k,j,i) + v(k,j,i-1) - gv ) ) * ddy &
-                       + ( u(k+1,j,i) * ( w(k,j,i) + w(k,j,i-1) )              &
-                         - u(k-1,j,i) * ( w(k-1,j,i) + w(k-1,j,i-1) ) )        &
-                                                                  * ddzw(k)    &
-                                                      )
-             ENDDO
-          ENDDO
-       ENDDO
-
-    END SUBROUTINE advec_u_pw
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Call for grid point i,j
-!------------------------------------------------------------------------------!
-    SUBROUTINE advec_u_pw_ij( i, j )
-
-       USE arrays_3d,                                                          &
-           ONLY:  ddzw, tend, u, v, w
-
-       USE control_parameters,                                                 &
-           ONLY:  u_gtrans, v_gtrans
-
-       USE grid_variables,                                                     &
-           ONLY:  ddx, ddy
-
-       USE indices,                                                            &
-           ONLY:  nzb_u_inner, nzt
-
-       USE kinds
-
-
-       IMPLICIT NONE
-
-       INTEGER(iwp) ::  i !<
-       INTEGER(iwp) ::  j !<
-       INTEGER(iwp) ::  k !<
-       
-       REAL(wp)    ::  gu !<
-       REAL(wp)    ::  gv !<
-
-       gu = 2.0_wp * u_gtrans
-       gv = 2.0_wp * v_gtrans
-       DO  k = nzb_u_inner(j,i)+1, nzt
-          tend(k,j,i) = tend(k,j,i) - 0.25_wp * (                              &
-                         ( u(k,j,i+1) * ( u(k,j,i+1) + u(k,j,i) - gu )         &
-                         - u(k,j,i-1) * ( u(k,j,i) + u(k,j,i-1) - gu ) ) * ddx &
-                       + ( u(k,j+1,i) * ( v(k,j+1,i) + v(k,j+1,i-1) - gv )     &
-                         - u(k,j-1,i) * ( v(k,j,i) + v(k,j,i-1) - gv ) ) * ddy &
-                       + ( u(k+1,j,i) * ( w(k,j,i) + w(k,j,i-1) )              &
-                         - u(k-1,j,i) * ( w(k-1,j,i) + w(k-1,j,i-1) ) )        &
-                                                                  * ddzw(k)    &
-                                                )
-       ENDDO
-
-    END SUBROUTINE advec_u_pw_ij
-
- END MODULE advec_u_pw_mod
Index: /palm/trunk/SOURCE/advec_u_pw_mod.f90
===================================================================
--- /palm/trunk/SOURCE/advec_u_pw_mod.f90	(revision 1850)
+++ /palm/trunk/SOURCE/advec_u_pw_mod.f90	(revision 1850)
@@ -0,0 +1,169 @@
+!> @file advec_u_pw_mod.f90
+!--------------------------------------------------------------------------------!
+! This file is part of PALM.
+!
+! PALM is free software: you can redistribute it and/or modify it under the terms
+! of the GNU General Public License as published by the Free Software Foundation,
+! either version 3 of the License, or (at your option) any later version.
+!
+! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
+! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
+! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along with
+! PALM. If not, see <http://www.gnu.org/licenses/>.
+!
+! Copyright 1997-2016 Leibniz Universitaet Hannover
+!--------------------------------------------------------------------------------!
+!
+! Current revisions:
+! -----------------
+! Module renamed
+! 
+! 
+! Former revisions:
+! -----------------
+! $Id$
+!
+! 1682 2015-10-07 23:56:08Z knoop
+! Code annotations made doxygen readable 
+! 
+! 1353 2014-04-08 15:21:23Z heinze
+! REAL constants provided with KIND-attribute
+!
+! 1320 2014-03-20 08:40:49Z raasch
+! ONLY-attribute added to USE-statements,
+! kind-parameters added to all INTEGER and REAL declaration statements,
+! kinds are defined in new module kinds,
+! revision history before 2012 removed,
+! comment fields (!:) to be used for variable explanations added to
+! all variable declaration statements
+!
+! 1036 2012-10-22 13:43:42Z raasch
+! code put under GPL (PALM 3.9)
+!
+! Revision 1.1  1997/08/11 06:09:21  raasch
+! Initial revision
+!
+!
+! Description:
+! ------------
+!> Advection term for u velocity-component using Piacsek and Williams.
+!> Vertical advection at the first grid point above the surface is done with
+!> normal centred differences, because otherwise no information from the surface
+!> would be communicated upwards due to w=0 at K=nzb.
+!------------------------------------------------------------------------------!
+ MODULE advec_u_pw_mod
+ 
+
+    PRIVATE
+    PUBLIC advec_u_pw
+
+    INTERFACE advec_u_pw
+       MODULE PROCEDURE advec_u_pw
+       MODULE PROCEDURE advec_u_pw_ij
+    END INTERFACE advec_u_pw
+ 
+ CONTAINS
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Call for all grid points
+!------------------------------------------------------------------------------!
+    SUBROUTINE advec_u_pw
+
+       USE arrays_3d,                                                          &
+           ONLY:  ddzw, tend, u, v, w
+
+       USE control_parameters,                                                 &
+           ONLY:  u_gtrans, v_gtrans
+
+       USE grid_variables,                                                     &
+           ONLY:  ddx, ddy
+
+       USE indices,                                                            &
+           ONLY:  nxlu, nxr, nyn, nys, nzb_u_inner, nzt
+
+       USE kinds
+
+
+       IMPLICIT NONE
+
+       INTEGER(iwp) ::  i !<
+       INTEGER(iwp) ::  j !<
+       INTEGER(iwp) ::  k !<
+       
+       REAL(wp)    ::  gu !<
+       REAL(wp)    ::  gv !<
+ 
+       gu = 2.0_wp * u_gtrans
+       gv = 2.0_wp * v_gtrans
+       DO  i = nxlu, nxr
+          DO  j = nys, nyn
+             DO  k = nzb_u_inner(j,i)+1, nzt
+                tend(k,j,i) = tend(k,j,i) - 0.25_wp * (                        &
+                         ( u(k,j,i+1) * ( u(k,j,i+1) + u(k,j,i) - gu )         &
+                         - u(k,j,i-1) * ( u(k,j,i) + u(k,j,i-1) - gu ) ) * ddx &
+                       + ( u(k,j+1,i) * ( v(k,j+1,i) + v(k,j+1,i-1) - gv )     &
+                         - u(k,j-1,i) * ( v(k,j,i) + v(k,j,i-1) - gv ) ) * ddy &
+                       + ( u(k+1,j,i) * ( w(k,j,i) + w(k,j,i-1) )              &
+                         - u(k-1,j,i) * ( w(k-1,j,i) + w(k-1,j,i-1) ) )        &
+                                                                  * ddzw(k)    &
+                                                      )
+             ENDDO
+          ENDDO
+       ENDDO
+
+    END SUBROUTINE advec_u_pw
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Call for grid point i,j
+!------------------------------------------------------------------------------!
+    SUBROUTINE advec_u_pw_ij( i, j )
+
+       USE arrays_3d,                                                          &
+           ONLY:  ddzw, tend, u, v, w
+
+       USE control_parameters,                                                 &
+           ONLY:  u_gtrans, v_gtrans
+
+       USE grid_variables,                                                     &
+           ONLY:  ddx, ddy
+
+       USE indices,                                                            &
+           ONLY:  nzb_u_inner, nzt
+
+       USE kinds
+
+
+       IMPLICIT NONE
+
+       INTEGER(iwp) ::  i !<
+       INTEGER(iwp) ::  j !<
+       INTEGER(iwp) ::  k !<
+       
+       REAL(wp)    ::  gu !<
+       REAL(wp)    ::  gv !<
+
+       gu = 2.0_wp * u_gtrans
+       gv = 2.0_wp * v_gtrans
+       DO  k = nzb_u_inner(j,i)+1, nzt
+          tend(k,j,i) = tend(k,j,i) - 0.25_wp * (                              &
+                         ( u(k,j,i+1) * ( u(k,j,i+1) + u(k,j,i) - gu )         &
+                         - u(k,j,i-1) * ( u(k,j,i) + u(k,j,i-1) - gu ) ) * ddx &
+                       + ( u(k,j+1,i) * ( v(k,j+1,i) + v(k,j+1,i-1) - gv )     &
+                         - u(k,j-1,i) * ( v(k,j,i) + v(k,j,i-1) - gv ) ) * ddy &
+                       + ( u(k+1,j,i) * ( w(k,j,i) + w(k,j,i-1) )              &
+                         - u(k-1,j,i) * ( w(k-1,j,i) + w(k-1,j,i-1) ) )        &
+                                                                  * ddzw(k)    &
+                                                )
+       ENDDO
+
+    END SUBROUTINE advec_u_pw_ij
+
+ END MODULE advec_u_pw_mod
Index: lm/trunk/SOURCE/advec_u_up.f90
===================================================================
--- /palm/trunk/SOURCE/advec_u_up.f90	(revision 1849)
+++ 	(revision )
@@ -1,214 +1,0 @@
-!> @file advec_u_up.f90
-!--------------------------------------------------------------------------------!
-! This file is part of PALM.
-!
-! PALM is free software: you can redistribute it and/or modify it under the terms
-! of the GNU General Public License as published by the Free Software Foundation,
-! either version 3 of the License, or (at your option) any later version.
-!
-! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
-! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
-! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along with
-! PALM. If not, see <http://www.gnu.org/licenses/>.
-!
-! Copyright 1997-2016 Leibniz Universitaet Hannover
-!--------------------------------------------------------------------------------!
-!
-! Current revisions:
-! -----------------
-! 
-! 
-! Former revisions:
-! -----------------
-! $Id$
-!
-! 1682 2015-10-07 23:56:08Z knoop
-! Code annotations made doxygen readable 
-! 
-! 1353 2014-04-08 15:21:23Z heinze
-! REAL constants provided with KIND-attribute
-!
-! 1320 2014-03-20 08:40:49Z raasch
-! ONLY-attribute added to USE-statements,
-! kind-parameters added to all INTEGER and REAL declaration statements,
-! kinds are defined in new module kinds,
-! revision history before 2012 removed,
-! comment fields (!:) to be used for variable explanations added to
-! all variable declaration statements
-!
-! 1036 2012-10-22 13:43:42Z raasch
-! code put under GPL (PALM 3.9)
-!
-! Revision 1.1  1997/08/29 08:55:25  raasch
-! Initial revision
-!
-!
-! Description:
-! ------------
-!> Advection term for the u velocity-component using upstream scheme.
-!> NOTE: vertical advection at k=1 still has wrong grid spacing for w>0!
-!>       The same problem occurs for all topography boundaries!
-!------------------------------------------------------------------------------!
- MODULE advec_u_up_mod
- 
-
-    PRIVATE
-    PUBLIC advec_u_up
-
-    INTERFACE advec_u_up
-       MODULE PROCEDURE advec_u_up
-       MODULE PROCEDURE advec_u_up_ij
-    END INTERFACE advec_u_up
-
- CONTAINS
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Call for all grid points
-!------------------------------------------------------------------------------!
-    SUBROUTINE advec_u_up
-
-       USE arrays_3d,                                                          &
-           ONLY:  ddzu, tend, u, v, w
-
-       USE control_parameters,                                                 &
-           ONLY:  u_gtrans, v_gtrans
-
-       USE grid_variables,                                                     &
-           ONLY:  ddx, ddy
-
-       USE indices,                                                            &
-           ONLY:  nxlu, nxr, nyn, nys, nzb_u_inner, nzt
-
-       USE kinds
-
-
-       IMPLICIT NONE
-
-       INTEGER(iwp) ::  i !<
-       INTEGER(iwp) ::  j !<
-       INTEGER(iwp) ::  k !<
-
-       REAL(wp) ::  ukomp !<
-       REAL(wp) ::  vkomp !<
-       REAL(wp) ::  wkomp !<
-
-       
-       DO  i = nxlu, nxr
-          DO  j = nys, nyn
-             DO  k = nzb_u_inner(j,i)+1, nzt
-!
-!--             x-direction
-                ukomp = u(k,j,i) - u_gtrans
-                IF ( ukomp > 0.0_wp )  THEN
-                   tend(k,j,i) = tend(k,j,i) - ukomp *                         &
-                                         ( u(k,j,i) - u(k,j,i-1) ) * ddx
-                ELSE
-                   tend(k,j,i) = tend(k,j,i) - ukomp *                         &
-                                          ( u(k,j,i+1) - u(k,j,i) ) * ddx
-                ENDIF
-!
-!--             y-direction
-                vkomp = 0.25_wp * ( v(k,j,i)   + v(k,j+1,i) +                  &
-                                 v(k,j,i-1) + v(k,j+1,i-1) ) - v_gtrans
-                IF ( vkomp > 0.0_wp )  THEN
-                   tend(k,j,i) = tend(k,j,i) - vkomp *                         &
-                                         ( u(k,j,i) - u(k,j-1,i) ) * ddy
-                ELSE
-                   tend(k,j,i) = tend(k,j,i) - vkomp *                         &
-                                         ( u(k,j+1,i) - u(k,j,i) ) * ddy
-                ENDIF
-!
-!--             z-direction
-                wkomp = 0.25_wp * ( w(k,j,i)   + w(k-1,j,i) +                  &
-                                 w(k,j,i-1) + w(k-1,j,i-1) )
-                IF ( wkomp > 0.0_wp )  THEN
-                   tend(k,j,i) = tend(k,j,i) - wkomp *                         &
-                                         ( u(k,j,i) - u(k-1,j,i) ) * ddzu(k)
-                ELSE
-                   tend(k,j,i) = tend(k,j,i) - wkomp *                         &
-                                         ( u(k+1,j,i) - u(k,j,i) ) * ddzu(k+1)
-                ENDIF
-
-             ENDDO
-          ENDDO
-       ENDDO
-
-    END SUBROUTINE advec_u_up
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Call for grid point i,j
-!------------------------------------------------------------------------------!
-    SUBROUTINE advec_u_up_ij( i, j )
-
-       USE arrays_3d,                                                          &
-           ONLY:  ddzu, tend, u, v, w
-
-       USE control_parameters,                                                 &
-           ONLY:  u_gtrans, v_gtrans
-
-       USE grid_variables,                                                     &
-           ONLY:  ddx, ddy
-
-       USE indices,                                                            &
-           ONLY:  nzb_u_inner, nzt
-
-       USE kinds
-
-
-       IMPLICIT NONE
-
-       INTEGER(iwp) ::  i !<
-       INTEGER(iwp) ::  j !<
-       INTEGER(iwp) ::  k !<
-
-       REAL(wp) ::  ukomp !<
-       REAL(wp) ::  vkomp !<
-       REAL(wp) ::  wkomp !<
-
-
-       DO  k = nzb_u_inner(j,i)+1, nzt
-!
-!--       x-direction
-          ukomp = u(k,j,i) - u_gtrans
-          IF ( ukomp > 0.0_wp )  THEN
-             tend(k,j,i) = tend(k,j,i) - ukomp *                               &
-                                         ( u(k,j,i) - u(k,j,i-1) ) * ddx
-          ELSE
-             tend(k,j,i) = tend(k,j,i) - ukomp *                               &
-                                         ( u(k,j,i+1) - u(k,j,i) ) * ddx
-          ENDIF
-!
-!--       y-direction
-          vkomp = 0.25_wp * ( v(k,j,i) + v(k,j+1,i) + v(k,j,i-1) + v(k,j+1,i-1) &
-                         ) - v_gtrans
-          IF ( vkomp > 0.0_wp )  THEN
-             tend(k,j,i) = tend(k,j,i) - vkomp *                               &
-                                         ( u(k,j,i) - u(k,j-1,i) ) * ddy
-          ELSE
-             tend(k,j,i) = tend(k,j,i) - vkomp *                               &
-                                         ( u(k,j+1,i) - u(k,j,i) ) * ddy
-          ENDIF
-!
-!--       z-direction
-          wkomp = 0.25_wp * ( w(k,j,i) + w(k-1,j,i) + w(k,j,i-1) + w(k-1,j,i-1) )
-          IF ( wkomp > 0.0_wp )  THEN
-             tend(k,j,i) = tend(k,j,i) - wkomp *                               &
-                                         ( u(k,j,i) - u(k-1,j,i) ) * ddzu(k)
-          ELSE
-             tend(k,j,i) = tend(k,j,i) - wkomp *                               &
-                                         ( u(k+1,j,i) - u(k,j,i) ) * ddzu(k+1)
-          ENDIF
-
-       ENDDO
-
-    END SUBROUTINE advec_u_up_ij
-
- END MODULE advec_u_up_mod
Index: /palm/trunk/SOURCE/advec_u_up_mod.f90
===================================================================
--- /palm/trunk/SOURCE/advec_u_up_mod.f90	(revision 1850)
+++ /palm/trunk/SOURCE/advec_u_up_mod.f90	(revision 1850)
@@ -0,0 +1,215 @@
+!> @file advec_u_up_mod.f90
+!--------------------------------------------------------------------------------!
+! This file is part of PALM.
+!
+! PALM is free software: you can redistribute it and/or modify it under the terms
+! of the GNU General Public License as published by the Free Software Foundation,
+! either version 3 of the License, or (at your option) any later version.
+!
+! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
+! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
+! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along with
+! PALM. If not, see <http://www.gnu.org/licenses/>.
+!
+! Copyright 1997-2016 Leibniz Universitaet Hannover
+!--------------------------------------------------------------------------------!
+!
+! Current revisions:
+! -----------------
+! Module renamed
+! 
+! 
+! Former revisions:
+! -----------------
+! $Id$
+!
+! 1682 2015-10-07 23:56:08Z knoop
+! Code annotations made doxygen readable 
+! 
+! 1353 2014-04-08 15:21:23Z heinze
+! REAL constants provided with KIND-attribute
+!
+! 1320 2014-03-20 08:40:49Z raasch
+! ONLY-attribute added to USE-statements,
+! kind-parameters added to all INTEGER and REAL declaration statements,
+! kinds are defined in new module kinds,
+! revision history before 2012 removed,
+! comment fields (!:) to be used for variable explanations added to
+! all variable declaration statements
+!
+! 1036 2012-10-22 13:43:42Z raasch
+! code put under GPL (PALM 3.9)
+!
+! Revision 1.1  1997/08/29 08:55:25  raasch
+! Initial revision
+!
+!
+! Description:
+! ------------
+!> Advection term for the u velocity-component using upstream scheme.
+!> NOTE: vertical advection at k=1 still has wrong grid spacing for w>0!
+!>       The same problem occurs for all topography boundaries!
+!------------------------------------------------------------------------------!
+ MODULE advec_u_up_mod
+ 
+
+    PRIVATE
+    PUBLIC advec_u_up
+
+    INTERFACE advec_u_up
+       MODULE PROCEDURE advec_u_up
+       MODULE PROCEDURE advec_u_up_ij
+    END INTERFACE advec_u_up
+
+ CONTAINS
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Call for all grid points
+!------------------------------------------------------------------------------!
+    SUBROUTINE advec_u_up
+
+       USE arrays_3d,                                                          &
+           ONLY:  ddzu, tend, u, v, w
+
+       USE control_parameters,                                                 &
+           ONLY:  u_gtrans, v_gtrans
+
+       USE grid_variables,                                                     &
+           ONLY:  ddx, ddy
+
+       USE indices,                                                            &
+           ONLY:  nxlu, nxr, nyn, nys, nzb_u_inner, nzt
+
+       USE kinds
+
+
+       IMPLICIT NONE
+
+       INTEGER(iwp) ::  i !<
+       INTEGER(iwp) ::  j !<
+       INTEGER(iwp) ::  k !<
+
+       REAL(wp) ::  ukomp !<
+       REAL(wp) ::  vkomp !<
+       REAL(wp) ::  wkomp !<
+
+       
+       DO  i = nxlu, nxr
+          DO  j = nys, nyn
+             DO  k = nzb_u_inner(j,i)+1, nzt
+!
+!--             x-direction
+                ukomp = u(k,j,i) - u_gtrans
+                IF ( ukomp > 0.0_wp )  THEN
+                   tend(k,j,i) = tend(k,j,i) - ukomp *                         &
+                                         ( u(k,j,i) - u(k,j,i-1) ) * ddx
+                ELSE
+                   tend(k,j,i) = tend(k,j,i) - ukomp *                         &
+                                          ( u(k,j,i+1) - u(k,j,i) ) * ddx
+                ENDIF
+!
+!--             y-direction
+                vkomp = 0.25_wp * ( v(k,j,i)   + v(k,j+1,i) +                  &
+                                 v(k,j,i-1) + v(k,j+1,i-1) ) - v_gtrans
+                IF ( vkomp > 0.0_wp )  THEN
+                   tend(k,j,i) = tend(k,j,i) - vkomp *                         &
+                                         ( u(k,j,i) - u(k,j-1,i) ) * ddy
+                ELSE
+                   tend(k,j,i) = tend(k,j,i) - vkomp *                         &
+                                         ( u(k,j+1,i) - u(k,j,i) ) * ddy
+                ENDIF
+!
+!--             z-direction
+                wkomp = 0.25_wp * ( w(k,j,i)   + w(k-1,j,i) +                  &
+                                 w(k,j,i-1) + w(k-1,j,i-1) )
+                IF ( wkomp > 0.0_wp )  THEN
+                   tend(k,j,i) = tend(k,j,i) - wkomp *                         &
+                                         ( u(k,j,i) - u(k-1,j,i) ) * ddzu(k)
+                ELSE
+                   tend(k,j,i) = tend(k,j,i) - wkomp *                         &
+                                         ( u(k+1,j,i) - u(k,j,i) ) * ddzu(k+1)
+                ENDIF
+
+             ENDDO
+          ENDDO
+       ENDDO
+
+    END SUBROUTINE advec_u_up
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Call for grid point i,j
+!------------------------------------------------------------------------------!
+    SUBROUTINE advec_u_up_ij( i, j )
+
+       USE arrays_3d,                                                          &
+           ONLY:  ddzu, tend, u, v, w
+
+       USE control_parameters,                                                 &
+           ONLY:  u_gtrans, v_gtrans
+
+       USE grid_variables,                                                     &
+           ONLY:  ddx, ddy
+
+       USE indices,                                                            &
+           ONLY:  nzb_u_inner, nzt
+
+       USE kinds
+
+
+       IMPLICIT NONE
+
+       INTEGER(iwp) ::  i !<
+       INTEGER(iwp) ::  j !<
+       INTEGER(iwp) ::  k !<
+
+       REAL(wp) ::  ukomp !<
+       REAL(wp) ::  vkomp !<
+       REAL(wp) ::  wkomp !<
+
+
+       DO  k = nzb_u_inner(j,i)+1, nzt
+!
+!--       x-direction
+          ukomp = u(k,j,i) - u_gtrans
+          IF ( ukomp > 0.0_wp )  THEN
+             tend(k,j,i) = tend(k,j,i) - ukomp *                               &
+                                         ( u(k,j,i) - u(k,j,i-1) ) * ddx
+          ELSE
+             tend(k,j,i) = tend(k,j,i) - ukomp *                               &
+                                         ( u(k,j,i+1) - u(k,j,i) ) * ddx
+          ENDIF
+!
+!--       y-direction
+          vkomp = 0.25_wp * ( v(k,j,i) + v(k,j+1,i) + v(k,j,i-1) + v(k,j+1,i-1) &
+                         ) - v_gtrans
+          IF ( vkomp > 0.0_wp )  THEN
+             tend(k,j,i) = tend(k,j,i) - vkomp *                               &
+                                         ( u(k,j,i) - u(k,j-1,i) ) * ddy
+          ELSE
+             tend(k,j,i) = tend(k,j,i) - vkomp *                               &
+                                         ( u(k,j+1,i) - u(k,j,i) ) * ddy
+          ENDIF
+!
+!--       z-direction
+          wkomp = 0.25_wp * ( w(k,j,i) + w(k-1,j,i) + w(k,j,i-1) + w(k-1,j,i-1) )
+          IF ( wkomp > 0.0_wp )  THEN
+             tend(k,j,i) = tend(k,j,i) - wkomp *                               &
+                                         ( u(k,j,i) - u(k-1,j,i) ) * ddzu(k)
+          ELSE
+             tend(k,j,i) = tend(k,j,i) - wkomp *                               &
+                                         ( u(k+1,j,i) - u(k,j,i) ) * ddzu(k+1)
+          ENDIF
+
+       ENDDO
+
+    END SUBROUTINE advec_u_up_ij
+
+ END MODULE advec_u_up_mod
Index: lm/trunk/SOURCE/advec_v_pw.f90
===================================================================
--- /palm/trunk/SOURCE/advec_v_pw.f90	(revision 1849)
+++ 	(revision )
@@ -1,171 +1,0 @@
-!> @file advec_v_pw.f90
-!--------------------------------------------------------------------------------!
-! This file is part of PALM.
-!
-! PALM is free software: you can redistribute it and/or modify it under the terms
-! of the GNU General Public License as published by the Free Software Foundation,
-! either version 3 of the License, or (at your option) any later version.
-!
-! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
-! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
-! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along with
-! PALM. If not, see <http://www.gnu.org/licenses/>.
-!
-! Copyright 1997-2016 Leibniz Universitaet Hannover
-!--------------------------------------------------------------------------------!
-!
-! Current revisions:
-! -----------------
-! 
-! 
-! Former revisions:
-! -----------------
-! $Id$
-!
-! 1682 2015-10-07 23:56:08Z knoop
-! Code annotations made doxygen readable 
-! 
-! 1353 2014-04-08 15:21:23Z heinze
-! REAL constants provided with KIND-attribute
-!
-! 1320 2014-03-20 08:40:49Z raasch
-! ONLY-attribute added to USE-statements,
-! kind-parameters added to all INTEGER and REAL declaration statements,
-! kinds are defined in new module kinds,
-! revision history before 2012 removed,
-! comment fields (!:) to be used for variable explanations added to
-! all variable declaration statements
-!
-! 1036 2012-10-22 13:43:42Z raasch
-! code put under GPL (PALM 3.9)
-!
-! Revision 1.1  1997/08/11 06:09:57  raasch
-! Initial revision
-!
-!
-! Description:
-! ------------
-!> Advection term for v velocity-component using Piacsek and Williams.
-!> Vertical advection at the first grid point above the surface is done with
-!> normal centred differences, because otherwise no information from the surface
-!> would be communicated upwards due to w=0 at K=nzb.
-!------------------------------------------------------------------------------!
- MODULE advec_v_pw_mod
- 
-
-    PRIVATE
-    PUBLIC advec_v_pw
-
-    INTERFACE advec_v_pw
-       MODULE PROCEDURE advec_v_pw
-       MODULE PROCEDURE advec_v_pw_ij
-    END INTERFACE advec_v_pw
- 
- CONTAINS
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Call for all grid points
-!------------------------------------------------------------------------------!
-    SUBROUTINE advec_v_pw
-
-       USE arrays_3d,                                                          &
-           ONLY:  ddzw, tend, u, v, w
-
-       USE control_parameters,                                                 &
-           ONLY:  u_gtrans, v_gtrans
-
-       USE grid_variables,                                                     &
-           ONLY:  ddx, ddy
-
-       USE indices,                                                            &
-           ONLY:  nxl, nxr, nyn, nysv, nzb_v_inner, nzt
-
-       USE kinds
-
-
-       IMPLICIT NONE
-
-       INTEGER(iwp) ::  i !<
-       INTEGER(iwp) ::  j !<
-       INTEGER(iwp) ::  k !<
-       
-       REAL(wp)    ::  gu !<
-       REAL(wp)    ::  gv !<
- 
-
-       gu = 2.0_wp * u_gtrans
-       gv = 2.0_wp * v_gtrans
-       DO  i = nxl, nxr
-          DO  j = nysv, nyn
-             DO  k = nzb_v_inner(j,i)+1, nzt
-                tend(k,j,i) = tend(k,j,i) - 0.25_wp * (                        &
-                         ( v(k,j,i+1) * ( u(k,j-1,i+1) + u(k,j,i+1) - gu )     &
-                         - v(k,j,i-1) * ( u(k,j-1,i) + u(k,j,i) - gu ) ) * ddx &
-                       + ( v(k,j+1,i) * ( v(k,j+1,i) + v(k,j,i) - gv )         &
-                         - v(k,j-1,i) * ( v(k,j,i) + v(k,j-1,i) - gv ) ) * ddy &
-                       + ( v(k+1,j,i) * ( w(k,j-1,i) + w(k,j,i) )              &
-                         - v(k-1,j,i) * ( w(k-1,j-1,i) + w(k-1,j,i) ) )        &
-                                                                  * ddzw(k)    &
-                                                      )
-             ENDDO
-          ENDDO
-       ENDDO
-
-    END SUBROUTINE advec_v_pw
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Call for grid point i,j
-!------------------------------------------------------------------------------!
-    SUBROUTINE advec_v_pw_ij( i, j )
-
-       USE arrays_3d,                                                          &
-           ONLY:  ddzw, tend, u, v, w
-
-       USE control_parameters,                                                 &
-           ONLY:  u_gtrans, v_gtrans
-
-       USE grid_variables,                                                     &
-           ONLY:  ddx, ddy
-
-       USE indices,                                                            &
-           ONLY:  nzb_v_inner, nzt
-
-       USE kinds
-
-
-       IMPLICIT NONE
-
-       INTEGER(iwp) ::  i !<
-       INTEGER(iwp) ::  j !<
-       INTEGER(iwp) ::  k !<
-       
-       REAL(wp)    ::  gu !<
-       REAL(wp)    ::  gv !<
-
-
-       gu = 2.0_wp * u_gtrans
-       gv = 2.0_wp * v_gtrans
-       DO  k = nzb_v_inner(j,i)+1, nzt
-          tend(k,j,i) = tend(k,j,i) - 0.25_wp * (                              &
-                         ( v(k,j,i+1) * ( u(k,j-1,i+1) + u(k,j,i+1) - gu )     &
-                         - v(k,j,i-1) * ( u(k,j-1,i) + u(k,j,i) - gu ) ) * ddx &
-                       + ( v(k,j+1,i) * ( v(k,j+1,i) + v(k,j,i) - gv )         &
-                         - v(k,j-1,i) * ( v(k,j,i) + v(k,j-1,i) - gv ) ) * ddy &
-                       + ( v(k+1,j,i) * ( w(k,j-1,i) + w(k,j,i) )              &
-                         - v(k-1,j,i) * ( w(k-1,j-1,i) + w(k-1,j,i) ) )        &
-                                                                  * ddzw(k)    &
-                                                )
-       ENDDO
- 
-    END SUBROUTINE advec_v_pw_ij
-
- END MODULE advec_v_pw_mod
- 
Index: /palm/trunk/SOURCE/advec_v_pw_mod.f90
===================================================================
--- /palm/trunk/SOURCE/advec_v_pw_mod.f90	(revision 1850)
+++ /palm/trunk/SOURCE/advec_v_pw_mod.f90	(revision 1850)
@@ -0,0 +1,172 @@
+!> @file advec_v_pw_mod.f90
+!--------------------------------------------------------------------------------!
+! This file is part of PALM.
+!
+! PALM is free software: you can redistribute it and/or modify it under the terms
+! of the GNU General Public License as published by the Free Software Foundation,
+! either version 3 of the License, or (at your option) any later version.
+!
+! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
+! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
+! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along with
+! PALM. If not, see <http://www.gnu.org/licenses/>.
+!
+! Copyright 1997-2016 Leibniz Universitaet Hannover
+!--------------------------------------------------------------------------------!
+!
+! Current revisions:
+! -----------------
+! Module renamed
+! 
+! 
+! Former revisions:
+! -----------------
+! $Id$
+!
+! 1682 2015-10-07 23:56:08Z knoop
+! Code annotations made doxygen readable 
+! 
+! 1353 2014-04-08 15:21:23Z heinze
+! REAL constants provided with KIND-attribute
+!
+! 1320 2014-03-20 08:40:49Z raasch
+! ONLY-attribute added to USE-statements,
+! kind-parameters added to all INTEGER and REAL declaration statements,
+! kinds are defined in new module kinds,
+! revision history before 2012 removed,
+! comment fields (!:) to be used for variable explanations added to
+! all variable declaration statements
+!
+! 1036 2012-10-22 13:43:42Z raasch
+! code put under GPL (PALM 3.9)
+!
+! Revision 1.1  1997/08/11 06:09:57  raasch
+! Initial revision
+!
+!
+! Description:
+! ------------
+!> Advection term for v velocity-component using Piacsek and Williams.
+!> Vertical advection at the first grid point above the surface is done with
+!> normal centred differences, because otherwise no information from the surface
+!> would be communicated upwards due to w=0 at K=nzb.
+!------------------------------------------------------------------------------!
+ MODULE advec_v_pw_mod
+ 
+
+    PRIVATE
+    PUBLIC advec_v_pw
+
+    INTERFACE advec_v_pw
+       MODULE PROCEDURE advec_v_pw
+       MODULE PROCEDURE advec_v_pw_ij
+    END INTERFACE advec_v_pw
+ 
+ CONTAINS
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Call for all grid points
+!------------------------------------------------------------------------------!
+    SUBROUTINE advec_v_pw
+
+       USE arrays_3d,                                                          &
+           ONLY:  ddzw, tend, u, v, w
+
+       USE control_parameters,                                                 &
+           ONLY:  u_gtrans, v_gtrans
+
+       USE grid_variables,                                                     &
+           ONLY:  ddx, ddy
+
+       USE indices,                                                            &
+           ONLY:  nxl, nxr, nyn, nysv, nzb_v_inner, nzt
+
+       USE kinds
+
+
+       IMPLICIT NONE
+
+       INTEGER(iwp) ::  i !<
+       INTEGER(iwp) ::  j !<
+       INTEGER(iwp) ::  k !<
+       
+       REAL(wp)    ::  gu !<
+       REAL(wp)    ::  gv !<
+ 
+
+       gu = 2.0_wp * u_gtrans
+       gv = 2.0_wp * v_gtrans
+       DO  i = nxl, nxr
+          DO  j = nysv, nyn
+             DO  k = nzb_v_inner(j,i)+1, nzt
+                tend(k,j,i) = tend(k,j,i) - 0.25_wp * (                        &
+                         ( v(k,j,i+1) * ( u(k,j-1,i+1) + u(k,j,i+1) - gu )     &
+                         - v(k,j,i-1) * ( u(k,j-1,i) + u(k,j,i) - gu ) ) * ddx &
+                       + ( v(k,j+1,i) * ( v(k,j+1,i) + v(k,j,i) - gv )         &
+                         - v(k,j-1,i) * ( v(k,j,i) + v(k,j-1,i) - gv ) ) * ddy &
+                       + ( v(k+1,j,i) * ( w(k,j-1,i) + w(k,j,i) )              &
+                         - v(k-1,j,i) * ( w(k-1,j-1,i) + w(k-1,j,i) ) )        &
+                                                                  * ddzw(k)    &
+                                                      )
+             ENDDO
+          ENDDO
+       ENDDO
+
+    END SUBROUTINE advec_v_pw
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Call for grid point i,j
+!------------------------------------------------------------------------------!
+    SUBROUTINE advec_v_pw_ij( i, j )
+
+       USE arrays_3d,                                                          &
+           ONLY:  ddzw, tend, u, v, w
+
+       USE control_parameters,                                                 &
+           ONLY:  u_gtrans, v_gtrans
+
+       USE grid_variables,                                                     &
+           ONLY:  ddx, ddy
+
+       USE indices,                                                            &
+           ONLY:  nzb_v_inner, nzt
+
+       USE kinds
+
+
+       IMPLICIT NONE
+
+       INTEGER(iwp) ::  i !<
+       INTEGER(iwp) ::  j !<
+       INTEGER(iwp) ::  k !<
+       
+       REAL(wp)    ::  gu !<
+       REAL(wp)    ::  gv !<
+
+
+       gu = 2.0_wp * u_gtrans
+       gv = 2.0_wp * v_gtrans
+       DO  k = nzb_v_inner(j,i)+1, nzt
+          tend(k,j,i) = tend(k,j,i) - 0.25_wp * (                              &
+                         ( v(k,j,i+1) * ( u(k,j-1,i+1) + u(k,j,i+1) - gu )     &
+                         - v(k,j,i-1) * ( u(k,j-1,i) + u(k,j,i) - gu ) ) * ddx &
+                       + ( v(k,j+1,i) * ( v(k,j+1,i) + v(k,j,i) - gv )         &
+                         - v(k,j-1,i) * ( v(k,j,i) + v(k,j-1,i) - gv ) ) * ddy &
+                       + ( v(k+1,j,i) * ( w(k,j-1,i) + w(k,j,i) )              &
+                         - v(k-1,j,i) * ( w(k-1,j-1,i) + w(k-1,j,i) ) )        &
+                                                                  * ddzw(k)    &
+                                                )
+       ENDDO
+ 
+    END SUBROUTINE advec_v_pw_ij
+
+ END MODULE advec_v_pw_mod
+ 
Index: lm/trunk/SOURCE/advec_v_up.f90
===================================================================
--- /palm/trunk/SOURCE/advec_v_up.f90	(revision 1849)
+++ 	(revision )
@@ -1,214 +1,0 @@
-!> @file advec_v_up.f90
-!--------------------------------------------------------------------------------!
-! This file is part of PALM.
-!
-! PALM is free software: you can redistribute it and/or modify it under the terms
-! of the GNU General Public License as published by the Free Software Foundation,
-! either version 3 of the License, or (at your option) any later version.
-!
-! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
-! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
-! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along with
-! PALM. If not, see <http://www.gnu.org/licenses/>.
-!
-! Copyright 1997-2016 Leibniz Universitaet Hannover
-!--------------------------------------------------------------------------------!
-!
-! Current revisions:
-! -----------------
-! 
-! 
-! Former revisions:
-! -----------------
-! $Id$
-!
-! 1682 2015-10-07 23:56:08Z knoop
-! Code annotations made doxygen readable 
-! 
-! 1353 2014-04-08 15:21:23Z heinze
-! REAL constants provided with KIND-attribute
-!
-! 1320 2014-03-20 08:40:49Z raasch
-! ONLY-attribute added to USE-statements,
-! kind-parameters added to all INTEGER and REAL declaration statements,
-! kinds are defined in new module kinds,
-! revision history before 2012 removed,
-! comment fields (!:) to be used for variable explanations added to
-! all variable declaration statements
-!
-! 1036 2012-10-22 13:43:42Z raasch
-! code put under GPL (PALM 3.9)
-!
-! Revision 1.1  1997/08/29 08:56:05  raasch
-! Initial revision
-!
-!
-! Description:
-! ------------
-!> Advection term for the v velocity-component using upstream scheme.
-!> NOTE: vertical advection at k=1 still has wrong grid spacing for w>0!
-!>       The same problem occurs for all topography boundaries!
-!------------------------------------------------------------------------------!
- MODULE advec_v_up_mod
- 
-
-    PRIVATE
-    PUBLIC advec_v_up
-
-    INTERFACE advec_v_up
-       MODULE PROCEDURE advec_v_up
-       MODULE PROCEDURE advec_v_up_ij
-    END INTERFACE advec_v_up
-
- CONTAINS
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Call for all grid points
-!------------------------------------------------------------------------------!
-    SUBROUTINE advec_v_up
-
-       USE arrays_3d,                                                          &
-           ONLY:  ddzu, tend, u, v, w
-
-       USE control_parameters,                                                 &
-           ONLY:  u_gtrans, v_gtrans
-
-       USE grid_variables,                                                     &
-           ONLY:  ddx, ddy
-
-       USE indices,                                                            &
-           ONLY:  nxl, nxr, nyn, nysv, nzb_v_inner, nzt
-
-       USE kinds
-
-
-       IMPLICIT NONE
-
-       INTEGER(iwp) ::  i !<
-       INTEGER(iwp) ::  j !<
-       INTEGER(iwp) ::  k !<
-
-       REAL(wp) ::  ukomp !<
-       REAL(wp) ::  vkomp !<
-       REAL(wp) ::  wkomp !<       
-
-
-       DO  i = nxl, nxr
-          DO  j = nysv, nyn
-             DO  k = nzb_v_inner(j,i)+1, nzt
-!
-!--             x-direction
-                ukomp = 0.25_wp * ( u(k,j,i)   + u(k,j-1,i) +                  &
-                                 u(k,j,i+1) + u(k,j-1,i+1) ) - u_gtrans
-                IF ( ukomp > 0.0_wp )  THEN
-                   tend(k,j,i) = tend(k,j,i) - ukomp *                         &
-                                         ( v(k,j,i) - v(k,j,i-1) ) * ddx
-                ELSE
-                   tend(k,j,i) = tend(k,j,i) - ukomp *                         &
-                                         ( v(k,j,i+1) - v(k,j,i) ) * ddx
-                ENDIF
-!
-!--             y-direction
-                vkomp = v(k,j,i) - v_gtrans
-                IF ( vkomp > 0.0_wp )  THEN
-                   tend(k,j,i) = tend(k,j,i) - vkomp *                         &
-                                         ( v(k,j,i) - v(k,j-1,i) ) * ddy
-                ELSE
-                   tend(k,j,i) = tend(k,j,i) - vkomp *                         &
-                                         ( v(k,j+1,i) - v(k,j,i) ) * ddy
-                ENDIF
-!
-!--             z-direction
-                wkomp = 0.25_wp * ( w(k,j,i)  + w(k-1,j,i) +                   &
-                                 w(k,j-1,i) + w(k-1,j-1,i) )
-                IF ( wkomp > 0.0_wp )  THEN
-                   tend(k,j,i) = tend(k,j,i) - wkomp *                         &
-                                         ( v(k,j,i) - v(k-1,j,i) ) * ddzu(k)
-                ELSE
-                   tend(k,j,i) = tend(k,j,i) - wkomp *                         &
-                                         ( v(k+1,j,i) - v(k,j,i) ) * ddzu(k+1)
-                ENDIF
-
-             ENDDO
-          ENDDO
-       ENDDO
-
-    END SUBROUTINE advec_v_up
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Call for grid point i,j
-!------------------------------------------------------------------------------!
-    SUBROUTINE advec_v_up_ij( i, j )
-
-       USE arrays_3d,                                                          &
-           ONLY:  ddzu, tend, u, v, w
-
-       USE control_parameters,                                                 &
-           ONLY:  u_gtrans, v_gtrans
-
-       USE grid_variables,                                                     &
-           ONLY:  ddx, ddy
-
-       USE indices,                                                            &
-           ONLY:  nzb_v_inner, nzt
-
-       USE kinds
-
-
-       IMPLICIT NONE
-
-       INTEGER(iwp) ::  i !<
-       INTEGER(iwp) ::  j !<
-       INTEGER(iwp) ::  k !<
-
-       REAL(wp) ::  ukomp !<
-       REAL(wp) ::  vkomp !<
-       REAL(wp) ::  wkomp !<
-
-
-       DO  k = nzb_v_inner(j,i)+1, nzt
-!
-!--       x-direction
-          ukomp = 0.25_wp * ( u(k,j,i) + u(k,j-1,i) + u(k,j,i+1) + u(k,j-1,i+1) &
-                         ) - u_gtrans
-          IF ( ukomp > 0.0_wp )  THEN
-             tend(k,j,i) = tend(k,j,i) - ukomp *                               &
-                                         ( v(k,j,i) - v(k,j,i-1) ) * ddx
-          ELSE
-             tend(k,j,i) = tend(k,j,i) - ukomp *                               &
-                                         ( v(k,j,i+1) - v(k,j,i) ) * ddx
-          ENDIF
-!
-!--       y-direction
-          vkomp = v(k,j,i) - v_gtrans
-          IF ( vkomp > 0.0_wp )  THEN
-             tend(k,j,i) = tend(k,j,i) - vkomp *                               &
-                                         ( v(k,j,i) - v(k,j-1,i) ) * ddy
-          ELSE
-             tend(k,j,i) = tend(k,j,i) - vkomp *                               &
-                                         ( v(k,j+1,i) - v(k,j,i) ) * ddy
-          ENDIF
-!
-!--       z-direction
-          wkomp = 0.25_wp * ( w(k,j,i) + w(k-1,j,i) + w(k,j-1,i) + w(k-1,j-1,i) )
-          IF ( wkomp > 0.0_wp )  THEN
-             tend(k,j,i) = tend(k,j,i) - wkomp *                               &
-                                         ( v(k,j,i) - v(k-1,j,i) ) * ddzu(k)
-          ELSE
-             tend(k,j,i) = tend(k,j,i) - wkomp *                               &
-                                         ( v(k+1,j,i) - v(k,j,i) ) * ddzu(k+1)
-          ENDIF
-
-       ENDDO
-
-    END SUBROUTINE advec_v_up_ij
-
- END MODULE advec_v_up_mod
Index: /palm/trunk/SOURCE/advec_v_up_mod.f90
===================================================================
--- /palm/trunk/SOURCE/advec_v_up_mod.f90	(revision 1850)
+++ /palm/trunk/SOURCE/advec_v_up_mod.f90	(revision 1850)
@@ -0,0 +1,215 @@
+!> @file advec_v_up_mod.f90
+!--------------------------------------------------------------------------------!
+! This file is part of PALM.
+!
+! PALM is free software: you can redistribute it and/or modify it under the terms
+! of the GNU General Public License as published by the Free Software Foundation,
+! either version 3 of the License, or (at your option) any later version.
+!
+! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
+! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
+! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along with
+! PALM. If not, see <http://www.gnu.org/licenses/>.
+!
+! Copyright 1997-2016 Leibniz Universitaet Hannover
+!--------------------------------------------------------------------------------!
+!
+! Current revisions:
+! -----------------
+! Module renamed
+! 
+! 
+! Former revisions:
+! -----------------
+! $Id$
+!
+! 1682 2015-10-07 23:56:08Z knoop
+! Code annotations made doxygen readable 
+! 
+! 1353 2014-04-08 15:21:23Z heinze
+! REAL constants provided with KIND-attribute
+!
+! 1320 2014-03-20 08:40:49Z raasch
+! ONLY-attribute added to USE-statements,
+! kind-parameters added to all INTEGER and REAL declaration statements,
+! kinds are defined in new module kinds,
+! revision history before 2012 removed,
+! comment fields (!:) to be used for variable explanations added to
+! all variable declaration statements
+!
+! 1036 2012-10-22 13:43:42Z raasch
+! code put under GPL (PALM 3.9)
+!
+! Revision 1.1  1997/08/29 08:56:05  raasch
+! Initial revision
+!
+!
+! Description:
+! ------------
+!> Advection term for the v velocity-component using upstream scheme.
+!> NOTE: vertical advection at k=1 still has wrong grid spacing for w>0!
+!>       The same problem occurs for all topography boundaries!
+!------------------------------------------------------------------------------!
+ MODULE advec_v_up_mod
+ 
+
+    PRIVATE
+    PUBLIC advec_v_up
+
+    INTERFACE advec_v_up
+       MODULE PROCEDURE advec_v_up
+       MODULE PROCEDURE advec_v_up_ij
+    END INTERFACE advec_v_up
+
+ CONTAINS
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Call for all grid points
+!------------------------------------------------------------------------------!
+    SUBROUTINE advec_v_up
+
+       USE arrays_3d,                                                          &
+           ONLY:  ddzu, tend, u, v, w
+
+       USE control_parameters,                                                 &
+           ONLY:  u_gtrans, v_gtrans
+
+       USE grid_variables,                                                     &
+           ONLY:  ddx, ddy
+
+       USE indices,                                                            &
+           ONLY:  nxl, nxr, nyn, nysv, nzb_v_inner, nzt
+
+       USE kinds
+
+
+       IMPLICIT NONE
+
+       INTEGER(iwp) ::  i !<
+       INTEGER(iwp) ::  j !<
+       INTEGER(iwp) ::  k !<
+
+       REAL(wp) ::  ukomp !<
+       REAL(wp) ::  vkomp !<
+       REAL(wp) ::  wkomp !<       
+
+
+       DO  i = nxl, nxr
+          DO  j = nysv, nyn
+             DO  k = nzb_v_inner(j,i)+1, nzt
+!
+!--             x-direction
+                ukomp = 0.25_wp * ( u(k,j,i)   + u(k,j-1,i) +                  &
+                                 u(k,j,i+1) + u(k,j-1,i+1) ) - u_gtrans
+                IF ( ukomp > 0.0_wp )  THEN
+                   tend(k,j,i) = tend(k,j,i) - ukomp *                         &
+                                         ( v(k,j,i) - v(k,j,i-1) ) * ddx
+                ELSE
+                   tend(k,j,i) = tend(k,j,i) - ukomp *                         &
+                                         ( v(k,j,i+1) - v(k,j,i) ) * ddx
+                ENDIF
+!
+!--             y-direction
+                vkomp = v(k,j,i) - v_gtrans
+                IF ( vkomp > 0.0_wp )  THEN
+                   tend(k,j,i) = tend(k,j,i) - vkomp *                         &
+                                         ( v(k,j,i) - v(k,j-1,i) ) * ddy
+                ELSE
+                   tend(k,j,i) = tend(k,j,i) - vkomp *                         &
+                                         ( v(k,j+1,i) - v(k,j,i) ) * ddy
+                ENDIF
+!
+!--             z-direction
+                wkomp = 0.25_wp * ( w(k,j,i)  + w(k-1,j,i) +                   &
+                                 w(k,j-1,i) + w(k-1,j-1,i) )
+                IF ( wkomp > 0.0_wp )  THEN
+                   tend(k,j,i) = tend(k,j,i) - wkomp *                         &
+                                         ( v(k,j,i) - v(k-1,j,i) ) * ddzu(k)
+                ELSE
+                   tend(k,j,i) = tend(k,j,i) - wkomp *                         &
+                                         ( v(k+1,j,i) - v(k,j,i) ) * ddzu(k+1)
+                ENDIF
+
+             ENDDO
+          ENDDO
+       ENDDO
+
+    END SUBROUTINE advec_v_up
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Call for grid point i,j
+!------------------------------------------------------------------------------!
+    SUBROUTINE advec_v_up_ij( i, j )
+
+       USE arrays_3d,                                                          &
+           ONLY:  ddzu, tend, u, v, w
+
+       USE control_parameters,                                                 &
+           ONLY:  u_gtrans, v_gtrans
+
+       USE grid_variables,                                                     &
+           ONLY:  ddx, ddy
+
+       USE indices,                                                            &
+           ONLY:  nzb_v_inner, nzt
+
+       USE kinds
+
+
+       IMPLICIT NONE
+
+       INTEGER(iwp) ::  i !<
+       INTEGER(iwp) ::  j !<
+       INTEGER(iwp) ::  k !<
+
+       REAL(wp) ::  ukomp !<
+       REAL(wp) ::  vkomp !<
+       REAL(wp) ::  wkomp !<
+
+
+       DO  k = nzb_v_inner(j,i)+1, nzt
+!
+!--       x-direction
+          ukomp = 0.25_wp * ( u(k,j,i) + u(k,j-1,i) + u(k,j,i+1) + u(k,j-1,i+1) &
+                         ) - u_gtrans
+          IF ( ukomp > 0.0_wp )  THEN
+             tend(k,j,i) = tend(k,j,i) - ukomp *                               &
+                                         ( v(k,j,i) - v(k,j,i-1) ) * ddx
+          ELSE
+             tend(k,j,i) = tend(k,j,i) - ukomp *                               &
+                                         ( v(k,j,i+1) - v(k,j,i) ) * ddx
+          ENDIF
+!
+!--       y-direction
+          vkomp = v(k,j,i) - v_gtrans
+          IF ( vkomp > 0.0_wp )  THEN
+             tend(k,j,i) = tend(k,j,i) - vkomp *                               &
+                                         ( v(k,j,i) - v(k,j-1,i) ) * ddy
+          ELSE
+             tend(k,j,i) = tend(k,j,i) - vkomp *                               &
+                                         ( v(k,j+1,i) - v(k,j,i) ) * ddy
+          ENDIF
+!
+!--       z-direction
+          wkomp = 0.25_wp * ( w(k,j,i) + w(k-1,j,i) + w(k,j-1,i) + w(k-1,j-1,i) )
+          IF ( wkomp > 0.0_wp )  THEN
+             tend(k,j,i) = tend(k,j,i) - wkomp *                               &
+                                         ( v(k,j,i) - v(k-1,j,i) ) * ddzu(k)
+          ELSE
+             tend(k,j,i) = tend(k,j,i) - wkomp *                               &
+                                         ( v(k+1,j,i) - v(k,j,i) ) * ddzu(k+1)
+          ENDIF
+
+       ENDDO
+
+    END SUBROUTINE advec_v_up_ij
+
+ END MODULE advec_v_up_mod
Index: lm/trunk/SOURCE/advec_w_pw.f90
===================================================================
--- /palm/trunk/SOURCE/advec_w_pw.f90	(revision 1849)
+++ 	(revision )
@@ -1,168 +1,0 @@
-!> @file advec_w_pw.f90
-!--------------------------------------------------------------------------------!
-! This file is part of PALM.
-!
-! PALM is free software: you can redistribute it and/or modify it under the terms
-! of the GNU General Public License as published by the Free Software Foundation,
-! either version 3 of the License, or (at your option) any later version.
-!
-! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
-! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
-! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along with
-! PALM. If not, see <http://www.gnu.org/licenses/>.
-!
-! Copyright 1997-2016 Leibniz Universitaet Hannover
-!--------------------------------------------------------------------------------!
-!
-! Current revisions:
-! -----------------
-! 
-! 
-! Former revisions:
-! -----------------
-! $Id$
-!
-! 1682 2015-10-07 23:56:08Z knoop
-! Code annotations made doxygen readable 
-! 
-! 1353 2014-04-08 15:21:23Z heinze
-! REAL constants provided with KIND-attribute
-!
-! 1320 2014-03-20 08:40:49Z raasch
-! ONLY-attribute added to USE-statements,
-! kind-parameters added to all INTEGER and REAL declaration statements,
-! kinds are defined in new module kinds,
-! revision history before 2012 removed,
-! comment fields (!:) to be used for variable explanations added to
-! all variable declaration statements
-!
-! 1036 2012-10-22 13:43:42Z raasch
-! code put under GPL (PALM 3.9)
-!
-! Revision 1.1  1997/08/11 06:10:29  raasch
-! Initial revision
-!
-!
-! Description:
-! ------------
-!> Advection term for w velocity-component using Piacsek and Williams.
-!> Vertical advection at the first grid point above the surface is done with
-!> normal centred differences, because otherwise no information from the surface
-!> would be communicated upwards due to w=0 at k=nzb.
-!------------------------------------------------------------------------------!
- MODULE advec_w_pw_mod
- 
-
-    PRIVATE
-    PUBLIC advec_w_pw
-
-    INTERFACE advec_w_pw
-       MODULE PROCEDURE advec_w_pw
-       MODULE PROCEDURE advec_w_pw_ij
-    END INTERFACE advec_w_pw
- 
- CONTAINS
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Call for all grid points
-!------------------------------------------------------------------------------!
-    SUBROUTINE advec_w_pw
-
-       USE arrays_3d,                                                          &
-           ONLY:  ddzu, tend, u, v, w
-
-       USE control_parameters,                                                 &
-           ONLY:  u_gtrans, v_gtrans
-
-       USE grid_variables,                                                     &
-           ONLY:  ddx, ddy
-
-       USE indices,                                                            &
-           ONLY:  nxl, nxr, nyn, nys, nzb_w_inner, nzt
-
-       USE kinds
-
-
-       IMPLICIT NONE
-
-       INTEGER(iwp) ::  i !<
-       INTEGER(iwp) ::  j !<
-       INTEGER(iwp) ::  k !<
-       
-       REAL(wp)    ::  gu !<
-       REAL(wp)    ::  gv !<
-
- 
-       gu = 2.0_wp * u_gtrans
-       gv = 2.0_wp * v_gtrans
-       DO  i = nxl, nxr
-          DO  j = nys, nyn
-             DO  k = nzb_w_inner(j,i)+1, nzt
-                tend(k,j,i) = tend(k,j,i) - 0.25_wp * (                        &
-                         ( w(k,j,i+1) * ( u(k+1,j,i+1) + u(k,j,i+1) - gu )     &
-                         - w(k,j,i-1) * ( u(k+1,j,i) + u(k,j,i) - gu ) ) * ddx &
-                       + ( w(k,j+1,i) * ( v(k+1,j+1,i) + v(k,j+1,i) - gv )     &
-                         - w(k,j-1,i) * ( v(k+1,j,i) + v(k,j,i) - gv ) ) * ddy &
-                       + ( w(k+1,j,i) * ( w(k+1,j,i) + w(k,j,i) )              &
-                         - w(k-1,j,i) * ( w(k,j,i) + w(k-1,j,i) ) )            &
-                                                                  * ddzu(k+1)  &
-                                                      )
-             ENDDO
-          ENDDO
-       ENDDO
-
-    END SUBROUTINE advec_w_pw
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Call for grid point i,j
-!------------------------------------------------------------------------------!
-    SUBROUTINE advec_w_pw_ij( i, j )
-
-       USE arrays_3d,                                                          &
-           ONLY:  ddzu, tend, u, v, w
-
-       USE control_parameters,                                                 &
-           ONLY:  u_gtrans, v_gtrans
-
-       USE grid_variables,                                                     &
-           ONLY:  ddx, ddy
-
-       USE indices,                                                            &
-           ONLY:  nzb_w_inner, nzt
-
-       USE kinds
-
-
-       IMPLICIT NONE
-
-       INTEGER(iwp) ::  i !<
-       INTEGER(iwp) ::  j !<
-       INTEGER(iwp) ::  k !<
-       
-       REAL(wp)    ::  gu !<
-       REAL(wp)    ::  gv !<
-
-       gu = 2.0_wp * u_gtrans
-       gv = 2.0_wp * v_gtrans
-       DO  k = nzb_w_inner(j,i)+1, nzt
-          tend(k,j,i) = tend(k,j,i) - 0.25_wp * (                              &
-                         ( w(k,j,i+1) * ( u(k+1,j,i+1) + u(k,j,i+1) - gu )     &
-                         - w(k,j,i-1) * ( u(k+1,j,i) + u(k,j,i) - gu ) ) * ddx &
-                       + ( w(k,j+1,i) * ( v(k+1,j+1,i) + v(k,j+1,i) - gv )     &
-                         - w(k,j-1,i) * ( v(k+1,j,i) + v(k,j,i) - gv ) ) * ddy &
-                       + ( w(k+1,j,i) * ( w(k+1,j,i) + w(k,j,i) )              &
-                         - w(k-1,j,i) * ( w(k,j,i) + w(k-1,j,i) ) )            &
-                                                                  * ddzu(k+1)  &
-                                                )
-       ENDDO
-    END SUBROUTINE advec_w_pw_ij
-
- END MODULE advec_w_pw_mod
Index: /palm/trunk/SOURCE/advec_w_pw_mod.f90
===================================================================
--- /palm/trunk/SOURCE/advec_w_pw_mod.f90	(revision 1850)
+++ /palm/trunk/SOURCE/advec_w_pw_mod.f90	(revision 1850)
@@ -0,0 +1,169 @@
+!> @file advec_w_pw_mod.f90
+!--------------------------------------------------------------------------------!
+! This file is part of PALM.
+!
+! PALM is free software: you can redistribute it and/or modify it under the terms
+! of the GNU General Public License as published by the Free Software Foundation,
+! either version 3 of the License, or (at your option) any later version.
+!
+! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
+! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
+! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along with
+! PALM. If not, see <http://www.gnu.org/licenses/>.
+!
+! Copyright 1997-2016 Leibniz Universitaet Hannover
+!--------------------------------------------------------------------------------!
+!
+! Current revisions:
+! -----------------
+! Module renamed
+! 
+! 
+! Former revisions:
+! -----------------
+! $Id$
+!
+! 1682 2015-10-07 23:56:08Z knoop
+! Code annotations made doxygen readable 
+! 
+! 1353 2014-04-08 15:21:23Z heinze
+! REAL constants provided with KIND-attribute
+!
+! 1320 2014-03-20 08:40:49Z raasch
+! ONLY-attribute added to USE-statements,
+! kind-parameters added to all INTEGER and REAL declaration statements,
+! kinds are defined in new module kinds,
+! revision history before 2012 removed,
+! comment fields (!:) to be used for variable explanations added to
+! all variable declaration statements
+!
+! 1036 2012-10-22 13:43:42Z raasch
+! code put under GPL (PALM 3.9)
+!
+! Revision 1.1  1997/08/11 06:10:29  raasch
+! Initial revision
+!
+!
+! Description:
+! ------------
+!> Advection term for w velocity-component using Piacsek and Williams.
+!> Vertical advection at the first grid point above the surface is done with
+!> normal centred differences, because otherwise no information from the surface
+!> would be communicated upwards due to w=0 at k=nzb.
+!------------------------------------------------------------------------------!
+ MODULE advec_w_pw_mod
+ 
+
+    PRIVATE
+    PUBLIC advec_w_pw
+
+    INTERFACE advec_w_pw
+       MODULE PROCEDURE advec_w_pw
+       MODULE PROCEDURE advec_w_pw_ij
+    END INTERFACE advec_w_pw
+ 
+ CONTAINS
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Call for all grid points
+!------------------------------------------------------------------------------!
+    SUBROUTINE advec_w_pw
+
+       USE arrays_3d,                                                          &
+           ONLY:  ddzu, tend, u, v, w
+
+       USE control_parameters,                                                 &
+           ONLY:  u_gtrans, v_gtrans
+
+       USE grid_variables,                                                     &
+           ONLY:  ddx, ddy
+
+       USE indices,                                                            &
+           ONLY:  nxl, nxr, nyn, nys, nzb_w_inner, nzt
+
+       USE kinds
+
+
+       IMPLICIT NONE
+
+       INTEGER(iwp) ::  i !<
+       INTEGER(iwp) ::  j !<
+       INTEGER(iwp) ::  k !<
+       
+       REAL(wp)    ::  gu !<
+       REAL(wp)    ::  gv !<
+
+ 
+       gu = 2.0_wp * u_gtrans
+       gv = 2.0_wp * v_gtrans
+       DO  i = nxl, nxr
+          DO  j = nys, nyn
+             DO  k = nzb_w_inner(j,i)+1, nzt
+                tend(k,j,i) = tend(k,j,i) - 0.25_wp * (                        &
+                         ( w(k,j,i+1) * ( u(k+1,j,i+1) + u(k,j,i+1) - gu )     &
+                         - w(k,j,i-1) * ( u(k+1,j,i) + u(k,j,i) - gu ) ) * ddx &
+                       + ( w(k,j+1,i) * ( v(k+1,j+1,i) + v(k,j+1,i) - gv )     &
+                         - w(k,j-1,i) * ( v(k+1,j,i) + v(k,j,i) - gv ) ) * ddy &
+                       + ( w(k+1,j,i) * ( w(k+1,j,i) + w(k,j,i) )              &
+                         - w(k-1,j,i) * ( w(k,j,i) + w(k-1,j,i) ) )            &
+                                                                  * ddzu(k+1)  &
+                                                      )
+             ENDDO
+          ENDDO
+       ENDDO
+
+    END SUBROUTINE advec_w_pw
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Call for grid point i,j
+!------------------------------------------------------------------------------!
+    SUBROUTINE advec_w_pw_ij( i, j )
+
+       USE arrays_3d,                                                          &
+           ONLY:  ddzu, tend, u, v, w
+
+       USE control_parameters,                                                 &
+           ONLY:  u_gtrans, v_gtrans
+
+       USE grid_variables,                                                     &
+           ONLY:  ddx, ddy
+
+       USE indices,                                                            &
+           ONLY:  nzb_w_inner, nzt
+
+       USE kinds
+
+
+       IMPLICIT NONE
+
+       INTEGER(iwp) ::  i !<
+       INTEGER(iwp) ::  j !<
+       INTEGER(iwp) ::  k !<
+       
+       REAL(wp)    ::  gu !<
+       REAL(wp)    ::  gv !<
+
+       gu = 2.0_wp * u_gtrans
+       gv = 2.0_wp * v_gtrans
+       DO  k = nzb_w_inner(j,i)+1, nzt
+          tend(k,j,i) = tend(k,j,i) - 0.25_wp * (                              &
+                         ( w(k,j,i+1) * ( u(k+1,j,i+1) + u(k,j,i+1) - gu )     &
+                         - w(k,j,i-1) * ( u(k+1,j,i) + u(k,j,i) - gu ) ) * ddx &
+                       + ( w(k,j+1,i) * ( v(k+1,j+1,i) + v(k,j+1,i) - gv )     &
+                         - w(k,j-1,i) * ( v(k+1,j,i) + v(k,j,i) - gv ) ) * ddy &
+                       + ( w(k+1,j,i) * ( w(k+1,j,i) + w(k,j,i) )              &
+                         - w(k-1,j,i) * ( w(k,j,i) + w(k-1,j,i) ) )            &
+                                                                  * ddzu(k+1)  &
+                                                )
+       ENDDO
+    END SUBROUTINE advec_w_pw_ij
+
+ END MODULE advec_w_pw_mod
Index: lm/trunk/SOURCE/advec_w_up.f90
===================================================================
--- /palm/trunk/SOURCE/advec_w_up.f90	(revision 1849)
+++ 	(revision )
@@ -1,211 +1,0 @@
-!> @file advec_w_up.f90
-!--------------------------------------------------------------------------------!
-! This file is part of PALM.
-!
-! PALM is free software: you can redistribute it and/or modify it under the terms
-! of the GNU General Public License as published by the Free Software Foundation,
-! either version 3 of the License, or (at your option) any later version.
-!
-! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
-! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
-! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along with
-! PALM. If not, see <http://www.gnu.org/licenses/>.
-!
-! Copyright 1997-2016 Leibniz Universitaet Hannover
-!--------------------------------------------------------------------------------!
-!
-! Current revisions:
-! -----------------
-! 
-! 
-! Former revisions:
-! -----------------
-! $Id$
-!
-! 1682 2015-10-07 23:56:08Z knoop
-! Code annotations made doxygen readable 
-! 
-! 1353 2014-04-08 15:21:23Z heinze
-! REAL constants provided with KIND-attribute
-!
-! 1320 2014-03-20 08:40:49Z raasch
-! ONLY-attribute added to USE-statements,
-! kind-parameters added to all INTEGER and REAL declaration statements,
-! kinds are defined in new module kinds,
-! revision history before 2012 removed,
-! comment fields (!:) to be used for variable explanations added to
-! all variable declaration statements
-!
-! 1036 2012-10-22 13:43:42Z raasch
-! code put under GPL (PALM 3.9)
-!
-! Revision 1.1  1997/08/29 08:56:33  raasch
-! Initial revision
-!
-!
-! Description:
-! ------------
-!> Advection term for the w velocity-component using upstream scheme.
-!> NOTE: vertical advection at k=1 still has wrong grid spacing for w>0
-!>       The same problem occurs for all topography boundaries!
-!------------------------------------------------------------------------------!
- MODULE advec_w_up_mod
- 
-
-    PRIVATE
-    PUBLIC advec_w_up
-
-    INTERFACE advec_w_up
-       MODULE PROCEDURE advec_w_up
-       MODULE PROCEDURE advec_w_up_ij
-    END INTERFACE advec_w_up
-
- CONTAINS
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Call for all grid points
-!------------------------------------------------------------------------------!
-    SUBROUTINE advec_w_up
-
-       USE arrays_3d,                                                          &
-           ONLY:  ddzw, tend, u, v, w
-
-       USE control_parameters,                                                 &
-           ONLY:  u_gtrans, v_gtrans
-
-       USE grid_variables,                                                     &
-           ONLY:  ddx, ddy
-
-       USE indices,                                                            &
-           ONLY:  nxl, nxr, nyn, nys, nzb_w_inner, nzt
-
-       USE kinds
-
-
-       IMPLICIT NONE
-
-       INTEGER(iwp) ::  i !<
-       INTEGER(iwp) ::  j !<
-       INTEGER(iwp) ::  k !<
-
-       REAL(wp) ::  ukomp !<
-       REAL(wp) ::  vkomp !<
-
-
-       DO  i = nxl, nxr
-          DO  j = nys, nyn
-             DO  k = nzb_w_inner(j,i)+1, nzt-1
-!
-!--             x-direction
-                ukomp = 0.25_wp * ( u(k,j,i)   + u(k,j,i+1) +                  &
-                                 u(k+1,j,i) + u(k+1,j,i+1) ) - u_gtrans
-                IF ( ukomp > 0.0_wp )  THEN
-                   tend(k,j,i) = tend(k,j,i) - ukomp *                         &
-                                         ( w(k,j,i) - w(k,j,i-1) ) * ddx
-                ELSE
-                   tend(k,j,i) = tend(k,j,i) - ukomp *                         &
-                                         ( w(k,j,i+1) - w(k,j,i) ) * ddx
-                ENDIF
-!
-!--             y-direction
-                vkomp = 0.25_wp * ( v(k,j,i) + v(k,j+1,i) +                    &
-                                 v(k+1,j,i) + v(k+1,j+1,i) ) - v_gtrans
-                IF ( vkomp > 0.0_wp )  THEN
-                   tend(k,j,i) = tend(k,j,i) - vkomp *                         &
-                                         ( w(k,j,i) - w(k,j-1,i) ) * ddy
-                ELSE
-                   tend(k,j,i) = tend(k,j,i) - vkomp *                         &
-                                         ( w(k,j+1,i) - w(k,j,i) ) * ddy
-                ENDIF
-!
-!--             z-direction
-                IF ( w(k,j,i) > 0.0_wp )  THEN
-                   tend(k,j,i) = tend(k,j,i) - w(k,j,i) *                      &
-                                         ( w(k,j,i) - w(k-1,j,i) ) * ddzw(k)
-                ELSE
-                   tend(k,j,i) = tend(k,j,i) - w(k,j,i) *                      &
-                                         ( w(k+1,j,i) - w(k,j,i) ) * ddzw(k+1)
-                ENDIF
-
-             ENDDO
-          ENDDO
-       ENDDO
-
-    END SUBROUTINE advec_w_up
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Call for grid point i,j
-!------------------------------------------------------------------------------!
-    SUBROUTINE advec_w_up_ij( i, j )
-
-       USE arrays_3d,                                                          &
-           ONLY:  ddzw, tend, u, v, w
-
-       USE control_parameters,                                                 &
-           ONLY:  u_gtrans, v_gtrans
-
-       USE grid_variables,                                                     &
-           ONLY:  ddx, ddy
-
-       USE indices,                                                            &
-           ONLY:  nzb_w_inner, nzt
-
-       USE kinds
-
-
-       IMPLICIT NONE
-
-       INTEGER(iwp) ::  i !<
-       INTEGER(iwp) ::  j !<
-       INTEGER(iwp) ::  k !<
-
-       REAL(wp) ::  ukomp !<
-       REAL(wp) ::  vkomp !<
-
-
-       DO  k = nzb_w_inner(j,i)+1, nzt-1
-!
-!--       x-direction
-          ukomp = 0.25_wp * ( u(k,j,i) + u(k,j,i+1) + u(k+1,j,i) + u(k+1,j,i+1) &
-                         ) - u_gtrans
-          IF ( ukomp > 0.0_wp )  THEN
-             tend(k,j,i) = tend(k,j,i) - ukomp *                               &
-                                         ( w(k,j,i) - w(k,j,i-1) ) * ddx
-          ELSE
-             tend(k,j,i) = tend(k,j,i) - ukomp *                               &
-                                         ( w(k,j,i+1) - w(k,j,i) ) * ddx
-          ENDIF
-!
-!--       y-direction
-          vkomp = 0.25_wp * ( v(k,j,i) + v(k,j+1,i) + v(k+1,j,i) + v(k+1,j+1,i) &
-                         ) - v_gtrans
-          IF ( vkomp > 0.0_wp )  THEN
-             tend(k,j,i) = tend(k,j,i) - vkomp *                               &
-                                         ( w(k,j,i) - w(k,j-1,i) ) * ddy
-          ELSE
-             tend(k,j,i) = tend(k,j,i) - vkomp *                               &
-                                         ( w(k,j+1,i) - w(k,j,i) ) * ddy
-          ENDIF
-!
-!--       z-direction
-          IF ( w(k,j,i) > 0.0_wp )  THEN
-             tend(k,j,i) = tend(k,j,i) - w(k,j,i) *                            &
-                                         ( w(k,j,i) - w(k-1,j,i) ) * ddzw(k)
-          ELSE
-             tend(k,j,i) = tend(k,j,i) - w(k,j,i) *                            &
-                                         ( w(k+1,j,i) - w(k,j,i) ) * ddzw(k+1)
-          ENDIF
-
-       ENDDO
-
-    END SUBROUTINE advec_w_up_ij
-
- END MODULE advec_w_up_mod
Index: /palm/trunk/SOURCE/advec_w_up_mod.f90
===================================================================
--- /palm/trunk/SOURCE/advec_w_up_mod.f90	(revision 1850)
+++ /palm/trunk/SOURCE/advec_w_up_mod.f90	(revision 1850)
@@ -0,0 +1,212 @@
+!> @file advec_w_up_mod.f90
+!--------------------------------------------------------------------------------!
+! This file is part of PALM.
+!
+! PALM is free software: you can redistribute it and/or modify it under the terms
+! of the GNU General Public License as published by the Free Software Foundation,
+! either version 3 of the License, or (at your option) any later version.
+!
+! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
+! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
+! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along with
+! PALM. If not, see <http://www.gnu.org/licenses/>.
+!
+! Copyright 1997-2016 Leibniz Universitaet Hannover
+!--------------------------------------------------------------------------------!
+!
+! Current revisions:
+! -----------------
+! Module renamed
+! 
+! 
+! Former revisions:
+! -----------------
+! $Id$
+!
+! 1682 2015-10-07 23:56:08Z knoop
+! Code annotations made doxygen readable 
+! 
+! 1353 2014-04-08 15:21:23Z heinze
+! REAL constants provided with KIND-attribute
+!
+! 1320 2014-03-20 08:40:49Z raasch
+! ONLY-attribute added to USE-statements,
+! kind-parameters added to all INTEGER and REAL declaration statements,
+! kinds are defined in new module kinds,
+! revision history before 2012 removed,
+! comment fields (!:) to be used for variable explanations added to
+! all variable declaration statements
+!
+! 1036 2012-10-22 13:43:42Z raasch
+! code put under GPL (PALM 3.9)
+!
+! Revision 1.1  1997/08/29 08:56:33  raasch
+! Initial revision
+!
+!
+! Description:
+! ------------
+!> Advection term for the w velocity-component using upstream scheme.
+!> NOTE: vertical advection at k=1 still has wrong grid spacing for w>0
+!>       The same problem occurs for all topography boundaries!
+!------------------------------------------------------------------------------!
+ MODULE advec_w_up_mod
+ 
+
+    PRIVATE
+    PUBLIC advec_w_up
+
+    INTERFACE advec_w_up
+       MODULE PROCEDURE advec_w_up
+       MODULE PROCEDURE advec_w_up_ij
+    END INTERFACE advec_w_up
+
+ CONTAINS
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Call for all grid points
+!------------------------------------------------------------------------------!
+    SUBROUTINE advec_w_up
+
+       USE arrays_3d,                                                          &
+           ONLY:  ddzw, tend, u, v, w
+
+       USE control_parameters,                                                 &
+           ONLY:  u_gtrans, v_gtrans
+
+       USE grid_variables,                                                     &
+           ONLY:  ddx, ddy
+
+       USE indices,                                                            &
+           ONLY:  nxl, nxr, nyn, nys, nzb_w_inner, nzt
+
+       USE kinds
+
+
+       IMPLICIT NONE
+
+       INTEGER(iwp) ::  i !<
+       INTEGER(iwp) ::  j !<
+       INTEGER(iwp) ::  k !<
+
+       REAL(wp) ::  ukomp !<
+       REAL(wp) ::  vkomp !<
+
+
+       DO  i = nxl, nxr
+          DO  j = nys, nyn
+             DO  k = nzb_w_inner(j,i)+1, nzt-1
+!
+!--             x-direction
+                ukomp = 0.25_wp * ( u(k,j,i)   + u(k,j,i+1) +                  &
+                                 u(k+1,j,i) + u(k+1,j,i+1) ) - u_gtrans
+                IF ( ukomp > 0.0_wp )  THEN
+                   tend(k,j,i) = tend(k,j,i) - ukomp *                         &
+                                         ( w(k,j,i) - w(k,j,i-1) ) * ddx
+                ELSE
+                   tend(k,j,i) = tend(k,j,i) - ukomp *                         &
+                                         ( w(k,j,i+1) - w(k,j,i) ) * ddx
+                ENDIF
+!
+!--             y-direction
+                vkomp = 0.25_wp * ( v(k,j,i) + v(k,j+1,i) +                    &
+                                 v(k+1,j,i) + v(k+1,j+1,i) ) - v_gtrans
+                IF ( vkomp > 0.0_wp )  THEN
+                   tend(k,j,i) = tend(k,j,i) - vkomp *                         &
+                                         ( w(k,j,i) - w(k,j-1,i) ) * ddy
+                ELSE
+                   tend(k,j,i) = tend(k,j,i) - vkomp *                         &
+                                         ( w(k,j+1,i) - w(k,j,i) ) * ddy
+                ENDIF
+!
+!--             z-direction
+                IF ( w(k,j,i) > 0.0_wp )  THEN
+                   tend(k,j,i) = tend(k,j,i) - w(k,j,i) *                      &
+                                         ( w(k,j,i) - w(k-1,j,i) ) * ddzw(k)
+                ELSE
+                   tend(k,j,i) = tend(k,j,i) - w(k,j,i) *                      &
+                                         ( w(k+1,j,i) - w(k,j,i) ) * ddzw(k+1)
+                ENDIF
+
+             ENDDO
+          ENDDO
+       ENDDO
+
+    END SUBROUTINE advec_w_up
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Call for grid point i,j
+!------------------------------------------------------------------------------!
+    SUBROUTINE advec_w_up_ij( i, j )
+
+       USE arrays_3d,                                                          &
+           ONLY:  ddzw, tend, u, v, w
+
+       USE control_parameters,                                                 &
+           ONLY:  u_gtrans, v_gtrans
+
+       USE grid_variables,                                                     &
+           ONLY:  ddx, ddy
+
+       USE indices,                                                            &
+           ONLY:  nzb_w_inner, nzt
+
+       USE kinds
+
+
+       IMPLICIT NONE
+
+       INTEGER(iwp) ::  i !<
+       INTEGER(iwp) ::  j !<
+       INTEGER(iwp) ::  k !<
+
+       REAL(wp) ::  ukomp !<
+       REAL(wp) ::  vkomp !<
+
+
+       DO  k = nzb_w_inner(j,i)+1, nzt-1
+!
+!--       x-direction
+          ukomp = 0.25_wp * ( u(k,j,i) + u(k,j,i+1) + u(k+1,j,i) + u(k+1,j,i+1) &
+                         ) - u_gtrans
+          IF ( ukomp > 0.0_wp )  THEN
+             tend(k,j,i) = tend(k,j,i) - ukomp *                               &
+                                         ( w(k,j,i) - w(k,j,i-1) ) * ddx
+          ELSE
+             tend(k,j,i) = tend(k,j,i) - ukomp *                               &
+                                         ( w(k,j,i+1) - w(k,j,i) ) * ddx
+          ENDIF
+!
+!--       y-direction
+          vkomp = 0.25_wp * ( v(k,j,i) + v(k,j+1,i) + v(k+1,j,i) + v(k+1,j+1,i) &
+                         ) - v_gtrans
+          IF ( vkomp > 0.0_wp )  THEN
+             tend(k,j,i) = tend(k,j,i) - vkomp *                               &
+                                         ( w(k,j,i) - w(k,j-1,i) ) * ddy
+          ELSE
+             tend(k,j,i) = tend(k,j,i) - vkomp *                               &
+                                         ( w(k,j+1,i) - w(k,j,i) ) * ddy
+          ENDIF
+!
+!--       z-direction
+          IF ( w(k,j,i) > 0.0_wp )  THEN
+             tend(k,j,i) = tend(k,j,i) - w(k,j,i) *                            &
+                                         ( w(k,j,i) - w(k-1,j,i) ) * ddzw(k)
+          ELSE
+             tend(k,j,i) = tend(k,j,i) - w(k,j,i) *                            &
+                                         ( w(k+1,j,i) - w(k,j,i) ) * ddzw(k+1)
+          ENDIF
+
+       ENDDO
+
+    END SUBROUTINE advec_w_up_ij
+
+ END MODULE advec_w_up_mod
Index: lm/trunk/SOURCE/advec_ws.f90
===================================================================
--- /palm/trunk/SOURCE/advec_ws.f90	(revision 1849)
+++ 	(revision )
@@ -1,6440 +1,0 @@
-!> @file advec_ws.f90
-!--------------------------------------------------------------------------------!
-! This file is part of PALM.
-!
-! PALM is free software: you can redistribute it and/or modify it under the terms
-! of the GNU General Public License as published by the Free Software Foundation,
-! either version 3 of the License, or (at your option) any later version.
-!
-! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
-! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
-! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along with
-! PALM. If not, see <http://www.gnu.org/licenses/>.
-!
-! Copyright 1997-2016 Leibniz Universitaet Hannover
-!--------------------------------------------------------------------------------!
-!
-! Current revisions:
-! ------------------
-!
-! 
-! Former revisions:
-! -----------------
-! $Id$ 
-! 
-! 1822 2016-04-07 07:49:42Z hoffmann
-! icloud_scheme removed, microphysics_seifert added
-!
-! 1682 2015-10-07 23:56:08Z knoop
-! Code annotations made doxygen readable 
-! 
-! 1630 2015-08-26 16:57:23Z suehring
-! 
-! 
-! 1629 2015-08-26 16:56:11Z suehring
-! Bugfix concerning wall_flags at left and south PE boundaries
-!
-! 1581 2015-04-10 13:45:59Z suehring
-! 
-! 
-! 1580 2015-04-10 13:43:49Z suehring
-! Bugfix: statistical evaluation of scalar fluxes in case of monotonic limiter
-!
-! 1567 2015-03-10 17:57:55Z suehring
-! Bugfixes in monotonic limiter.
-!
-! 2015-03-09 13:10:37Z heinze
-! Bugfix: REAL constants provided with KIND-attribute in call of 
-! intrinsic functions like MAX and MIN 
-! 
-! 1557 2015-03-05 16:43:04Z suehring
-! Enable monotone advection for scalars using monotonic limiter
-!
-! 1374 2014-04-25 12:55:07Z raasch
-! missing variables added to ONLY list
-! 
-! 1361 2014-04-16 15:17:48Z hoffmann
-! accelerator and vector version for qr and nr added
-! 
-! 1353 2014-04-08 15:21:23Z heinze
-! REAL constants provided with KIND-attribute,
-! module kinds added
-! some formatting adjustments
-!
-! 1322 2014-03-20 16:38:49Z raasch
-! REAL constants defined as wp-kind
-!
-! 1320 2014-03-20 08:40:49Z raasch
-! ONLY-attribute added to USE-statements,
-! kind-parameters added to all INTEGER and REAL declaration statements,
-! kinds are defined in new module kinds,
-! old module precision_kind is removed,
-! revision history before 2012 removed,
-! comment fields (!:) to be used for variable explanations added to
-! all variable declaration statements
-!
-! 1257 2013-11-08 15:18:40Z raasch
-! accelerator loop directives removed
-!
-! 1221 2013-09-10 08:59:13Z raasch
-! wall_flags_00 introduced, which holds bits 32-...
-!
-! 1128 2013-04-12 06:19:32Z raasch
-! loop index bounds in accelerator version replaced by i_left, i_right, j_south,
-! j_north
-!
-! 1115 2013-03-26 18:16:16Z hoffmann
-! calculation of qr and nr is restricted to precipitation
-!
-! 1053 2012-11-13 17:11:03Z hoffmann
-! necessary expansions according to the two new prognostic equations (nr, qr) 
-! of the two-moment cloud physics scheme:
-! +flux_l_*, flux_s_*, diss_l_*, diss_s_*, sums_ws*s_ws_l 
-!
-! 1036 2012-10-22 13:43:42Z raasch
-! code put under GPL (PALM 3.9)
-!
-! 1027 2012-10-15 17:18:39Z suehring
-! Bugfix in calculation indices k_mm, k_pp in accelerator version
-!
-! 1019 2012-09-28 06:46:45Z raasch
-! small change in comment lines
-!
-! 1015 2012-09-27 09:23:24Z raasch
-! accelerator versions (*_acc) added
-!
-! 1010 2012-09-20 07:59:54Z raasch
-! cpp switch __nopointer added for pointer free version
-!
-! 888 2012-04-20 15:03:46Z suehring
-! Number of IBITS() calls with identical arguments is reduced.
-!
-! 862 2012-03-26 14:21:38Z suehring
-! ws-scheme also work with topography in combination with vector version.
-! ws-scheme also work with outflow boundaries in combination with
-! vector version.
-! Degradation of the applied order of scheme is now steered by multiplying with
-! Integer wall_flags_0. 2nd order scheme, WS3 and WS5 are calculated on each
-! grid point and mulitplied with the appropriate flag.
-! 2nd order numerical dissipation term changed. Now the appropriate 2nd order
-! term derived according to the 4th and 6th order terms is applied. It turns
-! out that diss_2nd does not provide sufficient dissipation near walls.
-! Therefore, the function diss_2nd is removed.
-! Near walls a divergence correction is necessary to overcome numerical
-! instabilities due to too less divergence reduction of the velocity field.
-! boundary_flags and logicals steering the degradation are removed.
-! Empty SUBROUTINE local_diss removed.
-! Further formatting adjustments.
-!
-! 801 2012-01-10 17:30:36Z suehring
-! Bugfix concerning OpenMP parallelization. Summation of sums_wsus_ws_l,
-! sums_wsvs_ws_l, sums_us2_ws_l, sums_vs2_ws_l, sums_ws2_ws_l, sums_wspts_ws_l,
-! sums_wsqs_ws_l, sums_wssas_ws_l is now thread-safe by adding an additional
-! dimension.
-!
-! Initial revision
-!
-! 411 2009-12-11 12:31:43 Z suehring
-!
-! Description:
-! ------------
-!> Advection scheme for scalars and momentum using the flux formulation of
-!> Wicker and Skamarock 5th order. Additionally the module contains of a 
-!> routine using for initialisation and steering of the statical evaluation. 
-!> The computation of turbulent fluxes takes place inside the advection
-!> routines.
-!> Near non-cyclic boundaries the order of the applied advection scheme is
-!> degraded.
-!> A divergence correction is applied. It is necessary for topography, since
-!> the divergence is not sufficiently reduced, resulting in erroneous fluxes and
-!> partly numerical instabilities. 
-!-----------------------------------------------------------------------------!
- MODULE advec_ws
-
- 
-
-    PRIVATE
-    PUBLIC   advec_s_ws, advec_s_ws_acc, advec_u_ws, advec_u_ws_acc,          &
-             advec_v_ws, advec_v_ws_acc, advec_w_ws, advec_w_ws_acc,          &
-             ws_init, ws_statistics
-
-    INTERFACE ws_init
-       MODULE PROCEDURE ws_init
-    END INTERFACE ws_init
-
-    INTERFACE ws_statistics
-       MODULE PROCEDURE ws_statistics
-    END INTERFACE ws_statistics
-
-    INTERFACE advec_s_ws
-       MODULE PROCEDURE advec_s_ws
-       MODULE PROCEDURE advec_s_ws_ij
-    END INTERFACE advec_s_ws
-
-    INTERFACE advec_u_ws
-       MODULE PROCEDURE advec_u_ws
-       MODULE PROCEDURE advec_u_ws_ij
-    END INTERFACE advec_u_ws
-
-    INTERFACE advec_u_ws_acc
-       MODULE PROCEDURE advec_u_ws_acc
-    END INTERFACE advec_u_ws_acc
-
-    INTERFACE advec_v_ws
-       MODULE PROCEDURE advec_v_ws
-       MODULE PROCEDURE advec_v_ws_ij
-    END INTERFACE advec_v_ws
-
-    INTERFACE advec_v_ws_acc
-       MODULE PROCEDURE advec_v_ws_acc
-    END INTERFACE advec_v_ws_acc
-
-    INTERFACE advec_w_ws
-       MODULE PROCEDURE advec_w_ws
-       MODULE PROCEDURE advec_w_ws_ij
-    END INTERFACE advec_w_ws
-
-    INTERFACE advec_w_ws_acc
-       MODULE PROCEDURE advec_w_ws_acc
-    END INTERFACE advec_w_ws_acc
-
- CONTAINS
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Initialization of WS-scheme
-!------------------------------------------------------------------------------!
-    SUBROUTINE ws_init
-
-       USE arrays_3d,                                                          &
-           ONLY:  diss_l_e, diss_l_nr, diss_l_pt, diss_l_q, diss_l_qr,         &
-                  diss_l_sa, diss_l_u, diss_l_v, diss_l_w,  flux_l_e,          &
-                  flux_l_nr, flux_l_pt, flux_l_q, flux_l_qr, flux_l_sa,        &
-                  flux_l_u, flux_l_v, flux_l_w, diss_s_e, diss_s_nr, diss_s_pt,&
-                  diss_s_q, diss_s_qr, diss_s_sa, diss_s_u, diss_s_v, diss_s_w,& 
-                  flux_s_e, flux_s_nr, flux_s_pt, flux_s_q, flux_s_qr,         &
-                  flux_s_sa, flux_s_u, flux_s_v, flux_s_w
-
-       USE constants,                                                          &
-           ONLY:  adv_mom_1, adv_mom_3, adv_mom_5, adv_sca_1, adv_sca_3,       &
-                  adv_sca_5
-
-       USE control_parameters,                                                 &
-           ONLY:  cloud_physics, humidity, loop_optimization,                  &
-                  monotonic_adjustment, passive_scalar, microphysics_seifert,  &
-                  ocean, ws_scheme_mom, ws_scheme_sca
-
-       USE indices,                                                            &
-           ONLY:  nyn, nys, nzb, nzt
-
-       USE kinds
-       
-       USE pegrid
-
-       USE statistics,                                                         &
-           ONLY:  sums_us2_ws_l, sums_vs2_ws_l, sums_ws2_ws_l, sums_wsnrs_ws_l,&
-                  sums_wspts_ws_l, sums_wsqrs_ws_l, sums_wsqs_ws_l,            &
-                  sums_wssas_ws_l,  sums_wsus_ws_l, sums_wsvs_ws_l  
-
-!
-!--    Set the appropriate factors for scalar and momentum advection.
-       adv_sca_5 = 1.0_wp /  60.0_wp
-       adv_sca_3 = 1.0_wp /  12.0_wp
-       adv_sca_1 = 1.0_wp /   2.0_wp
-       adv_mom_5 = 1.0_wp / 120.0_wp
-       adv_mom_3 = 1.0_wp /  24.0_wp
-       adv_mom_1 = 1.0_wp /   4.0_wp
-!         
-!--    Arrays needed for statical evaluation of fluxes.
-       IF ( ws_scheme_mom )  THEN
-
-          ALLOCATE( sums_wsus_ws_l(nzb:nzt+1,0:threads_per_task-1),            &
-                    sums_wsvs_ws_l(nzb:nzt+1,0:threads_per_task-1),            &
-                    sums_us2_ws_l(nzb:nzt+1,0:threads_per_task-1),             &
-                    sums_vs2_ws_l(nzb:nzt+1,0:threads_per_task-1),             &
-                    sums_ws2_ws_l(nzb:nzt+1,0:threads_per_task-1) )
-
-          sums_wsus_ws_l = 0.0_wp
-          sums_wsvs_ws_l = 0.0_wp
-          sums_us2_ws_l  = 0.0_wp
-          sums_vs2_ws_l  = 0.0_wp
-          sums_ws2_ws_l  = 0.0_wp
-
-       ENDIF
-
-       IF ( ws_scheme_sca )  THEN
-
-          ALLOCATE( sums_wspts_ws_l(nzb:nzt+1,0:threads_per_task-1) )
-          sums_wspts_ws_l = 0.0_wp
-
-          IF ( humidity  .OR.  passive_scalar )  THEN
-             ALLOCATE( sums_wsqs_ws_l(nzb:nzt+1,0:threads_per_task-1) )
-             sums_wsqs_ws_l = 0.0_wp
-          ENDIF
-
-          IF ( cloud_physics  .AND.  microphysics_seifert )  THEN
-             ALLOCATE( sums_wsqrs_ws_l(nzb:nzt+1,0:threads_per_task-1) )
-             ALLOCATE( sums_wsnrs_ws_l(nzb:nzt+1,0:threads_per_task-1) )
-             sums_wsqrs_ws_l = 0.0_wp
-             sums_wsnrs_ws_l = 0.0_wp
-          ENDIF
-
-          IF ( ocean )  THEN
-             ALLOCATE( sums_wssas_ws_l(nzb:nzt+1,0:threads_per_task-1) )
-             sums_wssas_ws_l = 0.0_wp
-          ENDIF
-
-       ENDIF
-
-!
-!--    Arrays needed for reasons of speed optimization for cache version.
-!--    For the vector version the buffer arrays are not necessary,
-!--    because the the fluxes can swapped directly inside the loops of the 
-!--    advection routines.
-       IF ( loop_optimization /= 'vector' )  THEN
-
-          IF ( ws_scheme_mom )  THEN
-
-             ALLOCATE( flux_s_u(nzb+1:nzt,0:threads_per_task-1),               &
-                       flux_s_v(nzb+1:nzt,0:threads_per_task-1),               &
-                       flux_s_w(nzb+1:nzt,0:threads_per_task-1),               &
-                       diss_s_u(nzb+1:nzt,0:threads_per_task-1),               &
-                       diss_s_v(nzb+1:nzt,0:threads_per_task-1),               &
-                       diss_s_w(nzb+1:nzt,0:threads_per_task-1) )
-             ALLOCATE( flux_l_u(nzb+1:nzt,nys:nyn,0:threads_per_task-1),       &
-                       flux_l_v(nzb+1:nzt,nys:nyn,0:threads_per_task-1),       &
-                       flux_l_w(nzb+1:nzt,nys:nyn,0:threads_per_task-1),       &
-                       diss_l_u(nzb+1:nzt,nys:nyn,0:threads_per_task-1),       &
-                       diss_l_v(nzb+1:nzt,nys:nyn,0:threads_per_task-1),       &
-                       diss_l_w(nzb+1:nzt,nys:nyn,0:threads_per_task-1) )
-
-          ENDIF
-
-          IF ( ws_scheme_sca )  THEN
-
-             ALLOCATE( flux_s_pt(nzb+1:nzt,0:threads_per_task-1),              &
-                       flux_s_e(nzb+1:nzt,0:threads_per_task-1),               &
-                       diss_s_pt(nzb+1:nzt,0:threads_per_task-1),              &
-                       diss_s_e(nzb+1:nzt,0:threads_per_task-1) ) 
-             ALLOCATE( flux_l_pt(nzb+1:nzt,nys:nyn,0:threads_per_task-1),      &
-                       flux_l_e(nzb+1:nzt,nys:nyn,0:threads_per_task-1),       &
-                       diss_l_pt(nzb+1:nzt,nys:nyn,0:threads_per_task-1),      &
-                       diss_l_e(nzb+1:nzt,nys:nyn,0:threads_per_task-1) )
-
-             IF ( humidity  .OR.  passive_scalar )  THEN
-                ALLOCATE( flux_s_q(nzb+1:nzt,0:threads_per_task-1),            &
-                          diss_s_q(nzb+1:nzt,0:threads_per_task-1) )
-                ALLOCATE( flux_l_q(nzb+1:nzt,nys:nyn,0:threads_per_task-1),    &
-                          diss_l_q(nzb+1:nzt,nys:nyn,0:threads_per_task-1) )
-             ENDIF
-
-             IF ( cloud_physics  .AND.  microphysics_seifert )  THEN
-                ALLOCATE( flux_s_qr(nzb+1:nzt,0:threads_per_task-1),           &
-                          diss_s_qr(nzb+1:nzt,0:threads_per_task-1),           &
-                          flux_s_nr(nzb+1:nzt,0:threads_per_task-1),           &
-                          diss_s_nr(nzb+1:nzt,0:threads_per_task-1) )
-                ALLOCATE( flux_l_qr(nzb+1:nzt,nys:nyn,0:threads_per_task-1),   &
-                          diss_l_qr(nzb+1:nzt,nys:nyn,0:threads_per_task-1),   &
-                          flux_l_nr(nzb+1:nzt,nys:nyn,0:threads_per_task-1),   &
-                          diss_l_nr(nzb+1:nzt,nys:nyn,0:threads_per_task-1) ) 
-             ENDIF
-
-             IF ( ocean )  THEN
-                ALLOCATE( flux_s_sa(nzb+1:nzt,0:threads_per_task-1),           &
-                          diss_s_sa(nzb+1:nzt,0:threads_per_task-1) )
-                ALLOCATE( flux_l_sa(nzb+1:nzt,nys:nyn,0:threads_per_task-1),   &
-                          diss_l_sa(nzb+1:nzt,nys:nyn,0:threads_per_task-1) )
-             ENDIF
-
-          ENDIF
-
-       ENDIF
-
-    END SUBROUTINE ws_init
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Initialize variables used for storing statistic quantities (fluxes, variances)
-!------------------------------------------------------------------------------!
-    SUBROUTINE ws_statistics
-    
-       USE control_parameters,                                                 &
-           ONLY:  cloud_physics, humidity, passive_scalar, ocean,              &
-                  microphysics_seifert, ws_scheme_mom, ws_scheme_sca
-
-       USE kinds
-
-       USE statistics,                                                         &
-           ONLY:  sums_us2_ws_l, sums_vs2_ws_l, sums_ws2_ws_l, sums_wsnrs_ws_l,&
-                  sums_wspts_ws_l, sums_wsqrs_ws_l, sums_wsqs_ws_l,            &
-                  sums_wssas_ws_l,  sums_wsus_ws_l, sums_wsvs_ws_l  
-
-       IMPLICIT NONE
-
-!       
-!--    The arrays needed for statistical evaluation are set to to 0 at the 
-!--    beginning of prognostic_equations.
-       IF ( ws_scheme_mom )  THEN
-          sums_wsus_ws_l = 0.0_wp
-          sums_wsvs_ws_l = 0.0_wp
-          sums_us2_ws_l  = 0.0_wp
-          sums_vs2_ws_l  = 0.0_wp
-          sums_ws2_ws_l  = 0.0_wp
-       ENDIF
-
-       IF ( ws_scheme_sca )  THEN
-          sums_wspts_ws_l = 0.0_wp
-          IF ( humidity  .OR.  passive_scalar )  sums_wsqs_ws_l = 0.0_wp
-          IF ( cloud_physics  .AND.  microphysics_seifert )  THEN
-             sums_wsqrs_ws_l = 0.0_wp
-             sums_wsnrs_ws_l = 0.0_wp
-          ENDIF
-          IF ( ocean )  sums_wssas_ws_l = 0.0_wp
-
-       ENDIF
-
-    END SUBROUTINE ws_statistics
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Scalar advection - Call for grid point i,j
-!------------------------------------------------------------------------------!
-    SUBROUTINE advec_s_ws_ij( i, j, sk, sk_char, swap_flux_y_local,            &
-                              swap_diss_y_local, swap_flux_x_local,            &
-                              swap_diss_x_local, i_omp, tn )
-
-       USE arrays_3d,                                                          &
-           ONLY:  ddzw, tend, u, v, w
-
-       USE constants,                                                          &
-           ONLY:  adv_sca_1, adv_sca_3, adv_sca_5
-
-       USE control_parameters,                                                 &
-           ONLY:  intermediate_timestep_count, monotonic_adjustment, u_gtrans, &
-                  v_gtrans 
-
-       USE grid_variables,                                                     &
-           ONLY:  ddx, ddy
-
-       USE indices,                                                            &
-           ONLY:  nxl, nxlg, nxr, nxrg, nyn, nyng, nys, nysg, nzb, nzb_max,    &
-                  nzt, wall_flags_0
-
-       USE kinds
-
-       USE pegrid
-
-       USE statistics,                                                         &
-           ONLY:  sums_wsnrs_ws_l, sums_wspts_ws_l, sums_wsqrs_ws_l,           &
-                  sums_wsqs_ws_l, sums_wssas_ws_l, weight_substep
-
-       IMPLICIT NONE
-
-       CHARACTER (LEN = *), INTENT(IN) ::  sk_char !<
-       
-       INTEGER(iwp) ::  i     !<
-       INTEGER(iwp) ::  ibit0 !<
-       INTEGER(iwp) ::  ibit1 !<
-       INTEGER(iwp) ::  ibit2 !<
-       INTEGER(iwp) ::  ibit3 !<
-       INTEGER(iwp) ::  ibit4 !<
-       INTEGER(iwp) ::  ibit5 !<
-       INTEGER(iwp) ::  ibit6 !<
-       INTEGER(iwp) ::  ibit7 !<
-       INTEGER(iwp) ::  ibit8 !<
-       INTEGER(iwp) ::  i_omp !<
-       INTEGER(iwp) ::  j     !<
-       INTEGER(iwp) ::  k     !<
-       INTEGER(iwp) ::  k_mm  !<
-       INTEGER(iwp) ::  k_mmm !<
-       INTEGER(iwp) ::  k_pp  !<
-       INTEGER(iwp) ::  k_ppp !<
-       INTEGER(iwp) ::  tn    !<
-       
-       REAL(wp)     ::  diss_d !<
-       REAL(wp)     ::  div    !<
-       REAL(wp)     ::  flux_d !<
-       REAL(wp)     ::  fd_1   !<
-       REAL(wp)     ::  fl_1   !<
-       REAL(wp)     ::  fn_1   !<
-       REAL(wp)     ::  fr_1   !<
-       REAL(wp)     ::  fs_1   !<
-       REAL(wp)     ::  ft_1   !<
-       REAL(wp)     ::  phi_d  !<
-       REAL(wp)     ::  phi_l  !<
-       REAL(wp)     ::  phi_n  !<
-       REAL(wp)     ::  phi_r  !<
-       REAL(wp)     ::  phi_s  !<
-       REAL(wp)     ::  phi_t  !<
-       REAL(wp)     ::  rd     !<
-       REAL(wp)     ::  rl     !<
-       REAL(wp)     ::  rn     !<
-       REAL(wp)     ::  rr     !<
-       REAL(wp)     ::  rs     !<
-       REAL(wp)     ::  rt     !<
-       REAL(wp)     ::  u_comp !<
-       REAL(wp)     ::  v_comp !<
-       
-#if defined( __nopointer )
-       REAL(wp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ::  sk !<
-#else
-       REAL(wp), DIMENSION(:,:,:), POINTER    ::  sk     !<
-#endif
-       REAL(wp), DIMENSION(nzb:nzt+1)         ::  diss_n !<
-       REAL(wp), DIMENSION(nzb:nzt+1)         ::  diss_r !<
-       REAL(wp), DIMENSION(nzb:nzt+1)         ::  diss_t !<
-       REAL(wp), DIMENSION(nzb:nzt+1)         ::  flux_n !<
-       REAL(wp), DIMENSION(nzb:nzt+1)         ::  flux_r !<
-       REAL(wp), DIMENSION(nzb:nzt+1)         ::  flux_t !<
-       
-       REAL(wp), DIMENSION(nzb+1:nzt,0:threads_per_task-1) ::  swap_diss_y_local !<
-       REAL(wp), DIMENSION(nzb+1:nzt,0:threads_per_task-1) ::  swap_flux_y_local !<
-       
-       REAL(wp), DIMENSION(nzb+1:nzt,nys:nyn,0:threads_per_task-1) ::  swap_diss_x_local !<
-       REAL(wp), DIMENSION(nzb+1:nzt,nys:nyn,0:threads_per_task-1) ::  swap_flux_x_local !<
-       
-
-!
-!--    Compute southside fluxes of the respective PE bounds.
-       IF ( j == nys )  THEN
-!
-!--       Up to the top of the highest topography.
-          DO  k = nzb+1, nzb_max
-
-             ibit5 = IBITS(wall_flags_0(k,j-1,i),5,1)
-             ibit4 = IBITS(wall_flags_0(k,j-1,i),4,1)
-             ibit3 = IBITS(wall_flags_0(k,j-1,i),3,1)
-
-             v_comp                  = v(k,j,i) - v_gtrans
-             swap_flux_y_local(k,tn) = v_comp *         (                     &
-                                               ( 37.0_wp * ibit5 * adv_sca_5  &
-                                            +     7.0_wp * ibit4 * adv_sca_3  &
-                                            +              ibit3 * adv_sca_1  &
-                                               ) *                            &
-                                           ( sk(k,j,i)  + sk(k,j-1,i)     )   &
-                                         -     (  8.0_wp * ibit5 * adv_sca_5  &
-                                            +              ibit4 * adv_sca_3  &
-                                                ) *                           &
-                                           ( sk(k,j+1,i) + sk(k,j-2,i)    )   &
-                                         +     (           ibit5 * adv_sca_5  &
-                                               ) *                            &
-                                           ( sk(k,j+2,i) + sk(k,j-3,i)    )   &
-                                                        )
-
-             swap_diss_y_local(k,tn) = -ABS( v_comp ) * (                     &
-                                               ( 10.0_wp * ibit5 * adv_sca_5  &
-                                            +     3.0_wp * ibit4 * adv_sca_3  &
-                                            +              ibit3 * adv_sca_1  &
-                                               ) *                            &
-                                            ( sk(k,j,i)   - sk(k,j-1,i)  )    &
-                                        -      (  5.0_wp * ibit5 * adv_sca_5  &
-                                            +              ibit4 * adv_sca_3  &
-                                            ) *                               &
-                                            ( sk(k,j+1,i) - sk(k,j-2,i)  )    &
-                                        +      (           ibit5 * adv_sca_5  &
-                                               ) *                            &
-                                            ( sk(k,j+2,i) - sk(k,j-3,i)  )    &
-                                                        )
-
-          ENDDO
-!
-!--       Above to the top of the highest topography. No degradation necessary.
-          DO  k = nzb_max+1, nzt
-
-             v_comp                  = v(k,j,i) - v_gtrans
-             swap_flux_y_local(k,tn) = v_comp * (                             &
-                                    37.0_wp * ( sk(k,j,i)   + sk(k,j-1,i) )   &
-                                  -  8.0_wp * ( sk(k,j+1,i) + sk(k,j-2,i) )   &
-                                  +           ( sk(k,j+2,i) + sk(k,j-3,i) )   &
-                                                ) * adv_sca_5
-              swap_diss_y_local(k,tn) = -ABS( v_comp ) * (                    &
-                                    10.0_wp * ( sk(k,j,i)   - sk(k,j-1,i) )   &
-                                  -  5.0_wp * ( sk(k,j+1,i) - sk(k,j-2,i) )   &
-                                  +             sk(k,j+2,i) - sk(k,j-3,i)     &
-                                                         ) * adv_sca_5
-
-          ENDDO
-
-       ENDIF
-!
-!--    Compute leftside fluxes of the respective PE bounds.
-       IF ( i == i_omp )  THEN
-        
-          DO  k = nzb+1, nzb_max
-
-             ibit2 = IBITS(wall_flags_0(k,j,i-1),2,1)
-             ibit1 = IBITS(wall_flags_0(k,j,i-1),1,1)
-             ibit0 = IBITS(wall_flags_0(k,j,i-1),0,1)
-
-             u_comp                     = u(k,j,i) - u_gtrans
-             swap_flux_x_local(k,j,tn) = u_comp * (                           &
-                                               ( 37.0_wp * ibit2 * adv_sca_5  &
-                                            +     7.0_wp * ibit1 * adv_sca_3  &
-                                            +              ibit0 * adv_sca_1  &
-                                               ) *                            &
-                                            ( sk(k,j,i)   + sk(k,j,i-1)    )  &
-                                        -      (  8.0_wp * ibit2 * adv_sca_5  &
-                                            +              ibit1 * adv_sca_3  &
-                                               ) *                            &
-                                            ( sk(k,j,i+1) + sk(k,j,i-2)    )  &
-                                        +      (           ibit2 * adv_sca_5  &
-                                               ) *                            &
-                                            ( sk(k,j,i+2) + sk(k,j,i-3)    )  &
-                                                  )
-
-              swap_diss_x_local(k,j,tn) = -ABS( u_comp ) * (                  &
-                                               ( 10.0_wp * ibit2 * adv_sca_5  &
-                                            +     3.0_wp * ibit1 * adv_sca_3  &
-                                            +              ibit0 * adv_sca_1  &
-                                               ) *                            &
-                                            ( sk(k,j,i)   - sk(k,j,i-1)    )  &
-                                        -      (  5.0_wp * ibit2 * adv_sca_5  &
-                                            +              ibit1 * adv_sca_3  &
-                                               ) *                            &
-                                            ( sk(k,j,i+1) - sk(k,j,i-2)    )  &
-                                        +      (           ibit2 * adv_sca_5  &
-                                               ) *                            &
-                                            ( sk(k,j,i+2) - sk(k,j,i-3)    )  &
-                                                           )
-
-          ENDDO
-
-          DO  k = nzb_max+1, nzt
-
-             u_comp                 = u(k,j,i) - u_gtrans
-             swap_flux_x_local(k,j,tn) = u_comp * (                           &
-                                      37.0_wp * ( sk(k,j,i)   + sk(k,j,i-1) ) &
-                                    -  8.0_wp * ( sk(k,j,i+1) + sk(k,j,i-2) ) &
-                                    +           ( sk(k,j,i+2) + sk(k,j,i-3) ) &
-                                                  ) * adv_sca_5
-
-             swap_diss_x_local(k,j,tn) = -ABS( u_comp ) * (                   &
-                                      10.0_wp * ( sk(k,j,i)   - sk(k,j,i-1) ) &
-                                    -  5.0_wp * ( sk(k,j,i+1) - sk(k,j,i-2) ) &
-                                    +           ( sk(k,j,i+2) - sk(k,j,i-3) ) &
-                                                          ) * adv_sca_5
-
-          ENDDO
-           
-       ENDIF
-
-       flux_t(0) = 0.0_wp
-       diss_t(0) = 0.0_wp
-       flux_d    = 0.0_wp
-       diss_d    = 0.0_wp
-!        
-!--    Now compute the fluxes and tendency terms for the horizontal and
-!--    vertical parts up to the top of the highest topography.
-       DO  k = nzb+1, nzb_max
-!
-!--       Note: It is faster to conduct all multiplications explicitly, e.g.
-!--       * adv_sca_5 ... than to determine a factor and multiplicate the
-!--       flux at the end. 
-
-          ibit2 = IBITS(wall_flags_0(k,j,i),2,1)
-          ibit1 = IBITS(wall_flags_0(k,j,i),1,1)
-          ibit0 = IBITS(wall_flags_0(k,j,i),0,1)
-
-          u_comp    = u(k,j,i+1) - u_gtrans
-          flux_r(k) = u_comp * (                                              &
-                     ( 37.0_wp * ibit2 * adv_sca_5                            &
-                  +     7.0_wp * ibit1 * adv_sca_3                            &
-                  +              ibit0 * adv_sca_1                            &
-                     ) *                                                      &
-                             ( sk(k,j,i+1) + sk(k,j,i)   )                    &
-              -      (  8.0_wp * ibit2 * adv_sca_5                            &
-                  +              ibit1 * adv_sca_3                            &
-                     ) *                                                      &
-                             ( sk(k,j,i+2) + sk(k,j,i-1) )                    &
-              +      (           ibit2 * adv_sca_5                            &
-                     ) *                                                      &
-                             ( sk(k,j,i+3) + sk(k,j,i-2) )                    &
-                               )
-
-          diss_r(k) = -ABS( u_comp ) * (                                      &
-                     ( 10.0_wp * ibit2 * adv_sca_5                            &
-                  +     3.0_wp * ibit1 * adv_sca_3                            &
-                  +              ibit0 * adv_sca_1                            &
-                     ) *                                                      &
-                             ( sk(k,j,i+1) - sk(k,j,i)  )                     &
-              -      (  5.0_wp * ibit2 * adv_sca_5                            &
-                  +              ibit1 * adv_sca_3                            &
-                     ) *                                                      &
-                             ( sk(k,j,i+2) - sk(k,j,i-1) )                    &
-              +      (           ibit2 * adv_sca_5                            &
-                     ) *                                                      &
-                             ( sk(k,j,i+3) - sk(k,j,i-2) )                    &
-                                       )
-
-          ibit5 = IBITS(wall_flags_0(k,j,i),5,1)
-          ibit4 = IBITS(wall_flags_0(k,j,i),4,1)
-          ibit3 = IBITS(wall_flags_0(k,j,i),3,1)
-
-          v_comp    = v(k,j+1,i) - v_gtrans
-          flux_n(k) = v_comp * (                                              &
-                     ( 37.0_wp * ibit5 * adv_sca_5                            &
-                  +     7.0_wp * ibit4 * adv_sca_3                            &
-                  +              ibit3 * adv_sca_1                            &
-                     ) *                                                      &
-                             ( sk(k,j+1,i) + sk(k,j,i)   )                    &
-              -      (  8.0_wp * ibit5 * adv_sca_5                            &
-                  +              ibit4 * adv_sca_3                            &
-                     ) *                                                      &
-                             ( sk(k,j+2,i) + sk(k,j-1,i) )                    &
-              +      (           ibit5 * adv_sca_5                            &
-                     ) *                                                      &
-                             ( sk(k,j+3,i) + sk(k,j-2,i) )                    &
-                               )
-
-          diss_n(k) = -ABS( v_comp ) * (                                      &
-                     ( 10.0_wp * ibit5 * adv_sca_5                            &
-                  +     3.0_wp * ibit4 * adv_sca_3                            &
-                  +              ibit3 * adv_sca_1                            &
-                     ) *                                                      &
-                             ( sk(k,j+1,i) - sk(k,j,i)   )                    &
-              -      (  5.0_wp * ibit5 * adv_sca_5                            &
-                  +              ibit4 * adv_sca_3                            &
-                     ) *                                                      &
-                             ( sk(k,j+2,i) - sk(k,j-1,i) )                    &
-              +      (           ibit5 * adv_sca_5                            &
-                     ) *                                                      &
-                             ( sk(k,j+3,i) - sk(k,j-2,i) )                    &
-                                       )
-!
-!--       k index has to be modified near bottom and top, else array
-!--       subscripts will be exceeded.
-          ibit8 = IBITS(wall_flags_0(k,j,i),8,1)
-          ibit7 = IBITS(wall_flags_0(k,j,i),7,1)
-          ibit6 = IBITS(wall_flags_0(k,j,i),6,1)
-
-          k_ppp = k + 3 * ibit8
-          k_pp  = k + 2 * ( 1 - ibit6  )
-          k_mm  = k - 2 * ibit8
-
-
-          flux_t(k) = w(k,j,i) * (                                            &
-                     ( 37.0_wp * ibit8 * adv_sca_5                            &
-                  +     7.0_wp * ibit7 * adv_sca_3                            &
-                  +              ibit6 * adv_sca_1                            &
-                     ) *                                                      &
-                             ( sk(k+1,j,i)  + sk(k,j,i)    )                  &
-              -      (  8.0_wp * ibit8 * adv_sca_5                            &
-                  +              ibit7 * adv_sca_3                            &
-                     ) *                                                      &
-                             ( sk(k_pp,j,i) + sk(k-1,j,i)  )                  &
-              +      (           ibit8 * adv_sca_5                            &
-                     ) *     ( sk(k_ppp,j,i)+ sk(k_mm,j,i) )                  &
-                                 )
-
-          diss_t(k) = -ABS( w(k,j,i) ) * (                                    &
-                     ( 10.0_wp * ibit8 * adv_sca_5                            &
-                  +     3.0_wp * ibit7 * adv_sca_3                            &
-                  +              ibit6 * adv_sca_1                            &
-                     ) *                                                      &
-                             ( sk(k+1,j,i)   - sk(k,j,i)    )                 &
-              -      (  5.0_wp * ibit8 * adv_sca_5                            &
-                  +              ibit7 * adv_sca_3                            &
-                     ) *                                                      &
-                             ( sk(k_pp,j,i)  - sk(k-1,j,i)  )                 &
-              +      (           ibit8 * adv_sca_5                            &
-                     ) *                                                      &
-                             ( sk(k_ppp,j,i) - sk(k_mm,j,i) )                 &
-                                         )
-!
-!--       Apply monotonic adjustment.
-          IF ( monotonic_adjustment )  THEN
-!
-!--          At first, calculate first order fluxes.
-             u_comp = u(k,j,i) - u_gtrans
-             fl_1   =  ( u_comp   * ( sk(k,j,i) + sk(k,j,i-1) )               &
-                   -ABS( u_comp ) * ( sk(k,j,i) - sk(k,j,i-1) )               &
-                       ) * adv_sca_1 
-
-             u_comp = u(k,j,i+1) - u_gtrans
-             fr_1   =  ( u_comp   * ( sk(k,j,i+1) + sk(k,j,i) )               &
-                   -ABS( u_comp ) * ( sk(k,j,i+1) - sk(k,j,i) )               &
-                       ) * adv_sca_1 
-
-             v_comp = v(k,j,i) - v_gtrans
-             fs_1   =  ( v_comp   * ( sk(k,j,i) + sk(k,j-1,i) )               &
-                   -ABS( v_comp ) * ( sk(k,j,i) - sk(k,j-1,i) )               &
-                       ) * adv_sca_1 
-
-             v_comp = v(k,j+1,i) - v_gtrans
-             fn_1   =  ( v_comp   * ( sk(k,j+1,i) + sk(k,j,i) )               &
-                   -ABS( v_comp ) * ( sk(k,j+1,i) - sk(k,j,i) )               &
-                       ) * adv_sca_1 
-
-             fd_1   =  ( w(k-1,j,i)   * ( sk(k,j,i) + sk(k-1,j,i) )           &
-                   -ABS( w(k-1,j,i) ) * ( sk(k,j,i) - sk(k-1,j,i) )           &
-                       ) * adv_sca_1 
-
-             ft_1   =  ( w(k,j,i)   * ( sk(k+1,j,i) + sk(k,j,i) )             &
-                   -ABS( w(k,j,i) ) * ( sk(k+1,j,i) - sk(k,j,i) )             &
-                      ) * adv_sca_1 
-!
-!--          Calculate ratio of upwind gradients. Note, Min/Max is just to 
-!--          avoid if statements.
-             rl     = ( MAX( 0.0_wp, u(k,j,i) - u_gtrans ) *                  & 
-                           ABS( ( sk(k,j,i-1) - sk(k,j,i-2)            ) /    &
-                                ( sk(k,j,i)   - sk(k,j,i-1) + 1E-20_wp )      &
-                              ) +                                             & 
-                        MIN( 0.0_wp, u(k,j,i) - u_gtrans ) *                  &
-                           ABS( ( sk(k,j,i)   - sk(k,j,i+1)            ) /    &
-                                ( sk(k,j,i-1) - sk(k,j,i)   + 1E-20_wp )      &
-                              )                                               &
-                      ) / ABS( u(k,j,i) - u_gtrans + 1E-20_wp )
-
-             rr     = ( MAX( 0.0_wp, u(k,j,i+1) - u_gtrans ) *                & 
-                           ABS( ( sk(k,j,i)   - sk(k,j,i-1)            ) /    &
-                                ( sk(k,j,i+1) - sk(k,j,i)   + 1E-20_wp )      &
-                              ) +                                             & 
-                        MIN( 0.0_wp, u(k,j,i+1) - u_gtrans ) *                &
-                           ABS( ( sk(k,j,i+1) - sk(k,j,i+2)            ) /    &
-                                ( sk(k,j,i)   - sk(k,j,i+1) + 1E-20_wp )      &
-                              )                                               &
-                      ) / ABS( u(k,j,i+1) - u_gtrans + 1E-20_wp )
-
-             rs     = ( MAX( 0.0_wp, v(k,j,i) - v_gtrans ) *                  & 
-                           ABS( ( sk(k,j-1,i) - sk(k,j-2,i)            ) /    &
-                                ( sk(k,j,i)   - sk(k,j-1,i) + 1E-20_wp )      &
-                              ) +                                             & 
-                        MIN( 0.0_wp, v(k,j,i) - v_gtrans ) *                  &
-                           ABS( ( sk(k,j,i)   - sk(k,j+1,i)            ) /    &
-                                ( sk(k,j-1,i) - sk(k,j,i)   + 1E-20_wp )      &
-                              )                                               &
-                      ) / ABS( v(k,j,i) - v_gtrans + 1E-20_wp )
-
-             rn     = ( MAX( 0.0_wp, v(k,j+1,i) - v_gtrans ) *                & 
-                           ABS( ( sk(k,j,i)   - sk(k,j-1,i)            ) /    &
-                                ( sk(k,j+1,i) - sk(k,j,i)   + 1E-20_wp )      &
-                              ) +                                             & 
-                       MIN( 0.0_wp, v(k,j+1,i) - v_gtrans ) *                 &
-                           ABS( ( sk(k,j+1,i) - sk(k,j+2,i)            ) /    &
-                                ( sk(k,j,i)   - sk(k,j+1,i) + 1E-20_wp )      &
-                              )                                               &
-                      ) / ABS( v(k,j+1,i) - v_gtrans + 1E-20_wp )     
-!   
-!--          Reuse k_mm and compute k_mmm for the vertical gradient ratios. 
-!--          Note, for vertical advection below the third grid point above 
-!--          surface ( or below the model top) rd and rt are set to 0, i.e. 
-!--          use of first order scheme is enforced.
-             k_mmm  = k - 3 * ibit8
-
-             rd     = ( MAX( 0.0_wp, w(k-1,j,i) ) *                           & 
-                           ABS( ( sk(k_mm,j,i) - sk(k_mmm,j,i)           ) /  &
-                                ( sk(k-1,j,i)  - sk(k_mm,j,i) + 1E-20_wp )    &
-                              ) +                                             & 
-                        MIN( 0.0_wp, w(k-1,j,i) ) *                           &
-                           ABS( ( sk(k-1,j,i) - sk(k,j,i)            ) /      &
-                                ( sk(k_mm,j,i) - sk(k-1,j,i)   + 1E-20_wp )   &
-                              )                                               &
-                      ) * ibit8 / ABS( w(k-1,j,i) + 1E-20_wp ) 
- 
-             rt     = ( MAX( 0.0_wp, w(k,j,i) ) *                             & 
-                           ABS( ( sk(k,j,i)   - sk(k-1,j,i)            ) /    &
-                                ( sk(k+1,j,i) - sk(k,j,i)   + 1E-20_wp )      &
-                              ) +                                             & 
-                        MIN( 0.0_wp, w(k,j,i) ) *                             &
-                           ABS( ( sk(k+1,j,i) - sk(k_pp,j,i)           ) /    &
-                                ( sk(k,j,i)   - sk(k+1,j,i) + 1E-20_wp )      &
-                              )                                               &
-                      ) * ibit8 / ABS( w(k,j,i) + 1E-20_wp )
-!
-!--           Calculate empirical limiter function (van Albada2 limiter).
-              phi_l = MIN( 1.0_wp, ( 2.0_wp * ABS( rl ) ) /                   &
-                                         ( rl**2 + 1.0_wp ) ) 
-              phi_r = MIN( 1.0_wp, ( 2.0_wp * ABS( rr ) ) /                   &
-                                         ( rr**2 + 1.0_wp ) ) 
-              phi_s = MIN( 1.0_wp, ( 2.0_wp * ABS( rs ) ) /                   &
-                                         ( rs**2 + 1.0_wp ) ) 
-              phi_n = MIN( 1.0_wp, ( 2.0_wp * ABS( rn ) ) /                   &
-                                         ( rn**2 + 1.0_wp ) ) 
-              phi_d = MIN( 1.0_wp, ( 2.0_wp * ABS( rd ) ) /                   &
-                                         ( rd**2 + 1.0_wp ) ) 
-              phi_t = MIN( 1.0_wp, ( 2.0_wp * ABS( rt ) ) /                   &
-                                         ( rt**2 + 1.0_wp ) ) 
-!
-!--           Calculate the resulting monotone flux. 
-              swap_flux_x_local(k,j,tn) = fl_1 - phi_l *                      &
-                                        ( fl_1 - swap_flux_x_local(k,j,tn)  )
-              flux_r(k)                 = fr_1 - phi_r *                      &
-                                        ( fr_1 - flux_r(k)                  )
-              swap_flux_y_local(k,tn)   = fs_1 - phi_s *                      &
-                                        ( fs_1 - swap_flux_y_local(k,tn)    )
-              flux_n(k)                 = fn_1 - phi_n *                      &
-                                        ( fn_1 - flux_n(k)                  )
-              flux_d                    = fd_1 - phi_d *                      &
-                                        ( fd_1 - flux_d                     )
-              flux_t(k)                 = ft_1 - phi_t *                      &
-                                        ( ft_1 - flux_t(k)                  )
-!
-!--          Moreover, modify dissipation flux according to the limiter. 
-             swap_diss_x_local(k,j,tn) = swap_diss_x_local(k,j,tn) * phi_l
-             diss_r(k)                 = diss_r(k)                 * phi_r
-             swap_diss_y_local(k,tn)   = swap_diss_y_local(k,tn)   * phi_s
-             diss_n(k)                 = diss_n(k)                 * phi_n
-             diss_d                    = diss_d                    * phi_d
-             diss_t(k)                 = diss_t(k)                 * phi_t
-
-          ENDIF
-!
-!--       Calculate the divergence of the velocity field. A respective
-!--       correction is needed to overcome numerical instabilities caused
-!--       by a not sufficient reduction of divergences near topography. 
-          div         =   ( u(k,j,i+1) * ( ibit0 + ibit1 + ibit2 )             &
-                          - u(k,j,i)   * ( IBITS(wall_flags_0(k,j,i-1),0,1)    &
-                                         + IBITS(wall_flags_0(k,j,i-1),1,1)    &
-                                         + IBITS(wall_flags_0(k,j,i-1),2,1)    &
-                                         )                                     &
-                          ) * ddx                                              &
-                        + ( v(k,j+1,i) * ( ibit3 + ibit4 + ibit5 )             &
-                          - v(k,j,i)   * ( IBITS(wall_flags_0(k,j-1,i),3,1)    &
-                                         + IBITS(wall_flags_0(k,j-1,i),4,1)    &
-                                         + IBITS(wall_flags_0(k,j-1,i),5,1)    &
-                                         )                                     &
-                          ) * ddy                                              &
-                        + ( w(k,j,i)   * ( ibit6 + ibit7 + ibit8 )             &
-                          - w(k-1,j,i) * ( IBITS(wall_flags_0(k-1,j,i),6,1)    &
-                                         + IBITS(wall_flags_0(k-1,j,i),7,1)    &
-                                         + IBITS(wall_flags_0(k-1,j,i),8,1)    &
-                                         )                                     &      
-                          ) * ddzw(k)
-
-
-          tend(k,j,i) = tend(k,j,i) - (                                       &
-                        ( flux_r(k) + diss_r(k) - swap_flux_x_local(k,j,tn) - &
-                          swap_diss_x_local(k,j,tn)            ) * ddx        &
-                      + ( flux_n(k) + diss_n(k) - swap_flux_y_local(k,tn)   - &
-                          swap_diss_y_local(k,tn)              ) * ddy        &
-                      + ( flux_t(k) + diss_t(k) - flux_d - diss_d             &
-                                                               ) * ddzw(k)    &
-                                      ) + sk(k,j,i) * div
-
-          swap_flux_y_local(k,tn)   = flux_n(k)
-          swap_diss_y_local(k,tn)   = diss_n(k)
-          swap_flux_x_local(k,j,tn) = flux_r(k)
-          swap_diss_x_local(k,j,tn) = diss_r(k)
-          flux_d                    = flux_t(k)
-          diss_d                    = diss_t(k)
-
-       ENDDO
-!
-!--    Now compute the fluxes and tendency terms for the horizontal and
-!--    vertical parts above the top of the highest topography. No degradation
-!--    for the horizontal parts, but for the vertical it is stell needed.
-       DO  k = nzb_max+1, nzt
-
-          u_comp    = u(k,j,i+1) - u_gtrans
-          flux_r(k) = u_comp * (                                              &
-                      37.0_wp * ( sk(k,j,i+1) + sk(k,j,i)   )                 &
-                    -  8.0_wp * ( sk(k,j,i+2) + sk(k,j,i-1) )                 &
-                    +           ( sk(k,j,i+3) + sk(k,j,i-2) ) ) * adv_sca_5
-          diss_r(k) = -ABS( u_comp ) * (                                      &
-                      10.0_wp * ( sk(k,j,i+1) - sk(k,j,i)   )                 &
-                    -  5.0_wp * ( sk(k,j,i+2) - sk(k,j,i-1) )                 &
-                    +           ( sk(k,j,i+3) - sk(k,j,i-2) ) ) * adv_sca_5
-
-          v_comp    = v(k,j+1,i) - v_gtrans
-          flux_n(k) = v_comp * (                                              &
-                      37.0_wp * ( sk(k,j+1,i) + sk(k,j,i)   )                 &
-                    -  8.0_wp * ( sk(k,j+2,i) + sk(k,j-1,i) )                 &
-                    +           ( sk(k,j+3,i) + sk(k,j-2,i) ) ) * adv_sca_5
-          diss_n(k) = -ABS( v_comp ) * (                                      &
-                      10.0_wp * ( sk(k,j+1,i) - sk(k,j,i)   )                 &
-                    -  5.0_wp * ( sk(k,j+2,i) - sk(k,j-1,i) )                 &
-                    +           ( sk(k,j+3,i) - sk(k,j-2,i) ) ) * adv_sca_5
-!
-!--       k index has to be modified near bottom and top, else array
-!--       subscripts will be exceeded.
-          ibit8 = IBITS(wall_flags_0(k,j,i),8,1)
-          ibit7 = IBITS(wall_flags_0(k,j,i),7,1)
-          ibit6 = IBITS(wall_flags_0(k,j,i),6,1)
-
-          k_ppp = k + 3 * ibit8
-          k_pp  = k + 2 * ( 1 - ibit6  )
-          k_mm  = k - 2 * ibit8
-
-          flux_t(k) = w(k,j,i) * (                                            &
-                    ( 37.0_wp * ibit8 * adv_sca_5                             &
-                 +     7.0_wp * ibit7 * adv_sca_3                             &
-                 +              ibit6 * adv_sca_1                             &
-                    ) *                                                       &
-                             ( sk(k+1,j,i)  + sk(k,j,i)   )                   &
-              -     (  8.0_wp * ibit8 * adv_sca_5                             &
-                  +              ibit7 * adv_sca_3                            &
-                    ) *                                                       &
-                             ( sk(k_pp,j,i) + sk(k-1,j,i) )                   &
-              +     (           ibit8 * adv_sca_5                             &
-                    ) *     ( sk(k_ppp,j,i)+ sk(k_mm,j,i) )                   &
-                                 )
-
-          diss_t(k) = -ABS( w(k,j,i) ) * (                                    &
-                    ( 10.0_wp * ibit8 * adv_sca_5                             &
-                 +     3.0_wp * ibit7 * adv_sca_3                             &
-                 +              ibit6 * adv_sca_1                             &
-                    ) *                                                       &
-                             ( sk(k+1,j,i)   - sk(k,j,i)    )                 &
-              -     (  5.0_wp * ibit8 * adv_sca_5                             &
-                 +              ibit7 * adv_sca_3                             &
-                    ) *                                                       &
-                             ( sk(k_pp,j,i)  - sk(k-1,j,i)  )                 &
-              +     (           ibit8 * adv_sca_5                             &
-                    ) *                                                       &
-                             ( sk(k_ppp,j,i) - sk(k_mm,j,i) )                 &
-                                         )
-
-
-!
-!--       Apply monotonic adjustment.
-          IF ( monotonic_adjustment )  THEN
-!
-!--          At first, calculate first order fluxes.
-             u_comp = u(k,j,i) - u_gtrans
-             fl_1   =  ( u_comp   * ( sk(k,j,i) + sk(k,j,i-1) )               &
-                   -ABS( u_comp ) * ( sk(k,j,i) - sk(k,j,i-1) )               &
-                       ) * adv_sca_1 
-
-             u_comp = u(k,j,i+1) - u_gtrans
-             fr_1   =  ( u_comp   * ( sk(k,j,i+1) + sk(k,j,i) )               &
-                   -ABS( u_comp ) * ( sk(k,j,i+1) - sk(k,j,i) )               &
-                       ) * adv_sca_1 
-
-             v_comp = v(k,j,i) - v_gtrans
-             fs_1   =  ( v_comp   * ( sk(k,j,i) + sk(k,j-1,i) )               &
-                   -ABS( v_comp ) * ( sk(k,j,i) - sk(k,j-1,i) )               &
-                       ) * adv_sca_1 
-
-             v_comp = v(k,j+1,i) - v_gtrans
-             fn_1   =  ( v_comp   * ( sk(k,j+1,i) + sk(k,j,i) )               &
-                   -ABS( v_comp ) * ( sk(k,j+1,i) - sk(k,j,i) )               &
-                       ) * adv_sca_1 
-
-             fd_1   =  ( w(k-1,j,i)   * ( sk(k,j,i) + sk(k-1,j,i) )           &
-                   -ABS( w(k-1,j,i) ) * ( sk(k,j,i) - sk(k-1,j,i) )           &
-                       ) * adv_sca_1 
-
-             ft_1   =  ( w(k,j,i)   * ( sk(k+1,j,i) + sk(k,j,i) )             &
-                   -ABS( w(k,j,i) ) * ( sk(k+1,j,i) - sk(k,j,i) )             &
-                       ) * adv_sca_1 
-!
-!--          Calculate ratio of upwind gradients. Note, Min/Max is just to 
-!--          avoid if statements. 
-             rl     = ( MAX( 0.0_wp, u(k,j,i) - u_gtrans ) *                  & 
-                           ABS( ( sk(k,j,i-1) - sk(k,j,i-2)            ) /    &
-                                ( sk(k,j,i)   - sk(k,j,i-1) + 1E-20_wp )      &
-                              ) +                                             & 
-                        MIN( 0.0_wp, u(k,j,i) - u_gtrans ) *                  &
-                           ABS( ( sk(k,j,i)   - sk(k,j,i+1)            ) /    &
-                                ( sk(k,j,i-1) - sk(k,j,i)   + 1E-20_wp )      &
-                              )                                               &
-                      ) / ABS( u(k,j,i) - u_gtrans + 1E-20_wp )
-
-             rr     = ( MAX( 0.0_wp, u(k,j,i+1) - u_gtrans ) *                & 
-                           ABS( ( sk(k,j,i)   - sk(k,j,i-1)            ) /    &
-                                ( sk(k,j,i+1) - sk(k,j,i)   + 1E-20_wp )      &
-                              ) +                                             & 
-                        MIN( 0.0_wp, u(k,j,i+1) - u_gtrans ) *                &
-                           ABS( ( sk(k,j,i+1) - sk(k,j,i+2)            ) /    &
-                                ( sk(k,j,i)   - sk(k,j,i+1) + 1E-20_wp )      &
-                              )                                               &
-                      ) / ABS( u(k,j,i+1) - u_gtrans + 1E-20_wp )
-
-             rs     = ( MAX( 0.0_wp, v(k,j,i) - v_gtrans ) *                  & 
-                           ABS( ( sk(k,j-1,i) - sk(k,j-2,i)            ) /    &
-                                ( sk(k,j,i)   - sk(k,j-1,i) + 1E-20_wp )      &
-                              ) +                                             & 
-                        MIN( 0.0_wp, v(k,j,i) - v_gtrans ) *                  &
-                           ABS( ( sk(k,j,i)   - sk(k,j+1,i)            ) /    &
-                                ( sk(k,j-1,i) - sk(k,j,i)   + 1E-20_wp )      &
-                              )                                               &
-                      ) / ABS( v(k,j,i) - v_gtrans + 1E-20_wp )
-
-             rn     = ( MAX( 0.0_wp, v(k,j+1,i) - v_gtrans ) *                & 
-                           ABS( ( sk(k,j,i)   - sk(k,j-1,i)            ) /    &
-                                ( sk(k,j+1,i) - sk(k,j,i)   + 1E-20_wp )      &
-                              ) +                                             & 
-                       MIN( 0.0_wp, v(k,j+1,i) - v_gtrans ) *                 &
-                           ABS( ( sk(k,j+1,i) - sk(k,j+2,i)            ) /    &
-                                ( sk(k,j,i)   - sk(k,j+1,i) + 1E-20_wp )      &
-                              )                                               &
-                      ) / ABS( v(k,j+1,i) - v_gtrans + 1E-20_wp )     
-!
-!--          Reuse k_mm and compute k_mmm for the vertical gradient ratios. 
-!--          Note, for vertical advection below the third grid point above 
-!--          surface ( or below the model top) rd and rt are set to 0, i.e. 
-!--          use of first order scheme is enforced.
-             k_mmm  = k - 3 * ibit8
-
-             rd     = ( MAX( 0.0_wp, w(k-1,j,i) ) *                           & 
-                           ABS( ( sk(k_mm,j,i) - sk(k_mmm,j,i)           ) /  &
-                                ( sk(k-1,j,i)  - sk(k_mm,j,i) + 1E-20_wp )    &
-                              ) +                                             & 
-                        MIN( 0.0_wp, w(k-1,j,i) ) *                           &
-                           ABS( ( sk(k-1,j,i) - sk(k,j,i)            ) /      &
-                                ( sk(k_mm,j,i) - sk(k-1,j,i)   + 1E-20_wp )   &
-                              )                                               &
-                      ) * ibit8 / ABS( w(k-1,j,i) + 1E-20_wp ) 
- 
-             rt     = ( MAX( 0.0_wp, w(k,j,i) ) *                             & 
-                           ABS( ( sk(k,j,i)   - sk(k-1,j,i)            ) /    &
-                                ( sk(k+1,j,i) - sk(k,j,i)   + 1E-20_wp )      &
-                              ) +                                             & 
-                        MIN( 0.0_wp, w(k,j,i) ) *                             &
-                           ABS( ( sk(k+1,j,i) - sk(k_pp,j,i)           ) /    &
-                                ( sk(k,j,i)   - sk(k+1,j,i) + 1E-20_wp )      &
-                              )                                               &
-                      ) * ibit8 / ABS( w(k,j,i) + 1E-20_wp ) 
-!
-!--           Calculate empirical limiter function (van Albada2 limiter).
-              phi_l = MIN( 1.0_wp, ( 2.0_wp * ABS( rl ) ) /                   &
-                                         ( rl**2 + 1.0_wp ) ) 
-              phi_r = MIN( 1.0_wp, ( 2.0_wp * ABS( rr ) ) /                   &
-                                         ( rr**2 + 1.0_wp ) ) 
-              phi_s = MIN( 1.0_wp, ( 2.0_wp * ABS( rs ) ) /                   &
-                                         ( rs**2 + 1.0_wp ) ) 
-              phi_n = MIN( 1.0_wp, ( 2.0_wp * ABS( rn ) ) /                   &
-                                         ( rn**2 + 1.0_wp ) ) 
-              phi_d = MIN( 1.0_wp, ( 2.0_wp * ABS( rd ) ) /                   &
-                                         ( rd**2 + 1.0_wp ) ) 
-              phi_t = MIN( 1.0_wp, ( 2.0_wp * ABS( rt ) ) /                   &
-                                         ( rt**2 + 1.0_wp ) ) 
-!
-!--           Calculate the resulting monotone flux. 
-              swap_flux_x_local(k,j,tn) = fl_1 - phi_l *                      &
-                                        ( fl_1 - swap_flux_x_local(k,j,tn)  )
-              flux_r(k)                 = fr_1 - phi_r *                      &
-                                        ( fr_1 - flux_r(k)                  )
-              swap_flux_y_local(k,tn)   = fs_1 - phi_s *                      &
-                                        ( fs_1 - swap_flux_y_local(k,tn)    )
-              flux_n(k)                 = fn_1 - phi_n *                      &
-                                        ( fn_1 - flux_n(k)                  )
-              flux_d                    = fd_1 - phi_d *                      &
-                                        ( fd_1 - flux_d                     )
-              flux_t(k)                 = ft_1 - phi_t *                      &
-                                        ( ft_1 - flux_t(k)                  )
-!
-!--          Moreover, modify dissipation flux according to the limiter. 
-             swap_diss_x_local(k,j,tn) = swap_diss_x_local(k,j,tn) * phi_l
-             diss_r(k)                 = diss_r(k)                 * phi_r
-             swap_diss_y_local(k,tn)   = swap_diss_y_local(k,tn)   * phi_s
-             diss_n(k)                 = diss_n(k)                 * phi_n
-             diss_d                    = diss_d                    * phi_d
-             diss_t(k)                 = diss_t(k)                 * phi_t
-
-          ENDIF
-!
-!--       Calculate the divergence of the velocity field. A respective
-!--       correction is needed to overcome numerical instabilities introduced
-!--       by a not sufficient reduction of divergences near topography.
-          div         =   ( u(k,j,i+1) - u(k,j,i)   ) * ddx                   &
-                        + ( v(k,j+1,i) - v(k,j,i)   ) * ddy                   &
-                        + ( w(k,j,i)   - w(k-1,j,i) ) * ddzw(k)
-
-          tend(k,j,i) = tend(k,j,i) - (                                       &
-                        ( flux_r(k) + diss_r(k) - swap_flux_x_local(k,j,tn) - &
-                          swap_diss_x_local(k,j,tn)            ) * ddx        &
-                      + ( flux_n(k) + diss_n(k) - swap_flux_y_local(k,tn)   - &
-                          swap_diss_y_local(k,tn)              ) * ddy        &
-                      + ( flux_t(k) + diss_t(k) - flux_d - diss_d             &
-                                                               ) * ddzw(k)    &
-                                      ) + sk(k,j,i) * div
-
-
-          swap_flux_y_local(k,tn)   = flux_n(k)
-          swap_diss_y_local(k,tn)   = diss_n(k)
-          swap_flux_x_local(k,j,tn) = flux_r(k)
-          swap_diss_x_local(k,j,tn) = diss_r(k)
-          flux_d                    = flux_t(k)
-          diss_d                    = diss_t(k)
-
-       ENDDO
-
-!
-!--    Evaluation of statistics.
-       SELECT CASE ( sk_char )
-
-          CASE ( 'pt' )
-
-             DO  k = nzb, nzt
-                sums_wspts_ws_l(k,tn) = sums_wspts_ws_l(k,tn) +               &
-                                       ( flux_t(k) + diss_t(k) )              &
-                               * weight_substep(intermediate_timestep_count)
-             ENDDO
-            
-          CASE ( 'sa' )
-
-             DO  k = nzb, nzt
-                sums_wssas_ws_l(k,tn) = sums_wssas_ws_l(k,tn) +               &
-                                       ( flux_t(k) + diss_t(k) )              &
-                               * weight_substep(intermediate_timestep_count)
-             ENDDO
-            
-          CASE ( 'q' )
-
-             DO  k = nzb, nzt
-                sums_wsqs_ws_l(k,tn)  = sums_wsqs_ws_l(k,tn) +                &
-                                      ( flux_t(k) + diss_t(k) )               &
-                               * weight_substep(intermediate_timestep_count)
-             ENDDO
-
-          CASE ( 'qr' )
-
-             DO  k = nzb, nzt
-                sums_wsqrs_ws_l(k,tn)  = sums_wsqrs_ws_l(k,tn) +              &
-                                      ( flux_t(k) + diss_t(k) )               &
-                               * weight_substep(intermediate_timestep_count)
-             ENDDO
-
-          CASE ( 'nr' )
-
-             DO  k = nzb, nzt
-                sums_wsnrs_ws_l(k,tn)  = sums_wsnrs_ws_l(k,tn) +              &
-                                      ( flux_t(k) + diss_t(k) )               &
-                               * weight_substep(intermediate_timestep_count)
-             ENDDO
-
-         END SELECT
-         
-    END SUBROUTINE advec_s_ws_ij
-
-
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Advection of u-component - Call for grid point i,j
-!------------------------------------------------------------------------------!
-    SUBROUTINE advec_u_ws_ij( i, j, i_omp, tn )
-
-       USE arrays_3d,                                                         &
-           ONLY:  ddzw, diss_l_u, diss_s_u, flux_l_u, flux_s_u, tend, u, v, w
-
-       USE constants,                                                         &
-           ONLY:  adv_mom_1, adv_mom_3, adv_mom_5
-
-       USE control_parameters,                                                &
-           ONLY:  intermediate_timestep_count, u_gtrans, v_gtrans
-
-       USE grid_variables,                                                    &
-           ONLY:  ddx, ddy
-
-       USE indices,                                                           &
-           ONLY:  nxl, nxr, nyn, nys, nzb, nzb_max, nzt, wall_flags_0
-
-       USE kinds
-
-       USE statistics,                                                        &
-           ONLY:  hom, sums_us2_ws_l, sums_wsus_ws_l, weight_substep
-
-       IMPLICIT NONE
-
-       INTEGER(iwp) ::  i      !<
-       INTEGER(iwp) ::  ibit9  !<
-       INTEGER(iwp) ::  ibit10 !<
-       INTEGER(iwp) ::  ibit11 !<
-       INTEGER(iwp) ::  ibit12 !<
-       INTEGER(iwp) ::  ibit13 !<
-       INTEGER(iwp) ::  ibit14 !<
-       INTEGER(iwp) ::  ibit15 !<
-       INTEGER(iwp) ::  ibit16 !<
-       INTEGER(iwp) ::  ibit17 !<
-       INTEGER(iwp) ::  i_omp  !<
-       INTEGER(iwp) ::  j      !<
-       INTEGER(iwp) ::  k      !<
-       INTEGER(iwp) ::  k_mm   !<
-       INTEGER(iwp) ::  k_pp   !<
-       INTEGER(iwp) ::  k_ppp  !<
-       INTEGER(iwp) ::  tn     !<
-       
-       REAL(wp)    ::  diss_d   !<
-       REAL(wp)    ::  div      !<
-       REAL(wp)    ::  flux_d   !<
-       REAL(wp)    ::  gu       !<
-       REAL(wp)    ::  gv       !<
-       REAL(wp)    ::  u_comp_l !<
-       REAL(wp)    ::  v_comp   !<
-       REAL(wp)    ::  w_comp   !<
-       
-       REAL(wp), DIMENSION(nzb:nzt+1) ::  diss_n !<
-       REAL(wp), DIMENSION(nzb:nzt+1) ::  diss_r !<
-       REAL(wp), DIMENSION(nzb:nzt+1) ::  diss_t !<
-       REAL(wp), DIMENSION(nzb:nzt+1) ::  flux_n !<
-       REAL(wp), DIMENSION(nzb:nzt+1) ::  flux_r !<
-       REAL(wp), DIMENSION(nzb:nzt+1) ::  flux_t !<
-       REAL(wp), DIMENSION(nzb:nzt+1) ::  u_comp !<
-
-       gu = 2.0_wp * u_gtrans
-       gv = 2.0_wp * v_gtrans
-!
-!--    Compute southside fluxes for the respective boundary of PE
-       IF ( j == nys  )  THEN
-       
-          DO  k = nzb+1, nzb_max
-
-             ibit14 = IBITS(wall_flags_0(k,j-1,i),14,1)
-             ibit13 = IBITS(wall_flags_0(k,j-1,i),13,1)
-             ibit12 = IBITS(wall_flags_0(k,j-1,i),12,1)
-
-             v_comp      = v(k,j,i) + v(k,j,i-1) - gv
-             flux_s_u(k,tn) = v_comp * (                                      &
-                            ( 37.0_wp * ibit14 * adv_mom_5                    &
-                         +     7.0_wp * ibit13 * adv_mom_3                    &
-                         +              ibit12 * adv_mom_1                    &
-                            ) *                                               &
-                                        ( u(k,j,i)   + u(k,j-1,i) )           &
-                     -      (  8.0_wp * ibit14 * adv_mom_5                    &
-                         +              ibit13 * adv_mom_3                    &
-                            ) *                                               &
-                                        ( u(k,j+1,i) + u(k,j-2,i) )           &
-                     +      (           ibit14 * adv_mom_5                    &
-                            ) *                                               &
-                                        ( u(k,j+2,i) + u(k,j-3,i) )           &
-                                       )
-
-             diss_s_u(k,tn) = - ABS ( v_comp ) * (                            &
-                            ( 10.0_wp * ibit14 * adv_mom_5                    &
-                         +     3.0_wp * ibit13 * adv_mom_3                    &
-                         +              ibit12 * adv_mom_1                    &
-                            ) *                                               &
-                                        ( u(k,j,i)   - u(k,j-1,i) )           &
-                     -      (  5.0_wp * ibit14 * adv_mom_5                    &
-                         +              ibit13 * adv_mom_3                    &
-                            ) *                                               &
-                                        ( u(k,j+1,i) - u(k,j-2,i) )           &
-                     +      (           ibit14 * adv_mom_5                    &
-                            ) *                                               &
-                                        ( u(k,j+2,i) - u(k,j-3,i) )           &
-                                                 )
-
-          ENDDO
-
-          DO  k = nzb_max+1, nzt
-
-             v_comp         = v(k,j,i) + v(k,j,i-1) - gv
-             flux_s_u(k,tn) = v_comp * (                                      &
-                           37.0_wp * ( u(k,j,i) + u(k,j-1,i)   )              &
-                         -  8.0_wp * ( u(k,j+1,i) + u(k,j-2,i) )              &
-                         +           ( u(k,j+2,i) + u(k,j-3,i) ) ) * adv_mom_5
-             diss_s_u(k,tn) = - ABS(v_comp) * (                               &
-                           10.0_wp * ( u(k,j,i) - u(k,j-1,i)   )              &
-                         -  5.0_wp * ( u(k,j+1,i) - u(k,j-2,i) )              &
-                         +           ( u(k,j+2,i) - u(k,j-3,i) ) ) * adv_mom_5
-
-          ENDDO
-          
-       ENDIF
-!
-!--    Compute leftside fluxes for the respective boundary of PE
-       IF ( i == i_omp )  THEN
-       
-          DO  k = nzb+1, nzb_max
-
-             ibit11 = IBITS(wall_flags_0(k,j,i-1),11,1)
-             ibit10 = IBITS(wall_flags_0(k,j,i-1),10,1)
-             ibit9  = IBITS(wall_flags_0(k,j,i-1),9,1)
-
-             u_comp_l         = u(k,j,i) + u(k,j,i-1) - gu
-             flux_l_u(k,j,tn) = u_comp_l * (                                  &
-                              ( 37.0_wp * ibit11 * adv_mom_5                  &
-                           +     7.0_wp * ibit10 * adv_mom_3                  &
-                           +              ibit9  * adv_mom_1                  &
-                              ) *                                             &
-                                          ( u(k,j,i)   + u(k,j,i-1) )         &
-                       -      (  8.0_wp * ibit11 * adv_mom_5                  &
-                           +              ibit10 * adv_mom_3                  &
-                              ) *                                             &
-                                          ( u(k,j,i+1) + u(k,j,i-2) )         &
-                       +      (           ibit11 * adv_mom_5                  &
-                              ) *                                             &
-                                          ( u(k,j,i+2) + u(k,j,i-3) )         &
-                                           )
-
-              diss_l_u(k,j,tn) = - ABS( u_comp_l ) * (                        &
-                              ( 10.0_wp * ibit11 * adv_mom_5                  &
-                           +     3.0_wp * ibit10 * adv_mom_3                  &
-                           +              ibit9  * adv_mom_1                  &
-                              ) *                                             &
-                                        ( u(k,j,i)   - u(k,j,i-1) )           &
-                       -      (  5.0_wp * ibit11 * adv_mom_5                  &
-                           +              ibit10 * adv_mom_3                  &
-                              ) *                                             &
-                                        ( u(k,j,i+1) - u(k,j,i-2) )           &
-                       +      (           ibit11 * adv_mom_5                  &
-                              ) *                                             &
-                                        ( u(k,j,i+2) - u(k,j,i-3) )           &
-                                                     )
-
-          ENDDO
-
-          DO  k = nzb_max+1, nzt
-
-             u_comp_l         = u(k,j,i) + u(k,j,i-1) - gu
-             flux_l_u(k,j,tn) = u_comp_l * (                                   &
-                             37.0_wp * ( u(k,j,i) + u(k,j,i-1)   )             &
-                           -  8.0_wp * ( u(k,j,i+1) + u(k,j,i-2) )             &
-                           +           ( u(k,j,i+2) + u(k,j,i-3) ) ) * adv_mom_5
-             diss_l_u(k,j,tn) = - ABS(u_comp_l) * (                            &
-                             10.0_wp * ( u(k,j,i) - u(k,j,i-1)   )             &
-                           -  5.0_wp * ( u(k,j,i+1) - u(k,j,i-2) )             &
-                           +           ( u(k,j,i+2) - u(k,j,i-3) ) ) * adv_mom_5
-
-          ENDDO
-          
-       ENDIF
-
-       flux_t(0) = 0.0_wp
-       diss_t(0) = 0.0_wp
-       flux_d    = 0.0_wp
-       diss_d    = 0.0_wp
-!
-!--    Now compute the fluxes tendency terms for the horizontal and
-!--    vertical parts.
-       DO  k = nzb+1, nzb_max
-
-          ibit11 = IBITS(wall_flags_0(k,j,i),11,1)
-          ibit10 = IBITS(wall_flags_0(k,j,i),10,1)
-          ibit9  = IBITS(wall_flags_0(k,j,i),9,1)
-
-          u_comp(k) = u(k,j,i+1) + u(k,j,i)
-          flux_r(k) = ( u_comp(k) - gu ) * (                                  &
-                     ( 37.0_wp * ibit11 * adv_mom_5                           &
-                  +     7.0_wp * ibit10 * adv_mom_3                           &
-                  +              ibit9  * adv_mom_1                           &
-                     ) *                                                      &
-                                    ( u(k,j,i+1) + u(k,j,i)   )               &
-              -      (  8.0_wp * ibit11 * adv_mom_5                           &
-                  +              ibit10 * adv_mom_3                           & 
-                     ) *                                                      &
-                                    ( u(k,j,i+2) + u(k,j,i-1) )               &
-              +      (           ibit11 * adv_mom_5                           &
-                     ) *                                                      &
-                                    ( u(k,j,i+3) + u(k,j,i-2) )               &
-                                           )
-
-          diss_r(k) = - ABS( u_comp(k) - gu ) * (                             &
-                     ( 10.0_wp * ibit11 * adv_mom_5                           &
-                  +     3.0_wp * ibit10 * adv_mom_3                           &
-                  +              ibit9  * adv_mom_1                           &
-                     ) *                                                      &
-                                    ( u(k,j,i+1) - u(k,j,i)   )               &
-              -      (  5.0_wp * ibit11 * adv_mom_5                           &
-                  +              ibit10 * adv_mom_3                           &
-                     ) *                                                      &
-                                    ( u(k,j,i+2) - u(k,j,i-1) )               &
-              +      (           ibit11 * adv_mom_5                           &
-                     ) *                                                      &
-                                    ( u(k,j,i+3) - u(k,j,i-2) )               &
-                                                )
-
-          ibit14 = IBITS(wall_flags_0(k,j,i),14,1)
-          ibit13 = IBITS(wall_flags_0(k,j,i),13,1)
-          ibit12 = IBITS(wall_flags_0(k,j,i),12,1)
-
-          v_comp    = v(k,j+1,i) + v(k,j+1,i-1) - gv
-          flux_n(k) = v_comp * (                                              &
-                     ( 37.0_wp * ibit14 * adv_mom_5                           &
-                  +     7.0_wp * ibit13 * adv_mom_3                           &
-                  +              ibit12 * adv_mom_1                           &
-                     ) *                                                      &
-                                    ( u(k,j+1,i) + u(k,j,i)   )               &
-              -      (  8.0_wp * ibit14 * adv_mom_5                           &
-                  +              ibit13 * adv_mom_3                           &
-                     ) *                                                      &
-                                    ( u(k,j+2,i) + u(k,j-1,i) )               &
-              +      (           ibit14 * adv_mom_5                           &
-                     ) *                                                      &
-                                    ( u(k,j+3,i) + u(k,j-2,i) )               &
-                               )
-
-          diss_n(k) = - ABS ( v_comp ) * (                                    &
-                     ( 10.0_wp * ibit14 * adv_mom_5                           &
-                  +     3.0_wp * ibit13 * adv_mom_3                           &
-                  +              ibit12 * adv_mom_1                           &
-                     ) *                                                      &
-                                    ( u(k,j+1,i) - u(k,j,i)   )               &
-              -      (  5.0_wp * ibit14 * adv_mom_5                           &
-                  +              ibit13 * adv_mom_3                           &
-                     ) *                                                      &
-                                    ( u(k,j+2,i) - u(k,j-1,i) )               &
-              +      (           ibit14 * adv_mom_5                           &
-                     ) *                                                      &
-                                    ( u(k,j+3,i) - u(k,j-2,i) )               &
-                                         )
-!
-!--       k index has to be modified near bottom and top, else array
-!--       subscripts will be exceeded.
-          ibit17 = IBITS(wall_flags_0(k,j,i),17,1)
-          ibit16 = IBITS(wall_flags_0(k,j,i),16,1)
-          ibit15 = IBITS(wall_flags_0(k,j,i),15,1)
-
-          k_ppp = k + 3 * ibit17
-          k_pp  = k + 2 * ( 1 - ibit15 )
-          k_mm  = k - 2 * ibit17
-
-          w_comp    = w(k,j,i) + w(k,j,i-1)
-          flux_t(k) = w_comp  * (                                             &
-                     ( 37.0_wp * ibit17 * adv_mom_5                           &
-                  +     7.0_wp * ibit16 * adv_mom_3                           &
-                  +              ibit15 * adv_mom_1                           &
-                     ) *                                                      &
-                                ( u(k+1,j,i)  + u(k,j,i)     )                &
-              -      (  8.0_wp * ibit17 * adv_mom_5                           &
-                  +              ibit16 * adv_mom_3                           &
-                     ) *                                                      &
-                                ( u(k_pp,j,i) + u(k-1,j,i)   )                &
-              +      (           ibit17 * adv_mom_5                           &
-                     ) *                                                      &
-                                ( u(k_ppp,j,i) + u(k_mm,j,i) )                &
-                                 )
-
-          diss_t(k) = - ABS( w_comp ) * (                                     &
-                     ( 10.0_wp * ibit17 * adv_mom_5                           &
-                  +     3.0_wp * ibit16 * adv_mom_3                           &
-                  +              ibit15 * adv_mom_1                           &
-                     ) *                                                      &
-                                ( u(k+1,j,i)   - u(k,j,i)    )                &
-              -      (  5.0_wp * ibit17 * adv_mom_5                           &
-                  +              ibit16 * adv_mom_3                           &
-                     ) *                                                      &
-                                ( u(k_pp,j,i)  - u(k-1,j,i)  )                &
-              +      (           ibit17 * adv_mom_5                           &
-                     ) *                                                      &
-                                ( u(k_ppp,j,i) - u(k_mm,j,i) )                &
-                                         )
-!
-!--       Calculate the divergence of the velocity field. A respective
-!--       correction is needed to overcome numerical instabilities introduced
-!--       by a not sufficient reduction of divergences near topography. 
-          div = ( ( u_comp(k)       * ( ibit9 + ibit10 + ibit11 )             &
-                - ( u(k,j,i)   + u(k,j,i-1)   )                               &
-                                    * ( IBITS(wall_flags_0(k,j,i-1),9,1)      &
-                                      + IBITS(wall_flags_0(k,j,i-1),10,1)     &
-                                      + IBITS(wall_flags_0(k,j,i-1),11,1)     &
-                                      )                                       &   
-                  ) * ddx                                                     &
-               +  ( ( v_comp + gv ) * ( ibit12 + ibit13 + ibit14 )            &
-                  - ( v(k,j,i)   + v(k,j,i-1 )  )                             &
-                                    * ( IBITS(wall_flags_0(k,j-1,i),12,1)     &
-                                      + IBITS(wall_flags_0(k,j-1,i),13,1)     &
-                                      + IBITS(wall_flags_0(k,j-1,i),14,1)     &
-                                      )                                       &
-                  ) * ddy                                                     &
-               +  ( w_comp          * ( ibit15 + ibit16 + ibit17 )            &
-                - ( w(k-1,j,i) + w(k-1,j,i-1) )                               &
-                                    * ( IBITS(wall_flags_0(k-1,j,i),15,1)     &
-                                      + IBITS(wall_flags_0(k-1,j,i),16,1)     &
-                                      + IBITS(wall_flags_0(k-1,j,i),17,1)     &
-                                      )                                       &  
-                  ) * ddzw(k)   &
-                ) * 0.5_wp
-
-
-          tend(k,j,i) = tend(k,j,i) - (                                       &
-                            ( flux_r(k) + diss_r(k)                           &
-                          -   flux_l_u(k,j,tn) - diss_l_u(k,j,tn) ) * ddx     &
-                          + ( flux_n(k) + diss_n(k)                           &
-                          -   flux_s_u(k,tn) - diss_s_u(k,tn)     ) * ddy     &
-                          + ( flux_t(k) + diss_t(k)                           &
-                          -   flux_d    - diss_d                  ) * ddzw(k) &
-                                       ) + div * u(k,j,i)
-
-           flux_l_u(k,j,tn) = flux_r(k)
-           diss_l_u(k,j,tn) = diss_r(k)
-           flux_s_u(k,tn)   = flux_n(k)
-           diss_s_u(k,tn)   = diss_n(k)
-           flux_d           = flux_t(k)
-           diss_d           = diss_t(k)
-!
-!--        Statistical Evaluation of u'u'. The factor has to be applied for
-!--        right evaluation when gallilei_trans = .T. .
-           sums_us2_ws_l(k,tn) = sums_us2_ws_l(k,tn)                          &
-                              + ( flux_r(k) *                                 &
-                                ( u_comp(k) - 2.0_wp * hom(k,1,1,0) )         &
-                              / ( u_comp(k) - gu + 1.0E-20_wp   )             &
-                              +   diss_r(k) *                                 &
-                                  ABS( u_comp(k) - 2.0_wp * hom(k,1,1,0) )    &
-                              / ( ABS( u_comp(k) - gu ) + 1.0E-20_wp ) )      &
-                              *   weight_substep(intermediate_timestep_count)
-!
-!--        Statistical Evaluation of w'u'.
-           sums_wsus_ws_l(k,tn) = sums_wsus_ws_l(k,tn)                        &
-                              + ( flux_t(k) + diss_t(k) )                     &
-                              *   weight_substep(intermediate_timestep_count)
-       ENDDO
-
-       DO  k = nzb_max+1, nzt
-
-          u_comp(k) = u(k,j,i+1) + u(k,j,i)
-          flux_r(k) = ( u_comp(k) - gu ) * (                                  &
-                         37.0_wp * ( u(k,j,i+1) + u(k,j,i)   )                &
-                       -  8.0_wp * ( u(k,j,i+2) + u(k,j,i-1) )                &
-                       +           ( u(k,j,i+3) + u(k,j,i-2) ) ) * adv_mom_5
-             diss_r(k) = - ABS( u_comp(k) - gu ) * (                          &
-                         10.0_wp * ( u(k,j,i+1) - u(k,j,i)   )                &
-                       -  5.0_wp * ( u(k,j,i+2) - u(k,j,i-1) )                &
-                       +           ( u(k,j,i+3) - u(k,j,i-2) ) ) * adv_mom_5
-
-             v_comp    = v(k,j+1,i) + v(k,j+1,i-1) - gv
-             flux_n(k) = v_comp * (                                           &
-                         37.0_wp * ( u(k,j+1,i) + u(k,j,i)   )                &
-                       -  8.0_wp * ( u(k,j+2,i) + u(k,j-1,i) )                &
-                       +           ( u(k,j+3,i) + u(k,j-2,i) ) ) * adv_mom_5
-             diss_n(k) = - ABS( v_comp ) * (                                  &
-                         10.0_wp * ( u(k,j+1,i) - u(k,j,i)   )                &
-                       -  5.0_wp * ( u(k,j+2,i) - u(k,j-1,i) )                &
-                       +           ( u(k,j+3,i) - u(k,j-2,i) ) ) * adv_mom_5
-!
-!--       k index has to be modified near bottom and top, else array
-!--       subscripts will be exceeded.
-          ibit17 = IBITS(wall_flags_0(k,j,i),17,1)
-          ibit16 = IBITS(wall_flags_0(k,j,i),16,1)
-          ibit15 = IBITS(wall_flags_0(k,j,i),15,1)
-
-          k_ppp = k + 3 * ibit17
-          k_pp  = k + 2 * ( 1 - ibit15 )
-          k_mm  = k - 2 * ibit17
-
-          w_comp    = w(k,j,i) + w(k,j,i-1)
-          flux_t(k) = w_comp  * (                                             &
-                     ( 37.0_wp * ibit17 * adv_mom_5                           &
-                  +     7.0_wp * ibit16 * adv_mom_3                           &
-                  +              ibit15 * adv_mom_1                           &
-                     ) *                                                      &
-                                ( u(k+1,j,i)  + u(k,j,i)     )                &
-              -      (  8.0_wp * ibit17 * adv_mom_5                           &
-                  +              ibit16 * adv_mom_3                           &
-                     ) *                                                      &
-                                ( u(k_pp,j,i) + u(k-1,j,i)   )                &
-              +      (           ibit17 * adv_mom_5                           &
-                     ) *                                                      &
-                                ( u(k_ppp,j,i) + u(k_mm,j,i) )                &
-                                 )
-
-          diss_t(k) = - ABS( w_comp ) * (                                     &
-                     ( 10.0_wp * ibit17 * adv_mom_5                           &
-                  +     3.0_wp * ibit16 * adv_mom_3                           &
-                  +              ibit15 * adv_mom_1                           &
-                     ) *                                                      &
-                                ( u(k+1,j,i)   - u(k,j,i)    )                &
-              -      (  5.0_wp * ibit17 * adv_mom_5                           &
-                  +              ibit16 * adv_mom_3                           &
-                     ) *                                                      &
-                                ( u(k_pp,j,i)  - u(k-1,j,i)  )                &
-              +      (           ibit17 * adv_mom_5                           &
-                     ) *                                                      &
-                                ( u(k_ppp,j,i) - u(k_mm,j,i) )                &
-                                         )
-!
-!--       Calculate the divergence of the velocity field. A respective
-!--       correction is needed to overcome numerical instabilities introduced
-!--       by a not sufficient reduction of divergences near topography.
-          div = ( ( u_comp(k)   - ( u(k,j,i)   + u(k,j,i-1)   ) ) * ddx       &
-               +  ( v_comp + gv - ( v(k,j,i)   + v(k,j,i-1 )  ) ) * ddy       &
-               +  ( w_comp      - ( w(k-1,j,i) + w(k-1,j,i-1) ) ) * ddzw(k)   &
-                ) * 0.5_wp
-
-          tend(k,j,i) = tend(k,j,i) - (                                       &
-                            ( flux_r(k) + diss_r(k)                           &
-                          -   flux_l_u(k,j,tn) - diss_l_u(k,j,tn) ) * ddx     &
-                          + ( flux_n(k) + diss_n(k)                           &
-                          -   flux_s_u(k,tn) - diss_s_u(k,tn)     ) * ddy     &
-                          + ( flux_t(k) + diss_t(k)                           &
-                          -   flux_d    - diss_d                  ) * ddzw(k) &
-                                       ) + div * u(k,j,i)
-
-           flux_l_u(k,j,tn) = flux_r(k)
-           diss_l_u(k,j,tn) = diss_r(k)
-           flux_s_u(k,tn)   = flux_n(k)
-           diss_s_u(k,tn)   = diss_n(k)
-           flux_d           = flux_t(k)
-           diss_d           = diss_t(k)
-!
-!--        Statistical Evaluation of u'u'. The factor has to be applied for
-!--        right evaluation when gallilei_trans = .T. .
-           sums_us2_ws_l(k,tn) = sums_us2_ws_l(k,tn)                          &
-                              + ( flux_r(k) *                                 &
-                                ( u_comp(k) - 2.0_wp * hom(k,1,1,0)      )    &
-                              / ( u_comp(k) - gu + 1.0E-20_wp          )      &
-                              +   diss_r(k) *                                 &
-                                  ABS( u_comp(k) - 2.0_wp * hom(k,1,1,0) )    &
-                              / ( ABS( u_comp(k) - gu ) + 1.0E-20_wp ) )      &
-                              *   weight_substep(intermediate_timestep_count)
-!
-!--        Statistical Evaluation of w'u'.
-           sums_wsus_ws_l(k,tn) = sums_wsus_ws_l(k,tn)                        &
-                              + ( flux_t(k) + diss_t(k) )                     &
-                              *   weight_substep(intermediate_timestep_count)
-       ENDDO
-
-       sums_us2_ws_l(nzb,tn) = sums_us2_ws_l(nzb+1,tn)
-
-
-
-    END SUBROUTINE advec_u_ws_ij
-
-
-
-!-----------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Advection of v-component - Call for grid point i,j
-!-----------------------------------------------------------------------------!
-   SUBROUTINE advec_v_ws_ij( i, j, i_omp, tn )
-
-       USE arrays_3d,                                                          &
-           ONLY:  ddzw, diss_l_v, diss_s_v, flux_l_v, flux_s_v, tend, u, v, w
-
-       USE constants,                                                          &
-           ONLY:  adv_mom_1, adv_mom_3, adv_mom_5
-
-       USE control_parameters,                                                 &
-           ONLY:  intermediate_timestep_count, u_gtrans, v_gtrans
-
-       USE grid_variables,                                                     &
-           ONLY:  ddx, ddy
-
-       USE indices,                                                            &
-           ONLY:  nxl, nxr, nyn, nys, nysv, nzb, nzb_max, nzt, wall_flags_0
-
-       USE kinds
-
-       USE statistics,                                                         &
-           ONLY:  hom, sums_vs2_ws_l, sums_wsvs_ws_l, weight_substep
-
-       IMPLICIT NONE
-
-       INTEGER(iwp)  ::  i      !<
-       INTEGER(iwp)  ::  ibit18 !<
-       INTEGER(iwp)  ::  ibit19 !<
-       INTEGER(iwp)  ::  ibit20 !<
-       INTEGER(iwp)  ::  ibit21 !<
-       INTEGER(iwp)  ::  ibit22 !<
-       INTEGER(iwp)  ::  ibit23 !<
-       INTEGER(iwp)  ::  ibit24 !<
-       INTEGER(iwp)  ::  ibit25 !<
-       INTEGER(iwp)  ::  ibit26 !<
-       INTEGER(iwp)  ::  i_omp  !<
-       INTEGER(iwp)  ::  j      !<
-       INTEGER(iwp)  ::  k      !<
-       INTEGER(iwp)  ::  k_mm   !<
-       INTEGER(iwp)  ::  k_pp   !<
-       INTEGER(iwp)  ::  k_ppp  !<
-       INTEGER(iwp)  ::  tn     !<
-       
-       REAL(wp)     ::  diss_d   !<
-       REAL(wp)     ::  div      !<
-       REAL(wp)     ::  flux_d   !<
-       REAL(wp)     ::  gu       !<
-       REAL(wp)     ::  gv       !<
-       REAL(wp)     ::  u_comp   !<
-       REAL(wp)     ::  v_comp_l !<
-       REAL(wp)     ::  w_comp   !<
-       
-       REAL(wp), DIMENSION(nzb:nzt+1)  ::  diss_n !<
-       REAL(wp), DIMENSION(nzb:nzt+1)  ::  diss_r !<
-       REAL(wp), DIMENSION(nzb:nzt+1)  ::  diss_t !<
-       REAL(wp), DIMENSION(nzb:nzt+1)  ::  flux_n !<
-       REAL(wp), DIMENSION(nzb:nzt+1)  ::  flux_r !<
-       REAL(wp), DIMENSION(nzb:nzt+1)  ::  flux_t !<
-       REAL(wp), DIMENSION(nzb:nzt+1)  ::  v_comp !<
-
-       gu = 2.0_wp * u_gtrans
-       gv = 2.0_wp * v_gtrans
-
-!       
-!--    Compute leftside fluxes for the respective boundary.
-       IF ( i == i_omp )  THEN
-
-          DO  k = nzb+1, nzb_max
-
-             ibit20 = IBITS(wall_flags_0(k,j,i-1),20,1)
-             ibit19 = IBITS(wall_flags_0(k,j,i-1),19,1)
-             ibit18 = IBITS(wall_flags_0(k,j,i-1),18,1)
-
-             u_comp           = u(k,j-1,i) + u(k,j,i) - gu
-             flux_l_v(k,j,tn) = u_comp * (                                    &
-                              ( 37.0_wp * ibit20 * adv_mom_5                  &
-                           +     7.0_wp * ibit19 * adv_mom_3                  &
-                           +              ibit18 * adv_mom_1                  &
-                              ) *                                             &
-                                        ( v(k,j,i)   + v(k,j,i-1) )           &
-                       -      (  8.0_wp * ibit20 * adv_mom_5                  &
-                           +              ibit19 * adv_mom_3                  &
-                              ) *                                             &
-                                        ( v(k,j,i+1) + v(k,j,i-2) )           &
-                       +      (           ibit20 * adv_mom_5                  &
-                              ) *                                             &
-                                        ( v(k,j,i+2) + v(k,j,i-3) )           &
-                                         )
-
-              diss_l_v(k,j,tn) = - ABS( u_comp ) * (                          &
-                              ( 10.0_wp * ibit20 * adv_mom_5                  &
-                           +     3.0_wp * ibit19 * adv_mom_3                  &
-                           +              ibit18 * adv_mom_1                  &
-                              ) *                                             &
-                                        ( v(k,j,i)   - v(k,j,i-1) )           &
-                       -      (  5.0_wp * ibit20 * adv_mom_5                  &
-                           +              ibit19 * adv_mom_3                  &
-                              ) *                                             &
-                                        ( v(k,j,i+1) - v(k,j,i-2) )           &
-                       +      (           ibit20 * adv_mom_5                  &
-                              ) *                                             &
-                                        ( v(k,j,i+2) - v(k,j,i-3) )           &
-                                                   )
-
-          ENDDO
-
-          DO  k = nzb_max+1, nzt
-
-             u_comp           = u(k,j-1,i) + u(k,j,i) - gu
-             flux_l_v(k,j,tn) = u_comp * (                                    &
-                             37.0_wp * ( v(k,j,i) + v(k,j,i-1)   )            &
-                           -  8.0_wp * ( v(k,j,i+1) + v(k,j,i-2) )            &
-                           +           ( v(k,j,i+2) + v(k,j,i-3) ) ) * adv_mom_5
-             diss_l_v(k,j,tn) = - ABS( u_comp ) * (                           &
-                             10.0_wp * ( v(k,j,i) - v(k,j,i-1)   )            &
-                           -  5.0_wp * ( v(k,j,i+1) - v(k,j,i-2) )            &
-                           +           ( v(k,j,i+2) - v(k,j,i-3) ) ) * adv_mom_5
-
-          ENDDO
-          
-       ENDIF
-!
-!--    Compute southside fluxes for the respective boundary.
-       IF ( j == nysv )  THEN
-       
-          DO  k = nzb+1, nzb_max
-
-             ibit23 = IBITS(wall_flags_0(k,j-1,i),23,1)
-             ibit22 = IBITS(wall_flags_0(k,j-1,i),22,1)
-             ibit21 = IBITS(wall_flags_0(k,j-1,i),21,1)
-
-             v_comp_l       = v(k,j,i) + v(k,j-1,i) - gv
-             flux_s_v(k,tn) = v_comp_l * (                                    &
-                            ( 37.0_wp * ibit23 * adv_mom_5                    &
-                         +     7.0_wp * ibit22 * adv_mom_3                    &
-                         +              ibit21 * adv_mom_1                    &
-                            ) *                                               &
-                                        ( v(k,j,i)   + v(k,j-1,i) )           &
-                     -      (  8.0_wp * ibit23 * adv_mom_5                    &
-                         +              ibit22 * adv_mom_3                    &
-                            ) *                                               &
-                                        ( v(k,j+1,i) + v(k,j-2,i) )           &
-                     +      (           ibit23 * adv_mom_5                    &
-                            ) *                                               &
-                                        ( v(k,j+2,i) + v(k,j-3,i) )           &
-                                         )
-
-             diss_s_v(k,tn) = - ABS( v_comp_l ) * (                           &
-                            ( 10.0_wp * ibit23 * adv_mom_5                    &
-                         +     3.0_wp * ibit22 * adv_mom_3                    &
-                         +              ibit21 * adv_mom_1                    &
-                            ) *                                               &
-                                        ( v(k,j,i)   - v(k,j-1,i) )           &
-                     -      (  5.0_wp * ibit23 * adv_mom_5                    &
-                         +              ibit22 * adv_mom_3                    &
-                            ) *                                               &
-                                        ( v(k,j+1,i) - v(k,j-2,i) )           &
-                     +      (           ibit23 * adv_mom_5                    &
-                            ) *                                               &
-                                        ( v(k,j+2,i) - v(k,j-3,i) )           &
-                                                  )
-
-          ENDDO
-
-          DO  k = nzb_max+1, nzt
-
-             v_comp_l       = v(k,j,i) + v(k,j-1,i) - gv
-             flux_s_v(k,tn) = v_comp_l * (                                    &
-                           37.0_wp * ( v(k,j,i) + v(k,j-1,i)   )              &
-                         -  8.0_wp * ( v(k,j+1,i) + v(k,j-2,i) )              &
-                         +           ( v(k,j+2,i) + v(k,j-3,i) ) ) * adv_mom_5
-             diss_s_v(k,tn) = - ABS( v_comp_l ) * (                           &
-                           10.0_wp * ( v(k,j,i) - v(k,j-1,i)   )              &
-                         -  5.0_wp * ( v(k,j+1,i) - v(k,j-2,i) )              &
-                         +           ( v(k,j+2,i) - v(k,j-3,i) ) ) * adv_mom_5
-
-          ENDDO
-          
-       ENDIF
-
-       flux_t(0) = 0.0_wp
-       diss_t(0) = 0.0_wp
-       flux_d    = 0.0_wp
-       diss_d    = 0.0_wp
-!
-!--    Now compute the fluxes and tendency terms for the horizontal and
-!--    verical parts.
-       DO  k = nzb+1, nzb_max
-
-          ibit20 = IBITS(wall_flags_0(k,j,i),20,1)
-          ibit19 = IBITS(wall_flags_0(k,j,i),19,1)
-          ibit18 = IBITS(wall_flags_0(k,j,i),18,1)
- 
-          u_comp    = u(k,j-1,i+1) + u(k,j,i+1) - gu
-          flux_r(k) = u_comp * (                                              &
-                     ( 37.0_wp * ibit20 * adv_mom_5                           &
-                  +     7.0_wp * ibit19 * adv_mom_3                           &
-                  +              ibit18 * adv_mom_1                           &
-                     ) *                                                      &
-                                    ( v(k,j,i+1) + v(k,j,i)   )               &
-              -      (  8.0_wp * ibit20 * adv_mom_5                           &
-                  +              ibit19 * adv_mom_3                           &
-                     ) *                                                      &
-                                    ( v(k,j,i+2) + v(k,j,i-1) )               &
-              +      (           ibit20 * adv_mom_5                           &
-                     ) *                                                      &
-                                    ( v(k,j,i+3) + v(k,j,i-2) )               &
-                               )
-
-          diss_r(k) = - ABS( u_comp ) * (                                     &
-                     ( 10.0_wp * ibit20 * adv_mom_5                           &
-                  +     3.0_wp * ibit19 * adv_mom_3                           &
-                  +              ibit18 * adv_mom_1                           &
-                     ) *                                                      &
-                                    ( v(k,j,i+1) - v(k,j,i)  )                &
-              -      (  5.0_wp * ibit20 * adv_mom_5                           &
-                  +              ibit19 * adv_mom_3                           &
-                     ) *                                                      &
-                                    ( v(k,j,i+2) - v(k,j,i-1) )               &
-              +      (           ibit20 * adv_mom_5                           &
-                     ) *                                                      &
-                                    ( v(k,j,i+3) - v(k,j,i-2) )               &
-                                        )
-
-          ibit23 = IBITS(wall_flags_0(k,j,i),23,1)
-          ibit22 = IBITS(wall_flags_0(k,j,i),22,1)
-          ibit21 = IBITS(wall_flags_0(k,j,i),21,1)
-
-
-          v_comp(k) = v(k,j+1,i) + v(k,j,i)
-          flux_n(k) = ( v_comp(k) - gv ) * (                                  &
-                     ( 37.0_wp * ibit23 * adv_mom_5                           &
-                  +     7.0_wp * ibit22 * adv_mom_3                           &
-                  +              ibit21 * adv_mom_1                           &
-                     ) *                                                      &
-                                    ( v(k,j+1,i) + v(k,j,i)   )               &
-              -      (  8.0_wp * ibit23 * adv_mom_5                           &
-                  +              ibit22 * adv_mom_3                           &
-                     ) *                                                      &
-                                    ( v(k,j+2,i) + v(k,j-1,i) )               &
-              +      (           ibit23 * adv_mom_5                           &
-                     ) *                                                      &
-                                    ( v(k,j+3,i) + v(k,j-2,i) )               &
-                                           )
-
-          diss_n(k) = - ABS( v_comp(k) - gv ) * (                             &
-                     ( 10.0_wp * ibit23 * adv_mom_5                           &
-                  +     3.0_wp * ibit22 * adv_mom_3                           &
-                  +              ibit21 * adv_mom_1                           &
-                     ) *                                                      &
-                                    ( v(k,j+1,i) - v(k,j,i)   )               &
-              -      (  5.0_wp * ibit23 * adv_mom_5                           &
-                  +              ibit22 * adv_mom_3                           &
-                     ) *                                                      &
-                                    ( v(k,j+2,i) - v(k,j-1,i) )               &
-              +      (           ibit23 * adv_mom_5                           &
-                     ) *                                                      &
-                                    ( v(k,j+3,i) - v(k,j-2,i) )               &
-                                                )
-!
-!--       k index has to be modified near bottom and top, else array
-!--       subscripts will be exceeded.
-          ibit26 = IBITS(wall_flags_0(k,j,i),26,1)
-          ibit25 = IBITS(wall_flags_0(k,j,i),25,1)
-          ibit24 = IBITS(wall_flags_0(k,j,i),24,1)
-
-          k_ppp = k + 3 * ibit26
-          k_pp  = k + 2 * ( 1 - ibit24  )
-          k_mm  = k - 2 * ibit26
-
-          w_comp    = w(k,j-1,i) + w(k,j,i)
-          flux_t(k) = w_comp  * (                                             &
-                     ( 37.0_wp * ibit26 * adv_mom_5                           &
-                  +     7.0_wp * ibit25 * adv_mom_3                           &
-                  +              ibit24 * adv_mom_1                           &
-                     ) *                                                      &
-                                ( v(k+1,j,i)   + v(k,j,i)    )                &
-              -      (  8.0_wp * ibit26 * adv_mom_5                           &
-                  +              ibit25 * adv_mom_3                           &
-                     ) *                                                      &
-                                ( v(k_pp,j,i)  + v(k-1,j,i)  )                &
-              +      (           ibit26 * adv_mom_5                           &
-                     ) *                                                      &
-                                ( v(k_ppp,j,i) + v(k_mm,j,i) )                &
-                                 )
-
-          diss_t(k) = - ABS( w_comp ) * (                                     &
-                     ( 10.0_wp * ibit26 * adv_mom_5                           &
-                  +     3.0_wp * ibit25 * adv_mom_3                           &
-                  +              ibit24 * adv_mom_1                           &
-                     ) *                                                      &
-                                ( v(k+1,j,i)   - v(k,j,i)    )                &
-              -      (  5.0_wp * ibit26 * adv_mom_5                           &
-                  +              ibit25 * adv_mom_3                           &
-                     ) *                                                      &
-                                ( v(k_pp,j,i)  - v(k-1,j,i)  )                &
-              +      (           ibit26 * adv_mom_5                           &
-                     ) *                                                      &
-                                ( v(k_ppp,j,i) - v(k_mm,j,i) )                &
-                                         )
-!
-!--       Calculate the divergence of the velocity field. A respective
-!--       correction is needed to overcome numerical instabilities introduced
-!--       by a not sufficient reduction of divergences near topography. 
-          div = ( ( ( u_comp     + gu )                                       &
-                                       * ( ibit18 + ibit19 + ibit20 )         &
-                  - ( u(k,j-1,i) + u(k,j,i) )                                 &
-                                       * ( IBITS(wall_flags_0(k,j,i-1),18,1)  &
-                                         + IBITS(wall_flags_0(k,j,i-1),19,1)  &
-                                         + IBITS(wall_flags_0(k,j,i-1),20,1)  &
-                                         )                                    &   
-                  ) * ddx                                                     &
-               +  ( v_comp(k)                                                 &
-                                       * ( ibit21 + ibit22 + ibit23 )         &
-                - ( v(k,j,i)     + v(k,j-1,i) )                               &
-                                       * ( IBITS(wall_flags_0(k,j-1,i),21,1)  &
-                                         + IBITS(wall_flags_0(k,j-1,i),22,1)  &
-                                         + IBITS(wall_flags_0(k,j-1,i),23,1)  &
-                                         )                                    &   
-                  ) * ddy                                                     &
-               +  ( w_comp                                                    &
-                                       * ( ibit24 + ibit25 + ibit26 )         &
-                - ( w(k-1,j-1,i) + w(k-1,j,i) )                               &
-                                       * ( IBITS(wall_flags_0(k-1,j,i),24,1)  &
-                                         + IBITS(wall_flags_0(k-1,j,i),25,1)  &
-                                         + IBITS(wall_flags_0(k-1,j,i),26,1)  &
-                                         )                                    &
-                   ) * ddzw(k)   &
-                ) * 0.5_wp
-
-
-          tend(k,j,i) = tend(k,j,i) - (                                       &
-                         ( flux_r(k) + diss_r(k)                              &
-                       -   flux_l_v(k,j,tn) - diss_l_v(k,j,tn)   ) * ddx      &
-                       + ( flux_n(k) + diss_n(k)                              &
-                       -   flux_s_v(k,tn) - diss_s_v(k,tn)       ) * ddy      &
-                       + ( flux_t(k) + diss_t(k)                              &
-                       -   flux_d    - diss_d                    ) * ddzw(k)  &
-                                      ) + v(k,j,i) * div
-
-           flux_l_v(k,j,tn) = flux_r(k)
-           diss_l_v(k,j,tn) = diss_r(k)
-           flux_s_v(k,tn)   = flux_n(k)
-           diss_s_v(k,tn)   = diss_n(k)
-           flux_d           = flux_t(k)
-           diss_d           = diss_t(k)
-
-!
-!--        Statistical Evaluation of v'v'. The factor has to be applied for
-!--        right evaluation when gallilei_trans = .T. .
-           sums_vs2_ws_l(k,tn) = sums_vs2_ws_l(k,tn)                          &
-             + ( flux_n(k)                                                    &
-             * ( v_comp(k) - 2.0_wp * hom(k,1,2,0)      )                     &
-             / ( v_comp(k) - gv + 1.0E-20_wp       )                          &
-             +   diss_n(k)                                                    &
-             *   ABS( v_comp(k) - 2.0_wp * hom(k,1,2,0) )                     &
-             / ( ABS( v_comp(k) - gv ) +1.0E-20_wp ) )                        &
-             *   weight_substep(intermediate_timestep_count)
-!
-!--        Statistical Evaluation of w'v'.
-           sums_wsvs_ws_l(k,tn) = sums_wsvs_ws_l(k,tn)                        &
-                              + ( flux_t(k) + diss_t(k) )                     &
-                              *   weight_substep(intermediate_timestep_count)
-
-       ENDDO
-
-       DO  k = nzb_max+1, nzt
-
-          u_comp    = u(k,j-1,i+1) + u(k,j,i+1) - gu
-          flux_r(k) = u_comp * (                                              &
-                      37.0_wp * ( v(k,j,i+1) + v(k,j,i)   )                   &
-                    -  8.0_wp * ( v(k,j,i+2) + v(k,j,i-1) )                   &
-                    +           ( v(k,j,i+3) + v(k,j,i-2) ) ) * adv_mom_5
-
-          diss_r(k) = - ABS( u_comp ) * (                                     &
-                      10.0_wp * ( v(k,j,i+1) - v(k,j,i) )                     &
-                    -  5.0_wp * ( v(k,j,i+2) - v(k,j,i-1) )                   &
-                    +           ( v(k,j,i+3) - v(k,j,i-2) ) ) * adv_mom_5
-
-
-          v_comp(k) = v(k,j+1,i) + v(k,j,i)
-          flux_n(k) = ( v_comp(k) - gv ) * (                                  &
-                      37.0_wp * ( v(k,j+1,i) + v(k,j,i)   )                   &
-                    -  8.0_wp * ( v(k,j+2,i) + v(k,j-1,i) )                   &
-                      +         ( v(k,j+3,i) + v(k,j-2,i) ) ) * adv_mom_5
-
-          diss_n(k) = - ABS( v_comp(k) - gv ) * (                             &
-                      10.0_wp * ( v(k,j+1,i) - v(k,j,i)   )                   &
-                    -  5.0_wp * ( v(k,j+2,i) - v(k,j-1,i) )                   &
-                    +           ( v(k,j+3,i) - v(k,j-2,i) ) ) * adv_mom_5
-!
-!--       k index has to be modified near bottom and top, else array
-!--       subscripts will be exceeded.
-          ibit26 = IBITS(wall_flags_0(k,j,i),26,1)
-          ibit25 = IBITS(wall_flags_0(k,j,i),25,1)
-          ibit24 = IBITS(wall_flags_0(k,j,i),24,1)
-
-          k_ppp = k + 3 * ibit26
-          k_pp  = k + 2 * ( 1 - ibit24  )
-          k_mm  = k - 2 * ibit26
-
-          w_comp    = w(k,j-1,i) + w(k,j,i)
-          flux_t(k) = w_comp  * (                                             &
-                     ( 37.0_wp * ibit26 * adv_mom_5                           &
-                  +     7.0_wp * ibit25 * adv_mom_3                           &
-                  +              ibit24 * adv_mom_1                           &
-                     ) *                                                      &
-                                ( v(k+1,j,i)   + v(k,j,i)    )                &
-              -      (  8.0_wp * ibit26 * adv_mom_5                           &
-                  +              ibit25 * adv_mom_3                           &
-                     ) *                                                      &
-                                ( v(k_pp,j,i)  + v(k-1,j,i)  )                &
-              +      (           ibit26 * adv_mom_5                           &
-                     ) *                                                      &
-                                ( v(k_ppp,j,i) + v(k_mm,j,i) )                &
-                                 )
-
-          diss_t(k) = - ABS( w_comp ) * (                                     &
-                     ( 10.0_wp * ibit26 * adv_mom_5                           &
-                  +     3.0_wp * ibit25 * adv_mom_3                           &
-                  +              ibit24 * adv_mom_1                           &
-                     ) *                                                      &
-                                ( v(k+1,j,i)   - v(k,j,i)    )                &
-              -      (  5.0_wp * ibit26 * adv_mom_5                           &
-                  +              ibit25 * adv_mom_3                           &
-                     ) *                                                      &
-                                ( v(k_pp,j,i)  - v(k-1,j,i)  )                &
-              +      (           ibit26 * adv_mom_5                           &
-                     ) *                                                      &
-                                ( v(k_ppp,j,i) - v(k_mm,j,i) )                &
-                                         )
-!
-!--       Calculate the divergence of the velocity field. A respective
-!--       correction is needed to overcome numerical instabilities introduced
-!--       by a not sufficient reduction of divergences near topography.
-          div = ( ( u_comp + gu - ( u(k,j-1,i)   + u(k,j,i)   ) ) * ddx       &
-               +  ( v_comp(k)   - ( v(k,j,i)     + v(k,j-1,i) ) ) * ddy       &
-               +  ( w_comp      - ( w(k-1,j-1,i) + w(k-1,j,i) ) ) * ddzw(k)   &
-                ) * 0.5_wp
-
-          tend(k,j,i) = tend(k,j,i) - (                                       &
-                         ( flux_r(k) + diss_r(k)                              &
-                       -   flux_l_v(k,j,tn) - diss_l_v(k,j,tn)   ) * ddx      &
-                       + ( flux_n(k) + diss_n(k)                              &
-                       -   flux_s_v(k,tn) - diss_s_v(k,tn)       ) * ddy      &
-                       + ( flux_t(k) + diss_t(k)                              &
-                       -   flux_d    - diss_d                    ) * ddzw(k)  &
-                                      ) + v(k,j,i) * div
-
-           flux_l_v(k,j,tn) = flux_r(k)
-           diss_l_v(k,j,tn) = diss_r(k)
-           flux_s_v(k,tn)   = flux_n(k)
-           diss_s_v(k,tn)   = diss_n(k)
-           flux_d           = flux_t(k)
-           diss_d           = diss_t(k)
-
-!
-!--        Statistical Evaluation of v'v'. The factor has to be applied for
-!--        right evaluation when gallilei_trans = .T. .
-           sums_vs2_ws_l(k,tn) = sums_vs2_ws_l(k,tn)                          &
-             + ( flux_n(k)                                                    &
-             * ( v_comp(k) - 2.0_wp * hom(k,1,2,0)      )                     &
-             / ( v_comp(k) - gv + 1.0E-20_wp       )                          &
-             +   diss_n(k)                                                    &
-             *   ABS( v_comp(k) - 2.0_wp * hom(k,1,2,0) )                     &
-             / ( ABS( v_comp(k) - gv ) +1.0E-20_wp ) )                        &
-             *   weight_substep(intermediate_timestep_count)
-!
-!--        Statistical Evaluation of w'v'.
-           sums_wsvs_ws_l(k,tn) = sums_wsvs_ws_l(k,tn)                        &
-                              + ( flux_t(k) + diss_t(k) )                     &
-                              *   weight_substep(intermediate_timestep_count)
-
-       ENDDO
-       sums_vs2_ws_l(nzb,tn) = sums_vs2_ws_l(nzb+1,tn)
-
-
-    END SUBROUTINE advec_v_ws_ij
-
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Advection of w-component - Call for grid point i,j
-!------------------------------------------------------------------------------!
-    SUBROUTINE advec_w_ws_ij( i, j, i_omp, tn )
-
-       USE arrays_3d,                                                         &
-           ONLY:  ddzu, diss_l_w, diss_s_w, flux_l_w, flux_s_w, tend, u, v, w
-
-       USE constants,                                                         &
-           ONLY:  adv_mom_1, adv_mom_3, adv_mom_5
-
-       USE control_parameters,                                                &
-           ONLY:  intermediate_timestep_count, u_gtrans, v_gtrans
-
-       USE grid_variables,                                                    &
-           ONLY:  ddx, ddy
-
-       USE indices,                                                           &
-           ONLY:  nxl, nxr, nyn, nys, nzb, nzb_max, nzt, wall_flags_0,        &
-                  wall_flags_00
-
-       USE kinds
-       
-       USE statistics,                                                        &
-           ONLY:  hom, sums_ws2_ws_l, weight_substep
-
-       IMPLICIT NONE
-
-       INTEGER(iwp) ::  i      !<
-       INTEGER(iwp) ::  ibit27 !<
-       INTEGER(iwp) ::  ibit28 !<
-       INTEGER(iwp) ::  ibit29 !<
-       INTEGER(iwp) ::  ibit30 !<
-       INTEGER(iwp) ::  ibit31 !<
-       INTEGER(iwp) ::  ibit32 !<
-       INTEGER(iwp) ::  ibit33 !<
-       INTEGER(iwp) ::  ibit34 !<
-       INTEGER(iwp) ::  ibit35 !<
-       INTEGER(iwp) ::  i_omp  !<
-       INTEGER(iwp) ::  j      !<
-       INTEGER(iwp) ::  k      !<
-       INTEGER(iwp) ::  k_mm   !<
-       INTEGER(iwp) ::  k_pp   !<
-       INTEGER(iwp) ::  k_ppp  !<
-       INTEGER(iwp) ::  tn     !<
-       
-       REAL(wp)    ::  diss_d  !<
-       REAL(wp)    ::  div     !<
-       REAL(wp)    ::  flux_d  !<
-       REAL(wp)    ::  gu      !<
-       REAL(wp)    ::  gv      !<
-       REAL(wp)    ::  u_comp  !<
-       REAL(wp)    ::  v_comp  !<
-       REAL(wp)    ::  w_comp  !<
-       
-       REAL(wp), DIMENSION(nzb:nzt+1)  ::  diss_n !<
-       REAL(wp), DIMENSION(nzb:nzt+1)  ::  diss_r !<
-       REAL(wp), DIMENSION(nzb:nzt+1)  ::  diss_t !<
-       REAL(wp), DIMENSION(nzb:nzt+1)  ::  flux_n !<
-       REAL(wp), DIMENSION(nzb:nzt+1)  ::  flux_r !<
-       REAL(wp), DIMENSION(nzb:nzt+1)  ::  flux_t !<
-
-       gu = 2.0_wp * u_gtrans
-       gv = 2.0_wp * v_gtrans
-
-!
-!--    Compute southside fluxes for the respective boundary.
-       IF ( j == nys )  THEN
-
-          DO  k = nzb+1, nzb_max
-             ibit32 = IBITS(wall_flags_00(k,j-1,i),0,1)
-             ibit31 = IBITS(wall_flags_0(k,j-1,i),31,1)
-             ibit30 = IBITS(wall_flags_0(k,j-1,i),30,1)
-
-             v_comp         = v(k+1,j,i) + v(k,j,i) - gv
-             flux_s_w(k,tn) = v_comp * (                                      &
-                            ( 37.0_wp * ibit32 * adv_mom_5                    &
-                         +     7.0_wp * ibit31 * adv_mom_3                    &
-                         +              ibit30 * adv_mom_1                    &
-                            ) *                                               &
-                                        ( w(k,j,i)   + w(k,j-1,i) )           &
-                     -      (  8.0_wp * ibit32 * adv_mom_5                    &
-                         +              ibit31 * adv_mom_3                    &
-                            ) *                                               &
-                                        ( w(k,j+1,i) + w(k,j-2,i) )           &
-                     +      (           ibit32 * adv_mom_5                    &
-                            ) *                                               &
-                                        ( w(k,j+2,i) + w(k,j-3,i) )           &
-                                       )
-
-             diss_s_w(k,tn) = - ABS( v_comp ) * (                             &
-                            ( 10.0_wp * ibit32 * adv_mom_5                    &
-                         +     3.0_wp * ibit31 * adv_mom_3                    &
-                         +              ibit30 * adv_mom_1                    &
-                            ) *                                               &
-                                        ( w(k,j,i)   - w(k,j-1,i) )           &
-                     -      (  5.0_wp * ibit32 * adv_mom_5                    &
-                         +              ibit31 * adv_mom_3                    &
-                            ) *                                               &
-                                        ( w(k,j+1,i) - w(k,j-2,i) )           &
-                     +      (           ibit32 * adv_mom_5                    &
-                            ) *                                               &
-                                        ( w(k,j+2,i) - w(k,j-3,i) )           &
-                                                )
-
-          ENDDO
-
-          DO  k = nzb_max+1, nzt
-
-             v_comp         = v(k+1,j,i) + v(k,j,i) - gv
-             flux_s_w(k,tn) = v_comp * (                                      &
-                           37.0_wp * ( w(k,j,i) + w(k,j-1,i)   )              &
-                         -  8.0_wp * ( w(k,j+1,i) +w(k,j-2,i)  )              &
-                         +           ( w(k,j+2,i) + w(k,j-3,i) ) ) * adv_mom_5
-             diss_s_w(k,tn) = - ABS( v_comp ) * (                             &
-                           10.0_wp * ( w(k,j,i) - w(k,j-1,i)   )              &
-                         -  5.0_wp * ( w(k,j+1,i) - w(k,j-2,i) )              &
-                         +           ( w(k,j+2,i) - w(k,j-3,i) ) ) * adv_mom_5
-
-          ENDDO
-
-       ENDIF
-!
-!--    Compute leftside fluxes for the respective boundary.
-       IF ( i == i_omp ) THEN
-
-          DO  k = nzb+1, nzb_max
-
-             ibit29 = IBITS(wall_flags_0(k,j,i-1),29,1)
-             ibit28 = IBITS(wall_flags_0(k,j,i-1),28,1)
-             ibit27 = IBITS(wall_flags_0(k,j,i-1),27,1)
-
-             u_comp           = u(k+1,j,i) + u(k,j,i) - gu
-             flux_l_w(k,j,tn) = u_comp * (                                    &
-                             ( 37.0_wp * ibit29 * adv_mom_5                   &
-                          +     7.0_wp * ibit28 * adv_mom_3                   &
-                          +              ibit27 * adv_mom_1                   &
-                             ) *                                              &
-                                        ( w(k,j,i)   + w(k,j,i-1) )           &
-                      -      (  8.0_wp * ibit29 * adv_mom_5                   &
-                          +              ibit28 * adv_mom_3                   &
-                             ) *                                              &
-                                        ( w(k,j,i+1) + w(k,j,i-2) )           &
-                      +      (           ibit29 * adv_mom_5                   &
-                             ) *                                              &
-                                        ( w(k,j,i+2) + w(k,j,i-3) )           &
-                                         )
-
-               diss_l_w(k,j,tn) = - ABS( u_comp ) * (                         &
-                             ( 10.0_wp * ibit29 * adv_mom_5                   &
-                          +     3.0_wp * ibit28 * adv_mom_3                   &
-                          +              ibit27 * adv_mom_1                   &
-                             ) *                                              &
-                                        ( w(k,j,i)   - w(k,j,i-1) )           &
-                      -      (  5.0_wp * ibit29 * adv_mom_5                   &
-                          +              ibit28 * adv_mom_3                   &
-                             ) *                                              &
-                                        ( w(k,j,i+1) - w(k,j,i-2) )           &
-                      +      (           ibit29 * adv_mom_5                   &
-                             ) *                                              &
-                                        ( w(k,j,i+2) - w(k,j,i-3) )           &
-                                                    )
-
-          ENDDO
-
-          DO  k = nzb_max+1, nzt
-
-             u_comp           = u(k+1,j,i) + u(k,j,i) - gu
-             flux_l_w(k,j,tn) = u_comp * (                                    &
-                            37.0_wp * ( w(k,j,i) + w(k,j,i-1)   )             &
-                          -  8.0_wp * ( w(k,j,i+1) + w(k,j,i-2) )             &
-                          +           ( w(k,j,i+2) + w(k,j,i-3) ) ) * adv_mom_5
-             diss_l_w(k,j,tn) = - ABS( u_comp ) * (                           &
-                            10.0_wp * ( w(k,j,i) - w(k,j,i-1)   )             &
-                          -  5.0_wp * ( w(k,j,i+1) - w(k,j,i-2) )             &
-                          +           ( w(k,j,i+2) - w(k,j,i-3) ) ) * adv_mom_5 
-
-          ENDDO
-
-       ENDIF
-!
-!--    The lower flux has to be calculated explicetely for the tendency at
-!--    the first w-level. For topography wall this is done implicitely by
-!--    wall_flags_0.
-       k         = nzb + 1
-       w_comp    = w(k,j,i) + w(k-1,j,i)
-       flux_t(0) = w_comp       * ( w(k,j,i) + w(k-1,j,i) ) * adv_mom_1
-       diss_t(0) = -ABS(w_comp) * ( w(k,j,i) - w(k-1,j,i) ) * adv_mom_1
-       flux_d    = flux_t(0)
-       diss_d    = diss_t(0)
-!
-!--    Now compute the fluxes and tendency terms for the horizontal
-!--    and vertical parts.
-       DO  k = nzb+1, nzb_max
-
-          ibit29 = IBITS(wall_flags_0(k,j,i),29,1)
-          ibit28 = IBITS(wall_flags_0(k,j,i),28,1)
-          ibit27 = IBITS(wall_flags_0(k,j,i),27,1)
-
-          u_comp    = u(k+1,j,i+1) + u(k,j,i+1) - gu
-          flux_r(k) = u_comp * (                                              &
-                     ( 37.0_wp * ibit29 * adv_mom_5                           &
-                  +     7.0_wp * ibit28 * adv_mom_3                           &
-                  +              ibit27 * adv_mom_1                           &
-                     ) *                                                      &
-                                    ( w(k,j,i+1) + w(k,j,i)   )               &
-              -      (  8.0_wp * ibit29 * adv_mom_5                           &
-                  +              ibit28 * adv_mom_3                           &
-                     ) *                                                      &
-                                    ( w(k,j,i+2) + w(k,j,i-1) )               &
-              +      (           ibit29 * adv_mom_5                           &
-                     ) *                                                      &
-                                    ( w(k,j,i+3) + w(k,j,i-2) )               &
-                               )
-
-          diss_r(k) = - ABS( u_comp ) * (                                     &
-                     ( 10.0_wp * ibit29 * adv_mom_5                           &
-                  +     3.0_wp * ibit28 * adv_mom_3                           &
-                  +              ibit27 * adv_mom_1                           &
-                     ) *                                                      &
-                                    ( w(k,j,i+1) - w(k,j,i)   )               &
-              -      (  5.0_wp * ibit29 * adv_mom_5                           &
-                  +              ibit28 * adv_mom_3                           &
-                     ) *                                                      &
-                                    ( w(k,j,i+2) - w(k,j,i-1) )               &
-              +      (           ibit29 * adv_mom_5                           &
-                     ) *                                                      &
-                                    ( w(k,j,i+3) - w(k,j,i-2) )               &
-                                        )
-
-          ibit32 = IBITS(wall_flags_00(k,j,i),0,1)
-          ibit31 = IBITS(wall_flags_0(k,j,i),31,1)
-          ibit30 = IBITS(wall_flags_0(k,j,i),30,1)
-
-          v_comp    = v(k+1,j+1,i) + v(k,j+1,i) - gv
-          flux_n(k) = v_comp * (                                              &
-                     ( 37.0_wp * ibit32 * adv_mom_5                           &
-                  +     7.0_wp * ibit31 * adv_mom_3                           &
-                  +              ibit30 * adv_mom_1                           &
-                     ) *                                                      &
-                                    ( w(k,j+1,i) + w(k,j,i)   )               &
-              -      (  8.0_wp * ibit32 * adv_mom_5                           &
-                  +              ibit31 * adv_mom_3                           &
-                     ) *                                                      &
-                                    ( w(k,j+2,i) + w(k,j-1,i) )               &
-              +      (           ibit32 * adv_mom_5                           &
-                     ) *                                                      &
-                                    ( w(k,j+3,i) + w(k,j-2,i) )               &
-                               )
-
-          diss_n(k) = - ABS( v_comp ) * (                                     &
-                     ( 10.0_wp * ibit32 * adv_mom_5                           &
-                  +     3.0_wp * ibit31 * adv_mom_3                           &
-                  +              ibit30 * adv_mom_1                           &
-                     ) *                                                      &
-                                    ( w(k,j+1,i) - w(k,j,i)  )                &
-              -      (  5.0_wp * ibit32 * adv_mom_5                           &
-                  +              ibit31 * adv_mom_3                           &
-                     ) *                                                      &
-                                   ( w(k,j+2,i) - w(k,j-1,i) )                &
-              +      (           ibit32 * adv_mom_5                           &
-                     ) *                                                      &
-                                   ( w(k,j+3,i) - w(k,j-2,i) )                &
-                                        )
-!
-!--       k index has to be modified near bottom and top, else array
-!--       subscripts will be exceeded.
-          ibit35 = IBITS(wall_flags_00(k,j,i),3,1)
-          ibit34 = IBITS(wall_flags_00(k,j,i),2,1)
-          ibit33 = IBITS(wall_flags_00(k,j,i),1,1)
-
-          k_ppp = k + 3 * ibit35
-          k_pp  = k + 2 * ( 1 - ibit33  )
-          k_mm  = k - 2 * ibit35
-
-          w_comp    = w(k+1,j,i) + w(k,j,i)
-          flux_t(k) = w_comp  * (                                             &
-                     ( 37.0_wp * ibit35 * adv_mom_5                           &
-                  +     7.0_wp * ibit34 * adv_mom_3                           &
-                  +              ibit33 * adv_mom_1                           &
-                     ) *                                                      &
-                                ( w(k+1,j,i)  + w(k,j,i)     )                &
-              -      (  8.0_wp * ibit35 * adv_mom_5                           &
-                  +              ibit34 * adv_mom_3                           &
-                     ) *                                                      &
-                                ( w(k_pp,j,i)  + w(k-1,j,i)  )                &
-              +      (           ibit35 * adv_mom_5                           &
-                     ) *                                                      &
-                                ( w(k_ppp,j,i) + w(k_mm,j,i) )                &
-                                )
-
-          diss_t(k) = - ABS( w_comp ) * (                                     &
-                     ( 10.0_wp * ibit35 * adv_mom_5                           &
-                  +     3.0_wp * ibit34 * adv_mom_3                           &
-                  +              ibit33 * adv_mom_1                           &
-                     ) *                                                      &
-                                ( w(k+1,j,i)   - w(k,j,i)    )                &
-              -      (  5.0_wp * ibit35 * adv_mom_5                           &
-                  +              ibit34 * adv_mom_3                           &
-                     ) *                                                      &
-                                ( w(k_pp,j,i)  - w(k-1,j,i)  )                &
-              +      (           ibit35 * adv_mom_5                           &
-                     ) *                                                      &
-                                ( w(k_ppp,j,i) - w(k_mm,j,i) )                &
-                                        )
-
-!
-!--       Calculate the divergence of the velocity field. A respective
-!--       correction is needed to overcome numerical instabilities introduced
-!--       by a not sufficient reduction of divergences near topography. 
-          div = ( ( ( u_comp + gu ) * ( ibit27 + ibit28 + ibit29 )            &
-                  - ( u(k+1,j,i) + u(k,j,i)   )                               & 
-                                    * ( IBITS(wall_flags_0(k,j,i-1),27,1)     &
-                                      + IBITS(wall_flags_0(k,j,i-1),28,1)     &
-                                      + IBITS(wall_flags_0(k,j,i-1),29,1)     &
-                                      )                                       &
-                  ) * ddx                                                     &
-              +   ( ( v_comp + gv ) * ( ibit30 + ibit31 + ibit32 )            & 
-                  - ( v(k+1,j,i) + v(k,j,i)   )                               &
-                                    * ( IBITS(wall_flags_0(k,j-1,i),30,1)     &
-                                      + IBITS(wall_flags_0(k,j-1,i),31,1)     &
-                                      + IBITS(wall_flags_00(k,j-1,i),0,1)     &
-                                      )                                       &
-                  ) * ddy                                                     &
-              +   ( w_comp          * ( ibit33 + ibit34 + ibit35 )            &
-                - ( w(k,j,i)   + w(k-1,j,i)   )                               &
-                                    * ( IBITS(wall_flags_00(k-1,j,i),1,1)     &
-                                      + IBITS(wall_flags_00(k-1,j,i),2,1)     &
-                                      + IBITS(wall_flags_00(k-1,j,i),3,1)     &
-                                      )                                       & 
-                  ) * ddzu(k+1)   &
-                ) * 0.5_wp
-
-
-          tend(k,j,i) = tend(k,j,i) - (                                       &
-                      ( flux_r(k) + diss_r(k)                                 &
-                    -   flux_l_w(k,j,tn) - diss_l_w(k,j,tn)   ) * ddx         &
-                    + ( flux_n(k) + diss_n(k)                                 &
-                    -   flux_s_w(k,tn) - diss_s_w(k,tn)       ) * ddy         &
-                    + ( flux_t(k) + diss_t(k)                                 &
-                    -   flux_d    - diss_d                    ) * ddzu(k+1)   &
-                                      ) + div * w(k,j,i)
-
-          flux_l_w(k,j,tn) = flux_r(k)
-          diss_l_w(k,j,tn) = diss_r(k)
-          flux_s_w(k,tn)   = flux_n(k)
-          diss_s_w(k,tn)   = diss_n(k)
-          flux_d           = flux_t(k)
-          diss_d           = diss_t(k)
-!
-!--        Statistical Evaluation of w'w'.
-          sums_ws2_ws_l(k,tn)  = sums_ws2_ws_l(k,tn)                          &
-                             + ( flux_t(k) + diss_t(k) )                      &
-                             *   weight_substep(intermediate_timestep_count)
-
-       ENDDO
-
-       DO  k = nzb_max+1, nzt
-
-          u_comp    = u(k+1,j,i+1) + u(k,j,i+1) - gu
-          flux_r(k) = u_comp * (                                              &
-                      37.0_wp * ( w(k,j,i+1) + w(k,j,i)   )                   &
-                    -  8.0_wp * ( w(k,j,i+2) + w(k,j,i-1) )                   &
-                    +           ( w(k,j,i+3) + w(k,j,i-2) ) ) * adv_mom_5
-
-          diss_r(k) = - ABS( u_comp ) * (                                     &
-                      10.0_wp * ( w(k,j,i+1) - w(k,j,i)   )                   &
-                    -  5.0_wp * ( w(k,j,i+2) - w(k,j,i-1) )                   &
-                    +           ( w(k,j,i+3) - w(k,j,i-2) ) ) * adv_mom_5
-
-          v_comp    = v(k+1,j+1,i) + v(k,j+1,i) - gv
-          flux_n(k) = v_comp * (                                              &
-                      37.0_wp * ( w(k,j+1,i) + w(k,j,i)   )                   &
-                    -  8.0_wp * ( w(k,j+2,i) + w(k,j-1,i) )                   &
-                    +           ( w(k,j+3,i) + w(k,j-2,i) ) ) * adv_mom_5
-
-          diss_n(k) = - ABS( v_comp ) * (                                     &
-                      10.0_wp * ( w(k,j+1,i) - w(k,j,i)   )                   &
-                    -  5.0_wp * ( w(k,j+2,i) - w(k,j-1,i) )                   &
-                    +           ( w(k,j+3,i) - w(k,j-2,i) ) ) * adv_mom_5
-!
-!--       k index has to be modified near bottom and top, else array
-!--       subscripts will be exceeded.
-          ibit35 = IBITS(wall_flags_00(k,j,i),3,1)
-          ibit34 = IBITS(wall_flags_00(k,j,i),2,1)
-          ibit33 = IBITS(wall_flags_00(k,j,i),1,1)
-
-          k_ppp = k + 3 * ibit35
-          k_pp  = k + 2 * ( 1 - ibit33  )
-          k_mm  = k - 2 * ibit35
-
-          w_comp    = w(k+1,j,i) + w(k,j,i)
-          flux_t(k) = w_comp  * (                                             &
-                     ( 37.0_wp * ibit35 * adv_mom_5                           &
-                  +     7.0_wp * ibit34 * adv_mom_3                           &
-                  +              ibit33 * adv_mom_1                           &
-                     ) *                                                      &
-                                ( w(k+1,j,i)  + w(k,j,i)     )                &
-              -      (  8.0_wp * ibit35 * adv_mom_5                           &
-                  +              ibit34 * adv_mom_3                           &
-                     ) *                                                      &
-                                ( w(k_pp,j,i)  + w(k-1,j,i)  )                &
-              +      (           ibit35 * adv_mom_5                           &
-                     ) *                                                      &
-                                ( w(k_ppp,j,i) + w(k_mm,j,i) )                &
-                                )
-
-          diss_t(k) = - ABS( w_comp ) * (                                     &
-                     ( 10.0_wp * ibit35 * adv_mom_5                           &
-                  +     3.0_wp * ibit34 * adv_mom_3                           &
-                  +              ibit33 * adv_mom_1                           &
-                     ) *                                                      &
-                                ( w(k+1,j,i)   - w(k,j,i)    )                &
-              -      (  5.0_wp * ibit35 * adv_mom_5                           &
-                  +              ibit34 * adv_mom_3                           &
-                     ) *                                                      &
-                                ( w(k_pp,j,i)  - w(k-1,j,i)  )                &
-              +      (           ibit35 * adv_mom_5                           &
-                     ) *                                                      &
-                                ( w(k_ppp,j,i) - w(k_mm,j,i) )                &
-                                        )
-!
-!--       Calculate the divergence of the velocity field. A respective
-!--       correction is needed to overcome numerical instabilities introduced
-!--       by a not sufficient reduction of divergences near topography.
-          div = ( ( u_comp + gu - ( u(k+1,j,i) + u(k,j,i)   ) ) * ddx         &
-              +   ( v_comp + gv - ( v(k+1,j,i) + v(k,j,i)   ) ) * ddy         &
-              +   ( w_comp      - ( w(k,j,i)   + w(k-1,j,i) ) ) * ddzu(k+1)   &
-                ) * 0.5_wp
-
-          tend(k,j,i) = tend(k,j,i) - (                                       &
-                      ( flux_r(k) + diss_r(k)                                 &
-                    -   flux_l_w(k,j,tn) - diss_l_w(k,j,tn)   ) * ddx         &
-                    + ( flux_n(k) + diss_n(k)                                 &
-                    -   flux_s_w(k,tn) - diss_s_w(k,tn)       ) * ddy         &
-                    + ( flux_t(k) + diss_t(k)                                 &
-                    -   flux_d    - diss_d                    ) * ddzu(k+1)   &
-                                      ) + div * w(k,j,i)
-
-          flux_l_w(k,j,tn) = flux_r(k)
-          diss_l_w(k,j,tn) = diss_r(k)
-          flux_s_w(k,tn)   = flux_n(k)
-          diss_s_w(k,tn)   = diss_n(k)
-          flux_d           = flux_t(k)
-          diss_d           = diss_t(k)
-!
-!--        Statistical Evaluation of w'w'.
-          sums_ws2_ws_l(k,tn)  = sums_ws2_ws_l(k,tn)                          &
-                             + ( flux_t(k) + diss_t(k) )                      &
-                             *   weight_substep(intermediate_timestep_count)
-
-       ENDDO
-
-
-    END SUBROUTINE advec_w_ws_ij
-    
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Scalar advection - Call for all grid points
-!------------------------------------------------------------------------------!
-    SUBROUTINE advec_s_ws( sk, sk_char )
-
-       USE arrays_3d,                                                         &
-           ONLY:  ddzw, tend, u, v, w
-
-       USE constants,                                                         &
-           ONLY:  adv_sca_1, adv_sca_3, adv_sca_5
-
-       USE control_parameters,                                                &
-           ONLY:  intermediate_timestep_count, monotonic_adjustment, u_gtrans,&
-                  v_gtrans 
-
-       USE grid_variables,                                                    &
-           ONLY:  ddx, ddy
-
-       USE indices,                                                           &
-           ONLY:  nxl, nxlg, nxr, nxrg, nyn, nyng, nys, nysg, nzb, nzb_max,   &
-                  nzt, wall_flags_0
-           
-       USE kinds
-       
-       USE statistics,                                                        &
-           ONLY:  sums_wspts_ws_l, sums_wsqs_ws_l, sums_wssas_ws_l,           &
-                  sums_wsqrs_ws_l, sums_wsnrs_ws_l, weight_substep
-
-       IMPLICIT NONE
-
-       CHARACTER (LEN = *), INTENT(IN)    ::  sk_char !<
-       
-       INTEGER(iwp) ::  i      !<
-       INTEGER(iwp) ::  ibit0  !<
-       INTEGER(iwp) ::  ibit1  !<
-       INTEGER(iwp) ::  ibit2  !<
-       INTEGER(iwp) ::  ibit3  !<
-       INTEGER(iwp) ::  ibit4  !<
-       INTEGER(iwp) ::  ibit5  !<
-       INTEGER(iwp) ::  ibit6  !<
-       INTEGER(iwp) ::  ibit7  !<
-       INTEGER(iwp) ::  ibit8  !<
-       INTEGER(iwp) ::  j      !<
-       INTEGER(iwp) ::  k      !<
-       INTEGER(iwp) ::  k_mm   !<
-       INTEGER(iwp) ::  k_mmm  !<
-       INTEGER(iwp) ::  k_pp   !<
-       INTEGER(iwp) ::  k_ppp  !<
-       INTEGER(iwp) ::  tn = 0 !<
-       
-#if defined( __nopointer )
-       REAL(wp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ::  sk !<
-#else
-       REAL(wp), DIMENSION(:,:,:), POINTER ::  sk !<
-#endif
-
-       REAL(wp) ::  diss_d !<
-       REAL(wp) ::  div    !<
-       REAL(wp) ::  flux_d !<
-       REAL(wp) ::  fd_1   !<
-       REAL(wp) ::  fl_1   !<
-       REAL(wp) ::  fn_1   !<
-       REAL(wp) ::  fr_1   !<
-       REAL(wp) ::  fs_1   !<
-       REAL(wp) ::  ft_1   !<
-       REAL(wp) ::  phi_d  !<
-       REAL(wp) ::  phi_l  !<
-       REAL(wp) ::  phi_n  !<
-       REAL(wp) ::  phi_r  !<
-       REAL(wp) ::  phi_s  !<
-       REAL(wp) ::  phi_t  !<
-       REAL(wp) ::  rd     !<
-       REAL(wp) ::  rl     !<
-       REAL(wp) ::  rn     !<
-       REAL(wp) ::  rr     !<
-       REAL(wp) ::  rs     !<
-       REAL(wp) ::  rt     !<
-       REAL(wp) ::  u_comp !<
-       REAL(wp) ::  v_comp !<
-       
-       REAL(wp), DIMENSION(nzb:nzt)   ::  diss_n !<
-       REAL(wp), DIMENSION(nzb:nzt)   ::  diss_r !<
-       REAL(wp), DIMENSION(nzb:nzt)   ::  diss_t !<
-       REAL(wp), DIMENSION(nzb:nzt)   ::  flux_n !<
-       REAL(wp), DIMENSION(nzb:nzt)   ::  flux_r !<
-       REAL(wp), DIMENSION(nzb:nzt)   ::  flux_t !<
-       
-       REAL(wp), DIMENSION(nzb+1:nzt) ::  swap_diss_y_local !<
-       REAL(wp), DIMENSION(nzb+1:nzt) ::  swap_flux_y_local !<
-       
-       REAL(wp), DIMENSION(nzb+1:nzt,nys:nyn) ::  swap_diss_x_local !<
-       REAL(wp), DIMENSION(nzb+1:nzt,nys:nyn) ::  swap_flux_x_local !<
-        
-
-!
-!--    Compute the fluxes for the whole left boundary of the processor domain.
-       i = nxl
-       DO  j = nys, nyn
-
-          DO  k = nzb+1, nzb_max
-
-             ibit2 = IBITS(wall_flags_0(k,j,i-1),2,1)
-             ibit1 = IBITS(wall_flags_0(k,j,i-1),1,1)
-             ibit0 = IBITS(wall_flags_0(k,j,i-1),0,1)
-
-             u_comp                 = u(k,j,i) - u_gtrans
-             swap_flux_x_local(k,j) = u_comp * (                              &
-                                             ( 37.0_wp * ibit2 * adv_sca_5    &
-                                          +     7.0_wp * ibit1 * adv_sca_3    &
-                                          +              ibit0 * adv_sca_1    &
-                                             ) *                              &
-                                          ( sk(k,j,i)   + sk(k,j,i-1)    )    &
-                                      -      (  8.0_wp * ibit2 * adv_sca_5    &
-                                          +              ibit1 * adv_sca_3    &
-                                             ) *                              &
-                                          ( sk(k,j,i+1) + sk(k,j,i-2)    )    &
-                                      +      (           ibit2 * adv_sca_5    & 
-                                             ) *                              &
-                                          ( sk(k,j,i+2) + sk(k,j,i-3)    )    &
-                                               )
-
-              swap_diss_x_local(k,j) = -ABS( u_comp ) * (                     &
-                                             ( 10.0_wp * ibit2 * adv_sca_5    &
-                                          +     3.0_wp * ibit1 * adv_sca_3    &
-                                          +              ibit0 * adv_sca_1    &
-                                             ) *                              &
-                                          ( sk(k,j,i)   - sk(k,j,i-1) )       &
-                                      -      (  5.0_wp * ibit2 * adv_sca_5    &
-                                          +              ibit1 * adv_sca_3    &
-                                             ) *                              &
-                                         ( sk(k,j,i+1) - sk(k,j,i-2)  )       &
-                                      +      (           ibit2 * adv_sca_5    &
-                                             ) *                              &
-                                          ( sk(k,j,i+2) - sk(k,j,i-3) )       &
-                                                        )
-
-          ENDDO
-
-          DO  k = nzb_max+1, nzt
-
-             u_comp                 = u(k,j,i) - u_gtrans
-             swap_flux_x_local(k,j) = u_comp * (                              &
-                                      37.0_wp * ( sk(k,j,i)   + sk(k,j,i-1) ) &
-                                    -  8.0_wp * ( sk(k,j,i+1) + sk(k,j,i-2) ) &
-                                    +           ( sk(k,j,i+2) + sk(k,j,i-3) ) &
-                                               ) * adv_sca_5
-
-             swap_diss_x_local(k,j) = -ABS( u_comp ) * (                      &
-                                      10.0_wp * ( sk(k,j,i)   - sk(k,j,i-1) ) &
-                                    -  5.0_wp * ( sk(k,j,i+1) - sk(k,j,i-2) ) &
-                                    +           ( sk(k,j,i+2) - sk(k,j,i-3) ) &
-                                                       ) * adv_sca_5
-
-          ENDDO
-
-       ENDDO
-
-       DO  i = nxl, nxr
-
-          j = nys
-          DO  k = nzb+1, nzb_max
-
-             ibit5 = IBITS(wall_flags_0(k,j-1,i),5,1)
-             ibit4 = IBITS(wall_flags_0(k,j-1,i),4,1)
-             ibit3 = IBITS(wall_flags_0(k,j-1,i),3,1)
-
-             v_comp               = v(k,j,i) - v_gtrans
-             swap_flux_y_local(k) = v_comp * (                                &
-                                             ( 37.0_wp * ibit5 * adv_sca_5    &
-                                          +     7.0_wp * ibit4 * adv_sca_3    &
-                                          +              ibit3 * adv_sca_1    &
-                                             ) *                              &
-                                         ( sk(k,j,i)  + sk(k,j-1,i)     )     &
-                                       -     (  8.0_wp * ibit5 * adv_sca_5    &
-                                          +              ibit4 * adv_sca_3    &
-                                              ) *                             &
-                                         ( sk(k,j+1,i) + sk(k,j-2,i)    )     &
-                                      +      (           ibit5 * adv_sca_5    &
-                                             ) *                              &
-                                        ( sk(k,j+2,i) + sk(k,j-3,i)     )     &
-                                             )
-
-             swap_diss_y_local(k) = -ABS( v_comp ) * (                        &
-                                             ( 10.0_wp * ibit5 * adv_sca_5    &
-                                          +     3.0_wp * ibit4 * adv_sca_3    &
-                                          +              ibit3 * adv_sca_1    &
-                                             ) *                              &
-                                          ( sk(k,j,i)   - sk(k,j-1,i)    )    &
-                                      -      (  5.0_wp * ibit5 * adv_sca_5    &
-                                          +              ibit4 * adv_sca_3    &
-                                             ) *                              &
-                                          ( sk(k,j+1,i) - sk(k,j-2,i)    )    &
-                                      +      (           ibit5 * adv_sca_5    &
-                                             ) *                              &
-                                          ( sk(k,j+2,i) - sk(k,j-3,i)    )    &
-                                                     )
-
-          ENDDO
-!
-!--       Above to the top of the highest topography. No degradation necessary.
-          DO  k = nzb_max+1, nzt
-
-             v_comp               = v(k,j,i) - v_gtrans
-             swap_flux_y_local(k) = v_comp * (                               &
-                                    37.0_wp * ( sk(k,j,i)   + sk(k,j-1,i) )  &
-                                  -  8.0_wp * ( sk(k,j+1,i) + sk(k,j-2,i) )  &
-                                  +           ( sk(k,j+2,i) + sk(k,j-3,i) )  &
-                                             ) * adv_sca_5
-              swap_diss_y_local(k) = -ABS( v_comp ) * (                      &
-                                    10.0_wp * ( sk(k,j,i)   - sk(k,j-1,i) )  &
-                                  -  5.0_wp * ( sk(k,j+1,i) - sk(k,j-2,i) )  &
-                                  +             sk(k,j+2,i) - sk(k,j-3,i)    &
-                                                      ) * adv_sca_5
-
-          ENDDO
-
-          DO  j = nys, nyn
-
-             flux_t(0) = 0.0_wp
-             diss_t(0) = 0.0_wp
-             flux_d    = 0.0_wp
-             diss_d    = 0.0_wp
-
-             DO  k = nzb+1, nzb_max
-
-                ibit2 = IBITS(wall_flags_0(k,j,i),2,1)
-                ibit1 = IBITS(wall_flags_0(k,j,i),1,1)
-                ibit0 = IBITS(wall_flags_0(k,j,i),0,1)
-
-                u_comp    = u(k,j,i+1) - u_gtrans
-                flux_r(k) = u_comp * (                                        &
-                          ( 37.0_wp * ibit2 * adv_sca_5                       &
-                      +      7.0_wp * ibit1 * adv_sca_3                       &
-                      +               ibit0 * adv_sca_1                       &
-                          ) *                                                 &
-                             ( sk(k,j,i+1) + sk(k,j,i)   )                    &
-                   -      (  8.0_wp * ibit2 * adv_sca_5                       &
-                       +              ibit1 * adv_sca_3                       &
-                          ) *                                                 &
-                             ( sk(k,j,i+2) + sk(k,j,i-1) )                    &
-                   +      (           ibit2 * adv_sca_5                       &
-                          ) *                                                 &
-                             ( sk(k,j,i+3) + sk(k,j,i-2) )                    &
-                                     )
-
-                diss_r(k) = -ABS( u_comp ) * (                                &
-                          ( 10.0_wp * ibit2 * adv_sca_5                       &
-                       +     3.0_wp * ibit1 * adv_sca_3                       &
-                       +              ibit0 * adv_sca_1                       &
-                          ) *                                                 &
-                             ( sk(k,j,i+1) - sk(k,j,i)   )                    &
-                   -      (  5.0_wp * ibit2 * adv_sca_5                       &
-                       +              ibit1 * adv_sca_3                       &
-                          ) *                                                 &
-                             ( sk(k,j,i+2) - sk(k,j,i-1) )                    &
-                   +      (           ibit2 * adv_sca_5                       &
-                          ) *                                                 &
-                             ( sk(k,j,i+3) - sk(k,j,i-2) )                    &
-                                             )
-
-                ibit5 = IBITS(wall_flags_0(k,j,i),5,1)
-                ibit4 = IBITS(wall_flags_0(k,j,i),4,1)
-                ibit3 = IBITS(wall_flags_0(k,j,i),3,1)
-
-                v_comp    = v(k,j+1,i) - v_gtrans
-                flux_n(k) = v_comp * (                                        &
-                          ( 37.0_wp * ibit5 * adv_sca_5                       &
-                       +     7.0_wp * ibit4 * adv_sca_3                       &
-                       +              ibit3 * adv_sca_1                       &
-                          ) *                                                 &
-                             ( sk(k,j+1,i) + sk(k,j,i)   )                    &
-                   -      (  8.0_wp * ibit5 * adv_sca_5                       &
-                       +              ibit4 * adv_sca_3                       &
-                          ) *                                                 &
-                             ( sk(k,j+2,i) + sk(k,j-1,i) )                    &
-                   +      (           ibit5 * adv_sca_5                       &
-                          ) *                                                 &
-                             ( sk(k,j+3,i) + sk(k,j-2,i) )                    &
-                                     )
-
-                diss_n(k) = -ABS( v_comp ) * (                                &
-                          ( 10.0_wp * ibit5 * adv_sca_5                       &
-                       +     3.0_wp * ibit4 * adv_sca_3                       &
-                       +              ibit3 * adv_sca_1                       &
-                          ) *                                                 &
-                             ( sk(k,j+1,i) - sk(k,j,i)    )                   &
-                   -      (  5.0_wp * ibit5 * adv_sca_5                       &
-                       +              ibit4 * adv_sca_3                       &
-                          ) *                                                 &
-                             ( sk(k,j+2,i) - sk(k,j-1,i)  )                   &
-                   +      (           ibit5 * adv_sca_5                       &
-                          ) *                                                 &
-                             ( sk(k,j+3,i) - sk(k,j-2,i) )                    &
-                                             )
-!
-!--             k index has to be modified near bottom and top, else array
-!--             subscripts will be exceeded.
-                ibit8 = IBITS(wall_flags_0(k,j,i),8,1)
-                ibit7 = IBITS(wall_flags_0(k,j,i),7,1)
-                ibit6 = IBITS(wall_flags_0(k,j,i),6,1)
-
-                k_ppp = k + 3 * ibit8
-                k_pp  = k + 2 * ( 1 - ibit6  )
-                k_mm  = k - 2 * ibit8
-
-
-                flux_t(k) = w(k,j,i) * (                                      &
-                           ( 37.0_wp * ibit8 * adv_sca_5                      &
-                        +     7.0_wp * ibit7 * adv_sca_3                      &
-                        +           ibit6 * adv_sca_1                         &
-                           ) *                                                &
-                                   ( sk(k+1,j,i)  + sk(k,j,i)    )            &
-                    -      (  8.0_wp * ibit8 * adv_sca_5                      &
-                        +              ibit7 * adv_sca_3                      &
-                           ) *                                                &
-                                   ( sk(k_pp,j,i) + sk(k-1,j,i)  )            &
-                    +      (           ibit8 * adv_sca_5                      &
-                           ) *     ( sk(k_ppp,j,i)+ sk(k_mm,j,i) )            &
-                                       )
-
-                diss_t(k) = -ABS( w(k,j,i) ) * (                              &
-                           ( 10.0_wp * ibit8 * adv_sca_5                      &
-                        +     3.0_wp * ibit7 * adv_sca_3                      &
-                        +              ibit6 * adv_sca_1                      &
-                           ) *                                                &
-                                   ( sk(k+1,j,i)   - sk(k,j,i)    )           &
-                    -      (  5.0_wp * ibit8 * adv_sca_5                      &
-                        +              ibit7 * adv_sca_3                      &
-                           ) *                                                &
-                                   ( sk(k_pp,j,i)  - sk(k-1,j,i)  )           &
-                    +      (           ibit8 * adv_sca_5                      &
-                           ) *                                                &
-                                   ( sk(k_ppp,j,i) - sk(k_mm,j,i) )           &
-                                               )
-!
-!--             Apply monotonic adjustment.
-                IF ( monotonic_adjustment )  THEN
-!
-!--                At first, calculate first order fluxes.
-                   u_comp = u(k,j,i) - u_gtrans
-                   fl_1   =  ( u_comp   * ( sk(k,j,i) + sk(k,j,i-1) )         &
-                         -ABS( u_comp ) * ( sk(k,j,i) - sk(k,j,i-1) )         &
-                             ) * adv_sca_1 
-
-                   u_comp = u(k,j,i+1) - u_gtrans
-                   fr_1   =  ( u_comp   * ( sk(k,j,i+1) + sk(k,j,i) )         &
-                         -ABS( u_comp ) * ( sk(k,j,i+1) - sk(k,j,i) )         &
-                             ) * adv_sca_1 
-
-                   v_comp = v(k,j,i) - v_gtrans
-                   fs_1   =  ( v_comp   * ( sk(k,j,i) + sk(k,j-1,i) )         &
-                         -ABS( v_comp ) * ( sk(k,j,i) - sk(k,j-1,i) )         &
-                             ) * adv_sca_1 
-
-                   v_comp = v(k,j+1,i) - v_gtrans
-                   fn_1   =  ( v_comp   * ( sk(k,j+1,i) + sk(k,j,i) )         &
-                         -ABS( v_comp ) * ( sk(k,j+1,i) - sk(k,j,i) )         &
-                             ) * adv_sca_1 
-
-                   fd_1   = (  w(k-1,j,i)   * ( sk(k,j,i) + sk(k-1,j,i) )     &
-                         -ABS( w(k-1,j,i) ) * ( sk(k,j,i) - sk(k-1,j,i) )     &
-                            ) * adv_sca_1 
-
-                   ft_1   = (  w(k,j,i)   * ( sk(k+1,j,i) + sk(k,j,i) )       &
-                         -ABS( w(k,j,i) ) * ( sk(k+1,j,i) - sk(k,j,i) )       &
-                            ) * adv_sca_1 
-!
-!--                Calculate ratio of upwind gradients. Note, Min/Max is just
-!--                to avoid if statements.
-                   rl     = ( MAX( 0.0_wp, u(k,j,i) - u_gtrans ) *            & 
-                               ABS( ( sk(k,j,i-1) - sk(k,j,i-2)            ) /&
-                                    ( sk(k,j,i)   - sk(k,j,i-1) + 1E-20_wp )  &
-                                  ) +                                         & 
-                              MIN( 0.0_wp, u(k,j,i) - u_gtrans ) *            &
-                               ABS( ( sk(k,j,i)   - sk(k,j,i+1)            ) /&
-                                    ( sk(k,j,i-1) - sk(k,j,i)   + 1E-20_wp )  &
-                                  )                                           &
-                            ) / ABS( u(k,j,i) - u_gtrans + 1E-20_wp )
-
-                   rr     = ( MAX( 0.0_wp, u(k,j,i+1) - u_gtrans ) *          & 
-                               ABS( ( sk(k,j,i)   - sk(k,j,i-1)            ) /&
-                                    ( sk(k,j,i+1) - sk(k,j,i)   + 1E-20_wp )  &
-                                  ) +                                         & 
-                              MIN( 0.0_wp, u(k,j,i+1) - u_gtrans ) *          &
-                               ABS( ( sk(k,j,i+1) - sk(k,j,i+2)            ) /&
-                                    ( sk(k,j,i)   - sk(k,j,i+1) + 1E-20_wp )  &
-                                  )                                           &
-                            ) / ABS( u(k,j,i+1) - u_gtrans + 1E-20_wp )
-
-                   rs     = ( MAX( 0.0_wp, v(k,j,i) - v_gtrans ) *            & 
-                               ABS( ( sk(k,j-1,i) - sk(k,j-2,i)            ) /&
-                                    ( sk(k,j,i)   - sk(k,j-1,i) + 1E-20_wp )  &
-                                  ) +                                         & 
-                              MIN( 0.0_wp, v(k,j,i) - v_gtrans ) *            &
-                               ABS( ( sk(k,j,i)   - sk(k,j+1,i)            ) /&
-                                    ( sk(k,j-1,i) - sk(k,j,i)   + 1E-20_wp )  &
-                                  )                                           &
-                            ) / ABS( v(k,j,i) - v_gtrans + 1E-20_wp )
-
-                   rn     = ( MAX( 0.0_wp, v(k,j+1,i) - v_gtrans ) *          & 
-                               ABS( ( sk(k,j,i)   - sk(k,j-1,i)            ) /&
-                                    ( sk(k,j+1,i) - sk(k,j,i)   + 1E-20_wp )  &
-                                  ) +                                         & 
-                              MIN( 0.0_wp, v(k,j+1,i) - v_gtrans ) *          &
-                               ABS( ( sk(k,j+1,i) - sk(k,j+2,i)            ) /&
-                                    ( sk(k,j,i)   - sk(k,j+1,i) + 1E-20_wp )  &
-                                  )                                           &
-                            ) / ABS( v(k,j+1,i) - v_gtrans + 1E-20_wp )     
-!   
-!--                Reuse k_mm and compute k_mmm for the vertical gradient ratios. 
-!--                Note, for vertical advection below the third grid point above 
-!--                surface ( or below the model top) rd and rt are set to 0, i.e. 
-!--                use of first order scheme is enforced.
-                   k_mmm  = k - 3 * ibit8
-
-                   rd     = ( MAX( 0.0_wp, w(k-1,j,i) ) *                     & 
-                            ABS( ( sk(k_mm,j,i) - sk(k_mmm,j,i)           ) / &
-                                 ( sk(k-1,j,i)  - sk(k_mm,j,i) + 1E-20_wp )   &
-                               ) +                                            & 
-                              MIN( 0.0_wp, w(k-1,j,i) ) *                     &
-                            ABS( ( sk(k-1,j,i) - sk(k,j,i)            ) /     &
-                                 ( sk(k_mm,j,i) - sk(k-1,j,i)   + 1E-20_wp )  &
-                               )                                              &
-                            ) * ibit8 / ABS( w(k-1,j,i) + 1E-20_wp ) 
- 
-                   rt     = ( MAX( 0.0_wp, w(k,j,i) ) *                       & 
-                            ABS( ( sk(k,j,i)   - sk(k-1,j,i)            ) /   &
-                                 ( sk(k+1,j,i) - sk(k,j,i)   + 1E-20_wp )     &
-                               ) +                                            & 
-                              MIN( 0.0_wp, w(k,j,i) ) *                       &
-                            ABS( ( sk(k+1,j,i) - sk(k_pp,j,i)           ) /   &
-                                 ( sk(k,j,i)   - sk(k+1,j,i) + 1E-20_wp )     &
-                               )                                              &
-                            ) * ibit8 / ABS( w(k,j,i) + 1E-20_wp )
-!
-!--                Calculate empirical limiter function (van Albada2 limiter).
-                   phi_l = MIN( 1.0_wp, ( 2.0_wp * ABS( rl ) ) /              &
-                                        ( rl**2 + 1.0_wp ) ) 
-                   phi_r = MIN( 1.0_wp, ( 2.0_wp * ABS( rr ) ) /              &
-                                        ( rr**2 + 1.0_wp ) ) 
-                   phi_s = MIN( 1.0_wp, ( 2.0_wp * ABS( rs ) ) /              &
-                                        ( rs**2 + 1.0_wp ) ) 
-                   phi_n = MIN( 1.0_wp, ( 2.0_wp * ABS( rn ) ) /              &
-                                        ( rn**2 + 1.0_wp ) ) 
-                   phi_d = MIN( 1.0_wp, ( 2.0_wp * ABS( rd ) ) /              &
-                                        ( rd**2 + 1.0_wp ) ) 
-                   phi_t = MIN( 1.0_wp, ( 2.0_wp * ABS( rt ) ) /              &
-                                        ( rt**2 + 1.0_wp ) ) 
-!
-!--                Calculate the resulting monotone flux. 
-                   swap_flux_x_local(k,j) = fl_1 - phi_l *                    &
-                                          ( fl_1 - swap_flux_x_local(k,j) )
-                   flux_r(k)              = fr_1 - phi_r *                    &
-                                          ( fr_1 - flux_r(k)              )
-                   swap_flux_y_local(k)   = fs_1 - phi_s *                    &
-                                          ( fs_1 - swap_flux_y_local(k)   )
-                   flux_n(k)              = fn_1 - phi_n *                    &
-                                          ( fn_1 - flux_n(k)              )
-                   flux_d                 = fd_1 - phi_d *                    &
-                                          ( fd_1 - flux_d                 )
-                   flux_t(k)              = ft_1 - phi_t *                    &
-                                          ( ft_1 - flux_t(k)              )
-!
-!--                Moreover, modify dissipation flux according to the limiter. 
-                   swap_diss_x_local(k,j) = swap_diss_x_local(k,j) * phi_l
-                   diss_r(k)              = diss_r(k)              * phi_r
-                   swap_diss_y_local(k)   = swap_diss_y_local(k)   * phi_s
-                   diss_n(k)              = diss_n(k)              * phi_n
-                   diss_d                 = diss_d                 * phi_d
-                   diss_t(k)              = diss_t(k)              * phi_t
-
-                ENDIF
-!
-!--             Calculate the divergence of the velocity field. A respective
-!--             correction is needed to overcome numerical instabilities caused
-!--             by a not sufficient reduction of divergences near topography.
-                div   =   ( u(k,j,i+1) * ( ibit0 + ibit1 + ibit2 )             &
-                          - u(k,j,i)   * ( IBITS(wall_flags_0(k,j,i-1),0,1)    &
-                                         + IBITS(wall_flags_0(k,j,i-1),1,1)    &
-                                         + IBITS(wall_flags_0(k,j,i-1),2,1)    &
-                                         )                                     &
-                          ) * ddx                                              &
-                        + ( v(k,j+1,i) * ( ibit3 + ibit4 + ibit5 )             &
-                          - v(k,j,i)   * ( IBITS(wall_flags_0(k,j-1,i),3,1)    &
-                                         + IBITS(wall_flags_0(k,j-1,i),4,1)    &
-                                         + IBITS(wall_flags_0(k,j-1,i),5,1)    &
-                                         )                                     &
-                          ) * ddy                                              &
-                        + ( w(k,j,i)   * ( ibit6 + ibit7 + ibit8 )             &
-                          - w(k-1,j,i) * ( IBITS(wall_flags_0(k-1,j,i),6,1)    &
-                                         + IBITS(wall_flags_0(k-1,j,i),7,1)    &
-                                         + IBITS(wall_flags_0(k-1,j,i),8,1)    &
-                                         )                                     &      
-                          ) * ddzw(k)
-
-
-                tend(k,j,i) = tend(k,j,i) - (                                 &
-                        ( flux_r(k) + diss_r(k) - swap_flux_x_local(k,j) -    &
-                          swap_diss_x_local(k,j)            ) * ddx           &
-                      + ( flux_n(k) + diss_n(k) - swap_flux_y_local(k)   -    &
-                          swap_diss_y_local(k)              ) * ddy           &
-                      + ( flux_t(k) + diss_t(k) - flux_d - diss_d             &
-                                                               ) * ddzw(k)    &
-                                            ) + sk(k,j,i) * div
-
-                swap_flux_y_local(k)   = flux_n(k)
-                swap_diss_y_local(k)   = diss_n(k)
-                swap_flux_x_local(k,j) = flux_r(k)
-                swap_diss_x_local(k,j) = diss_r(k)
-                flux_d                 = flux_t(k)
-                diss_d                 = diss_t(k)
-
-             ENDDO
-
-             DO  k = nzb_max+1, nzt
-
-                u_comp    = u(k,j,i+1) - u_gtrans
-                flux_r(k) = u_comp * (                                        &
-                      37.0_wp * ( sk(k,j,i+1) + sk(k,j,i)   )                 &
-                    -  8.0_wp * ( sk(k,j,i+2) + sk(k,j,i-1) )                 &
-                    +           ( sk(k,j,i+3) + sk(k,j,i-2) ) ) * adv_sca_5
-                diss_r(k) = -ABS( u_comp ) * (                                &
-                      10.0_wp * ( sk(k,j,i+1) - sk(k,j,i)   )                 &
-                    -  5.0_wp * ( sk(k,j,i+2) - sk(k,j,i-1) )                 &
-                    +           ( sk(k,j,i+3) - sk(k,j,i-2) ) ) * adv_sca_5
-
-                v_comp    = v(k,j+1,i) - v_gtrans
-                flux_n(k) = v_comp * (                                        &
-                      37.0_wp * ( sk(k,j+1,i) + sk(k,j,i)   )                 &
-                    -  8.0_wp * ( sk(k,j+2,i) + sk(k,j-1,i) )                 &
-                    +           ( sk(k,j+3,i) + sk(k,j-2,i) ) ) * adv_sca_5
-                diss_n(k) = -ABS( v_comp ) * (                                &
-                      10.0_wp * ( sk(k,j+1,i) - sk(k,j,i)   )                 &
-                    -  5.0_wp * ( sk(k,j+2,i) - sk(k,j-1,i) )                 &
-                    +           ( sk(k,j+3,i) - sk(k,j-2,i) ) ) * adv_sca_5
-!
-!--             k index has to be modified near bottom and top, else array
-!--             subscripts will be exceeded.
-                ibit8 = IBITS(wall_flags_0(k,j,i),8,1)
-                ibit7 = IBITS(wall_flags_0(k,j,i),7,1)
-                ibit6 = IBITS(wall_flags_0(k,j,i),6,1)
-
-                k_ppp = k + 3 * ibit8
-                k_pp  = k + 2 * ( 1 - ibit6  )
-                k_mm  = k - 2 * ibit8
-
-
-                flux_t(k) = w(k,j,i) * (                                      &
-                           ( 37.0_wp * ibit8 * adv_sca_5                      &
-                        +     7.0_wp * ibit7 * adv_sca_3                      &
-                        +              ibit6 * adv_sca_1                      &
-                           ) *                                                &
-                                   ( sk(k+1,j,i)  + sk(k,j,i)     )           &
-                    -      (  8.0_wp * ibit8 * adv_sca_5                      &
-                        +              ibit7 * adv_sca_3                      &
-                           ) *                                                &
-                                   ( sk(k_pp,j,i) + sk(k-1,j,i)   )           &
-                    +      (           ibit8 * adv_sca_5                      &
-                           ) *     ( sk(k_ppp,j,i)+ sk(k_mm,j,i)  )           &
-                                       )
-
-                diss_t(k) = -ABS( w(k,j,i) ) * (                              &
-                           ( 10.0_wp * ibit8 * adv_sca_5                      &
-                        +     3.0_wp * ibit7 * adv_sca_3                      &
-                        +              ibit6 * adv_sca_1                      &
-                           ) *                                                &
-                                   ( sk(k+1,j,i)   - sk(k,j,i)    )           &
-                    -      (  5.0_wp * ibit8 * adv_sca_5                      &
-                        +              ibit7 * adv_sca_3                      &
-                           ) *                                                &
-                                   ( sk(k_pp,j,i)  - sk(k-1,j,i)  )           &
-                    +      (           ibit8 * adv_sca_5                      &
-                           ) *                                                &
-                                   ( sk(k_ppp,j,i) - sk(k_mm,j,i) )           &
-                                               )
-!
-!--             Apply monotonic adjustment.
-                IF ( monotonic_adjustment )  THEN
-!
-!--                At first, calculate first order fluxes.
-                   u_comp = u(k,j,i) - u_gtrans
-                   fl_1   =  ( u_comp   * ( sk(k,j,i) + sk(k,j,i-1) )         &
-                         -ABS( u_comp ) * ( sk(k,j,i) - sk(k,j,i-1) )         &
-                             ) * adv_sca_1 
-
-                   u_comp = u(k,j,i+1) - u_gtrans
-                   fr_1   =  ( u_comp   * ( sk(k,j,i+1) + sk(k,j,i) )         &
-                         -ABS( u_comp ) * ( sk(k,j,i+1) - sk(k,j,i) )         &
-                             ) * adv_sca_1 
-
-                   v_comp = v(k,j,i) - v_gtrans
-                   fs_1   =  ( v_comp   * ( sk(k,j,i) + sk(k,j-1,i) )         &
-                         -ABS( v_comp ) * ( sk(k,j,i) - sk(k,j-1,i) )         &
-                             ) * adv_sca_1 
-
-                   v_comp = v(k,j+1,i) - v_gtrans
-                   fn_1   =  ( v_comp   * ( sk(k,j+1,i) + sk(k,j,i) )         &
-                         -ABS( v_comp ) * ( sk(k,j+1,i) - sk(k,j,i) )         &
-                             ) * adv_sca_1 
-
-                   fd_1   = (  w(k-1,j,i)   * ( sk(k,j,i) + sk(k-1,j,i) )     &
-                         -ABS( w(k-1,j,i) ) * ( sk(k,j,i) - sk(k-1,j,i) )     &
-                            ) * adv_sca_1 
-
-                   ft_1   = (  w(k,j,i)   * ( sk(k+1,j,i) + sk(k,j,i) )       &
-                         -ABS( w(k,j,i) ) * ( sk(k+1,j,i) - sk(k,j,i) )       &
-                            ) * adv_sca_1 
-!
-!--                Calculate ratio of upwind gradients. Note, Min/Max is just
-!--                to avoid if statements.
-                   rl     = ( MAX( 0.0_wp, u(k,j,i) - u_gtrans ) *            & 
-                               ABS( ( sk(k,j,i-1) - sk(k,j,i-2)            ) /&
-                                    ( sk(k,j,i)   - sk(k,j,i-1) + 1E-20_wp )  &
-                                  ) +                                         & 
-                              MIN( 0.0_wp, u(k,j,i) - u_gtrans ) *            &
-                               ABS( ( sk(k,j,i)   - sk(k,j,i+1)            ) /&
-                                    ( sk(k,j,i-1) - sk(k,j,i)   + 1E-20_wp )  &
-                                  )                                           &
-                            ) / ABS( u(k,j,i) - u_gtrans + 1E-20_wp )
-
-                   rr     = ( MAX( 0.0_wp, u(k,j,i+1) - u_gtrans ) *          & 
-                               ABS( ( sk(k,j,i)   - sk(k,j,i-1)            ) /&
-                                    ( sk(k,j,i+1) - sk(k,j,i)   + 1E-20_wp )  &
-                                  ) +                                         & 
-                              MIN( 0.0_wp, u(k,j,i+1) - u_gtrans ) *          &
-                               ABS( ( sk(k,j,i+1) - sk(k,j,i+2)            ) /&
-                                    ( sk(k,j,i)   - sk(k,j,i+1) + 1E-20_wp )  &
-                                  )                                           &
-                            ) / ABS( u(k,j,i+1) - u_gtrans + 1E-20_wp )
-
-                   rs     = ( MAX( 0.0_wp, v(k,j,i) - v_gtrans ) *            & 
-                               ABS( ( sk(k,j-1,i) - sk(k,j-2,i)            ) /&
-                                    ( sk(k,j,i)   - sk(k,j-1,i) + 1E-20_wp )  &
-                                  ) +                                         & 
-                              MIN( 0.0_wp, v(k,j,i) - v_gtrans ) *            &
-                               ABS( ( sk(k,j,i)   - sk(k,j+1,i)            ) /&
-                                    ( sk(k,j-1,i) - sk(k,j,i)   + 1E-20_wp )  &
-                                  )                                           &
-                            ) / ABS( v(k,j,i) - v_gtrans + 1E-20_wp )
-
-                   rn     = ( MAX( 0.0_wp, v(k,j+1,i) - v_gtrans ) *          & 
-                               ABS( ( sk(k,j,i)   - sk(k,j-1,i)            ) /&
-                                    ( sk(k,j+1,i) - sk(k,j,i)   + 1E-20_wp )  &
-                                  ) +                                         & 
-                              MIN( 0.0_wp, v(k,j+1,i) - v_gtrans ) *          &
-                               ABS( ( sk(k,j+1,i) - sk(k,j+2,i)            ) /&
-                                    ( sk(k,j,i)   - sk(k,j+1,i) + 1E-20_wp )  &
-                                  )                                           &
-                            ) / ABS( v(k,j+1,i) - v_gtrans + 1E-20_wp )     
-!   
-!--                Reuse k_mm and compute k_mmm for the vertical gradient ratios. 
-!--                Note, for vertical advection below the third grid point above 
-!--                surface ( or below the model top) rd and rt are set to 0, i.e. 
-!--                use of first order scheme is enforced.
-                   k_mmm  = k - 3 * ibit8
-
-                   rd     = ( MAX( 0.0_wp, w(k-1,j,i) ) *                     & 
-                            ABS( ( sk(k_mm,j,i) - sk(k_mmm,j,i)           ) / &
-                                 ( sk(k-1,j,i)  - sk(k_mm,j,i) + 1E-20_wp )   &
-                               ) +                                            & 
-                              MIN( 0.0_wp, w(k-1,j,i) ) *                     &
-                            ABS( ( sk(k-1,j,i) - sk(k,j,i)            ) /     &
-                                 ( sk(k_mm,j,i) - sk(k-1,j,i)   + 1E-20_wp )  &
-                               )                                              &
-                            ) * ibit8 / ABS( w(k-1,j,i) + 1E-20_wp ) 
- 
-                   rt     = ( MAX( 0.0_wp, w(k,j,i) ) *                       & 
-                            ABS( ( sk(k,j,i)   - sk(k-1,j,i)            ) /   &
-                                 ( sk(k+1,j,i) - sk(k,j,i)   + 1E-20_wp )     &
-                               ) +                                            & 
-                              MIN( 0.0_wp, w(k,j,i) ) *                       &
-                            ABS( ( sk(k+1,j,i) - sk(k_pp,j,i)           ) /   &
-                                 ( sk(k,j,i)   - sk(k+1,j,i) + 1E-20_wp )     &
-                               )                                              &
-                            ) * ibit8 / ABS( w(k,j,i) + 1E-20_wp ) 
-!
-!--                Calculate empirical limiter function (van Albada2 limiter).
-                   phi_l = MIN( 1.0_wp, ( 2.0_wp * ABS( rl ) ) /              &
-                                        ( rl**2 + 1.0_wp ) ) 
-                   phi_r = MIN( 1.0_wp, ( 2.0_wp * ABS( rr ) ) /              &
-                                        ( rr**2 + 1.0_wp ) ) 
-                   phi_s = MIN( 1.0_wp, ( 2.0_wp * ABS( rs ) ) /              &
-                                        ( rs**2 + 1.0_wp ) ) 
-                   phi_n = MIN( 1.0_wp, ( 2.0_wp * ABS( rn ) ) /              &
-                                        ( rn**2 + 1.0_wp ) ) 
-                   phi_d = MIN( 1.0_wp, ( 2.0_wp * ABS( rd ) ) /              &
-                                        ( rd**2 + 1.0_wp ) ) 
-                   phi_t = MIN( 1.0_wp, ( 2.0_wp * ABS( rt ) ) /              &
-                                        ( rt**2 + 1.0_wp ) ) 
-!
-!--                Calculate the resulting monotone flux. 
-                   swap_flux_x_local(k,j) = fl_1 - phi_l *                    &
-                                          ( fl_1 - swap_flux_x_local(k,j) )
-                   flux_r(k)              = fr_1 - phi_r *                    &
-                                          ( fr_1 - flux_r(k)              )
-                   swap_flux_y_local(k)   = fs_1 - phi_s *                    &
-                                          ( fs_1 - swap_flux_y_local(k)   )
-                   flux_n(k)              = fn_1 - phi_n *                    &
-                                          ( fn_1 - flux_n(k)              )
-                   flux_d                 = fd_1 - phi_d *                    &
-                                          ( fd_1 - flux_d                 )
-                   flux_t(k)              = ft_1 - phi_t *                    &
-                                          ( ft_1 - flux_t(k)              )
-!
-!--                Moreover, modify dissipation flux according to the limiter. 
-                   swap_diss_x_local(k,j) = swap_diss_x_local(k,j) * phi_l
-                   diss_r(k)              = diss_r(k)              * phi_r
-                   swap_diss_y_local(k)   = swap_diss_y_local(k)   * phi_s
-                   diss_n(k)              = diss_n(k)              * phi_n
-                   diss_d                 = diss_d                 * phi_d
-                   diss_t(k)              = diss_t(k)              * phi_t
-
-                ENDIF
-!
-!--             Calculate the divergence of the velocity field. A respective
-!--             correction is needed to overcome numerical instabilities introduced
-!--             by a not sufficient reduction of divergences near topography.
-                div         =   ( u(k,j,i+1) - u(k,j,i)   ) * ddx             &
-                              + ( v(k,j+1,i) - v(k,j,i)   ) * ddy             &
-                              + ( w(k,j,i)   - w(k-1,j,i) ) * ddzw(k)
-
-                tend(k,j,i) = tend(k,j,i) - (                                 &
-                        ( flux_r(k) + diss_r(k) - swap_flux_x_local(k,j) -    &
-                          swap_diss_x_local(k,j)            ) * ddx           &
-                      + ( flux_n(k) + diss_n(k) - swap_flux_y_local(k)   -    &
-                          swap_diss_y_local(k)              ) * ddy           &
-                      + ( flux_t(k) + diss_t(k) - flux_d - diss_d             &
-                                                               ) * ddzw(k)    &
-                                            ) + sk(k,j,i) * div
-
-                swap_flux_y_local(k)   = flux_n(k)
-                swap_diss_y_local(k)   = diss_n(k)
-                swap_flux_x_local(k,j) = flux_r(k)
-                swap_diss_x_local(k,j) = diss_r(k)
-                flux_d                 = flux_t(k)
-                diss_d                 = diss_t(k)
-
-             ENDDO
-!
-!--          Evaluation of statistics. 
-             SELECT CASE ( sk_char )
-
-                 CASE ( 'pt' )
-                    DO  k = nzb, nzt
-                       sums_wspts_ws_l(k,tn) = sums_wspts_ws_l(k,tn)          &
-                        + ( flux_t(k) + diss_t(k) )                           &
-                        *   weight_substep(intermediate_timestep_count)
-                    ENDDO
-                 CASE ( 'sa' )
-                    DO  k = nzb, nzt
-                       sums_wssas_ws_l(k,tn) = sums_wssas_ws_l(k,tn)          &
-                        + ( flux_t(k) + diss_t(k) )                           &
-                        *   weight_substep(intermediate_timestep_count)
-                    ENDDO
-                 CASE ( 'q' )
-                    DO  k = nzb, nzt
-                       sums_wsqs_ws_l(k,tn) = sums_wsqs_ws_l(k,tn)            &
-                        + ( flux_t(k) + diss_t(k) )                           &
-                        *   weight_substep(intermediate_timestep_count)
-                    ENDDO
-                 CASE ( 'qr' )
-                    DO  k = nzb, nzt
-                       sums_wsqrs_ws_l(k,tn) = sums_wsqrs_ws_l(k,tn)          &
-                        + ( flux_t(k) + diss_t(k) )                           &
-                        *   weight_substep(intermediate_timestep_count)
-                    ENDDO
-                 CASE ( 'nr' )
-                    DO  k = nzb, nzt
-                       sums_wsnrs_ws_l(k,tn) = sums_wsnrs_ws_l(k,tn)          &
-                        + ( flux_t(k) + diss_t(k) )                           &
-                        *   weight_substep(intermediate_timestep_count)
-                    ENDDO
-
-              END SELECT
-
-         ENDDO
-      ENDDO
-
-    END SUBROUTINE advec_s_ws
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Scalar advection - Call for all grid points - accelerator version
-!------------------------------------------------------------------------------!
-    SUBROUTINE advec_s_ws_acc ( sk, sk_char )
-
-       USE arrays_3d,                                                         &
-           ONLY:  ddzw, tend, u, v, w
-
-       USE constants,                                                         &
-           ONLY:  adv_sca_1, adv_sca_3, adv_sca_5
-
-       USE control_parameters,                                                &
-           ONLY:  intermediate_timestep_count, monotonic_adjustment, u_gtrans,&
-                  v_gtrans
-
-       USE grid_variables,                                                    &
-           ONLY:  ddx, ddy
-
-       USE indices,                                                           &
-           ONLY:  i_left, i_right, j_north, j_south, nxlg, nxrg, nyng, nysg,  &
-                  nzb, nzb_max, nzt, wall_flags_0
-
-       USE kinds
-       
-!        USE statistics,                                                       &
-!            ONLY:  sums_wspts_ws_l, sums_wsqs_ws_l, sums_wssas_ws_l,          &
-!                   sums_wsqrs_ws_l, sums_wsnrs_ws_l, weight_substep
-
-       IMPLICIT NONE
-
-       CHARACTER (LEN = *), INTENT(IN)    :: sk_char !<
-
-       INTEGER(iwp) ::  i      !<
-       INTEGER(iwp) ::  ibit0  !<
-       INTEGER(iwp) ::  ibit1  !<
-       INTEGER(iwp) ::  ibit2  !<
-       INTEGER(iwp) ::  ibit3  !<
-       INTEGER(iwp) ::  ibit4  !<
-       INTEGER(iwp) ::  ibit5  !<
-       INTEGER(iwp) ::  ibit6  !<
-       INTEGER(iwp) ::  ibit7  !<
-       INTEGER(iwp) ::  ibit8  !<
-       INTEGER(iwp) ::  j      !<
-       INTEGER(iwp) ::  k      !<
-       INTEGER(iwp) ::  k_mm   !<
-       INTEGER(iwp) ::  k_mmm  !<
-       INTEGER(iwp) ::  k_pp   !<
-       INTEGER(iwp) ::  k_ppp  !<
-       INTEGER(iwp) ::  tn = 0 !<
-
-       REAL(wp)    ::  diss_d !<
-       REAL(wp)    ::  diss_l !<
-       REAL(wp)    ::  diss_n !<
-       REAL(wp)    ::  diss_r !<
-       REAL(wp)    ::  diss_s !<
-       REAL(wp)    ::  diss_t !<
-       REAL(wp)    ::  div    !<
-       REAL(wp)    ::  flux_d !<
-       REAL(wp)    ::  flux_l !<
-       REAL(wp)    ::  flux_n !<
-       REAL(wp)    ::  flux_r !<
-       REAL(wp)    ::  flux_s !<
-       REAL(wp)    ::  flux_t !<
-       REAL(wp)    ::  fd_1   !<
-       REAL(wp)    ::  fl_1   !<
-       REAL(wp)    ::  fn_1   !<
-       REAL(wp)    ::  fr_1   !<
-       REAL(wp)    ::  fs_1   !<
-       REAL(wp)    ::  ft_1   !<
-       REAL(wp)    ::  phi_d  !<
-       REAL(wp)    ::  phi_l  !<
-       REAL(wp)    ::  phi_n  !<
-       REAL(wp)    ::  phi_r  !<
-       REAL(wp)    ::  phi_s  !<
-       REAL(wp)    ::  phi_t  !<
-       REAL(wp)    ::  rd     !<
-       REAL(wp)    ::  rl     !<
-       REAL(wp)    ::  rn     !<
-       REAL(wp)    ::  rr     !<
-       REAL(wp)    ::  rs     !<
-       REAL(wp)    ::  rt     !<
-       REAL(wp)    ::  u_comp !<
-       REAL(wp)    ::  v_comp !<
-
-       REAL(wp), INTENT(IN), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg)  ::  sk !<
-
-!
-!--    Computation of fluxes and tendency terms
-       !$acc kernels present( ddzw, sk, tend, u, v, w, wall_flags_0 )
-       DO  i = i_left, i_right
-          DO  j = j_south, j_north
-             DO  k = nzb+1, nzt
-
-                ibit2 = IBITS(wall_flags_0(k,j,i-1),2,1)
-                ibit1 = IBITS(wall_flags_0(k,j,i-1),1,1)
-                ibit0 = IBITS(wall_flags_0(k,j,i-1),0,1)
-
-                u_comp              = u(k,j,i) - u_gtrans
-                flux_l              = u_comp * (                              &
-                                               ( 37.0_wp * ibit2 * adv_sca_5  &
-                                            +     7.0_wp * ibit1 * adv_sca_3  &
-                                            +              ibit0 * adv_sca_1  &
-                                               ) *                            &
-                                         ( sk(k,j,i)   + sk(k,j,i-1)    )     &
-                                        -      (  8.0_wp * ibit2 * adv_sca_5  &
-                                            +              ibit1 * adv_sca_3  &
-                                               ) *                            &
-                                         ( sk(k,j,i+1) + sk(k,j,i-2)    )     &
-                                        +      (           ibit2 * adv_sca_5  &
-                                               ) *                            &
-                                         ( sk(k,j,i+2) + sk(k,j,i-3)    )     &
-                                               )
-
-                diss_l              = -ABS( u_comp ) * (                      &
-                                               ( 10.0_wp * ibit2 * adv_sca_5  &
-                                            +     3.0_wp * ibit1 * adv_sca_3  &
-                                            +              ibit0 * adv_sca_1  &
-                                               ) *                            &
-                                         ( sk(k,j,i)   - sk(k,j,i-1)    )     &
-                                        -      (  5.0_wp * ibit2 * adv_sca_5  &
-                                            +              ibit1 * adv_sca_3  &
-                                               ) *                            &
-                                         ( sk(k,j,i+1) - sk(k,j,i-2)    )     &
-                                        +      (           ibit2 * adv_sca_5  &
-                                               ) *                            &
-                                         ( sk(k,j,i+2) - sk(k,j,i-3)    )     &
-                                                        )
-
-                ibit2 = IBITS(wall_flags_0(k,j,i),2,1)
-                ibit1 = IBITS(wall_flags_0(k,j,i),1,1)
-                ibit0 = IBITS(wall_flags_0(k,j,i),0,1)
-
-                u_comp    = u(k,j,i+1) - u_gtrans
-                flux_r    = u_comp * (                                        &
-                          ( 37.0_wp * ibit2 * adv_sca_5                       &
-                      +      7.0_wp * ibit1 * adv_sca_3                       &
-                      +               ibit0 * adv_sca_1                       &
-                          ) *                                                 &
-                             ( sk(k,j,i+1) + sk(k,j,i)   )                    &
-                   -      (  8.0_wp * ibit2 * adv_sca_5                       &
-                       +              ibit1 * adv_sca_3                       &
-                          ) *                                                 &
-                             ( sk(k,j,i+2) + sk(k,j,i-1) )                    &
-                   +      (           ibit2 * adv_sca_5                       &
-                          ) *                                                 &
-                             ( sk(k,j,i+3) + sk(k,j,i-2) )                    &
-                                     )
-
-                diss_r    = -ABS( u_comp ) * (                                &
-                          ( 10.0_wp * ibit2 * adv_sca_5                       &
-                       +     3.0_wp * ibit1 * adv_sca_3                       &
-                       +              ibit0 * adv_sca_1                       &
-                          ) *                                                 &
-                             ( sk(k,j,i+1) - sk(k,j,i)   )                    &
-                   -      (  5.0_wp * ibit2 * adv_sca_5                       &
-                       +              ibit1 * adv_sca_3                       &
-                          ) *                                                 &
-                             ( sk(k,j,i+2) - sk(k,j,i-1) )                    &
-                   +      (           ibit2 * adv_sca_5                       &
-                          ) *                                                 &
-                             ( sk(k,j,i+3) - sk(k,j,i-2) )                    &
-                                             )
-
-                ibit5 = IBITS(wall_flags_0(k,j-1,i),5,1)
-                ibit4 = IBITS(wall_flags_0(k,j-1,i),4,1)
-                ibit3 = IBITS(wall_flags_0(k,j-1,i),3,1)
-
-                v_comp    = v(k,j,i) - v_gtrans
-                flux_s    = v_comp * (                                        &
-                          ( 37.0_wp * ibit5 * adv_sca_5                       &
-                       +     7.0_wp * ibit4 * adv_sca_3                       &
-                       +              ibit3 * adv_sca_1                       &
-                          ) *                                                 &
-                             ( sk(k,j,i)  + sk(k,j-1,i)     )                 &
-                    -     (  8.0_wp * ibit5 * adv_sca_5                       &
-                       +              ibit4 * adv_sca_3                       &
-                          ) *                                                 &
-                             ( sk(k,j+1,i) + sk(k,j-2,i)    )                 &
-                   +      (           ibit5 * adv_sca_5                       &
-                          ) *                                                 &
-                             ( sk(k,j+2,i) + sk(k,j-3,i)    )                 &
-                                     )
-
-                diss_s    = -ABS( v_comp ) * (                                &
-                          ( 10.0_wp * ibit5 * adv_sca_5                       &
-                       +     3.0_wp * ibit4 * adv_sca_3                       &
-                       +              ibit3 * adv_sca_1                       &
-                          ) *                                                 &
-                             ( sk(k,j,i)   - sk(k,j-1,i)  )                   &
-                   -      (  5.0_wp * ibit5 * adv_sca_5                       &
-                       +              ibit4 * adv_sca_3                       &
-                          ) *                                                 &
-                             ( sk(k,j+1,i) - sk(k,j-2,i)  )                   &
-                   +      (           ibit5 * adv_sca_5                       &
-                          ) *                                                 &
-                             ( sk(k,j+2,i) - sk(k,j-3,i)  )                   &
-                                             )
-
-                ibit5 = IBITS(wall_flags_0(k,j,i),5,1)
-                ibit4 = IBITS(wall_flags_0(k,j,i),4,1)
-                ibit3 = IBITS(wall_flags_0(k,j,i),3,1)
-
-                v_comp    = v(k,j+1,i) - v_gtrans
-                flux_n    = v_comp * (                                        &
-                          ( 37.0_wp * ibit5 * adv_sca_5                       &
-                       +     7.0_wp * ibit4 * adv_sca_3                       &
-                       +              ibit3 * adv_sca_1                       &
-                          ) *                                                 &
-                             ( sk(k,j+1,i) + sk(k,j,i)   )                    &
-                   -      (  8.0_wp * ibit5 * adv_sca_5                       &
-                       +              ibit4 * adv_sca_3                       &
-                          ) *                                                 &
-                             ( sk(k,j+2,i) + sk(k,j-1,i) )                    &
-                   +      (           ibit5 * adv_sca_5                       &
-                          ) *                                                 &
-                             ( sk(k,j+3,i) + sk(k,j-2,i) )                    &
-                                     )
-
-                diss_n    = -ABS( v_comp ) * (                                &
-                          ( 10.0_wp * ibit5 * adv_sca_5                       &
-                       +     3.0_wp * ibit4 * adv_sca_3                       &
-                       +              ibit3 * adv_sca_1                       &
-                          ) *                                                 &
-                             ( sk(k,j+1,i) - sk(k,j,i)    )                   &
-                   -      (  5.0_wp * ibit5 * adv_sca_5                       &
-                       +              ibit4 * adv_sca_3                       &
-                          ) *                                                 &
-                             ( sk(k,j+2,i) - sk(k,j-1,i)  )                   &
-                   +      (           ibit5 * adv_sca_5                       &
-                          ) *                                                 &
-                             ( sk(k,j+3,i) - sk(k,j-2,i)  )                   &
-                                             )
-
-!
-!--             indizes k_m, k_mm, ... should be known at these point
-                ibit8 = IBITS(wall_flags_0(k-1,j,i),8,1)
-                ibit7 = IBITS(wall_flags_0(k-1,j,i),7,1)
-                ibit6 = IBITS(wall_flags_0(k-1,j,i),6,1)
-
-                k_pp  = k + 2 * ibit8
-                k_mm  = k - 2 * ( ibit7 + ibit8 )
-                k_mmm = k - 3 * ibit8
-
-                flux_d    = w(k-1,j,i) * (                                    &
-                           ( 37.0_wp * ibit8 * adv_sca_5                      &
-                        +     7.0_wp * ibit7 * adv_sca_3                      &
-                        +              ibit6 * adv_sca_1                      &
-                           ) *                                                &
-                                   ( sk(k,j,i)    + sk(k-1,j,i)  )            &
-                    -      (  8.0_wp * ibit8 * adv_sca_5                      &
-                          +            ibit7 * adv_sca_3                      &
-                           ) *                                                &
-                                   ( sk(k+1,j,i) + sk(k_mm,j,i)  )            &
-                    +      (           ibit8 * adv_sca_5                      &
-                           ) *     ( sk(k_pp,j,i)+ sk(k_mmm,j,i) )            &
-                                         )
-
-                diss_d    = -ABS( w(k-1,j,i) ) * (                            &
-                           ( 10.0_wp * ibit8 * adv_sca_5                      &
-                        +     3.0_wp * ibit7 * adv_sca_3                      &
-                        +              ibit6 * adv_sca_1                      &
-                           ) *                                                &
-                                   ( sk(k,j,i)    - sk(k-1,j,i)   )           &
-                    -      (  5.0_wp * ibit8 * adv_sca_5                      &
-                        +              ibit7 * adv_sca_3                      &
-                           ) *                                                &
-                                   ( sk(k+1,j,i)  - sk(k_mm,j,i)  )           &
-                    +      (           ibit8 * adv_sca_5                      &
-                           ) *                                                &
-                                   ( sk(k_pp,j,i) - sk(k_mmm,j,i) )           &
-                                                 )
-
-                ibit8 = IBITS(wall_flags_0(k,j,i),8,1)
-                ibit7 = IBITS(wall_flags_0(k,j,i),7,1)
-                ibit6 = IBITS(wall_flags_0(k,j,i),6,1)
-
-                k_ppp = k + 3 * ibit8
-                k_pp  = k + 2 * ( 1 - ibit6  )
-                k_mm  = k - 2 * ibit8
-
-                flux_t    = w(k,j,i) * (                                      &
-                           ( 37.0_wp * ibit8 * adv_sca_5                      &
-                        +     7.0_wp * ibit7 * adv_sca_3                      &
-                        +              ibit6 * adv_sca_1                      &
-                           ) *                                                &
-                                   ( sk(k+1,j,i)  + sk(k,j,i)    )            &
-                    -      (  8.0_wp * ibit8 * adv_sca_5                      &
-                        +              ibit7 * adv_sca_3                      &
-                           ) *                                                &
-                                   ( sk(k_pp,j,i) + sk(k-1,j,i)  )            &
-                    +      (           ibit8 * adv_sca_5                      &
-                           ) *     ( sk(k_ppp,j,i)+ sk(k_mm,j,i) )            &
-                                       )
-
-                diss_t    = -ABS( w(k,j,i) ) * (                              &
-                           ( 10.0_wp * ibit8 * adv_sca_5                      &
-                        +     3.0_wp * ibit7 * adv_sca_3                      &
-                        +              ibit6 * adv_sca_1                      &
-                           ) *                                                &
-                                   ( sk(k+1,j,i)   - sk(k,j,i)    )           &
-                    -      (  5.0_wp * ibit8 * adv_sca_5                      &
-                        +              ibit7 * adv_sca_3                      &
-                           ) *                                                &
-                                   ( sk(k_pp,j,i)  - sk(k-1,j,i)  )           &
-                    +      (           ibit8 * adv_sca_5                      &
-                           ) *                                                &
-                                   ( sk(k_ppp,j,i) - sk(k_mm,j,i) )           &
-                                         )
-!
-!--             Apply monotonic adjustment.
-                IF ( monotonic_adjustment )  THEN
-!
-!--                At first, calculate first order fluxes.
-                   u_comp = u(k,j,i) - u_gtrans
-                   fl_1   =  ( u_comp   * ( sk(k,j,i) + sk(k,j,i-1) )         &
-                         -ABS( u_comp ) * ( sk(k,j,i) - sk(k,j,i-1) )         &
-                             ) * adv_sca_1 
-
-                   u_comp = u(k,j,i+1) - u_gtrans
-                   fr_1   =  ( u_comp   * ( sk(k,j,i+1) + sk(k,j,i) )         &
-                         -ABS( u_comp ) * ( sk(k,j,i+1) - sk(k,j,i) )         &
-                             ) * adv_sca_1 
-
-                   v_comp = v(k,j,i) - v_gtrans
-                   fs_1   =  ( v_comp   * ( sk(k,j,i) + sk(k,j-1,i) )         &
-                         -ABS( v_comp ) * ( sk(k,j,i) - sk(k,j-1,i) )         &
-                             ) * adv_sca_1 
-
-                   v_comp = v(k,j+1,i) - v_gtrans
-                   fn_1   =  ( v_comp   * ( sk(k,j+1,i) + sk(k,j,i) )         &
-                         -ABS( v_comp ) * ( sk(k,j+1,i) - sk(k,j,i) )         &
-                             ) * adv_sca_1 
-
-                   fd_1   = (  w(k-1,j,i)   * ( sk(k,j,i) + sk(k-1,j,i) )     &
-                        -ABS( w(k-1,j,i) ) * ( sk(k,j,i) - sk(k-1,j,i) )      &
-                            ) * adv_sca_1 
-
-                   ft_1   = (  w(k,j,i)   * ( sk(k+1,j,i) + sk(k,j,i) )       &
-                        -ABS( w(k,j,i) ) * ( sk(k+1,j,i) - sk(k,j,i) )        &
-                            ) * adv_sca_1 
-!
-!--                Calculate ratio of upwind gradients. Note, Min/Max is just
-!--                to avoid if statements.
-                   rl     = ( MAX( 0.0_wp, u(k,j,i) - u_gtrans ) *            & 
-                               ABS( ( sk(k,j,i-1) - sk(k,j,i-2)            ) /&
-                                    ( sk(k,j,i)   - sk(k,j,i-1) + 1E-20_wp )  &
-                                  ) +                                         & 
-                              MIN( 0.0_wp, u(k,j,i) - u_gtrans ) *            &
-                               ABS( ( sk(k,j,i)   - sk(k,j,i+1)            ) /&
-                                    ( sk(k,j,i-1) - sk(k,j,i)   + 1E-20_wp )  &
-                                  )                                           &
-                            ) / ABS( u(k,j,i) - u_gtrans + 1E-20_wp )
-
-                   rr     = ( MAX( 0.0_wp, u(k,j,i+1) - u_gtrans ) *          & 
-                               ABS( ( sk(k,j,i)   - sk(k,j,i-1)            ) /&
-                                    ( sk(k,j,i+1) - sk(k,j,i)   + 1E-20_wp )  &
-                                  ) +                                         & 
-                              MIN( 0.0_wp, u(k,j,i+1) - u_gtrans ) *          &
-                               ABS( ( sk(k,j,i+1) - sk(k,j,i+2)            ) /&
-                                    ( sk(k,j,i)   - sk(k,j,i+1) + 1E-20_wp )  &
-                                  )                                           &
-                            ) / ABS( u(k,j,i+1) - u_gtrans + 1E-20_wp )
-
-                   rs     = ( MAX( 0.0_wp, v(k,j,i) - v_gtrans ) *            & 
-                               ABS( ( sk(k,j-1,i) - sk(k,j-2,i)            ) /&
-                                    ( sk(k,j,i)   - sk(k,j-1,i) + 1E-20_wp )  &
-                                  ) +                                         & 
-                              MIN( 0.0_wp, v(k,j,i) - v_gtrans ) *            &
-                               ABS( ( sk(k,j,i)   - sk(k,j+1,i)            ) /&
-                                    ( sk(k,j-1,i) - sk(k,j,i)   + 1E-20_wp )  &
-                                  )                                           &
-                            ) / ABS( v(k,j,i) - v_gtrans + 1E-20_wp )
-
-                   rn     = ( MAX( 0.0_wp, v(k,j+1,i) - v_gtrans ) *          & 
-                               ABS( ( sk(k,j,i)   - sk(k,j-1,i)            ) /&
-                                    ( sk(k,j+1,i) - sk(k,j,i)   + 1E-20_wp )  &
-                                  ) +                                         & 
-                              MIN( 0.0_wp, v(k,j+1,i) - v_gtrans ) *          &
-                               ABS( ( sk(k,j+1,i) - sk(k,j+2,i)            ) /&
-                                    ( sk(k,j,i)   - sk(k,j+1,i) + 1E-20_wp )  &
-                                  )                                           &
-                            ) / ABS( v(k,j+1,i) - v_gtrans + 1E-20_wp )     
-!   
-!--                Reuse k_mm and compute k_mmm for the vertical gradient ratios. 
-!--                Note, for vertical advection below the third grid point above 
-!--                surface ( or below the model top) rd and rt are set to 0, i.e. 
-!--                use of first order scheme is enforced.
-                   k_mmm  = k - 3 * ibit8
-
-                   rd     = ( MAX( 0.0_wp, w(k-1,j,i) ) *                     & 
-                            ABS( ( sk(k_mm,j,i) - sk(k_mmm,j,i)           ) / &
-                                 ( sk(k-1,j,i)  - sk(k_mm,j,i) + 1E-20_wp )   &
-                               ) +                                            & 
-                              MIN( 0.0_wp, w(k-1,j,i) ) *                     &
-                            ABS( ( sk(k-1,j,i) - sk(k,j,i)            ) /     &
-                                 ( sk(k_mm,j,i) - sk(k-1,j,i)   + 1E-20_wp )  &
-                               )                                              &
-                            ) * ibit8 / ABS( w(k-1,j,i) + 1E-20_wp ) 
- 
-                   rt     = ( MAX( 0.0_wp, w(k,j,i) ) *                       & 
-                            ABS( ( sk(k,j,i)   - sk(k-1,j,i)            ) /   &
-                                 ( sk(k+1,j,i) - sk(k,j,i)   + 1E-20_wp )     &
-                               ) +                                            & 
-                              MIN( 0.0_wp, w(k,j,i) ) *                       &
-                            ABS( ( sk(k+1,j,i) - sk(k_pp,j,i)           ) /   &
-                                 ( sk(k,j,i)   - sk(k+1,j,i) + 1E-20_wp )     &
-                               )                                              &
-                            ) * ibit8 / ABS( w(k,j,i) + 1E-20_wp )
-!
-!--                Calculate empirical limiter function (van Albada2 limiter).
-                   phi_l = MIN( 1.0_wp, ( 2.0_wp * ABS( rl ) ) /              &
-                                        ( rl**2 + 1.0_wp ) ) 
-                   phi_r = MIN( 1.0_wp, ( 2.0_wp * ABS( rr ) ) /              &
-                                        ( rr**2 + 1.0_wp ) ) 
-                   phi_s = MIN( 1.0_wp, ( 2.0_wp * ABS( rs ) ) /              &
-                                        ( rs**2 + 1.0_wp ) ) 
-                   phi_n = MIN( 1.0_wp, ( 2.0_wp * ABS( rn ) ) /              &
-                                        ( rn**2 + 1.0_wp ) ) 
-                   phi_d = MIN( 1.0_wp, ( 2.0_wp * ABS( rd ) ) /              &
-                                        ( rd**2 + 1.0_wp ) ) 
-                   phi_t = MIN( 1.0_wp, ( 2.0_wp * ABS( rt ) ) /              &
-                                        ( rt**2 + 1.0_wp ) ) 
-!
-!--                Calculate the resulting monotone flux. 
-                   flux_l = fl_1 - phi_l * ( fl_1 - flux_l )
-                   flux_r = fr_1 - phi_r * ( fr_1 - flux_r )
-                   flux_s = fs_1 - phi_s * ( fs_1 - flux_s )
-                   flux_n = fn_1 - phi_n * ( fn_1 - flux_n )
-                   flux_d = fd_1 - phi_d * ( fd_1 - flux_d )
-                   flux_t = ft_1 - phi_t * ( ft_1 - flux_t )
-!
-!--                Moreover, modify dissipation flux according to the limiter. 
-                   diss_l = diss_l * phi_l
-                   diss_r = diss_r * phi_r
-                   diss_s = diss_s * phi_s
-                   diss_n = diss_n * phi_n
-                   diss_d = diss_d * phi_d
-                   diss_t = diss_t * phi_t
-
-                ENDIF
-!
-!--             Calculate the divergence of the velocity field. A respective
-!--             correction is needed to overcome numerical instabilities caused
-!--             by a not sufficient reduction of divergences near topography.
-                div   =   ( u(k,j,i+1) * ( ibit0 + ibit1 + ibit2 )             &
-                          - u(k,j,i)   * ( IBITS(wall_flags_0(k,j,i-1),0,1)    &
-                                         + IBITS(wall_flags_0(k,j,i-1),1,1)    &
-                                         + IBITS(wall_flags_0(k,j,i-1),2,1)    &
-                                         )                                     &
-                          ) * ddx                                              &
-                        + ( v(k,j+1,i) * ( ibit3 + ibit4 + ibit5 )             &
-                          - v(k,j,i)   * ( IBITS(wall_flags_0(k,j-1,i),3,1)    &
-                                         + IBITS(wall_flags_0(k,j-1,i),4,1)    &
-                                         + IBITS(wall_flags_0(k,j-1,i),5,1)    &
-                                         )                                     &
-                          ) * ddy                                              &
-                        + ( w(k,j,i)   * ( ibit6 + ibit7 + ibit8 )             &
-                          - w(k-1,j,i) * ( IBITS(wall_flags_0(k-1,j,i),6,1)    &
-                                         + IBITS(wall_flags_0(k-1,j,i),7,1)    &
-                                         + IBITS(wall_flags_0(k-1,j,i),8,1)    &
-                                         )                                     &      
-                          ) * ddzw(k)
-
-
-                tend(k,j,i) = - (                                             &
-                               ( flux_r + diss_r - flux_l - diss_l ) * ddx    &
-                             + ( flux_n + diss_n - flux_s - diss_s ) * ddy    &
-                             + ( flux_t + diss_t - flux_d - diss_d ) * ddzw(k)&
-                                ) + div * sk(k,j,i)
-
-!++
-!--             Evaluation of statistics
-!                SELECT CASE ( sk_char )
-!
-!                   CASE ( 'pt' )
-!                      sums_wspts_ws_l(k,tn) = sums_wspts_ws_l(k,tn)         &
-!                       + ( flux_t + diss_t )                                &
-!                       *   weight_substep(intermediate_timestep_count)
-!                   CASE ( 'sa' )
-!                      sums_wssas_ws_l(k,tn) = sums_wssas_ws_l(k,tn)         &
-!                       + ( flux_t + diss_t )                                &
-!                       *   weight_substep(intermediate_timestep_count)
-!                   CASE ( 'q' )
-!                      sums_wsqs_ws_l(k,tn) = sums_wsqs_ws_l(k,tn)           &
-!                      + ( flux_t + diss_t )                                 &
-!                      *   weight_substep(intermediate_timestep_count)
-!                   CASE ( 'qr' )
-!                      sums_wsqrs_ws_l(k,tn) = sums_wsqrs_ws_l(k,tn)         &
-!                      + ( flux_t + diss_t )                                 &
-!                      *   weight_substep(intermediate_timestep_count)
-!                   CASE ( 'nr' )
-!                      sums_wsnrs_ws_l(k,tn) = sums_wsnrs_ws_l(k,tn)         &
-!                      + ( flux_t + diss_t )                                 &
-!                      *   weight_substep(intermediate_timestep_count)
-!
-!                END SELECT
-
-             ENDDO
-         ENDDO
-      ENDDO
-      !$acc end kernels
-
-    END SUBROUTINE advec_s_ws_acc
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Advection of u - Call for all grid points
-!------------------------------------------------------------------------------!
-    SUBROUTINE advec_u_ws
-
-       USE arrays_3d,                                                          &
-           ONLY:  ddzw, tend, u, v, w
-
-       USE constants,                                                          &
-           ONLY:  adv_mom_1, adv_mom_3, adv_mom_5
-
-       USE control_parameters,                                                 &
-           ONLY:  intermediate_timestep_count, u_gtrans, v_gtrans
-
-       USE grid_variables,                                                     &
-           ONLY:  ddx, ddy
-
-       USE indices,                                                            &
-           ONLY:  nxl, nxlu, nxr, nyn, nys, nzb, nzb_max, nzt, wall_flags_0
-           
-       USE kinds
-       
-       USE statistics,                                                         &
-           ONLY:  hom, sums_us2_ws_l, sums_wsus_ws_l, weight_substep
-
-       IMPLICIT NONE
-
-       INTEGER(iwp) ::  i      !<
-       INTEGER(iwp) ::  ibit9  !<
-       INTEGER(iwp) ::  ibit10 !<
-       INTEGER(iwp) ::  ibit11 !<
-       INTEGER(iwp) ::  ibit12 !<
-       INTEGER(iwp) ::  ibit13 !<
-       INTEGER(iwp) ::  ibit14 !<
-       INTEGER(iwp) ::  ibit15 !<
-       INTEGER(iwp) ::  ibit16 !<
-       INTEGER(iwp) ::  ibit17 !<
-       INTEGER(iwp) ::  j      !<
-       INTEGER(iwp) ::  k      !<
-       INTEGER(iwp) ::  k_mm   !<
-       INTEGER(iwp) ::  k_pp   !<
-       INTEGER(iwp) ::  k_ppp  !<
-       INTEGER(iwp) ::  tn = 0 !<
-       
-       REAL(wp)    ::  diss_d !<
-       REAL(wp)    ::  div    !<
-       REAL(wp)    ::  flux_d !<
-       REAL(wp)    ::  gu     !<
-       REAL(wp)    ::  gv     !<
-       REAL(wp)    ::  v_comp !<
-       REAL(wp)    ::  w_comp !<
-       
-       REAL(wp), DIMENSION(nzb+1:nzt) ::  swap_diss_y_local_u !<
-       REAL(wp), DIMENSION(nzb+1:nzt) ::  swap_flux_y_local_u !<
-       
-       REAL(wp), DIMENSION(nzb+1:nzt,nys:nyn) ::  swap_diss_x_local_u !<
-       REAL(wp), DIMENSION(nzb+1:nzt,nys:nyn) ::  swap_flux_x_local_u !<
-       
-       REAL(wp), DIMENSION(nzb:nzt) ::  diss_n !<
-       REAL(wp), DIMENSION(nzb:nzt) ::  diss_r !<
-       REAL(wp), DIMENSION(nzb:nzt) ::  diss_t !<
-       REAL(wp), DIMENSION(nzb:nzt) ::  flux_n !<
-       REAL(wp), DIMENSION(nzb:nzt) ::  flux_r !<
-       REAL(wp), DIMENSION(nzb:nzt) ::  flux_t !<
-       REAL(wp), DIMENSION(nzb:nzt) ::  u_comp !<
- 
-       gu = 2.0_wp * u_gtrans
-       gv = 2.0_wp * v_gtrans
-
-!
-!--    Compute the fluxes for the whole left boundary of the processor domain.
-       i = nxlu
-       DO  j = nys, nyn
-          DO  k = nzb+1, nzb_max
-
-             ibit11 = IBITS(wall_flags_0(k,j,i-1),11,1)
-             ibit10 = IBITS(wall_flags_0(k,j,i-1),10,1)
-             ibit9  = IBITS(wall_flags_0(k,j,i-1),9,1)
-
-             u_comp(k)                = u(k,j,i) + u(k,j,i-1) - gu
-             swap_flux_x_local_u(k,j) = u_comp(k) * (                          &
-                                       ( 37.0_wp * ibit11 * adv_mom_5             &
-                                    +     7.0_wp * ibit10 * adv_mom_3             &
-                                    +              ibit9  * adv_mom_1             &
-                                       ) *                                     &
-                                     ( u(k,j,i)   + u(k,j,i-1) )               &
-                                -      (  8.0_wp * ibit11 * adv_mom_5             &
-                                    +              ibit10 * adv_mom_3             &
-                                       ) *                                     &
-                                     ( u(k,j,i+1) + u(k,j,i-2) )               &
-                                +      (           ibit11 * adv_mom_5             &
-                                       ) *                                     &
-                                     ( u(k,j,i+2) + u(k,j,i-3) )               &
-                                                   )
-
-              swap_diss_x_local_u(k,j) = - ABS( u_comp(k) ) * (                &
-                                       ( 10.0_wp * ibit11 * adv_mom_5             &
-                                    +     3.0_wp * ibit10 * adv_mom_3             &
-                                    +              ibit9  * adv_mom_1             &
-                                       ) *                                     &
-                                     ( u(k,j,i)   - u(k,j,i-1) )               &
-                                -      (  5.0_wp * ibit11 * adv_mom_5             &
-                                    +              ibit10 * adv_mom_3             &
-                                       ) *                                     &
-                                     ( u(k,j,i+1) - u(k,j,i-2) )               &
-                                +      (           ibit11 * adv_mom_5             &
-                                       ) *                                     &
-                                     ( u(k,j,i+2) - u(k,j,i-3) )               &
-                                                             )
-
-          ENDDO
-
-          DO  k = nzb_max+1, nzt
-
-             u_comp(k)         = u(k,j,i) + u(k,j,i-1) - gu
-             swap_flux_x_local_u(k,j) = u_comp(k) * (                          &
-                             37.0_wp * ( u(k,j,i) + u(k,j,i-1)   )                &
-                           -  8.0_wp * ( u(k,j,i+1) + u(k,j,i-2) )                &
-                           +           ( u(k,j,i+2) + u(k,j,i-3) ) ) * adv_mom_5
-             swap_diss_x_local_u(k,j) = - ABS(u_comp(k)) * (                   &
-                             10.0_wp * ( u(k,j,i) - u(k,j,i-1)   )                &
-                           -  5.0_wp * ( u(k,j,i+1) - u(k,j,i-2) )                &
-                           +           ( u(k,j,i+2) - u(k,j,i-3) ) ) * adv_mom_5
-
-          ENDDO
-       ENDDO
-
-       DO i = nxlu, nxr
-!       
-!--       The following loop computes the fluxes for the south boundary points
-          j = nys
-          DO  k = nzb+1, nzb_max
-
-             ibit14 = IBITS(wall_flags_0(k,j-1,i),14,1)
-             ibit13 = IBITS(wall_flags_0(k,j-1,i),13,1)
-             ibit12 = IBITS(wall_flags_0(k,j-1,i),12,1)
-
-             v_comp                 = v(k,j,i) + v(k,j,i-1) - gv
-             swap_flux_y_local_u(k) = v_comp * (                              &
-                                   ( 37.0_wp * ibit14 * adv_mom_5                &
-                                +     7.0_wp * ibit13 * adv_mom_3                &
-                                +              ibit12 * adv_mom_1                &
-                                   ) *                                        &
-                                     ( u(k,j,i)   + u(k,j-1,i) )              &
-                            -      (  8.0_wp * ibit14 * adv_mom_5                &
-                            +                  ibit13 * adv_mom_3                    &
-                                   ) *                                        &
-                                     ( u(k,j+1,i) + u(k,j-2,i) )              &
-                        +      (               ibit14 * adv_mom_5                    &
-                               ) *                                            &
-                                     ( u(k,j+2,i) + u(k,j-3,i) )              &
-                                               )
-
-             swap_diss_y_local_u(k) = - ABS ( v_comp ) * (                    &
-                                   ( 10.0_wp * ibit14 * adv_mom_5                &
-                                +     3.0_wp * ibit13 * adv_mom_3                &
-                                +              ibit12 * adv_mom_1                &
-                                   ) *                                        &
-                                     ( u(k,j,i)   - u(k,j-1,i) )              &
-                            -      (  5.0_wp * ibit14 * adv_mom_5                &
-                                +              ibit13 * adv_mom_3                &
-                                   ) *                                        &
-                                     ( u(k,j+1,i) - u(k,j-2,i) )              &
-                            +      (           ibit14 * adv_mom_5                &
-                                   ) *                                        &
-                                     ( u(k,j+2,i) - u(k,j-3,i) )              &
-                                                         )
-
-          ENDDO
-
-          DO  k = nzb_max+1, nzt
-
-             v_comp                 = v(k,j,i) + v(k,j,i-1) - gv
-             swap_flux_y_local_u(k) = v_comp * (                              &
-                           37.0_wp * ( u(k,j,i) + u(k,j-1,i)   )                 &
-                         -  8.0_wp * ( u(k,j+1,i) + u(k,j-2,i) )                 &
-                         +           ( u(k,j+2,i) + u(k,j-3,i) ) ) * adv_mom_5
-             swap_diss_y_local_u(k) = - ABS(v_comp) * (                       &
-                           10.0_wp * ( u(k,j,i) - u(k,j-1,i)   )                 &
-                         -  5.0_wp * ( u(k,j+1,i) - u(k,j-2,i) )                 &
-                         +           ( u(k,j+2,i) - u(k,j-3,i) ) ) * adv_mom_5
-
-          ENDDO
-!
-!--       Computation of interior fluxes and tendency terms
-          DO  j = nys, nyn
-
-             flux_t(0) = 0.0_wp
-             diss_t(0) = 0.0_wp
-             flux_d    = 0.0_wp
-             diss_d    = 0.0_wp
-
-             DO  k = nzb+1, nzb_max
-
-                ibit11 = IBITS(wall_flags_0(k,j,i),11,1)
-                ibit10 = IBITS(wall_flags_0(k,j,i),10,1)
-                ibit9  = IBITS(wall_flags_0(k,j,i),9,1)
-
-                u_comp(k) = u(k,j,i+1) + u(k,j,i)
-                flux_r(k) = ( u_comp(k) - gu ) * (                           &
-                          ( 37.0_wp * ibit11 * adv_mom_5                        &
-                       +     7.0_wp * ibit10 * adv_mom_3                        &
-                       +              ibit9  * adv_mom_1                        &
-                          ) *                                                &
-                                 ( u(k,j,i+1) + u(k,j,i)   )                 &
-                   -      (  8.0_wp * ibit11 * adv_mom_5                        &
-                       +              ibit10 * adv_mom_3                        &
-                          ) *                                                &
-                                 ( u(k,j,i+2) + u(k,j,i-1) )                 &
-                   +      (           ibit11 * adv_mom_5                        &
-                          ) *                                                &
-                                 ( u(k,j,i+3) + u(k,j,i-2) )                 &
-                                                 )
-
-                diss_r(k) = - ABS( u_comp(k) - gu ) * (                      &
-                          ( 10.0_wp * ibit11 * adv_mom_5                        &
-                       +     3.0_wp * ibit10 * adv_mom_3                        & 
-                       +              ibit9  * adv_mom_1                        &
-                          ) *                                                &
-                                 ( u(k,j,i+1) - u(k,j,i)  )                  &
-                   -      (  5.0_wp * ibit11 * adv_mom_5                        &
-                       +              ibit10 * adv_mom_3                        &
-                          ) *                                                &
-                                 ( u(k,j,i+2) - u(k,j,i-1) )                 &
-                   +      (           ibit11 * adv_mom_5                        &
-                          ) *                                                &
-                                 ( u(k,j,i+3) - u(k,j,i-2) )                 &
-                                                     )
-
-                ibit14 = IBITS(wall_flags_0(k,j,i),14,1)
-                ibit13 = IBITS(wall_flags_0(k,j,i),13,1)
-                ibit12 = IBITS(wall_flags_0(k,j,i),12,1)
-
-                v_comp    = v(k,j+1,i) + v(k,j+1,i-1) - gv
-                flux_n(k) = v_comp * (                                       &
-                          ( 37.0_wp * ibit14 * adv_mom_5                        &
-                       +     7.0_wp * ibit13 * adv_mom_3                        &
-                       +              ibit12 * adv_mom_1                        &
-                          ) *                                                &
-                                 ( u(k,j+1,i) + u(k,j,i)   )                 &
-                   -      (  8.0_wp * ibit14 * adv_mom_5                        &
-                       +              ibit13 * adv_mom_3                        &
-                          ) *                                                &
-                                 ( u(k,j+2,i) + u(k,j-1,i) )                 &
-                   +      (           ibit14 * adv_mom_5                        & 
-                          ) *                                                &
-                                 ( u(k,j+3,i) + u(k,j-2,i) )                 &
-                                                 )
-
-                diss_n(k) = - ABS ( v_comp ) * (                             &
-                          ( 10.0_wp * ibit14 * adv_mom_5                        &
-                       +     3.0_wp * ibit13 * adv_mom_3                        &
-                       +              ibit12 * adv_mom_1                        &
-                          ) *                                                &
-                                 ( u(k,j+1,i) - u(k,j,i)  )                  &
-                   -      (  5.0_wp * ibit14 * adv_mom_5                        &
-                       +              ibit13 * adv_mom_3                        &
-                          ) *                                                &
-                                 ( u(k,j+2,i) - u(k,j-1,i) )                 &
-                   +      (           ibit14 * adv_mom_5                        &
-                          ) *                                                &
-                                 ( u(k,j+3,i) - u(k,j-2,i) )                 &
-                                                      )
-!
-!--             k index has to be modified near bottom and top, else array
-!--             subscripts will be exceeded.
-                ibit17 = IBITS(wall_flags_0(k,j,i),17,1)
-                ibit16 = IBITS(wall_flags_0(k,j,i),16,1)
-                ibit15 = IBITS(wall_flags_0(k,j,i),15,1)
-
-                k_ppp = k + 3 * ibit17
-                k_pp  = k + 2 * ( 1 - ibit15  )
-                k_mm  = k - 2 * ibit17
-
-                w_comp    = w(k,j,i) + w(k,j,i-1)
-                flux_t(k) = w_comp  * (                                      &
-                          ( 37.0_wp * ibit17 * adv_mom_5                        &
-                       +     7.0_wp * ibit16 * adv_mom_3                        &
-                       +              ibit15 * adv_mom_1                        & 
-                          ) *                                                &
-                             ( u(k+1,j,i)  + u(k,j,i)     )                  &
-                   -      (  8.0_wp * ibit17 * adv_mom_5                        &
-                       +              ibit16 * adv_mom_3                        &
-                          ) *                                                &
-                             ( u(k_pp,j,i) + u(k-1,j,i)   )                  &
-                   +      (           ibit17 * adv_mom_5                        &
-                          ) *                                                &
-                             ( u(k_ppp,j,i) + u(k_mm,j,i) )                  &
-                                      )
-
-                diss_t(k) = - ABS( w_comp ) * (                              &
-                          ( 10.0_wp * ibit17 * adv_mom_5                        &
-                       +     3.0_wp * ibit16 * adv_mom_3                        &
-                       +              ibit15 * adv_mom_1                        &
-                          ) *                                                &
-                             ( u(k+1,j,i)   - u(k,j,i)    )                  &
-                   -      (  5.0_wp * ibit17 * adv_mom_5                        &
-                       +              ibit16 * adv_mom_3                        &
-                          ) *                                                &
-                             ( u(k_pp,j,i)  - u(k-1,j,i)  )                  &
-                   +      (           ibit17 * adv_mom_5                        &
-                           ) *                                               &
-                             ( u(k_ppp,j,i) - u(k_mm,j,i) )                  &
-                                              )
-!
-!--             Calculate the divergence of the velocity field. A respective
-!--             correction is needed to overcome numerical instabilities caused
-!--             by a not sufficient reduction of divergences near topography.
-                div = ( ( u_comp(k) * ( ibit9 + ibit10 + ibit11 )             &
-                - ( u(k,j,i)   + u(k,j,i-1)   )                               &
-                                    * ( IBITS(wall_flags_0(k,j,i-1),9,1)      &
-                                      + IBITS(wall_flags_0(k,j,i-1),10,1)     &
-                                      + IBITS(wall_flags_0(k,j,i-1),11,1)     &
-                                      )                                       &   
-                  ) * ddx                                                     &
-               +  ( ( v_comp + gv ) * ( ibit12 + ibit13 + ibit14 )            &
-                  - ( v(k,j,i)   + v(k,j,i-1 )  )                             &
-                                    * ( IBITS(wall_flags_0(k,j-1,i),12,1)     &
-                                      + IBITS(wall_flags_0(k,j-1,i),13,1)     &
-                                      + IBITS(wall_flags_0(k,j-1,i),14,1)     &
-                                      )                                       &
-                  ) * ddy                                                     &
-               +  ( w_comp          * ( ibit15 + ibit16 + ibit17 )            &
-                - ( w(k-1,j,i) + w(k-1,j,i-1) )                               &
-                                    * ( IBITS(wall_flags_0(k-1,j,i),15,1)     &
-                                      + IBITS(wall_flags_0(k-1,j,i),16,1)     &
-                                      + IBITS(wall_flags_0(k-1,j,i),17,1)     &
-                                      )                                       &  
-                  ) * ddzw(k)   &
-                ) * 0.5_wp
-
-
-
-                tend(k,j,i) = tend(k,j,i) - (                                  &
-                 ( flux_r(k) + diss_r(k)                                       &
-               -   swap_flux_x_local_u(k,j) - swap_diss_x_local_u(k,j) ) * ddx &
-               + ( flux_n(k) + diss_n(k)                                       &
-               -   swap_flux_y_local_u(k)   - swap_diss_y_local_u(k)   ) * ddy &
-               + ( flux_t(k) + diss_t(k)                                       &
-               -   flux_d    - diss_d                                          &
-                                                                  ) * ddzw(k)  &
-                                           ) + div * u(k,j,i)
-
-                swap_flux_x_local_u(k,j) = flux_r(k)
-                swap_diss_x_local_u(k,j) = diss_r(k)
-                swap_flux_y_local_u(k)   = flux_n(k)
-                swap_diss_y_local_u(k)   = diss_n(k)
-                flux_d                   = flux_t(k)
-                diss_d                   = diss_t(k)
-!
-!--             Statistical Evaluation of u'u'. The factor has to be applied
-!--             for right evaluation when gallilei_trans = .T. .
-                sums_us2_ws_l(k,tn) = sums_us2_ws_l(k,tn)                     &
-                              + ( flux_r(k) *                                 &
-                                ( u_comp(k) - 2.0_wp * hom(k,1,1,0) )            &
-                              / ( u_comp(k) - gu + 1.0E-20_wp    )            &
-                              +   diss_r(k) *                                 &
-                                  ABS( u_comp(k) - 2.0_wp * hom(k,1,1,0) )       &
-                              / ( ABS( u_comp(k) - gu ) + 1.0E-20_wp ) )      &
-                              *   weight_substep(intermediate_timestep_count)
-!
-!--             Statistical Evaluation of w'u'.
-                sums_wsus_ws_l(k,tn) = sums_wsus_ws_l(k,tn)                   &
-                              + ( flux_t(k) + diss_t(k) )                     &
-                              *   weight_substep(intermediate_timestep_count)
-             ENDDO
-
-             DO  k = nzb_max+1, nzt
-
-                u_comp(k) = u(k,j,i+1) + u(k,j,i)
-                flux_r(k) = ( u_comp(k) - gu ) * (                            &
-                         37.0_wp * ( u(k,j,i+1) + u(k,j,i)   )                   &
-                       -  8.0_wp * ( u(k,j,i+2) + u(k,j,i-1) )                   &
-                       +           ( u(k,j,i+3) + u(k,j,i-2) ) ) * adv_mom_5
-                diss_r(k) = - ABS( u_comp(k) - gu ) * (                       &
-                         10.0_wp * ( u(k,j,i+1) - u(k,j,i)   )                   &
-                       -  5.0_wp * ( u(k,j,i+2) - u(k,j,i-1) )                   &
-                       +           ( u(k,j,i+3) - u(k,j,i-2) ) ) * adv_mom_5
-
-                v_comp    = v(k,j+1,i) + v(k,j+1,i-1) - gv
-                flux_n(k) = v_comp * (                                        &
-                         37.0_wp * ( u(k,j+1,i) + u(k,j,i)   )                   &
-                       -  8.0_wp * ( u(k,j+2,i) + u(k,j-1,i) )                   &
-                       +           ( u(k,j+3,i) + u(k,j-2,i) ) ) * adv_mom_5
-                diss_n(k) = - ABS( v_comp ) * (                               &
-                         10.0_wp * ( u(k,j+1,i) - u(k,j,i)   )                   &
-                       -  5.0_wp * ( u(k,j+2,i) - u(k,j-1,i) )                   &
-                       +           ( u(k,j+3,i) - u(k,j-2,i) ) ) * adv_mom_5
-!
-!--             k index has to be modified near bottom and top, else array
-!--             subscripts will be exceeded.
-                ibit17 = IBITS(wall_flags_0(k,j,i),17,1)
-                ibit16 = IBITS(wall_flags_0(k,j,i),16,1)
-                ibit15 = IBITS(wall_flags_0(k,j,i),15,1)
-
-                k_ppp = k + 3 * ibit17
-                k_pp  = k + 2 * ( 1 - ibit15  )
-                k_mm  = k - 2 * ibit17
-
-                w_comp    = w(k,j,i) + w(k,j,i-1)
-                flux_t(k) = w_comp  * (                                      &
-                          ( 37.0_wp * ibit17 * adv_mom_5                        &
-                       +     7.0_wp * ibit16 * adv_mom_3                        &
-                       +              ibit15 * adv_mom_1                        &
-                          ) *                                                &
-                             ( u(k+1,j,i)  + u(k,j,i)     )                  &
-                   -      (  8.0_wp * ibit17 * adv_mom_5                        &
-                       +              ibit16 * adv_mom_3                        &
-                          ) *                                                &
-                             ( u(k_pp,j,i) + u(k-1,j,i)   )                  &
-                   +      (           ibit17 * adv_mom_5                        &
-                          ) *                                                &
-                             ( u(k_ppp,j,i) + u(k_mm,j,i) )                  &
-                                      )
-
-                diss_t(k) = - ABS( w_comp ) * (                              &
-                          ( 10.0_wp * ibit17 * adv_mom_5                        &
-                       +     3.0_wp * ibit16 * adv_mom_3                        &
-                       +              ibit15 * adv_mom_1                        &
-                          ) *                                                &
-                             ( u(k+1,j,i)   - u(k,j,i)    )                  &
-                   -      (  5.0_wp * ibit17 * adv_mom_5                        &
-                       +              ibit16 * adv_mom_3                        &
-                          ) *                                                &
-                             ( u(k_pp,j,i)  - u(k-1,j,i)  )                  &
-                   +      (           ibit17 * adv_mom_5                        &
-                           ) *                                               &
-                             ( u(k_ppp,j,i) - u(k_mm,j,i) )                  &
-                                              )
-!
-!--             Calculate the divergence of the velocity field. A respective
-!--             correction is needed to overcome numerical instabilities caused
-!--             by a not sufficient reduction of divergences near topography.
-                div = ( ( u_comp(k)   - ( u(k,j,i)   + u(k,j,i-1)   ) ) * ddx &
-                     +  ( v_comp + gv - ( v(k,j,i)   + v(k,j,i-1 )  ) ) * ddy &
-                     +  ( w_comp      - ( w(k-1,j,i) + w(k-1,j,i-1) ) )       &
-                                                                    * ddzw(k) &
-                      ) * 0.5_wp
-
-                 tend(k,j,i) = tend(k,j,i) - (                                 &
-                 ( flux_r(k) + diss_r(k)                                       &
-               -   swap_flux_x_local_u(k,j) - swap_diss_x_local_u(k,j) ) * ddx &
-               + ( flux_n(k) + diss_n(k)                                       &
-               -   swap_flux_y_local_u(k)   - swap_diss_y_local_u(k)   ) * ddy &
-               + ( flux_t(k) + diss_t(k)                                       &
-               -   flux_d    - diss_d                                          &
-                                                                  ) * ddzw(k)  &
-                                           ) + div * u(k,j,i)
-
-                 swap_flux_x_local_u(k,j) = flux_r(k)
-                 swap_diss_x_local_u(k,j) = diss_r(k)
-                 swap_flux_y_local_u(k)   = flux_n(k)
-                 swap_diss_y_local_u(k)   = diss_n(k)
-                 flux_d                   = flux_t(k)
-                 diss_d                   = diss_t(k)
-!
-!--              Statistical Evaluation of u'u'. The factor has to be applied
-!--              for right evaluation when gallilei_trans = .T. .
-                 sums_us2_ws_l(k,tn) = sums_us2_ws_l(k,tn)                    &
-                              + ( flux_r(k) *                                 &
-                                ( u_comp(k) - 2.0_wp * hom(k,1,1,0) )            &
-                              / ( u_comp(k) - gu + 1.0E-20_wp   )             &
-                              +   diss_r(k) *                                 &
-                                  ABS( u_comp(k) - 2.0_wp * hom(k,1,1,0) )       &
-                              / ( ABS( u_comp(k) - gu ) + 1.0E-20_wp ) )      &
-                              *   weight_substep(intermediate_timestep_count)
-!
-!--              Statistical Evaluation of w'u'.
-                 sums_wsus_ws_l(k,tn) = sums_wsus_ws_l(k,tn)                  &
-                              + ( flux_t(k) + diss_t(k) )                     &
-                              *   weight_substep(intermediate_timestep_count)
-       ENDDO
-          ENDDO
-       ENDDO
-       sums_us2_ws_l(nzb,tn) = sums_us2_ws_l(nzb+1,tn)
-
-
-    END SUBROUTINE advec_u_ws
-    
-    
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Advection of u - Call for all grid points - accelerator version
-!------------------------------------------------------------------------------!
-    SUBROUTINE advec_u_ws_acc
-
-       USE arrays_3d,                                                          &
-           ONLY:  ddzw, tend, u, v, w
-
-       USE constants,                                                          &
-           ONLY:  adv_mom_1, adv_mom_3, adv_mom_5
-
-       USE control_parameters,                                                 &
-           ONLY:  intermediate_timestep_count, u_gtrans, v_gtrans
-
-       USE grid_variables,                                                     &
-           ONLY:  ddx, ddy
-
-       USE indices,                                                            &
-           ONLY:  i_left, i_right, j_north, j_south, nxl, nxr, nyn, nys, nzb,  &
-                  nzb_max, nzt, wall_flags_0
-           
-       USE kinds
-       
-!        USE statistics,                                                       &
-!            ONLY:  hom, sums_us2_ws_l, sums_wsus_ws_l, weight_substep
-
-       IMPLICIT NONE
-
-       INTEGER(iwp) ::  i      !<
-       INTEGER(iwp) ::  ibit9  !<
-       INTEGER(iwp) ::  ibit10 !<
-       INTEGER(iwp) ::  ibit11 !<
-       INTEGER(iwp) ::  ibit12 !<
-       INTEGER(iwp) ::  ibit13 !<
-       INTEGER(iwp) ::  ibit14 !<
-       INTEGER(iwp) ::  ibit15 !<
-       INTEGER(iwp) ::  ibit16 !<
-       INTEGER(iwp) ::  ibit17 !<
-       INTEGER(iwp) ::  j      !<
-       INTEGER(iwp) ::  k      !<
-       INTEGER(iwp) ::  k_mmm  !<
-       INTEGER(iwp) ::  k_mm   !<
-       INTEGER(iwp) ::  k_pp   !<
-       INTEGER(iwp) ::  k_ppp  !<
-       INTEGER(iwp) ::  tn = 0 !<
-
-       REAL(wp)    ::  diss_d   !<
-       REAL(wp)    ::  diss_l   !<
-       REAL(wp)    ::  diss_n   !<
-       REAL(wp)    ::  diss_r   !<
-       REAL(wp)    ::  diss_s   !<
-       REAL(wp)    ::  diss_t   !<
-       REAL(wp)    ::  div      !<
-       REAL(wp)    ::  flux_d   !<
-       REAL(wp)    ::  flux_l   !<
-       REAL(wp)    ::  flux_n   !<
-       REAL(wp)    ::  flux_r   !<
-       REAL(wp)    ::  flux_s   !<
-       REAL(wp)    ::  flux_t   !<
-       REAL(wp)    ::  gu       !<
-       REAL(wp)    ::  gv       !<
-       REAL(wp)    ::  u_comp   !<
-       REAL(wp)    ::  u_comp_l !<
-       REAL(wp)    ::  v_comp   !<
-       REAL(wp)    ::  v_comp_s !<
-       REAL(wp)    ::  w_comp   !<
-
-
-       gu = 2.0_wp * u_gtrans
-       gv = 2.0_wp * v_gtrans
-
-!
-!--    Computation of fluxes and tendency terms
-       !$acc  kernels present( ddzw, tend, u, v, w, wall_flags_0 )
-       DO i = i_left, i_right
-          DO  j = j_south, j_north
-             DO  k = nzb+1, nzt
-
-                ibit11 = IBITS(wall_flags_0(k,j,i-1),11,1)
-                ibit10 = IBITS(wall_flags_0(k,j,i-1),10,1)
-                ibit9  = IBITS(wall_flags_0(k,j,i-1),9,1)
-
-                u_comp_l           = u(k,j,i) + u(k,j,i-1) - gu
-                flux_l             = u_comp_l * (                          &
-                                    ( 37.0_wp * ibit11 * adv_mom_5             &
-                                 +     7.0_wp * ibit10 * adv_mom_3             &
-                                 +              ibit9  * adv_mom_1             &
-                                    ) *                                     &
-                                  ( u(k,j,i)   + u(k,j,i-1) )               &
-                             -      (  8.0_wp * ibit11 * adv_mom_5             &
-                                 +              ibit10 * adv_mom_3             &
-                                    ) *                                     &
-                                  ( u(k,j,i+1) + u(k,j,i-2) )               &
-                             +      (           ibit11 * adv_mom_5             &
-                                    ) *                                     &
-                                  ( u(k,j,i+2) + u(k,j,i-3) )               &
-                                                )
-
-                diss_l             = - ABS( u_comp_l ) * (                &
-                                   ( 10.0_wp * ibit11 * adv_mom_5             &
-                                +     3.0_wp * ibit10 * adv_mom_3             &
-                                +              ibit9  * adv_mom_1             &
-                                   ) *                                     &
-                                 ( u(k,j,i)   - u(k,j,i-1) )               &
-                            -      (  5.0_wp * ibit11 * adv_mom_5             &
-                                +              ibit10 * adv_mom_3             &
-                                   ) *                                     &
-                                 ( u(k,j,i+1) - u(k,j,i-2) )               &
-                            +      (           ibit11 * adv_mom_5             &
-                                   ) *                                     &
-                                 ( u(k,j,i+2) - u(k,j,i-3) )               &
-                                                         )
-
-                ibit11 = IBITS(wall_flags_0(k,j,i),11,1)
-                ibit10 = IBITS(wall_flags_0(k,j,i),10,1)
-                ibit9  = IBITS(wall_flags_0(k,j,i),9,1)
-
-                u_comp    = u(k,j,i+1) + u(k,j,i)
-                flux_r    = ( u_comp   - gu ) * (                           &
-                          ( 37.0_wp * ibit11 * adv_mom_5                        &
-                       +     7.0_wp * ibit10 * adv_mom_3                        &
-                       +              ibit9  * adv_mom_1                        &
-                          ) *                                                &
-                                 ( u(k,j,i+1) + u(k,j,i)   )                 &
-                   -      (  8.0_wp * ibit11 * adv_mom_5                        &
-                       +              ibit10 * adv_mom_3                        &
-                          ) *                                                &
-                                 ( u(k,j,i+2) + u(k,j,i-1) )                 &
-                   +      (           ibit11 * adv_mom_5                        &
-                          ) *                                                &
-                                 ( u(k,j,i+3) + u(k,j,i-2) )                 &
-                                                 )
-
-                diss_r    = - ABS( u_comp    - gu ) * (                      &
-                          ( 10.0_wp * ibit11 * adv_mom_5                        &
-                       +     3.0_wp * ibit10 * adv_mom_3                        &
-                       +              ibit9  * adv_mom_1                        &
-                          ) *                                                &
-                                 ( u(k,j,i+1) - u(k,j,i)  )                  &
-                   -      (  5.0_wp * ibit11 * adv_mom_5                        &
-                       +              ibit10 * adv_mom_3                        &
-                          ) *                                                &
-                                 ( u(k,j,i+2) - u(k,j,i-1) )                 &
-                   +      (           ibit11 * adv_mom_5                        &
-                          ) *                                                &
-                                 ( u(k,j,i+3) - u(k,j,i-2) )                 &
-                                                     )
-
-                ibit14 = IBITS(wall_flags_0(k,j-1,i),14,1)
-                ibit13 = IBITS(wall_flags_0(k,j-1,i),13,1)
-                ibit12 = IBITS(wall_flags_0(k,j-1,i),12,1)
-
-                v_comp_s                 = v(k,j,i) + v(k,j,i-1) - gv
-                flux_s                   = v_comp_s * (                       &
-                                   ( 37.0_wp * ibit14 * adv_mom_5                &
-                                +     7.0_wp * ibit13 * adv_mom_3                &
-                                +              ibit12 * adv_mom_1                &
-                                   ) *                                         &
-                                     ( u(k,j,i)   + u(k,j-1,i) )              &
-                            -      (  8.0_wp * ibit14 * adv_mom_5                &
-                            +                  ibit13 * adv_mom_3                    &
-                                   ) *                                        &
-                                     ( u(k,j+1,i) + u(k,j-2,i) )              &
-                        +      (               ibit14 * adv_mom_5                    &
-                               ) *                                            &
-                                     ( u(k,j+2,i) + u(k,j-3,i) )              &
-                                               )
-
-                diss_s                  = - ABS ( v_comp_s ) * (              &
-                                   ( 10.0_wp * ibit14 * adv_mom_5                &
-                                +     3.0_wp * ibit13 * adv_mom_3                &
-                                +              ibit12 * adv_mom_1                &
-                                   ) *                                        &
-                                     ( u(k,j,i)   - u(k,j-1,i) )              &
-                            -      (  5.0_wp * ibit14 * adv_mom_5                &
-                                +              ibit13 * adv_mom_3                &
-                                   ) *                                        &
-                                     ( u(k,j+1,i) - u(k,j-2,i) )              &
-                            +      (           ibit14 * adv_mom_5                &
-                                   ) *                                        &
-                                     ( u(k,j+2,i) - u(k,j-3,i) )              &
-                                                         )
-
-
-                ibit14 = IBITS(wall_flags_0(k,j,i),14,1)
-                ibit13 = IBITS(wall_flags_0(k,j,i),13,1)
-                ibit12 = IBITS(wall_flags_0(k,j,i),12,1)
-
-                v_comp    = v(k,j+1,i) + v(k,j+1,i-1) - gv
-                flux_n    = v_comp * (                                       &
-                          ( 37.0_wp * ibit14 * adv_mom_5                        &
-                       +     7.0_wp * ibit13 * adv_mom_3                        &
-                       +              ibit12 * adv_mom_1                        &
-                          ) *                                                &
-                                 ( u(k,j+1,i) + u(k,j,i)   )                 &
-                   -      (  8.0_wp * ibit14 * adv_mom_5                        &
-                       +              ibit13 * adv_mom_3                        &
-                          ) *                                                &
-                                 ( u(k,j+2,i) + u(k,j-1,i) )                 &
-                   +      (           ibit14 * adv_mom_5                        &
-                          ) *                                                &
-                                 ( u(k,j+3,i) + u(k,j-2,i) )                 &
-                                                 )
-
-                diss_n    = - ABS ( v_comp ) * (                             &
-                          ( 10.0_wp * ibit14 * adv_mom_5                        &
-                       +     3.0_wp * ibit13 * adv_mom_3                        &
-                       +              ibit12 * adv_mom_1                        &
-                          ) *                                                &
-                                 ( u(k,j+1,i) - u(k,j,i)  )                  &
-                   -      (  5.0_wp * ibit14 * adv_mom_5                        &
-                       +              ibit13 * adv_mom_3                        &
-                          ) *                                                &
-                                 ( u(k,j+2,i) - u(k,j-1,i) )                 &
-                   +      (           ibit14 * adv_mom_5                        &
-                          ) *                                                &
-                                 ( u(k,j+3,i) - u(k,j-2,i) )                 &
-                                                      )
-
-                ibit17 = IBITS(wall_flags_0(k-1,j,i),17,1)
-                ibit16 = IBITS(wall_flags_0(k-1,j,i),16,1)
-                ibit15 = IBITS(wall_flags_0(k-1,j,i),15,1)
-
-                k_pp  = k + 2 * ibit17
-                k_mm  = k - 2 * ( ibit16 + ibit17 )
-                k_mmm = k - 3 * ibit17
-
-                w_comp    = w(k-1,j,i) + w(k-1,j,i-1)
-                flux_d    = w_comp  * (                                      &
-                          ( 37.0_wp * ibit17 * adv_mom_5                        &
-                       +     7.0_wp * ibit16 * adv_mom_3                        &
-                       +              ibit15 * adv_mom_1                        &
-                          ) *                                                &
-                             ( u(k,j,i)    + u(k-1,j,i)   )                  &
-                   -      (  8.0_wp * ibit17 * adv_mom_5                        &
-                       +              ibit16 * adv_mom_3                        &
-                          ) *                                                &
-                             ( u(k+1,j,i) + u(k_mm,j,i)   )                  &
-                   +      (           ibit17 * adv_mom_5                        &
-                          ) *                                                 &
-                             ( u(k_pp,j,i) + u(k_mmm,j,i) )                  &
-                                      )
-
-                diss_d    = - ABS( w_comp ) * (                              &
-                          ( 10.0_wp * ibit17 * adv_mom_5                        &
-                       +     3.0_wp * ibit16 * adv_mom_3                        &
-                       +              ibit15 * adv_mom_1                        &
-                          ) *                                                &
-                             ( u(k,j,i)     - u(k-1,j,i)  )                  &
-                   -      (  5.0_wp * ibit17 * adv_mom_5                        &
-                       +              ibit16 * adv_mom_3                        &
-                          ) *                                                &
-                             ( u(k+1,j,i)  - u(k_mm,j,i)  )                  &
-                   +      (           ibit17 * adv_mom_5                        &
-                           ) *                                               &
-                             ( u(k_pp,j,i) - u(k_mmm,j,i) )                  &
-                                              )
-!
-!--             k index has to be modified near bottom and top, else array
-!--             subscripts will be exceeded.
-                ibit17 = IBITS(wall_flags_0(k,j,i),17,1)
-                ibit16 = IBITS(wall_flags_0(k,j,i),16,1)
-                ibit15 = IBITS(wall_flags_0(k,j,i),15,1)
-
-                k_ppp = k + 3 * ibit17
-                k_pp  = k + 2 * ( 1 - ibit15  )
-                k_mm  = k - 2 * ibit17
-
-                w_comp    = w(k,j,i) + w(k,j,i-1)
-                flux_t    = w_comp  * (                                      &
-                          ( 37.0_wp * ibit17 * adv_mom_5                        &
-                       +     7.0_wp * ibit16 * adv_mom_3                        &
-                       +              ibit15 * adv_mom_1                        &
-                          ) *                                                &
-                             ( u(k+1,j,i)  + u(k,j,i)     )                  &
-                   -      (  8.0_wp * ibit17 * adv_mom_5                        &
-                       +              ibit16 * adv_mom_3                        &
-                          ) *                                                &
-                             ( u(k_pp,j,i) + u(k-1,j,i)   )                  &
-                   +      (           ibit17 * adv_mom_5                        &
-                          ) *                                                &
-                             ( u(k_ppp,j,i) + u(k_mm,j,i) )                  &
-                                      )
-
-                diss_t    = - ABS( w_comp ) * (                              &
-                          ( 10.0_wp * ibit17 * adv_mom_5                        &
-                       +     3.0_wp * ibit16 * adv_mom_3                        &
-                       +              ibit15 * adv_mom_1                        &
-                          ) *                                                &
-                             ( u(k+1,j,i)   - u(k,j,i)    )                  &
-                   -      (  5.0_wp * ibit17 * adv_mom_5                        &
-                       +              ibit16 * adv_mom_3                        &
-                          ) *                                                &
-                             ( u(k_pp,j,i)  - u(k-1,j,i)  )                  &
-                   +      (           ibit17 * adv_mom_5                        &
-                           ) *                                               &
-                             ( u(k_ppp,j,i) - u(k_mm,j,i) )                  &
-                                              )
-!
-!--             Calculate the divergence of the velocity field. A respective
-!--             correction is needed to overcome numerical instabilities caused
-!--             by a not sufficient reduction of divergences near topography.
-                div = ( ( u_comp    * ( ibit9 + ibit10 + ibit11 )             &
-                - ( u(k,j,i)   + u(k,j,i-1)   )                               &
-                                    * ( IBITS(wall_flags_0(k,j,i-1),9,1)      &
-                                      + IBITS(wall_flags_0(k,j,i-1),10,1)     &
-                                      + IBITS(wall_flags_0(k,j,i-1),11,1)     &
-                                      )                                       &   
-                  ) * ddx                                                     &
-               +  ( ( v_comp + gv ) * ( ibit12 + ibit13 + ibit14 )            &
-                  - ( v(k,j,i)   + v(k,j,i-1 )  )                             &
-                                    * ( IBITS(wall_flags_0(k,j-1,i),12,1)     &
-                                      + IBITS(wall_flags_0(k,j-1,i),13,1)     &
-                                      + IBITS(wall_flags_0(k,j-1,i),14,1)     &
-                                      )                                       &
-                  ) * ddy                                                     &
-               +  ( w_comp          * ( ibit15 + ibit16 + ibit17 )            &
-                - ( w(k-1,j,i) + w(k-1,j,i-1) )                               &
-                                    * ( IBITS(wall_flags_0(k-1,j,i),15,1)     &
-                                      + IBITS(wall_flags_0(k-1,j,i),16,1)     &
-                                      + IBITS(wall_flags_0(k-1,j,i),17,1)     &
-                                      )                                       &  
-                  ) * ddzw(k)   &
-                ) * 0.5_wp
-
-
-                tend(k,j,i) = - (                                              &
-                               ( flux_r + diss_r - flux_l - diss_l ) * ddx     &
-                             + ( flux_n + diss_n - flux_s - diss_s ) * ddy     &
-                             + ( flux_t + diss_t - flux_d - diss_d ) * ddzw(k) &
-                                ) + div * u(k,j,i)
-
-!++
-!--             Statistical Evaluation of u'u'. The factor has to be applied
-!--             for right evaluation when gallilei_trans = .T. .
-!                sums_us2_ws_l(k,tn) = sums_us2_ws_l(k,tn)                     &
-!                              + ( flux_r    *                                 &
-!                                ( u_comp    - 2.0_wp * hom(k,1,1,0) )            &
-!                              / ( u_comp    - gu + 1.0E-20_wp   )             &
-!                              +   diss_r    *                                 &
-!                                  ABS( u_comp    - 2.0_wp * hom(k,1,1,0) )       &
-!                              / ( ABS( u_comp    - gu ) + 1.0E-20_wp ) )      &
-!                              *   weight_substep(intermediate_timestep_count)
-!
-!--             Statistical Evaluation of w'u'.
-!                sums_wsus_ws_l(k,tn) = sums_wsus_ws_l(k,tn)                   &
-!                              + ( flux_t    + diss_t    )                     &
-!                              *   weight_substep(intermediate_timestep_count)
-             ENDDO
-          ENDDO
-       ENDDO
-       !$acc end kernels
-
-!++
-!       sums_us2_ws_l(nzb,tn) = sums_us2_ws_l(nzb+1,tn)
-
-    END SUBROUTINE advec_u_ws_acc
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Advection of v - Call for all grid points
-!------------------------------------------------------------------------------!
-    SUBROUTINE advec_v_ws
-
-       USE arrays_3d,                                                          &
-           ONLY:  ddzw, tend, u, v, w
-
-       USE constants,                                                          &
-           ONLY:  adv_mom_1, adv_mom_3, adv_mom_5
-
-       USE control_parameters,                                                 &
-           ONLY:  intermediate_timestep_count, u_gtrans, v_gtrans
-
-       USE grid_variables,                                                     &
-           ONLY:  ddx, ddy
-
-       USE indices,                                                            &
-           ONLY:  nxl, nxr, nyn, nys, nysv, nzb, nzb_max, nzt, wall_flags_0
-
-       USE kinds
-
-       USE statistics,                                                         &
-           ONLY:  hom, sums_vs2_ws_l, sums_wsvs_ws_l, weight_substep
-
-       IMPLICIT NONE
-
-
-       INTEGER(iwp) ::  i      !<
-       INTEGER(iwp) ::  ibit18 !<
-       INTEGER(iwp) ::  ibit19 !<
-       INTEGER(iwp) ::  ibit20 !<
-       INTEGER(iwp) ::  ibit21 !<
-       INTEGER(iwp) ::  ibit22 !<
-       INTEGER(iwp) ::  ibit23 !<
-       INTEGER(iwp) ::  ibit24 !<
-       INTEGER(iwp) ::  ibit25 !<
-       INTEGER(iwp) ::  ibit26 !<
-       INTEGER(iwp) ::  j      !<
-       INTEGER(iwp) ::  k      !<
-       INTEGER(iwp) ::  k_mm   !<
-       INTEGER(iwp) ::  k_pp   !<
-       INTEGER(iwp) ::  k_ppp  !<
-       INTEGER(iwp) ::  tn = 0 !<
-       
-       REAL(wp)    ::  diss_d !<
-       REAL(wp)    ::  div    !<
-       REAL(wp)    ::  flux_d !<
-       REAL(wp)    ::  gu     !<
-       REAL(wp)    ::  gv     !<
-       REAL(wp)    ::  u_comp !<
-       REAL(wp)    ::  w_comp !<
-       
-       REAL(wp), DIMENSION(nzb+1:nzt) ::  swap_diss_y_local_v !<
-       REAL(wp), DIMENSION(nzb+1:nzt) ::  swap_flux_y_local_v !<
-       
-       REAL(wp), DIMENSION(nzb+1:nzt,nys:nyn) ::  swap_diss_x_local_v !<
-       REAL(wp), DIMENSION(nzb+1:nzt,nys:nyn) ::  swap_flux_x_local_v !<
-       
-       REAL(wp), DIMENSION(nzb:nzt) ::  diss_n !<
-       REAL(wp), DIMENSION(nzb:nzt) ::  diss_r !<
-       REAL(wp), DIMENSION(nzb:nzt) ::  diss_t !<
-       REAL(wp), DIMENSION(nzb:nzt) ::  flux_n !<
-       REAL(wp), DIMENSION(nzb:nzt) ::  flux_r !<
-       REAL(wp), DIMENSION(nzb:nzt) ::  flux_t !<
-       REAL(wp), DIMENSION(nzb:nzt) ::  v_comp !<
-
-       gu = 2.0_wp * u_gtrans
-       gv = 2.0_wp * v_gtrans
-!
-!--    First compute the whole left boundary of the processor domain
-       i = nxl
-       DO  j = nysv, nyn
-          DO  k = nzb+1, nzb_max
-
-             ibit20 = IBITS(wall_flags_0(k,j,i-1),20,1)
-             ibit19 = IBITS(wall_flags_0(k,j,i-1),19,1)
-             ibit18 = IBITS(wall_flags_0(k,j,i-1),18,1)
-
-             u_comp                   = u(k,j-1,i) + u(k,j,i) - gu
-             swap_flux_x_local_v(k,j) = u_comp * (                             &
-                                      ( 37.0_wp * ibit20 * adv_mom_5              &
-                                   +     7.0_wp * ibit19 * adv_mom_3              &
-                                   +              ibit18 * adv_mom_1              &
-                                      ) *                                      &
-                                     ( v(k,j,i)   + v(k,j,i-1) )               &
-                               -      (  8.0_wp * ibit20 * adv_mom_5              &
-                                   +              ibit19 * adv_mom_3              &
-                                      ) *                                      &
-                                     ( v(k,j,i+1) + v(k,j,i-2) )               &
-                               +      (           ibit20 * adv_mom_5              &
-                                      ) *                                      &
-                                     ( v(k,j,i+2) + v(k,j,i-3) )               &
-                                                 )
-
-              swap_diss_x_local_v(k,j) = - ABS( u_comp ) * (                   &
-                                      ( 10.0_wp * ibit20 * adv_mom_5              &
-                                   +     3.0_wp * ibit19 * adv_mom_3              &
-                                   +              ibit18 * adv_mom_1              &
-                                      ) *                                      &
-                                     ( v(k,j,i)   - v(k,j,i-1) )               &
-                               -      (  5.0_wp * ibit20 * adv_mom_5              &
-                                   +              ibit19 * adv_mom_3              &
-                                      ) *                                      &
-                                     ( v(k,j,i+1) - v(k,j,i-2) )               &
-                               +      (           ibit20 * adv_mom_5              &
-                                      ) *                                      &
-                                     ( v(k,j,i+2) - v(k,j,i-3) )               &
-                                                           )
-
-          ENDDO
-
-          DO  k = nzb_max+1, nzt
-
-             u_comp                   = u(k,j-1,i) + u(k,j,i) - gu
-             swap_flux_x_local_v(k,j) = u_comp * (                            &
-                             37.0_wp * ( v(k,j,i) + v(k,j,i-1)   )               &
-                           -  8.0_wp * ( v(k,j,i+1) + v(k,j,i-2) )               &
-                           +           ( v(k,j,i+2) + v(k,j,i-3) ) ) * adv_mom_5
-             swap_diss_x_local_v(k,j) = - ABS( u_comp ) * (                   &
-                             10.0_wp * ( v(k,j,i) - v(k,j,i-1)   )               &
-                           -  5.0_wp * ( v(k,j,i+1) - v(k,j,i-2) )               &
-                           +           ( v(k,j,i+2) - v(k,j,i-3) ) ) * adv_mom_5
-
-          ENDDO
-
-       ENDDO
-
-       DO i = nxl, nxr
-
-          j = nysv
-          DO  k = nzb+1, nzb_max
-
-             ibit23 = IBITS(wall_flags_0(k,j-1,i),23,1)
-             ibit22 = IBITS(wall_flags_0(k,j-1,i),22,1)
-             ibit21 = IBITS(wall_flags_0(k,j-1,i),21,1)
-
-             v_comp(k)              = v(k,j,i) + v(k,j-1,i) - gv
-             swap_flux_y_local_v(k) = v_comp(k) * (                           &
-                                   ( 37.0_wp * ibit23 * adv_mom_5                &
-                                +     7.0_wp * ibit22 * adv_mom_3                &
-                                +              ibit21 * adv_mom_1                &
-                                   ) *                                        &
-                                     ( v(k,j,i)   + v(k,j-1,i) )              &
-                            -      (  8.0_wp * ibit23 * adv_mom_5                &
-                                +              ibit22 * adv_mom_3                &
-                                   ) *                                        &
-                                     ( v(k,j+1,i) + v(k,j-2,i) )              &
-                            +      (           ibit23 * adv_mom_5                &
-                                   ) *                                        &
-                                     ( v(k,j+2,i) + v(k,j-3,i) )              &
-                                                 )
-
-             swap_diss_y_local_v(k) = - ABS( v_comp(k) ) * (                  &
-                                   ( 10.0_wp * ibit23 * adv_mom_5                &
-                                +     3.0_wp * ibit22 * adv_mom_3                &
-                                +              ibit21 * adv_mom_1                &
-                                   ) *                                        &
-                                     ( v(k,j,i)   - v(k,j-1,i) )              &
-                            -      (  5.0_wp * ibit23 * adv_mom_5                &
-                                +              ibit22 * adv_mom_3                &
-                                   ) *                                        &
-                                     ( v(k,j+1,i) - v(k,j-2,i) )              &
-                            +      (           ibit23 * adv_mom_5                &
-                                   ) *                                        &
-                                     ( v(k,j+2,i) - v(k,j-3,i) )              &
-                                                          )
-
-          ENDDO
-
-          DO  k = nzb_max+1, nzt
-
-             v_comp(k)              = v(k,j,i) + v(k,j-1,i) - gv
-             swap_flux_y_local_v(k) = v_comp(k) * (                           &
-                           37.0_wp * ( v(k,j,i) + v(k,j-1,i)   )                 &
-                         -  8.0_wp * ( v(k,j+1,i) + v(k,j-2,i) )                 &
-                         +           ( v(k,j+2,i) + v(k,j-3,i) ) ) * adv_mom_5
-             swap_diss_y_local_v(k) = - ABS( v_comp(k) ) * (                  &
-                           10.0_wp * ( v(k,j,i) - v(k,j-1,i)   )                 &
-                         -  5.0_wp * ( v(k,j+1,i) - v(k,j-2,i) )                 &
-                         +           ( v(k,j+2,i) - v(k,j-3,i) ) ) * adv_mom_5
-
-          ENDDO
-
-          DO  j = nysv, nyn
-
-             flux_t(0) = 0.0_wp
-             diss_t(0) = 0.0_wp
-             flux_d    = 0.0_wp
-             diss_d    = 0.0_wp
-
-             DO  k = nzb+1, nzb_max
-
-                ibit20 = IBITS(wall_flags_0(k,j,i),20,1)
-                ibit19 = IBITS(wall_flags_0(k,j,i),19,1)
-                ibit18 = IBITS(wall_flags_0(k,j,i),18,1)
-
-                u_comp    = u(k,j-1,i+1) + u(k,j,i+1) - gu
-                flux_r(k) = u_comp * (                                       &
-                          ( 37.0_wp * ibit20 * adv_mom_5                        &
-                       +     7.0_wp * ibit19 * adv_mom_3                        &
-                       +              ibit18 * adv_mom_1                        &
-                          ) *                                                &
-                                 ( v(k,j,i+1) + v(k,j,i)   )                 &
-                   -      (  8.0_wp * ibit20 * adv_mom_5                        &
-                       +              ibit19 * adv_mom_3                        &
-                          ) *                                                &
-                                 ( v(k,j,i+2) + v(k,j,i-1) )                 &
-                   +      (           ibit20 * adv_mom_5                        &
-                          ) *                                                &
-                                 ( v(k,j,i+3) + v(k,j,i-2) )                 &
-                                     )
-
-                diss_r(k) = - ABS( u_comp ) * (                              &
-                          ( 10.0_wp * ibit20 * adv_mom_5                        &
-                       +     3.0_wp * ibit19 * adv_mom_3                        &
-                       +              ibit18 * adv_mom_1                        &
-                          ) *                                                &
-                                 ( v(k,j,i+1) - v(k,j,i)  )                  &
-                   -      (  5.0_wp * ibit20 * adv_mom_5                        &
-                       +              ibit19 * adv_mom_3                        &
-                          ) *                                                &
-                                 ( v(k,j,i+2) - v(k,j,i-1) )                 &
-                   +      (           ibit20 * adv_mom_5                        &
-                          ) *                                                &
-                                 ( v(k,j,i+3) - v(k,j,i-2) )                 &
-                                              )
-
-                ibit23 = IBITS(wall_flags_0(k,j,i),23,1)
-                ibit22 = IBITS(wall_flags_0(k,j,i),22,1)
-                ibit21 = IBITS(wall_flags_0(k,j,i),21,1)
-
-                v_comp(k) = v(k,j+1,i) + v(k,j,i)
-                flux_n(k) = ( v_comp(k) - gv ) * (                           &
-                          ( 37.0_wp * ibit23 * adv_mom_5                        &
-                       +     7.0_wp * ibit22 * adv_mom_3                        &
-                       +              ibit21 * adv_mom_1                        &
-                          ) *                                                &
-                                 ( v(k,j+1,i) + v(k,j,i)   )                 &
-                   -      (  8.0_wp * ibit23 * adv_mom_5                        &
-                       +              ibit22 * adv_mom_3                        &
-                          ) *                                                &
-                                 ( v(k,j+2,i) + v(k,j-1,i) )                 &
-                   +      (           ibit23 * adv_mom_5                        &
-                          ) *                                                &
-                                 ( v(k,j+3,i) + v(k,j-2,i) )                 &
-                                     )
-
-                diss_n(k) = - ABS( v_comp(k) - gv ) * (                      &
-                          ( 10.0_wp * ibit23 * adv_mom_5                        &
-                       +     3.0_wp * ibit22 * adv_mom_3                        &
-                       +              ibit21 * adv_mom_1                        &
-                          ) *                                                &
-                                 ( v(k,j+1,i) - v(k,j,i)  )                  &
-                   -      (  5.0_wp * ibit23 * adv_mom_5                        &
-                       +              ibit22 * adv_mom_3                        &
-                          ) *                                                &
-                                 ( v(k,j+2,i) - v(k,j-1,i) )                 &
-                   +      (           ibit23 * adv_mom_5                        &
-                          ) *                                                &
-                                 ( v(k,j+3,i) - v(k,j-2,i) )                 &
-                                                      )
-!
-!--             k index has to be modified near bottom and top, else array
-!--             subscripts will be exceeded.
-                ibit26 = IBITS(wall_flags_0(k,j,i),26,1)
-                ibit25 = IBITS(wall_flags_0(k,j,i),25,1)
-                ibit24 = IBITS(wall_flags_0(k,j,i),24,1)
-
-                k_ppp = k + 3 * ibit26
-                k_pp  = k + 2 * ( 1 - ibit24  )
-                k_mm  = k - 2 * ibit26
-
-                w_comp    = w(k,j-1,i) + w(k,j,i)
-                flux_t(k) = w_comp  * (                                      &
-                          ( 37.0_wp * ibit26 * adv_mom_5                        &
-                       +     7.0_wp * ibit25 * adv_mom_3                        &
-                       +              ibit24 * adv_mom_1                        &
-                          ) *                                                &
-                             ( v(k+1,j,i)   + v(k,j,i)    )                  &
-                   -      (  8.0_wp * ibit26 * adv_mom_5                        &
-                       +              ibit25 * adv_mom_3                        &
-                          ) *                                                &
-                             ( v(k_pp,j,i)  + v(k-1,j,i)  )                  &
-                   +      (           ibit26 * adv_mom_5                        &
-                          ) *                                                &
-                             ( v(k_ppp,j,i) + v(k_mm,j,i) )                  &
-                                      )
-
-                diss_t(k) = - ABS( w_comp ) * (                              &
-                          ( 10.0_wp * ibit26 * adv_mom_5                        &
-                       +     3.0_wp * ibit25 * adv_mom_3                        &
-                       +              ibit24 * adv_mom_1                        &
-                          ) *                                                &
-                             ( v(k+1,j,i)   - v(k,j,i)    )                  &
-                   -      (  5.0_wp * ibit26 * adv_mom_5                        &
-                       +              ibit25 * adv_mom_3                        &
-                          ) *                                                &
-                             ( v(k_pp,j,i)  - v(k-1,j,i)  )                  &
-                   +      (           ibit26 * adv_mom_5                        &
-                          ) *                                                &
-                             ( v(k_ppp,j,i) - v(k_mm,j,i) )                  &
-                                               )
-!
-!--             Calculate the divergence of the velocity field. A respective
-!--             correction is needed to overcome numerical instabilities caused
-!--             by a not sufficient reduction of divergences near topography.
-                div = ( ( ( u_comp     + gu )                                 &
-                                       * ( ibit18 + ibit19 + ibit20 )         &
-                - ( u(k,j-1,i)   + u(k,j,i) )                                 &
-                                       * ( IBITS(wall_flags_0(k,j,i-1),18,1)  &
-                                         + IBITS(wall_flags_0(k,j,i-1),19,1)  &
-                                         + IBITS(wall_flags_0(k,j,i-1),20,1)  &
-                                         )                                    &   
-                  ) * ddx                                                     &
-               +  ( v_comp(k)                                                 &
-                                       * ( ibit21 + ibit22 + ibit23 )         &
-                - ( v(k,j,i)     + v(k,j-1,i) )                               &
-                                       * ( IBITS(wall_flags_0(k,j-1,i),21,1)  &
-                                         + IBITS(wall_flags_0(k,j-1,i),22,1)  &
-                                         + IBITS(wall_flags_0(k,j-1,i),23,1)  &
-                                         )                                    &   
-                  ) * ddy                                                     &
-               +  ( w_comp                                                    &
-                                       * ( ibit24 + ibit25 + ibit26 )         &
-                - ( w(k-1,j-1,i) + w(k-1,j,i) )                               &
-                                       * ( IBITS(wall_flags_0(k-1,j,i),24,1)  &
-                                         + IBITS(wall_flags_0(k-1,j,i),25,1)  &
-                                         + IBITS(wall_flags_0(k-1,j,i),26,1)  &
-                                         )                                    &
-                   ) * ddzw(k)   &
-                ) * 0.5_wp
-
-
-                tend(k,j,i) = tend(k,j,i) - (                                 &
-                       ( flux_r(k) + diss_r(k)                                &
-                     -   swap_flux_x_local_v(k,j) - swap_diss_x_local_v(k,j)  &
-                       ) * ddx                                                &
-                     + ( flux_n(k) + diss_n(k)                                &
-                     -   swap_flux_y_local_v(k) - swap_diss_y_local_v(k)      &
-                       ) * ddy                                                &
-                     + ( flux_t(k) + diss_t(k)                                &
-                     -   flux_d    - diss_d                                   &
-                       ) * ddzw(k)                                            &
-                                            )  + v(k,j,i) * div
-
-                swap_flux_x_local_v(k,j) = flux_r(k)
-                swap_diss_x_local_v(k,j) = diss_r(k)
-                swap_flux_y_local_v(k)   = flux_n(k)
-                swap_diss_y_local_v(k)   = diss_n(k)
-                flux_d                   = flux_t(k)
-                diss_d                   = diss_t(k)
-
-!
-!--             Statistical Evaluation of v'v'. The factor has to be applied
-!--             for right evaluation when gallilei_trans = .T. .
-                sums_vs2_ws_l(k,tn) = sums_vs2_ws_l(k,tn)                     &
-                      + ( flux_n(k)                                           &
-                      * ( v_comp(k) - 2.0_wp * hom(k,1,2,0) )                    &
-                      / ( v_comp(k) - gv + 1.0E-20_wp )                       &
-                      +   diss_n(k)                                           &
-                      *   ABS( v_comp(k) - 2.0_wp * hom(k,1,2,0) )               &
-                      / ( ABS( v_comp(k) - gv ) +1.0E-20_wp ) )               &
-                      *   weight_substep(intermediate_timestep_count)
-!
-!--              Statistical Evaluation of w'v'.
-                 sums_wsvs_ws_l(k,tn) = sums_wsvs_ws_l(k,tn)                  &
-                              + ( flux_t(k) + diss_t(k) )                     &
-                              *   weight_substep(intermediate_timestep_count)
-
-             ENDDO
-
-             DO  k = nzb_max+1, nzt
-
-                u_comp    = u(k,j-1,i+1) + u(k,j,i+1) - gu
-                flux_r(k) = u_comp * (                                        &
-                      37.0_wp * ( v(k,j,i+1) + v(k,j,i)   )                      &
-                    -  8.0_wp * ( v(k,j,i+2) + v(k,j,i-1) )                      &
-                    +           ( v(k,j,i+3) + v(k,j,i-2) ) ) * adv_mom_5
-
-                diss_r(k) = - ABS( u_comp ) * (                               &
-                      10.0_wp * ( v(k,j,i+1) - v(k,j,i) )                        &
-                    -  5.0_wp * ( v(k,j,i+2) - v(k,j,i-1) )                      &
-                    +           ( v(k,j,i+3) - v(k,j,i-2) ) ) * adv_mom_5
-
-
-                v_comp(k) = v(k,j+1,i) + v(k,j,i)
-                flux_n(k) = ( v_comp(k) - gv ) * (                            &
-                      37.0_wp * ( v(k,j+1,i) + v(k,j,i)   )                      &
-                    -  8.0_wp * ( v(k,j+2,i) + v(k,j-1,i) )                      &
-                      +         ( v(k,j+3,i) + v(k,j-2,i) ) ) * adv_mom_5
-
-                diss_n(k) = - ABS( v_comp(k) - gv ) * (                       &
-                      10.0_wp * ( v(k,j+1,i) - v(k,j,i)   )                      &
-                    -  5.0_wp * ( v(k,j+2,i) - v(k,j-1,i) )                      &
-                    +           ( v(k,j+3,i) - v(k,j-2,i) ) ) * adv_mom_5
-!
-!--             k index has to be modified near bottom and top, else array
-!--             subscripts will be exceeded.
-                ibit26 = IBITS(wall_flags_0(k,j,i),26,1)
-                ibit25 = IBITS(wall_flags_0(k,j,i),25,1)
-                ibit24 = IBITS(wall_flags_0(k,j,i),24,1)
-
-                k_ppp = k + 3 * ibit26
-                k_pp  = k + 2 * ( 1 - ibit24  )
-                k_mm  = k - 2 * ibit26
-
-                w_comp    = w(k,j-1,i) + w(k,j,i)
-                flux_t(k) = w_comp  * (                                      &
-                          ( 37.0_wp * ibit26 * adv_mom_5                        &
-                       +     7.0_wp * ibit25 * adv_mom_3                        &
-                       +              ibit24 * adv_mom_1                        &
-                          ) *                                                &
-                             ( v(k+1,j,i)   + v(k,j,i)    )                  &
-                   -      (  8.0_wp * ibit26 * adv_mom_5                        &
-                       +              ibit25 * adv_mom_3                        &
-                          ) *                                                &
-                             ( v(k_pp,j,i)  + v(k-1,j,i)  )                  &
-                   +      (           ibit26 * adv_mom_5                        &
-                          ) *                                                &
-                             ( v(k_ppp,j,i) + v(k_mm,j,i) )                  &
-                                      )
-
-                diss_t(k) = - ABS( w_comp ) * (                              &
-                          ( 10.0_wp * ibit26 * adv_mom_5                        &
-                       +     3.0_wp * ibit25 * adv_mom_3                        &
-                       +              ibit24 * adv_mom_1                        &
-                          ) *                                                &
-                             ( v(k+1,j,i)   - v(k,j,i)    )                  &
-                   -      (  5.0_wp * ibit26 * adv_mom_5                        &
-                       +              ibit25 * adv_mom_3                        &
-                          ) *                                                &
-                             ( v(k_pp,j,i)  - v(k-1,j,i)  )                  &
-                   +      (           ibit26 * adv_mom_5                        &
-                          ) *                                                &
-                             ( v(k_ppp,j,i) - v(k_mm,j,i) )                  &
-                                               )
-!
-!--             Calculate the divergence of the velocity field. A respective
-!--             correction is needed to overcome numerical instabilities caused
-!--             by a not sufficient reduction of divergences near topography.
-                div = ( ( u_comp + gu - ( u(k,j-1,i)   + u(k,j,i)   ) ) * ddx &
-                     +  ( v_comp(k)   - ( v(k,j,i)     + v(k,j-1,i) ) ) * ddy &
-                     +  ( w_comp      - ( w(k-1,j-1,i) + w(k-1,j,i) ) )       &
-                                                                    * ddzw(k) &
-                      ) * 0.5_wp
- 
-                tend(k,j,i) = tend(k,j,i) - (                                 &
-                       ( flux_r(k) + diss_r(k)                                &
-                     -   swap_flux_x_local_v(k,j) - swap_diss_x_local_v(k,j)  &
-                       ) * ddx                                                &
-                     + ( flux_n(k) + diss_n(k)                                &
-                     -   swap_flux_y_local_v(k) - swap_diss_y_local_v(k)      &
-                       ) * ddy                                                &
-                     + ( flux_t(k) + diss_t(k)                                &
-                     -   flux_d    - diss_d                                   &
-                       ) * ddzw(k)                                            &
-                                            )  + v(k,j,i) * div
-
-                swap_flux_x_local_v(k,j) = flux_r(k)
-                swap_diss_x_local_v(k,j) = diss_r(k)
-                swap_flux_y_local_v(k)   = flux_n(k)
-                swap_diss_y_local_v(k)   = diss_n(k)
-                flux_d                   = flux_t(k)
-                diss_d                   = diss_t(k)
-
-!
-!--             Statistical Evaluation of v'v'. The factor has to be applied
-!--             for right evaluation when gallilei_trans = .T. .
-                sums_vs2_ws_l(k,tn) = sums_vs2_ws_l(k,tn)                     &
-                         + ( flux_n(k)                                        &
-                         * ( v_comp(k) - 2.0_wp * hom(k,1,2,0) )                 &
-                         / ( v_comp(k) - gv + 1.0E-20_wp )                    &
-                         +   diss_n(k)                                        &
-                         *   ABS( v_comp(k) - 2.0_wp * hom(k,1,2,0) )            &
-                         / ( ABS( v_comp(k) - gv ) +1.0E-20_wp ) )            &
-                         *   weight_substep(intermediate_timestep_count)
-!
-!--             Statistical Evaluation of w'v'.
-                sums_wsvs_ws_l(k,tn) = sums_wsvs_ws_l(k,tn)                    &
-                              + ( flux_t(k) + diss_t(k) )                      &
-                              *   weight_substep(intermediate_timestep_count)
-
-             ENDDO
-          ENDDO
-       ENDDO
-       sums_vs2_ws_l(nzb,tn) = sums_vs2_ws_l(nzb+1,tn)
-
-
-    END SUBROUTINE advec_v_ws
-    
-    
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Advection of v - Call for all grid points - accelerator version
-!------------------------------------------------------------------------------!
-    SUBROUTINE advec_v_ws_acc
-
-       USE arrays_3d,                                                          &
-           ONLY:  ddzw, tend, u, v, w
-
-       USE constants,                                                          &
-           ONLY:  adv_mom_1, adv_mom_3, adv_mom_5
-
-       USE control_parameters,                                                 &
-           ONLY:  intermediate_timestep_count, u_gtrans, v_gtrans
-
-       USE grid_variables,                                                     &
-           ONLY:  ddx, ddy
-
-       USE indices,                                                            &
-           ONLY:  i_left, i_right, j_north, j_south, nxl, nxr, nyn, nys, nzb,  &
-                  nzb_max, nzt, wall_flags_0
-           
-       USE kinds
-       
-!        USE statistics,                                                       &
-!            ONLY:  hom, sums_vs2_ws_l, sums_wsvs_ws_l, weight_substep
-
-       IMPLICIT NONE
-
-
-       INTEGER(iwp) ::  i      !<
-       INTEGER(iwp) ::  ibit18 !<
-       INTEGER(iwp) ::  ibit19 !<
-       INTEGER(iwp) ::  ibit20 !<
-       INTEGER(iwp) ::  ibit21 !<
-       INTEGER(iwp) ::  ibit22 !<
-       INTEGER(iwp) ::  ibit23 !<
-       INTEGER(iwp) ::  ibit24 !<
-       INTEGER(iwp) ::  ibit25 !<
-       INTEGER(iwp) ::  ibit26 !<
-       INTEGER(iwp) ::  j      !<
-       INTEGER(iwp) ::  k      !<
-       INTEGER(iwp) ::  k_mm   !<
-       INTEGER(iwp) ::  k_mmm  !<
-       INTEGER(iwp) ::  k_pp   !<
-       INTEGER(iwp) ::  k_ppp  !<
-       INTEGER(iwp) ::  tn = 0 !<
-
-       REAL(wp)    ::  diss_d   !<
-       REAL(wp)    ::  diss_l   !<
-       REAL(wp)    ::  diss_n   !<
-       REAL(wp)    ::  diss_r   !<
-       REAL(wp)    ::  diss_s   !<
-       REAL(wp)    ::  diss_t   !<
-       REAL(wp)    ::  div      !<
-       REAL(wp)    ::  flux_d   !<
-       REAL(wp)    ::  flux_l   !<
-       REAL(wp)    ::  flux_n   !<
-       REAL(wp)    ::  flux_r   !<
-       REAL(wp)    ::  flux_s   !<
-       REAL(wp)    ::  flux_t   !<
-       REAL(wp)    ::  gu       !<
-       REAL(wp)    ::  gv       !<
-       REAL(wp)    ::  u_comp   !<
-       REAL(wp)    ::  u_comp_l !<
-       REAL(wp)    ::  v_comp   !<
-       REAL(wp)    ::  v_comp_s !<
-       REAL(wp)    ::  w_comp   !<
-
-       gu = 2.0_wp * u_gtrans
-       gv = 2.0_wp * v_gtrans
-
-!
-!--    Computation of fluxes and tendency terms
-       !$acc kernels present( ddzw, tend, u, v, w, wall_flags_0 )
-       DO  i = i_left, i_right
-          DO  j = j_south, j_north
-             DO  k = nzb+1, nzt
-
-                ibit20 = IBITS(wall_flags_0(k,j,i-1),20,1)
-                ibit19 = IBITS(wall_flags_0(k,j,i-1),19,1)
-                ibit18 = IBITS(wall_flags_0(k,j,i-1),18,1)
-
-                u_comp_l                 = u(k,j-1,i) + u(k,j,i) - gu
-                flux_l                   = u_comp_l * (                          &
-                                      ( 37.0_wp * ibit20 * adv_mom_5              &
-                                   +     7.0_wp * ibit19 * adv_mom_3              &
-                                   +              ibit18 * adv_mom_1              &
-                                      ) *                                      &
-                                     ( v(k,j,i)   + v(k,j,i-1) )               &
-                               -      (  8.0_wp * ibit20 * adv_mom_5              &
-                                   +              ibit19 * adv_mom_3              &
-                                      ) *                                      &
-                                     ( v(k,j,i+1) + v(k,j,i-2) )               &
-                               +      (           ibit20 * adv_mom_5              &
-                                      ) *                                      &
-                                     ( v(k,j,i+2) + v(k,j,i-3) )               &
-                                                 )
-
-                diss_l                   = - ABS( u_comp_l ) * (                 &
-                                      ( 10.0_wp * ibit20 * adv_mom_5              &
-                                   +     3.0_wp * ibit19 * adv_mom_3              &
-                                   +              ibit18 * adv_mom_1              &
-                                      ) *                                      &
-                                     ( v(k,j,i)   - v(k,j,i-1) )               &
-                               -      (  5.0_wp * ibit20 * adv_mom_5              &
-                                   +              ibit19 * adv_mom_3              &
-                                      ) *                                      &
-                                     ( v(k,j,i+1) - v(k,j,i-2) )               &
-                               +      (           ibit20 * adv_mom_5              &
-                                      ) *                                      &
-                                     ( v(k,j,i+2) - v(k,j,i-3) )               &
-                                                           )
-
-                ibit20 = IBITS(wall_flags_0(k,j,i),20,1)
-                ibit19 = IBITS(wall_flags_0(k,j,i),19,1)
-                ibit18 = IBITS(wall_flags_0(k,j,i),18,1)
-
-                u_comp    = u(k,j-1,i+1) + u(k,j,i+1) - gu
-                flux_r    = u_comp * (                                       &
-                          ( 37.0_wp * ibit20 * adv_mom_5                        &
-                       +     7.0_wp * ibit19 * adv_mom_3                        &
-                       +              ibit18 * adv_mom_1                        &
-                          ) *                                                &
-                                 ( v(k,j,i+1) + v(k,j,i)   )                 &
-                   -      (  8.0_wp * ibit20 * adv_mom_5                        &
-                       +              ibit19 * adv_mom_3                        &
-                          ) *                                                &
-                                 ( v(k,j,i+2) + v(k,j,i-1) )                 &
-                   +      (           ibit20 * adv_mom_5                        &
-                          ) *                                                &
-                                 ( v(k,j,i+3) + v(k,j,i-2) )                 &
-                                     )
-
-                diss_r    = - ABS( u_comp ) * (                              &
-                          ( 10.0_wp * ibit20 * adv_mom_5                        &
-                       +     3.0_wp * ibit19 * adv_mom_3                        &
-                       +              ibit18 * adv_mom_1                        &
-                          ) *                                                &
-                                 ( v(k,j,i+1) - v(k,j,i)  )                  &
-                   -      (  5.0_wp * ibit20 * adv_mom_5                        &
-                       +              ibit19 * adv_mom_3                        &
-                          ) *                                                &
-                                 ( v(k,j,i+2) - v(k,j,i-1) )                 &
-                   +      (           ibit20 * adv_mom_5                        &
-                          ) *                                                &
-                                 ( v(k,j,i+3) - v(k,j,i-2) )                 &
-                                              )
-
-                ibit23 = IBITS(wall_flags_0(k,j-1,i),23,1)
-                ibit22 = IBITS(wall_flags_0(k,j-1,i),22,1)
-                ibit21 = IBITS(wall_flags_0(k,j-1,i),21,1)
-
-
-                v_comp_s              = v(k,j,i) + v(k,j-1,i) - gv
-                flux_s                = v_comp_s    * (                       &
-                                   ( 37.0_wp * ibit23 * adv_mom_5                &
-                                +     7.0_wp * ibit22 * adv_mom_3                &
-                                +              ibit21 * adv_mom_1                &
-                                   ) *                                        &
-                                     ( v(k,j,i)   + v(k,j-1,i) )              &
-                            -      (  8.0_wp * ibit23 * adv_mom_5                &
-                                +              ibit22 * adv_mom_3                &
-                                   ) *                                        &
-                                     ( v(k,j+1,i) + v(k,j-2,i) )              &
-                            +      (           ibit23 * adv_mom_5                &
-                                   ) *                                        &
-                                     ( v(k,j+2,i) + v(k,j-3,i) )              &
-                                                 )
-
-                diss_s                = - ABS( v_comp_s ) * (                 &
-                                   ( 10.0_wp * ibit23 * adv_mom_5                &
-                                +     3.0_wp * ibit22 * adv_mom_3                &
-                                +              ibit21 * adv_mom_1                &
-                                   ) *                                        &
-                                     ( v(k,j,i)   - v(k,j-1,i) )              &
-                            -      (  5.0_wp * ibit23 * adv_mom_5                &
-                                +              ibit22 * adv_mom_3                &
-                                   ) *                                        &
-                                     ( v(k,j+1,i) - v(k,j-2,i) )              &
-                            +      (           ibit23 * adv_mom_5                &
-                                   ) *                                        &
-                                     ( v(k,j+2,i) - v(k,j-3,i) )              &
-                                                          )
-
-                ibit23 = IBITS(wall_flags_0(k,j,i),23,1)
-                ibit22 = IBITS(wall_flags_0(k,j,i),22,1)
-                ibit21 = IBITS(wall_flags_0(k,j,i),21,1)
-
-                v_comp = v(k,j+1,i) + v(k,j,i)
-                flux_n = ( v_comp - gv ) * (                                 &
-                          ( 37.0_wp * ibit23 * adv_mom_5                        &
-                       +     7.0_wp * ibit22 * adv_mom_3                        &
-                       +              ibit21 * adv_mom_1                        &
-                          ) *                                                &
-                                 ( v(k,j+1,i) + v(k,j,i)   )                 &
-                   -      (  8.0_wp * ibit23 * adv_mom_5                        &
-                       +              ibit22 * adv_mom_3                        &
-                          ) *                                                &
-                                 ( v(k,j+2,i) + v(k,j-1,i) )                 &
-                   +      (           ibit23 * adv_mom_5                        &
-                          ) *                                                &
-                                 ( v(k,j+3,i) + v(k,j-2,i) )                 &
-                                     )
-
-                diss_n = - ABS( v_comp - gv ) * (                         &
-                          ( 10.0_wp * ibit23 * adv_mom_5                        &
-                       +     3.0_wp * ibit22 * adv_mom_3                        &
-                       +              ibit21 * adv_mom_1                        &
-                          ) *                                                &
-                                 ( v(k,j+1,i) - v(k,j,i)  )                  &
-                   -      (  5.0_wp * ibit23 * adv_mom_5                        &
-                       +              ibit22 * adv_mom_3                        &
-                          ) *                                                &
-                                 ( v(k,j+2,i) - v(k,j-1,i) )                 &
-                   +      (           ibit23 * adv_mom_5                        &
-                          ) *                                                &
-                                 ( v(k,j+3,i) - v(k,j-2,i) )                 &
-                                                     )
-
-                ibit26 = IBITS(wall_flags_0(k-1,j,i),26,1)
-                ibit25 = IBITS(wall_flags_0(k-1,j,i),25,1)
-                ibit24 = IBITS(wall_flags_0(k-1,j,i),24,1)
-
-                k_pp  = k + 2 * ibit26
-                k_mm  = k - 2 * ( ibit25 + ibit26 )
-                k_mmm = k - 3 * ibit26
-
-                w_comp    = w(k-1,j-1,i) + w(k-1,j,i)
-                flux_d    = w_comp  * (                                      &
-                          ( 37.0_wp * ibit26 * adv_mom_5                        &
-                       +     7.0_wp * ibit25 * adv_mom_3                        &
-                       +              ibit24 * adv_mom_1                        &
-                          ) *                                                &
-                             ( v(k,j,i)     + v(k-1,j,i)  )                  &
-                   -      (  8.0_wp * ibit26 * adv_mom_5                        &
-                       +              ibit25 * adv_mom_3                        &
-                          ) *                                                &
-                             ( v(k+1,j,i)  + v(k_mm,j,i)  )                  &
-                   +      (           ibit26 * adv_mom_5                        &
-                          ) *                                                &
-                             ( v(k_pp,j,i) + v(k_mmm,j,i) )                  &
-                                      )
-
-                diss_d    = - ABS( w_comp ) * (                              &
-                          ( 10.0_wp * ibit26 * adv_mom_5                        &
-                       +     3.0_wp * ibit25 * adv_mom_3                        &
-                       +              ibit24 * adv_mom_1                        &
-                          ) *                                                &
-                             ( v(k,j,i)     - v(k-1,j,i)  )                  &
-                   -      (  5.0_wp * ibit26 * adv_mom_5                        &
-                       +              ibit25 * adv_mom_3                        &
-                          ) *                                                &
-                             ( v(k+1,j,i)  - v(k_mm,j,i)  )                  &
-                   +      (           ibit26 * adv_mom_5                        &
-                          ) *                                                &
-                             ( v(k_pp,j,i) - v(k_mmm,j,i) )                  &
-                                               )
-!
-!--             k index has to be modified near bottom and top, else array
-!--             subscripts will be exceeded.
-                ibit26 = IBITS(wall_flags_0(k,j,i),26,1)
-                ibit25 = IBITS(wall_flags_0(k,j,i),25,1)
-                ibit24 = IBITS(wall_flags_0(k,j,i),24,1)
-
-                k_ppp = k + 3 * ibit26
-                k_pp  = k + 2 * ( 1 - ibit24  )
-                k_mm  = k - 2 * ibit26
-
-                w_comp    = w(k,j-1,i) + w(k,j,i)
-                flux_t    = w_comp  * (                                      &
-                          ( 37.0_wp * ibit26 * adv_mom_5                        &
-                       +     7.0_wp * ibit25 * adv_mom_3                        &
-                       +              ibit24 * adv_mom_1                        &
-                          ) *                                                &
-                             ( v(k+1,j,i)   + v(k,j,i)    )                  &
-                   -      (  8.0_wp * ibit26 * adv_mom_5                        &
-                       +              ibit25 * adv_mom_3                        &
-                          ) *                                                &
-                             ( v(k_pp,j,i)  + v(k-1,j,i)  )                  &
-                   +      (           ibit26 * adv_mom_5                        &
-                          ) *                                                &
-                             ( v(k_ppp,j,i) + v(k_mm,j,i) )                  &
-                                      )
-
-                diss_t    = - ABS( w_comp ) * (                              &
-                          ( 10.0_wp * ibit26 * adv_mom_5                        &
-                       +     3.0_wp * ibit25 * adv_mom_3                        &
-                       +              ibit24 * adv_mom_1                        &
-                          ) *                                                &
-                             ( v(k+1,j,i)   - v(k,j,i)    )                  &
-                   -      (  5.0_wp * ibit26 * adv_mom_5                        &
-                       +              ibit25 * adv_mom_3                        &
-                          ) *                                                &
-                             ( v(k_pp,j,i)  - v(k-1,j,i)  )                  &
-                   +      (           ibit26 * adv_mom_5                        &
-                          ) *                                                &
-                             ( v(k_ppp,j,i) - v(k_mm,j,i) )                  &
-                                               )
-!
-!--             Calculate the divergence of the velocity field. A respective
-!--             correction is needed to overcome numerical instabilities caused
-!--             by a not sufficient reduction of divergences near topography.
-                div = ( ( ( u_comp     + gu )                                 &
-                                       * ( ibit18 + ibit19 + ibit20 )         &
-                - ( u(k,j-1,i)   + u(k,j,i) )                                 &
-                                       * ( IBITS(wall_flags_0(k,j,i-1),18,1)  &
-                                         + IBITS(wall_flags_0(k,j,i-1),19,1)  &
-                                         + IBITS(wall_flags_0(k,j,i-1),20,1)  &
-                                         )                                    &   
-                  ) * ddx                                                     &
-               +  ( v_comp                                                    &
-                                       * ( ibit21 + ibit22 + ibit23 )         &
-                - ( v(k,j,i)     + v(k,j-1,i) )                               &
-                                       * ( IBITS(wall_flags_0(k,j-1,i),21,1)  &
-                                         + IBITS(wall_flags_0(k,j-1,i),22,1)  &
-                                         + IBITS(wall_flags_0(k,j-1,i),23,1)  &
-                                         )                                    &   
-                  ) * ddy                                                     &
-               +  ( w_comp                                                    &
-                                       * ( ibit24 + ibit25 + ibit26 )         &
-                - ( w(k-1,j-1,i) + w(k-1,j,i) )                               &
-                                       * ( IBITS(wall_flags_0(k-1,j,i),24,1)  &
-                                         + IBITS(wall_flags_0(k-1,j,i),25,1)  &
-                                         + IBITS(wall_flags_0(k-1,j,i),26,1)  &
-                                         )                                    &
-                   ) * ddzw(k)   &
-                ) * 0.5_wp
-
-
-                tend(k,j,i) = - (                                              &
-                               ( flux_r + diss_r - flux_l - diss_l ) * ddx     &
-                             + ( flux_n + diss_n - flux_s - diss_s ) * ddy     &
-                             + ( flux_t + diss_t - flux_d - diss_d ) * ddzw(k) &
-                                ) + div * v(k,j,i)
-
-
-!++
-!--             Statistical Evaluation of v'v'. The factor has to be applied
-!--             for right evaluation when gallilei_trans = .T. .
-!                sums_vs2_ws_l(k,tn) = sums_vs2_ws_l(k,tn)                  &
-!                      + ( flux_n                                           &
-!                      * ( v_comp - 2.0_wp * hom(k,1,2,0) )                    &
-!                      / ( v_comp - gv + 1.0E-20_wp )                       &
-!                      +   diss_n                                           &
-!                      *   ABS( v_comp - 2.0_wp * hom(k,1,2,0) )               &
-!                      / ( ABS( v_comp - gv ) +1.0E-20_wp ) )               &
-!                      *   weight_substep(intermediate_timestep_count)
-!
-!--              Statistical Evaluation of w'v'.
-!                 sums_wsvs_ws_l(k,tn) = sums_wsvs_ws_l(k,tn)                &
-!                              + ( flux_t + diss_t )                         &
-!                              *   weight_substep(intermediate_timestep_count)
-
-             ENDDO
-          ENDDO
-       ENDDO
-       !$acc end kernels
-
-!++
-!       sums_vs2_ws_l(nzb,tn) = sums_vs2_ws_l(nzb+1,tn)
-
-    END SUBROUTINE advec_v_ws_acc
-    
-    
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Advection of w - Call for all grid points
-!------------------------------------------------------------------------------!
-    SUBROUTINE advec_w_ws
-
-       USE arrays_3d,                                                          &
-           ONLY:  ddzu, tend, u, v, w
-
-       USE constants,                                                          &
-           ONLY:  adv_mom_1, adv_mom_3, adv_mom_5
-
-       USE control_parameters,                                                 &
-           ONLY:  intermediate_timestep_count, u_gtrans, v_gtrans
-
-       USE grid_variables,                                                     &
-           ONLY:  ddx, ddy
-
-       USE indices,                                                            &
-           ONLY:  nxl, nxr, nyn, nys, nzb, nzb_max, nzt, wall_flags_0,         &
-                  wall_flags_00
-
-       USE kinds
-       
-       USE statistics,                                                         &
-           ONLY:  hom, sums_ws2_ws_l, weight_substep
-
-       IMPLICIT NONE
-
-       INTEGER(iwp) ::  i      !<
-       INTEGER(iwp) ::  ibit27 !<
-       INTEGER(iwp) ::  ibit28 !<
-       INTEGER(iwp) ::  ibit29 !<
-       INTEGER(iwp) ::  ibit30 !<
-       INTEGER(iwp) ::  ibit31 !<
-       INTEGER(iwp) ::  ibit32 !<
-       INTEGER(iwp) ::  ibit33 !<
-       INTEGER(iwp) ::  ibit34 !<
-       INTEGER(iwp) ::  ibit35 !<
-       INTEGER(iwp) ::  j      !<
-       INTEGER(iwp) ::  k      !<
-       INTEGER(iwp) ::  k_mm   !<
-       INTEGER(iwp) ::  k_pp   !<
-       INTEGER(iwp) ::  k_ppp  !<
-       INTEGER(iwp) ::  tn = 0 !<
-       
-       REAL(wp)    ::  diss_d !<
-       REAL(wp)    ::  div    !<
-       REAL(wp)    ::  flux_d !<
-       REAL(wp)    ::  gu     !<
-       REAL(wp)    ::  gv     !<
-       REAL(wp)    ::  u_comp !<
-       REAL(wp)    ::  v_comp !<
-       REAL(wp)    ::  w_comp !<
-       
-       REAL(wp), DIMENSION(nzb:nzt)    ::  diss_t !<
-       REAL(wp), DIMENSION(nzb:nzt)    ::  flux_t !<
-       
-       REAL(wp), DIMENSION(nzb+1:nzt)  ::  diss_n !<
-       REAL(wp), DIMENSION(nzb+1:nzt)  ::  diss_r !<
-       REAL(wp), DIMENSION(nzb+1:nzt)  ::  flux_n !<
-       REAL(wp), DIMENSION(nzb+1:nzt)  ::  flux_r !<
-       REAL(wp), DIMENSION(nzb+1:nzt)  ::  swap_diss_y_local_w !<
-       REAL(wp), DIMENSION(nzb+1:nzt)  ::  swap_flux_y_local_w !<
-       
-       REAL(wp), DIMENSION(nzb+1:nzt,nys:nyn) ::  swap_diss_x_local_w !<
-       REAL(wp), DIMENSION(nzb+1:nzt,nys:nyn) ::  swap_flux_x_local_w !<
- 
-       gu = 2.0_wp * u_gtrans
-       gv = 2.0_wp * v_gtrans
-!
-!--   compute the whole left boundary of the processor domain
-       i = nxl
-       DO  j = nys, nyn
-          DO  k = nzb+1, nzb_max
-
-             ibit29 = IBITS(wall_flags_0(k,j,i-1),29,1)
-             ibit28 = IBITS(wall_flags_0(k,j,i-1),28,1)
-             ibit27 = IBITS(wall_flags_0(k,j,i-1),27,1)
-
-             u_comp                   = u(k+1,j,i) + u(k,j,i) - gu
-             swap_flux_x_local_w(k,j) = u_comp * (                             &
-                                      ( 37.0_wp * ibit29 * adv_mom_5              &
-                                   +     7.0_wp * ibit28 * adv_mom_3              &
-                                   +              ibit27 * adv_mom_1              &
-                                      ) *                                      &
-                                     ( w(k,j,i)   + w(k,j,i-1) )               &
-                               -      (  8.0_wp * ibit29 * adv_mom_5              &
-                                   +              ibit28 * adv_mom_3              &
-                                      ) *                                      &
-                                     ( w(k,j,i+1) + w(k,j,i-2) )               &
-                               +      (           ibit29 * adv_mom_5              &
-                                      ) *                                      &
-                                     ( w(k,j,i+2) + w(k,j,i-3) )               &
-                                                 )
-
-               swap_diss_x_local_w(k,j) = - ABS( u_comp ) * (                  &
-                                        ( 10.0_wp * ibit29 * adv_mom_5            &
-                                     +     3.0_wp * ibit28 * adv_mom_3            &
-                                     +              ibit27 * adv_mom_1            &
-                                        ) *                                    &
-                                     ( w(k,j,i)   - w(k,j,i-1) )               &
-                                 -      (  5.0_wp * ibit29 * adv_mom_5            &
-                                     +              ibit28 * adv_mom_3            &
-                                        ) *                                    &
-                                     ( w(k,j,i+1) - w(k,j,i-2) )               &
-                                 +      (           ibit29 * adv_mom_5            &
-                                        ) *                                    &
-                                     ( w(k,j,i+2) - w(k,j,i-3) )               &
-                                                            )
-
-          ENDDO
-
-          DO  k = nzb_max+1, nzt
-
-             u_comp                   = u(k+1,j,i) + u(k,j,i) - gu
-             swap_flux_x_local_w(k,j) = u_comp * (                             &
-                            37.0_wp * ( w(k,j,i) + w(k,j,i-1)   )                 &
-                          -  8.0_wp * ( w(k,j,i+1) + w(k,j,i-2) )                 &
-                          +           ( w(k,j,i+2) + w(k,j,i-3) ) ) * adv_mom_5
-             swap_diss_x_local_w(k,j) = - ABS( u_comp ) * (                    &
-                            10.0_wp * ( w(k,j,i) - w(k,j,i-1)   )                 &
-                          -  5.0_wp * ( w(k,j,i+1) - w(k,j,i-2) )                 &
-                          +           ( w(k,j,i+2) - w(k,j,i-3) ) ) * adv_mom_5
-
-          ENDDO
-
-       ENDDO
-
-       DO i = nxl, nxr
-
-          j = nys
-          DO  k = nzb+1, nzb_max
-
-             ibit32 = IBITS(wall_flags_00(k,j-1,i),0,1)
-             ibit31 = IBITS(wall_flags_0(k,j-1,i),31,1)
-             ibit30 = IBITS(wall_flags_0(k,j-1,i),30,1)
-
-             v_comp                 = v(k+1,j,i) + v(k,j,i) - gv
-             swap_flux_y_local_w(k) = v_comp * (                              &
-                                    ( 37.0_wp * ibit32 * adv_mom_5               &
-                                 +     7.0_wp * ibit31 * adv_mom_3               &
-                                 +              ibit30 * adv_mom_1               &
-                                    ) *                                        &
-                                     ( w(k,j,i)   + w(k,j-1,i) )              &
-                             -      (  8.0_wp * ibit32 * adv_mom_5               &
-                                 +              ibit31 * adv_mom_3               &
-                                    ) *                                       &
-                                     ( w(k,j+1,i) + w(k,j-2,i) )              &
-                             +      (           ibit32 * adv_mom_5               &
-                                    ) *                                       &
-                                     ( w(k,j+2,i) + w(k,j-3,i) )              &
-                                               )
-
-             swap_diss_y_local_w(k) = - ABS( v_comp ) * (                     &
-                                    ( 10.0_wp * ibit32 * adv_mom_5               &
-                                 +     3.0_wp * ibit31 * adv_mom_3               &
-                                 +              ibit30 * adv_mom_1               &
-                                    ) *                                       &
-                                     ( w(k,j,i)   - w(k,j-1,i) )              &
-                             -      (  5.0_wp * ibit32 * adv_mom_5               &
-                                 +              ibit31 * adv_mom_3               &
-                                    ) *                                       &
-                                     ( w(k,j+1,i) - w(k,j-2,i) )              &
-                             +      (           ibit32 * adv_mom_5               &
-                                    ) *                                       &
-                                     ( w(k,j+2,i) - w(k,j-3,i) )              &
-                                                        )
-
-          ENDDO
-
-          DO  k = nzb_max+1, nzt
-
-             v_comp                 = v(k+1,j,i) + v(k,j,i) - gv
-             swap_flux_y_local_w(k) = v_comp * (                              &
-                           37.0_wp * ( w(k,j,i) + w(k,j-1,i)   )                 &
-                         -  8.0_wp * ( w(k,j+1,i) +w(k,j-2,i)  )                 &
-                         +           ( w(k,j+2,i) + w(k,j-3,i) ) ) * adv_mom_5
-             swap_diss_y_local_w(k) = - ABS( v_comp ) * (                     &
-                           10.0_wp * ( w(k,j,i) - w(k,j-1,i)   )                 &
-                         -  5.0_wp * ( w(k,j+1,i) - w(k,j-2,i) )                 &
-                         +           ( w(k,j+2,i) - w(k,j-3,i) ) ) * adv_mom_5
-
-          ENDDO
-
-          DO  j = nys, nyn
-
-!
-!--          The lower flux has to be calculated explicetely for the tendency
-!--          at the first w-level. For topography wall this is done implicitely
-!--          by wall_flags_0.
-             k         = nzb + 1
-             w_comp    = w(k,j,i) + w(k-1,j,i)
-             flux_t(0) = w_comp       * ( w(k,j,i) + w(k-1,j,i) ) * adv_mom_1
-             diss_t(0) = -ABS(w_comp) * ( w(k,j,i) - w(k-1,j,i) ) * adv_mom_1
-             flux_d    = flux_t(0)
-             diss_d    = diss_t(0)
-
-             DO  k = nzb+1, nzb_max
-
-                ibit29 = IBITS(wall_flags_0(k,j,i),29,1)
-                ibit28 = IBITS(wall_flags_0(k,j,i),28,1)
-                ibit27 = IBITS(wall_flags_0(k,j,i),27,1)
-
-                u_comp    = u(k+1,j,i+1) + u(k,j,i+1) - gu
-                flux_r(k) = u_comp * (                                       &
-                          ( 37.0_wp * ibit29 * adv_mom_5                        &
-                       +     7.0_wp * ibit28 * adv_mom_3                        &
-                       +              ibit27 * adv_mom_1                        &
-                          ) *                                                &
-                                 ( w(k,j,i+1) + w(k,j,i)   )                 &
-                   -      (  8.0_wp * ibit29 * adv_mom_5                        &
-                       +              ibit28 * adv_mom_3                        &
-                          ) *                                                &
-                                 ( w(k,j,i+2) + w(k,j,i-1) )                 &
-                   +      (           ibit29 * adv_mom_5                        &
-                          ) *                                                &
-                                 ( w(k,j,i+3) + w(k,j,i-2) )                 &
-                                     )
-
-                diss_r(k) = - ABS( u_comp ) * (                              &
-                          ( 10.0_wp * ibit29 * adv_mom_5                        &
-                       +     3.0_wp * ibit28 * adv_mom_3                        &
-                       +              ibit27 * adv_mom_1                        &
-                          ) *                                                &
-                                 ( w(k,j,i+1) - w(k,j,i)  )                  &
-                   -      (  5.0_wp * ibit29 * adv_mom_5                        &
-                       +              ibit28 * adv_mom_3                        &
-                          ) *                                                &
-                                 ( w(k,j,i+2) - w(k,j,i-1) )                 &
-                   +      (           ibit29 * adv_mom_5                        &
-                          ) *                                                &
-                                 ( w(k,j,i+3) - w(k,j,i-2) )                 &
-                                              )
-
-                ibit32 = IBITS(wall_flags_00(k,j,i),0,1)
-                ibit31 = IBITS(wall_flags_0(k,j,i),31,1)
-                ibit30 = IBITS(wall_flags_0(k,j,i),30,1)
-
-                v_comp    = v(k+1,j+1,i) + v(k,j+1,i) - gv
-                flux_n(k) = v_comp * (                                       &
-                          ( 37.0_wp * ibit32 * adv_mom_5                        &
-                       +     7.0_wp * ibit31 * adv_mom_3                        &
-                       +              ibit30 * adv_mom_1                        &
-                          ) *                                                &
-                                 ( w(k,j+1,i) + w(k,j,i)   )                 &
-                   -      (  8.0_wp * ibit32 * adv_mom_5                        &
-                       +              ibit31 * adv_mom_3                        &
-                          ) *                                                 &
-                                 ( w(k,j+2,i) + w(k,j-1,i) )                 &
-                   +      (           ibit32 * adv_mom_5                        &
-                          ) *                                                &
-                                 ( w(k,j+3,i) + w(k,j-2,i) )                 &
-                                     )
-
-                diss_n(k) = - ABS( v_comp ) * (                              &
-                          ( 10.0_wp * ibit32 * adv_mom_5                        &
-                       +     3.0_wp * ibit31 * adv_mom_3                        &
-                       +              ibit30 * adv_mom_1                        &
-                          ) *                                                &
-                                 ( w(k,j+1,i) - w(k,j,i)  )                  &
-                   -      (  5.0_wp * ibit32 * adv_mom_5                        &
-                       +              ibit31 * adv_mom_3                        &
-                          ) *                                                &
-                                 ( w(k,j+2,i) - w(k,j-1,i) )                 &
-                   +      (           ibit32 * adv_mom_5                        &
-                          ) *                                                &
-                                 ( w(k,j+3,i) - w(k,j-2,i) )                 &
-                                              )
-!
-!--             k index has to be modified near bottom and top, else array
-!--             subscripts will be exceeded.
-                ibit35 = IBITS(wall_flags_00(k,j,i),3,1)
-                ibit34 = IBITS(wall_flags_00(k,j,i),2,1)
-                ibit33 = IBITS(wall_flags_00(k,j,i),1,1)
-
-                k_ppp = k + 3 * ibit35
-                k_pp  = k + 2 * ( 1 - ibit33  )
-                k_mm  = k - 2 * ibit35
-
-                w_comp    = w(k+1,j,i) + w(k,j,i)
-                flux_t(k) = w_comp  * (                                      &
-                          ( 37.0_wp * ibit35 * adv_mom_5                        &
-                       +     7.0_wp * ibit34 * adv_mom_3                        &
-                       +              ibit33 * adv_mom_1                        &
-                          ) *                                                &
-                             ( w(k+1,j,i)  + w(k,j,i)     )                  &
-                   -      (  8.0_wp * ibit35 * adv_mom_5                        &
-                       +              ibit34 * adv_mom_3                        &
-                          ) *                                                &
-                             ( w(k_pp,j,i)  + w(k-1,j,i)  )                  &
-                   +      (           ibit35 * adv_mom_5                        &
-                          ) *                                                &
-                             ( w(k_ppp,j,i) + w(k_mm,j,i) )                  &
-                                       )
-
-                diss_t(k) = - ABS( w_comp ) * (                              &
-                          ( 10.0_wp * ibit35 * adv_mom_5                        &
-                       +     3.0_wp * ibit34 * adv_mom_3                        &
-                       +              ibit33 * adv_mom_1                        &
-                          ) *                                                &
-                             ( w(k+1,j,i)   - w(k,j,i)    )                  &
-                   -      (  5.0_wp * ibit35 * adv_mom_5                        &
-                       +              ibit34 * adv_mom_3                        &
-                          ) *                                                &
-                             ( w(k_pp,j,i)  - w(k-1,j,i)  )                  &
-                   +      (           ibit35 * adv_mom_5                        &
-                          ) *                                                &
-                             ( w(k_ppp,j,i) - w(k_mm,j,i) )                  &
-                                               )
-!
-!--             Calculate the divergence of the velocity field. A respective
-!--             correction is needed to overcome numerical instabilities caused
-!--             by a not sufficient reduction of divergences near topography.
-                div = ( ( ( u_comp + gu ) * ( ibit27 + ibit28 + ibit29 )      &
-                  - ( u(k+1,j,i) + u(k,j,i)   )                               & 
-                                    * ( IBITS(wall_flags_0(k,j,i-1),27,1)     &
-                                      + IBITS(wall_flags_0(k,j,i-1),28,1)     &
-                                      + IBITS(wall_flags_0(k,j,i-1),29,1)     &
-                                      )                                       &
-                  ) * ddx                                                     &
-              +   ( ( v_comp + gv ) * ( ibit30 + ibit31 + ibit32 )            & 
-                  - ( v(k+1,j,i) + v(k,j,i)   )                               &
-                                    * ( IBITS(wall_flags_0(k,j-1,i),30,1)     &
-                                      + IBITS(wall_flags_0(k,j-1,i),31,1)     &
-                                      + IBITS(wall_flags_00(k,j-1,i),0,1)     &
-                                      )                                       &
-                  ) * ddy                                                     &
-              +   ( w_comp          * ( ibit33 + ibit34 + ibit35 )            &
-                - ( w(k,j,i)   + w(k-1,j,i)   )                               &
-                                    * ( IBITS(wall_flags_00(k-1,j,i),1,1)     &
-                                      + IBITS(wall_flags_00(k-1,j,i),2,1)     &
-                                      + IBITS(wall_flags_00(k-1,j,i),3,1)     &
-                                      )                                       & 
-                  ) * ddzu(k+1)   &
-                ) * 0.5_wp
-
-
-
-                tend(k,j,i) = tend(k,j,i) - (                                 &
-                      ( flux_r(k) + diss_r(k)                                 &
-                    -   swap_flux_x_local_w(k,j) - swap_diss_x_local_w(k,j)   &
-                      ) * ddx                                                 &
-                    + ( flux_n(k) + diss_n(k)                                 &
-                    -   swap_flux_y_local_w(k)   - swap_diss_y_local_w(k)     &
-                      ) * ddy                                                 &
-                    + ( flux_t(k) + diss_t(k)                                 &
-                    -   flux_d    - diss_d                                    &
-                      ) * ddzu(k+1)                                           &
-                                            )  + div * w(k,j,i)
-
-                swap_flux_x_local_w(k,j) = flux_r(k)
-                swap_diss_x_local_w(k,j) = diss_r(k)
-                swap_flux_y_local_w(k)   = flux_n(k)
-                swap_diss_y_local_w(k)   = diss_n(k)
-                flux_d                   = flux_t(k)
-                diss_d                   = diss_t(k)
-
-                sums_ws2_ws_l(k,tn)  = sums_ws2_ws_l(k,tn)                    &
-                               + ( flux_t(k) + diss_t(k) )                    &
-                               *   weight_substep(intermediate_timestep_count)
-
-             ENDDO
-
-             DO  k = nzb_max+1, nzt
-
-                u_comp    = u(k+1,j,i+1) + u(k,j,i+1) - gu
-                flux_r(k) = u_comp * (                                      &
-                      37.0_wp * ( w(k,j,i+1) + w(k,j,i)   )                    &
-                    -  8.0_wp * ( w(k,j,i+2) + w(k,j,i-1) )                    &
-                    +           ( w(k,j,i+3) + w(k,j,i-2) ) ) * adv_mom_5
-
-                diss_r(k) = - ABS( u_comp ) * (                             &
-                      10.0_wp * ( w(k,j,i+1) - w(k,j,i)   )                    &
-                    -  5.0_wp * ( w(k,j,i+2) - w(k,j,i-1) )                    &
-                    +           ( w(k,j,i+3) - w(k,j,i-2) ) ) * adv_mom_5
-
-                v_comp    = v(k+1,j+1,i) + v(k,j+1,i) - gv
-                flux_n(k) = v_comp * (                                      &
-                      37.0_wp * ( w(k,j+1,i) + w(k,j,i)   )                    &
-                    -  8.0_wp * ( w(k,j+2,i) + w(k,j-1,i) )                    &
-                    +           ( w(k,j+3,i) + w(k,j-2,i) ) ) * adv_mom_5
-
-                diss_n(k) = - ABS( v_comp ) * (                             &
-                      10.0_wp * ( w(k,j+1,i) - w(k,j,i)   )                    &
-                    -  5.0_wp * ( w(k,j+2,i) - w(k,j-1,i) )                    &
-                    +           ( w(k,j+3,i) - w(k,j-2,i) ) ) * adv_mom_5
-!
-!--             k index has to be modified near bottom and top, else array
-!--             subscripts will be exceeded.
-                ibit35 = IBITS(wall_flags_00(k,j,i),3,1)
-                ibit34 = IBITS(wall_flags_00(k,j,i),2,1)
-                ibit33 = IBITS(wall_flags_00(k,j,i),1,1)
-
-                k_ppp = k + 3 * ibit35
-                k_pp  = k + 2 * ( 1 - ibit33  )
-                k_mm  = k - 2 * ibit35
-
-                w_comp    = w(k+1,j,i) + w(k,j,i)
-                flux_t(k) = w_comp  * (                                      &
-                          ( 37.0_wp * ibit35 * adv_mom_5                        &
-                       +     7.0_wp * ibit34 * adv_mom_3                        &
-                       +              ibit33 * adv_mom_1                        &
-                          ) *                                                &
-                             ( w(k+1,j,i)  + w(k,j,i)     )                  &
-                   -      (  8.0_wp * ibit35 * adv_mom_5                        &
-                       +              ibit34 * adv_mom_3                        &
-                          ) *                                                &
-                             ( w(k_pp,j,i)  + w(k-1,j,i)  )                  &
-                   +      (           ibit35 * adv_mom_5                        &
-                          ) *                                                &
-                             ( w(k_ppp,j,i) + w(k_mm,j,i) )                  &
-                                       )
-
-                diss_t(k) = - ABS( w_comp ) * (                              &
-                          ( 10.0_wp * ibit35 * adv_mom_5                        &
-                       +     3.0_wp * ibit34 * adv_mom_3                        &
-                       +              ibit33 * adv_mom_1                        &
-                          ) *                                                &
-                             ( w(k+1,j,i)   - w(k,j,i)    )                  &
-                   -      (  5.0_wp * ibit35 * adv_mom_5                        &
-                       +              ibit34 * adv_mom_3                        &
-                          ) *                                                &
-                             ( w(k_pp,j,i)  - w(k-1,j,i)  )                  &
-                   +      (           ibit35 * adv_mom_5                        &
-                          ) *                                                &
-                             ( w(k_ppp,j,i) - w(k_mm,j,i) )                  &
-                                               )
-!
-!--             Calculate the divergence of the velocity field. A respective
-!--             correction is needed to overcome numerical instabilities caused
-!--             by a not sufficient reduction of divergences near topography.
-                div = ( ( u_comp + gu - ( u(k+1,j,i) + u(k,j,i)   ) ) * ddx  &
-                    +   ( v_comp + gv - ( v(k+1,j,i) + v(k,j,i)   ) ) * ddy  &
-                    +   ( w_comp      - ( w(k,j,i)   + w(k-1,j,i) ) )        &
-                                                                 * ddzu(k+1) &
-                      ) * 0.5_wp
-
-                tend(k,j,i) = tend(k,j,i) - (                                 &
-                      ( flux_r(k) + diss_r(k)                                 &
-                    -   swap_flux_x_local_w(k,j) - swap_diss_x_local_w(k,j)   &
-                      ) * ddx                                                 &
-                    + ( flux_n(k) + diss_n(k)                                 &
-                    -   swap_flux_y_local_w(k)   - swap_diss_y_local_w(k)     &
-                      ) * ddy                                                 &
-                    + ( flux_t(k) + diss_t(k)                                 &
-                    -   flux_d    - diss_d                                    &
-                      ) * ddzu(k+1)                                           &
-                                            )  + div * w(k,j,i)
-
-                swap_flux_x_local_w(k,j) = flux_r(k)
-                swap_diss_x_local_w(k,j) = diss_r(k)
-                swap_flux_y_local_w(k)   = flux_n(k)
-                swap_diss_y_local_w(k)   = diss_n(k)
-                flux_d                   = flux_t(k)
-                diss_d                   = diss_t(k)
-
-                sums_ws2_ws_l(k,tn)  = sums_ws2_ws_l(k,tn)                    &
-                               + ( flux_t(k) + diss_t(k) )                    &
-                               *   weight_substep(intermediate_timestep_count)
-
-             ENDDO
-          ENDDO
-       ENDDO
-
-    END SUBROUTINE advec_w_ws
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Advection of w - Call for all grid points - accelerator version
-!------------------------------------------------------------------------------!
-    SUBROUTINE advec_w_ws_acc
-
-       USE arrays_3d,                                                          &
-           ONLY:  ddzu, tend, u, v, w
-
-       USE constants,                                                          &
-           ONLY:  adv_mom_1, adv_mom_3, adv_mom_5
-
-       USE control_parameters,                                                 &
-           ONLY:  intermediate_timestep_count, u_gtrans, v_gtrans
-
-       USE grid_variables,                                                     &
-           ONLY:  ddx, ddy
-
-       USE indices,                                                            &
-           ONLY:  i_left, i_right, j_north, j_south, nxl, nxr, nyn, nys, nzb,  &
-                  nzb_max, nzt, wall_flags_0, wall_flags_00
-           
-       USE kinds
-       
-!        USE statistics,                                                       &
-!            ONLY:  hom, sums_ws2_ws_l, weight_substep
-
-       IMPLICIT NONE
-
-       INTEGER(iwp) ::  i      !<
-       INTEGER(iwp) ::  ibit27 !<
-       INTEGER(iwp) ::  ibit28 !<
-       INTEGER(iwp) ::  ibit29 !<
-       INTEGER(iwp) ::  ibit30 !<
-       INTEGER(iwp) ::  ibit31 !<
-       INTEGER(iwp) ::  ibit32 !<
-       INTEGER(iwp) ::  ibit33 !<
-       INTEGER(iwp) ::  ibit34 !<
-       INTEGER(iwp) ::  ibit35 !<
-       INTEGER(iwp) ::  j      !<
-       INTEGER(iwp) ::  k      !<
-       INTEGER(iwp) ::  k_mmm  !<
-       INTEGER(iwp) ::  k_mm   !<
-       INTEGER(iwp) ::  k_pp   !<
-       INTEGER(iwp) ::  k_ppp  !<
-       INTEGER(iwp) ::  tn = 0 !<
-
-       REAL(wp)    ::  diss_d   !<
-       REAL(wp)    ::  diss_l   !<
-       REAL(wp)    ::  diss_n   !<
-       REAL(wp)    ::  diss_r   !<
-       REAL(wp)    ::  diss_s   !<
-       REAL(wp)    ::  diss_t   !<
-       REAL(wp)    ::  div      !<
-       REAL(wp)    ::  flux_d   !<
-       REAL(wp)    ::  flux_l   !<
-       REAL(wp)    ::  flux_n   !<
-       REAL(wp)    ::  flux_r   !<
-       REAL(wp)    ::  flux_s   !<
-       REAL(wp)    ::  flux_t   !<
-       REAL(wp)    ::  gu       !<
-       REAL(wp)    ::  gv       !<
-       REAL(wp)    ::  u_comp   !<
-       REAL(wp)    ::  u_comp_l !<
-       REAL(wp)    ::  v_comp   !<
-       REAL(wp)    ::  v_comp_s !<
-       REAL(wp)    ::  w_comp   !<
-
-       gu = 2.0_wp * u_gtrans
-       gv = 2.0_wp * v_gtrans
-
-
-!
-!--    Computation of fluxes and tendency terms
-       !$acc kernels present( ddzu, tend, u, v, w, wall_flags_0, wall_flags_00 )
-       DO i = i_left, i_right
-          DO  j = j_south, j_north
-             DO  k = nzb+1, nzt
-
-                ibit27 = IBITS(wall_flags_0(k,j,i-1),27,1)
-                ibit28 = IBITS(wall_flags_0(k,j,i-1),28,1)
-                ibit29 = IBITS(wall_flags_0(k,j,i-1),29,1)
-
-                u_comp_l                 = u(k+1,j,i) + u(k,j,i) - gu
-                flux_l                   = u_comp_l * (                        &
-                                      ( 37.0_wp * ibit29 * adv_mom_5              &
-                                   +     7.0_wp * ibit28 * adv_mom_3              &
-                                   +              ibit27 * adv_mom_1              &
-                                      ) *                                      &
-                                     ( w(k,j,i)   + w(k,j,i-1) )               &
-                               -      (  8.0_wp * ibit29 * adv_mom_5              &
-                                   +              ibit28 * adv_mom_3              &
-                                      ) *                                      &
-                                     ( w(k,j,i+1) + w(k,j,i-2) )               &
-                               +      (           ibit29 * adv_mom_5              &
-                                      ) *                                      &
-                                     ( w(k,j,i+2) + w(k,j,i-3) )               &
-                                                 )
-
-                diss_l                    = - ABS( u_comp_l ) * (              &
-                                        ( 10.0_wp * ibit29 * adv_mom_5            &
-                                     +     3.0_wp * ibit28 * adv_mom_3            &
-                                     +              ibit27 * adv_mom_1            &
-                                        ) *                                    &
-                                     ( w(k,j,i)   - w(k,j,i-1) )               &
-                                 -      (  5.0_wp * ibit29 * adv_mom_5            &
-                                     +              ibit28 * adv_mom_3            &
-                                        ) *                                    &
-                                     ( w(k,j,i+1) - w(k,j,i-2) )               &
-                                 +      (           ibit29 * adv_mom_5            &
-                                        ) *                                    &
-                                     ( w(k,j,i+2) - w(k,j,i-3) )               &
-                                                            )
-
-                ibit27 = IBITS(wall_flags_0(k,j,i),27,1)
-                ibit28 = IBITS(wall_flags_0(k,j,i),28,1)
-                ibit29 = IBITS(wall_flags_0(k,j,i),29,1)
-
-                u_comp    = u(k+1,j,i+1) + u(k,j,i+1) - gu
-                flux_r    = u_comp * (                                       &
-                          ( 37.0_wp * ibit29 * adv_mom_5                        &
-                       +     7.0_wp * ibit28 * adv_mom_3                        &
-                       +              ibit27 * adv_mom_1                        &
-                          ) *                                                &
-                                 ( w(k,j,i+1) + w(k,j,i)   )                 &
-                   -      (  8.0_wp * ibit29 * adv_mom_5                        &
-                       +              ibit28 * adv_mom_3                        &
-                          ) *                                                &
-                                 ( w(k,j,i+2) + w(k,j,i-1) )                 &
-                   +      (           ibit29 * adv_mom_5                        &
-                          ) *                                                &
-                                 ( w(k,j,i+3) + w(k,j,i-2) )                 &
-                                     )
-
-                diss_r    = - ABS( u_comp ) * (                              &
-                          ( 10.0_wp * ibit29 * adv_mom_5                        &
-                       +     3.0_wp * ibit28 * adv_mom_3                        &
-                       +              ibit27 * adv_mom_1                        &
-                          ) *                                                &
-                                 ( w(k,j,i+1) - w(k,j,i)  )                  &
-                   -      (  5.0_wp * ibit29 * adv_mom_5                        &
-                       +              ibit28 * adv_mom_3                        &
-                          ) *                                                &
-                                 ( w(k,j,i+2) - w(k,j,i-1) )                 &
-                   +      (           ibit29 * adv_mom_5                        &
-                          ) *                                                &
-                                 ( w(k,j,i+3) - w(k,j,i-2) )                 &
-                                              )
-                ibit32 = IBITS(wall_flags_00(k,j-1,i),0,1)
-                ibit31 = IBITS(wall_flags_0(k,j-1,i),31,1)
-                ibit30 = IBITS(wall_flags_0(k,j-1,i),30,1)
-
-                v_comp_s               = v(k+1,j,i) + v(k,j,i) - gv
-                flux_s                 = v_comp_s * (                         &
-                                    ( 37.0_wp * ibit32 * adv_mom_5               &
-                                 +     7.0_wp * ibit31 * adv_mom_3               &
-                                 +              ibit30 * adv_mom_1               &
-                                    ) *                                       &
-                                     ( w(k,j,i)   + w(k,j-1,i) )              &
-                             -      (  8.0_wp * ibit32 * adv_mom_5               &
-                                 +              ibit31 * adv_mom_3               &
-                                    ) *                                       &
-                                     ( w(k,j+1,i) + w(k,j-2,i) )              &
-                             +      (           ibit32 * adv_mom_5               &
-                                    ) *                                       &
-                                     ( w(k,j+2,i) + w(k,j-3,i) )              &
-                                               )
-
-                diss_s                 = - ABS( v_comp_s ) * (                &
-                                    ( 10.0_wp * ibit32 * adv_mom_5               &
-                                 +     3.0_wp * ibit31 * adv_mom_3               &
-                                 +              ibit30 * adv_mom_1               &
-                                    ) *                                       &
-                                     ( w(k,j,i)   - w(k,j-1,i) )              &
-                             -      (  5.0_wp * ibit32 * adv_mom_5               &
-                                 +              ibit31 * adv_mom_3               &
-                                    ) *                                       &
-                                     ( w(k,j+1,i) - w(k,j-2,i) )              &
-                             +      (           ibit32 * adv_mom_5               &
-                                    ) *                                       &
-                                     ( w(k,j+2,i) - w(k,j-3,i) )              &
-                                                        )
-
-                ibit32 = IBITS(wall_flags_00(k,j,i),0,1)
-                ibit31 = IBITS(wall_flags_0(k,j,i),31,1)
-                ibit30 = IBITS(wall_flags_0(k,j,i),30,1)
-
-                v_comp    = v(k+1,j+1,i) + v(k,j+1,i) - gv
-                flux_n    = v_comp * (                                       &
-                          ( 37.0_wp * ibit32 * adv_mom_5                        &
-                       +     7.0_wp * ibit31 * adv_mom_3                        &
-                       +              ibit30 * adv_mom_1                        &
-                          ) *                                                 &
-                                 ( w(k,j+1,i) + w(k,j,i)   )                 &
-                   -      (  8.0_wp * ibit32 * adv_mom_5                        &
-                       +              ibit31 * adv_mom_3                        &
-                          ) *                                                &
-                                 ( w(k,j+2,i) + w(k,j-1,i) )                 &
-                   +      (           ibit32 * adv_mom_5                        &
-                          ) *                                                &
-                                 ( w(k,j+3,i) + w(k,j-2,i) )                 &
-                                     )
-
-                diss_n    = - ABS( v_comp ) * (                              &
-                          ( 10.0_wp * ibit32 * adv_mom_5                        &
-                       +     3.0_wp * ibit31 * adv_mom_3                        &
-                       +              ibit30 * adv_mom_1                        &
-                          ) *                                                &
-                                 ( w(k,j+1,i) - w(k,j,i)  )                  &
-                   -      (  5.0_wp * ibit32 * adv_mom_5                        &
-                       +              ibit31 * adv_mom_3                        &
-                          ) *                                                &
-                                 ( w(k,j+2,i) - w(k,j-1,i) )                 &
-                   +      (           ibit32 * adv_mom_5                        &
-                          ) *                                                &
-                                 ( w(k,j+3,i) - w(k,j-2,i) )                 &
-                                              )
-
-                ibit35 = IBITS(wall_flags_00(k-1,j,i),3,1)
-                ibit34 = IBITS(wall_flags_00(k-1,j,i),2,1)
-                ibit33 = IBITS(wall_flags_00(k-1,j,i),1,1)
-
-                k_pp  = k + 2 * ibit35
-                k_mm  = k - 2 * ( ibit34 + ibit35 )
-                k_mmm = k - 3 * ibit35
-
-                w_comp    = w(k,j,i) + w(k-1,j,i)
-                flux_d    = w_comp  * (                                      &
-                          ( 37.0_wp * ibit35 * adv_mom_5                        &
-                       +     7.0_wp * ibit34 * adv_mom_3                        &
-                       +              ibit33 * adv_mom_1                        &
-                          ) *                                                &
-                             ( w(k,j,i)    + w(k-1,j,i)   )                  &
-                   -      (  8.0_wp * ibit35 * adv_mom_5                        &
-                       +              ibit34 * adv_mom_3                        &
-                          ) *                                                &
-                             ( w(k+1,j,i)  + w(k_mm,j,i)  )                  &
-                   +      (           ibit35 * adv_mom_5                        &
-                          ) *                                                &
-                             ( w(k_pp,j,i) + w(k_mmm,j,i) )                  &
-                                       )
-
-                diss_d    = - ABS( w_comp ) * (                              &
-                          ( 10.0_wp * ibit35 * adv_mom_5                        &
-                       +     3.0_wp * ibit34 * adv_mom_3                        &
-                       +              ibit33 * adv_mom_1                        &
-                          ) *                                                &
-                             ( w(k,j,i)    - w(k-1,j,i)   )                  &
-                   -      (  5.0_wp * ibit35 * adv_mom_5                        &
-                       +              ibit34 * adv_mom_3                        &
-                          ) *                                                &
-                             ( w(k+1,j,i)  - w(k_mm,j,i)  )                  &
-                   +      (           ibit35 * adv_mom_5                        &
-                          ) *                                                &
-                             ( w(k_pp,j,i) - w(k_mmm,j,i) )                  &
-                                               )
-
-!
-!--             k index has to be modified near bottom and top, else array
-!--             subscripts will be exceeded.
-                ibit35 = IBITS(wall_flags_00(k,j,i),3,1)
-                ibit34 = IBITS(wall_flags_00(k,j,i),2,1)
-                ibit33 = IBITS(wall_flags_00(k,j,i),1,1)
-
-                k_ppp = k + 3 * ibit35
-                k_pp  = k + 2 * ( 1 - ibit33  )
-                k_mm  = k - 2 * ibit35
-
-                w_comp    = w(k+1,j,i) + w(k,j,i)
-                flux_t    = w_comp  * (                                      &
-                          ( 37.0_wp * ibit35 * adv_mom_5                        &
-                       +     7.0_wp * ibit34 * adv_mom_3                        &
-                       +              ibit33 * adv_mom_1                        &
-                          ) *                                                &
-                             ( w(k+1,j,i)  + w(k,j,i)     )                  &
-                   -      (  8.0_wp * ibit35 * adv_mom_5                        &
-                       +              ibit34 * adv_mom_3                        &
-                          ) *                                                &
-                             ( w(k_pp,j,i)  + w(k-1,j,i)  )                  &
-                   +      (           ibit35 * adv_mom_5                        &
-                          ) *                                                &
-                             ( w(k_ppp,j,i) + w(k_mm,j,i) )                  &
-                                       )
-
-                diss_t    = - ABS( w_comp ) * (                              &
-                          ( 10.0_wp * ibit35 * adv_mom_5                        &
-                       +     3.0_wp * ibit34 * adv_mom_3                        &
-                       +              ibit33 * adv_mom_1                        &
-                          ) *                                                &
-                             ( w(k+1,j,i)   - w(k,j,i)    )                  &
-                   -      (  5.0_wp * ibit35 * adv_mom_5                        &
-                       +              ibit34 * adv_mom_3                        &
-                          ) *                                                &
-                             ( w(k_pp,j,i)  - w(k-1,j,i)  )                  &
-                   +      (           ibit35 * adv_mom_5                        &
-                          ) *                                                &
-                             ( w(k_ppp,j,i) - w(k_mm,j,i) )                  &
-                                               )
-!
-!--             Calculate the divergence of the velocity field. A respective
-!--             correction is needed to overcome numerical instabilities caused
-!--             by a not sufficient reduction of divergences near topography.
-                div = ( ( ( u_comp + gu ) * ( ibit27 + ibit28 + ibit29 )      &
-                  - ( u(k+1,j,i) + u(k,j,i)   )                               & 
-                                    * ( IBITS(wall_flags_0(k,j,i-1),27,1)     &
-                                      + IBITS(wall_flags_0(k,j,i-1),28,1)     &
-                                      + IBITS(wall_flags_0(k,j,i-1),29,1)     &
-                                      )                                       &
-                  ) * ddx                                                     &
-              +   ( ( v_comp + gv ) * ( ibit30 + ibit31 + ibit32 )            & 
-                  - ( v(k+1,j,i) + v(k,j,i)   )                               &
-                                    * ( IBITS(wall_flags_0(k,j-1,i),30,1)     &
-                                      + IBITS(wall_flags_0(k,j-1,i),31,1)     &
-                                      + IBITS(wall_flags_00(k,j-1,i),0,1)     &
-                                      )                                       &
-                  ) * ddy                                                     &
-              +   ( w_comp          * ( ibit33 + ibit34 + ibit35 )            &
-                - ( w(k,j,i)   + w(k-1,j,i)   )                               &
-                                    * ( IBITS(wall_flags_00(k-1,j,i),1,1)     &
-                                      + IBITS(wall_flags_00(k-1,j,i),2,1)     &
-                                      + IBITS(wall_flags_00(k-1,j,i),3,1)     &
-                                      )                                       & 
-                  ) * ddzu(k+1)   &
-                ) * 0.5_wp
-
-
-                tend(k,j,i) = - (                                                &
-                               ( flux_r + diss_r - flux_l - diss_l ) * ddx       &
-                             + ( flux_n + diss_n - flux_s - diss_s ) * ddy       &
-                             + ( flux_t + diss_t - flux_d - diss_d ) * ddzu(k+1) &
-                                 ) + div * w(k,j,i)
-
-
-!++
-!--             Statistical Evaluation of w'w'.
-!                sums_ws2_ws_l(k,tn)  = sums_ws2_ws_l(k,tn)                    &
-!                               + ( flux_t + diss_t )                    &
-!                               *   weight_substep(intermediate_timestep_count)
-
-             ENDDO
-          ENDDO
-       ENDDO
-       !$acc end kernels
-
-    END SUBROUTINE advec_w_ws_acc
-
- END MODULE advec_ws
Index: /palm/trunk/SOURCE/advec_ws_mod.f90
===================================================================
--- /palm/trunk/SOURCE/advec_ws_mod.f90	(revision 1850)
+++ /palm/trunk/SOURCE/advec_ws_mod.f90	(revision 1850)
@@ -0,0 +1,6441 @@
+!> @file advec_ws_mod.f90
+!--------------------------------------------------------------------------------!
+! This file is part of PALM.
+!
+! PALM is free software: you can redistribute it and/or modify it under the terms
+! of the GNU General Public License as published by the Free Software Foundation,
+! either version 3 of the License, or (at your option) any later version.
+!
+! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
+! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
+! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along with
+! PALM. If not, see <http://www.gnu.org/licenses/>.
+!
+! Copyright 1997-2016 Leibniz Universitaet Hannover
+!--------------------------------------------------------------------------------!
+!
+! Current revisions:
+! ------------------
+! Module renamed
+!
+! 
+! Former revisions:
+! -----------------
+! $Id$ 
+! 
+! 1822 2016-04-07 07:49:42Z hoffmann
+! icloud_scheme removed, microphysics_seifert added
+!
+! 1682 2015-10-07 23:56:08Z knoop
+! Code annotations made doxygen readable 
+! 
+! 1630 2015-08-26 16:57:23Z suehring
+! 
+! 
+! 1629 2015-08-26 16:56:11Z suehring
+! Bugfix concerning wall_flags at left and south PE boundaries
+!
+! 1581 2015-04-10 13:45:59Z suehring
+! 
+! 
+! 1580 2015-04-10 13:43:49Z suehring
+! Bugfix: statistical evaluation of scalar fluxes in case of monotonic limiter
+!
+! 1567 2015-03-10 17:57:55Z suehring
+! Bugfixes in monotonic limiter.
+!
+! 2015-03-09 13:10:37Z heinze
+! Bugfix: REAL constants provided with KIND-attribute in call of 
+! intrinsic functions like MAX and MIN 
+! 
+! 1557 2015-03-05 16:43:04Z suehring
+! Enable monotone advection for scalars using monotonic limiter
+!
+! 1374 2014-04-25 12:55:07Z raasch
+! missing variables added to ONLY list
+! 
+! 1361 2014-04-16 15:17:48Z hoffmann
+! accelerator and vector version for qr and nr added
+! 
+! 1353 2014-04-08 15:21:23Z heinze
+! REAL constants provided with KIND-attribute,
+! module kinds added
+! some formatting adjustments
+!
+! 1322 2014-03-20 16:38:49Z raasch
+! REAL constants defined as wp-kind
+!
+! 1320 2014-03-20 08:40:49Z raasch
+! ONLY-attribute added to USE-statements,
+! kind-parameters added to all INTEGER and REAL declaration statements,
+! kinds are defined in new module kinds,
+! old module precision_kind is removed,
+! revision history before 2012 removed,
+! comment fields (!:) to be used for variable explanations added to
+! all variable declaration statements
+!
+! 1257 2013-11-08 15:18:40Z raasch
+! accelerator loop directives removed
+!
+! 1221 2013-09-10 08:59:13Z raasch
+! wall_flags_00 introduced, which holds bits 32-...
+!
+! 1128 2013-04-12 06:19:32Z raasch
+! loop index bounds in accelerator version replaced by i_left, i_right, j_south,
+! j_north
+!
+! 1115 2013-03-26 18:16:16Z hoffmann
+! calculation of qr and nr is restricted to precipitation
+!
+! 1053 2012-11-13 17:11:03Z hoffmann
+! necessary expansions according to the two new prognostic equations (nr, qr) 
+! of the two-moment cloud physics scheme:
+! +flux_l_*, flux_s_*, diss_l_*, diss_s_*, sums_ws*s_ws_l 
+!
+! 1036 2012-10-22 13:43:42Z raasch
+! code put under GPL (PALM 3.9)
+!
+! 1027 2012-10-15 17:18:39Z suehring
+! Bugfix in calculation indices k_mm, k_pp in accelerator version
+!
+! 1019 2012-09-28 06:46:45Z raasch
+! small change in comment lines
+!
+! 1015 2012-09-27 09:23:24Z raasch
+! accelerator versions (*_acc) added
+!
+! 1010 2012-09-20 07:59:54Z raasch
+! cpp switch __nopointer added for pointer free version
+!
+! 888 2012-04-20 15:03:46Z suehring
+! Number of IBITS() calls with identical arguments is reduced.
+!
+! 862 2012-03-26 14:21:38Z suehring
+! ws-scheme also work with topography in combination with vector version.
+! ws-scheme also work with outflow boundaries in combination with
+! vector version.
+! Degradation of the applied order of scheme is now steered by multiplying with
+! Integer wall_flags_0. 2nd order scheme, WS3 and WS5 are calculated on each
+! grid point and mulitplied with the appropriate flag.
+! 2nd order numerical dissipation term changed. Now the appropriate 2nd order
+! term derived according to the 4th and 6th order terms is applied. It turns
+! out that diss_2nd does not provide sufficient dissipation near walls.
+! Therefore, the function diss_2nd is removed.
+! Near walls a divergence correction is necessary to overcome numerical
+! instabilities due to too less divergence reduction of the velocity field.
+! boundary_flags and logicals steering the degradation are removed.
+! Empty SUBROUTINE local_diss removed.
+! Further formatting adjustments.
+!
+! 801 2012-01-10 17:30:36Z suehring
+! Bugfix concerning OpenMP parallelization. Summation of sums_wsus_ws_l,
+! sums_wsvs_ws_l, sums_us2_ws_l, sums_vs2_ws_l, sums_ws2_ws_l, sums_wspts_ws_l,
+! sums_wsqs_ws_l, sums_wssas_ws_l is now thread-safe by adding an additional
+! dimension.
+!
+! Initial revision
+!
+! 411 2009-12-11 12:31:43 Z suehring
+!
+! Description:
+! ------------
+!> Advection scheme for scalars and momentum using the flux formulation of
+!> Wicker and Skamarock 5th order. Additionally the module contains of a 
+!> routine using for initialisation and steering of the statical evaluation. 
+!> The computation of turbulent fluxes takes place inside the advection
+!> routines.
+!> Near non-cyclic boundaries the order of the applied advection scheme is
+!> degraded.
+!> A divergence correction is applied. It is necessary for topography, since
+!> the divergence is not sufficiently reduced, resulting in erroneous fluxes and
+!> partly numerical instabilities. 
+!-----------------------------------------------------------------------------!
+ MODULE advec_ws
+
+ 
+
+    PRIVATE
+    PUBLIC   advec_s_ws, advec_s_ws_acc, advec_u_ws, advec_u_ws_acc,          &
+             advec_v_ws, advec_v_ws_acc, advec_w_ws, advec_w_ws_acc,          &
+             ws_init, ws_statistics
+
+    INTERFACE ws_init
+       MODULE PROCEDURE ws_init
+    END INTERFACE ws_init
+
+    INTERFACE ws_statistics
+       MODULE PROCEDURE ws_statistics
+    END INTERFACE ws_statistics
+
+    INTERFACE advec_s_ws
+       MODULE PROCEDURE advec_s_ws
+       MODULE PROCEDURE advec_s_ws_ij
+    END INTERFACE advec_s_ws
+
+    INTERFACE advec_u_ws
+       MODULE PROCEDURE advec_u_ws
+       MODULE PROCEDURE advec_u_ws_ij
+    END INTERFACE advec_u_ws
+
+    INTERFACE advec_u_ws_acc
+       MODULE PROCEDURE advec_u_ws_acc
+    END INTERFACE advec_u_ws_acc
+
+    INTERFACE advec_v_ws
+       MODULE PROCEDURE advec_v_ws
+       MODULE PROCEDURE advec_v_ws_ij
+    END INTERFACE advec_v_ws
+
+    INTERFACE advec_v_ws_acc
+       MODULE PROCEDURE advec_v_ws_acc
+    END INTERFACE advec_v_ws_acc
+
+    INTERFACE advec_w_ws
+       MODULE PROCEDURE advec_w_ws
+       MODULE PROCEDURE advec_w_ws_ij
+    END INTERFACE advec_w_ws
+
+    INTERFACE advec_w_ws_acc
+       MODULE PROCEDURE advec_w_ws_acc
+    END INTERFACE advec_w_ws_acc
+
+ CONTAINS
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Initialization of WS-scheme
+!------------------------------------------------------------------------------!
+    SUBROUTINE ws_init
+
+       USE arrays_3d,                                                          &
+           ONLY:  diss_l_e, diss_l_nr, diss_l_pt, diss_l_q, diss_l_qr,         &
+                  diss_l_sa, diss_l_u, diss_l_v, diss_l_w,  flux_l_e,          &
+                  flux_l_nr, flux_l_pt, flux_l_q, flux_l_qr, flux_l_sa,        &
+                  flux_l_u, flux_l_v, flux_l_w, diss_s_e, diss_s_nr, diss_s_pt,&
+                  diss_s_q, diss_s_qr, diss_s_sa, diss_s_u, diss_s_v, diss_s_w,& 
+                  flux_s_e, flux_s_nr, flux_s_pt, flux_s_q, flux_s_qr,         &
+                  flux_s_sa, flux_s_u, flux_s_v, flux_s_w
+
+       USE constants,                                                          &
+           ONLY:  adv_mom_1, adv_mom_3, adv_mom_5, adv_sca_1, adv_sca_3,       &
+                  adv_sca_5
+
+       USE control_parameters,                                                 &
+           ONLY:  cloud_physics, humidity, loop_optimization,                  &
+                  monotonic_adjustment, passive_scalar, microphysics_seifert,  &
+                  ocean, ws_scheme_mom, ws_scheme_sca
+
+       USE indices,                                                            &
+           ONLY:  nyn, nys, nzb, nzt
+
+       USE kinds
+       
+       USE pegrid
+
+       USE statistics,                                                         &
+           ONLY:  sums_us2_ws_l, sums_vs2_ws_l, sums_ws2_ws_l, sums_wsnrs_ws_l,&
+                  sums_wspts_ws_l, sums_wsqrs_ws_l, sums_wsqs_ws_l,            &
+                  sums_wssas_ws_l,  sums_wsus_ws_l, sums_wsvs_ws_l  
+
+!
+!--    Set the appropriate factors for scalar and momentum advection.
+       adv_sca_5 = 1.0_wp /  60.0_wp
+       adv_sca_3 = 1.0_wp /  12.0_wp
+       adv_sca_1 = 1.0_wp /   2.0_wp
+       adv_mom_5 = 1.0_wp / 120.0_wp
+       adv_mom_3 = 1.0_wp /  24.0_wp
+       adv_mom_1 = 1.0_wp /   4.0_wp
+!         
+!--    Arrays needed for statical evaluation of fluxes.
+       IF ( ws_scheme_mom )  THEN
+
+          ALLOCATE( sums_wsus_ws_l(nzb:nzt+1,0:threads_per_task-1),            &
+                    sums_wsvs_ws_l(nzb:nzt+1,0:threads_per_task-1),            &
+                    sums_us2_ws_l(nzb:nzt+1,0:threads_per_task-1),             &
+                    sums_vs2_ws_l(nzb:nzt+1,0:threads_per_task-1),             &
+                    sums_ws2_ws_l(nzb:nzt+1,0:threads_per_task-1) )
+
+          sums_wsus_ws_l = 0.0_wp
+          sums_wsvs_ws_l = 0.0_wp
+          sums_us2_ws_l  = 0.0_wp
+          sums_vs2_ws_l  = 0.0_wp
+          sums_ws2_ws_l  = 0.0_wp
+
+       ENDIF
+
+       IF ( ws_scheme_sca )  THEN
+
+          ALLOCATE( sums_wspts_ws_l(nzb:nzt+1,0:threads_per_task-1) )
+          sums_wspts_ws_l = 0.0_wp
+
+          IF ( humidity  .OR.  passive_scalar )  THEN
+             ALLOCATE( sums_wsqs_ws_l(nzb:nzt+1,0:threads_per_task-1) )
+             sums_wsqs_ws_l = 0.0_wp
+          ENDIF
+
+          IF ( cloud_physics  .AND.  microphysics_seifert )  THEN
+             ALLOCATE( sums_wsqrs_ws_l(nzb:nzt+1,0:threads_per_task-1) )
+             ALLOCATE( sums_wsnrs_ws_l(nzb:nzt+1,0:threads_per_task-1) )
+             sums_wsqrs_ws_l = 0.0_wp
+             sums_wsnrs_ws_l = 0.0_wp
+          ENDIF
+
+          IF ( ocean )  THEN
+             ALLOCATE( sums_wssas_ws_l(nzb:nzt+1,0:threads_per_task-1) )
+             sums_wssas_ws_l = 0.0_wp
+          ENDIF
+
+       ENDIF
+
+!
+!--    Arrays needed for reasons of speed optimization for cache version.
+!--    For the vector version the buffer arrays are not necessary,
+!--    because the the fluxes can swapped directly inside the loops of the 
+!--    advection routines.
+       IF ( loop_optimization /= 'vector' )  THEN
+
+          IF ( ws_scheme_mom )  THEN
+
+             ALLOCATE( flux_s_u(nzb+1:nzt,0:threads_per_task-1),               &
+                       flux_s_v(nzb+1:nzt,0:threads_per_task-1),               &
+                       flux_s_w(nzb+1:nzt,0:threads_per_task-1),               &
+                       diss_s_u(nzb+1:nzt,0:threads_per_task-1),               &
+                       diss_s_v(nzb+1:nzt,0:threads_per_task-1),               &
+                       diss_s_w(nzb+1:nzt,0:threads_per_task-1) )
+             ALLOCATE( flux_l_u(nzb+1:nzt,nys:nyn,0:threads_per_task-1),       &
+                       flux_l_v(nzb+1:nzt,nys:nyn,0:threads_per_task-1),       &
+                       flux_l_w(nzb+1:nzt,nys:nyn,0:threads_per_task-1),       &
+                       diss_l_u(nzb+1:nzt,nys:nyn,0:threads_per_task-1),       &
+                       diss_l_v(nzb+1:nzt,nys:nyn,0:threads_per_task-1),       &
+                       diss_l_w(nzb+1:nzt,nys:nyn,0:threads_per_task-1) )
+
+          ENDIF
+
+          IF ( ws_scheme_sca )  THEN
+
+             ALLOCATE( flux_s_pt(nzb+1:nzt,0:threads_per_task-1),              &
+                       flux_s_e(nzb+1:nzt,0:threads_per_task-1),               &
+                       diss_s_pt(nzb+1:nzt,0:threads_per_task-1),              &
+                       diss_s_e(nzb+1:nzt,0:threads_per_task-1) ) 
+             ALLOCATE( flux_l_pt(nzb+1:nzt,nys:nyn,0:threads_per_task-1),      &
+                       flux_l_e(nzb+1:nzt,nys:nyn,0:threads_per_task-1),       &
+                       diss_l_pt(nzb+1:nzt,nys:nyn,0:threads_per_task-1),      &
+                       diss_l_e(nzb+1:nzt,nys:nyn,0:threads_per_task-1) )
+
+             IF ( humidity  .OR.  passive_scalar )  THEN
+                ALLOCATE( flux_s_q(nzb+1:nzt,0:threads_per_task-1),            &
+                          diss_s_q(nzb+1:nzt,0:threads_per_task-1) )
+                ALLOCATE( flux_l_q(nzb+1:nzt,nys:nyn,0:threads_per_task-1),    &
+                          diss_l_q(nzb+1:nzt,nys:nyn,0:threads_per_task-1) )
+             ENDIF
+
+             IF ( cloud_physics  .AND.  microphysics_seifert )  THEN
+                ALLOCATE( flux_s_qr(nzb+1:nzt,0:threads_per_task-1),           &
+                          diss_s_qr(nzb+1:nzt,0:threads_per_task-1),           &
+                          flux_s_nr(nzb+1:nzt,0:threads_per_task-1),           &
+                          diss_s_nr(nzb+1:nzt,0:threads_per_task-1) )
+                ALLOCATE( flux_l_qr(nzb+1:nzt,nys:nyn,0:threads_per_task-1),   &
+                          diss_l_qr(nzb+1:nzt,nys:nyn,0:threads_per_task-1),   &
+                          flux_l_nr(nzb+1:nzt,nys:nyn,0:threads_per_task-1),   &
+                          diss_l_nr(nzb+1:nzt,nys:nyn,0:threads_per_task-1) ) 
+             ENDIF
+
+             IF ( ocean )  THEN
+                ALLOCATE( flux_s_sa(nzb+1:nzt,0:threads_per_task-1),           &
+                          diss_s_sa(nzb+1:nzt,0:threads_per_task-1) )
+                ALLOCATE( flux_l_sa(nzb+1:nzt,nys:nyn,0:threads_per_task-1),   &
+                          diss_l_sa(nzb+1:nzt,nys:nyn,0:threads_per_task-1) )
+             ENDIF
+
+          ENDIF
+
+       ENDIF
+
+    END SUBROUTINE ws_init
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Initialize variables used for storing statistic quantities (fluxes, variances)
+!------------------------------------------------------------------------------!
+    SUBROUTINE ws_statistics
+    
+       USE control_parameters,                                                 &
+           ONLY:  cloud_physics, humidity, passive_scalar, ocean,              &
+                  microphysics_seifert, ws_scheme_mom, ws_scheme_sca
+
+       USE kinds
+
+       USE statistics,                                                         &
+           ONLY:  sums_us2_ws_l, sums_vs2_ws_l, sums_ws2_ws_l, sums_wsnrs_ws_l,&
+                  sums_wspts_ws_l, sums_wsqrs_ws_l, sums_wsqs_ws_l,            &
+                  sums_wssas_ws_l,  sums_wsus_ws_l, sums_wsvs_ws_l  
+
+       IMPLICIT NONE
+
+!       
+!--    The arrays needed for statistical evaluation are set to to 0 at the 
+!--    beginning of prognostic_equations.
+       IF ( ws_scheme_mom )  THEN
+          sums_wsus_ws_l = 0.0_wp
+          sums_wsvs_ws_l = 0.0_wp
+          sums_us2_ws_l  = 0.0_wp
+          sums_vs2_ws_l  = 0.0_wp
+          sums_ws2_ws_l  = 0.0_wp
+       ENDIF
+
+       IF ( ws_scheme_sca )  THEN
+          sums_wspts_ws_l = 0.0_wp
+          IF ( humidity  .OR.  passive_scalar )  sums_wsqs_ws_l = 0.0_wp
+          IF ( cloud_physics  .AND.  microphysics_seifert )  THEN
+             sums_wsqrs_ws_l = 0.0_wp
+             sums_wsnrs_ws_l = 0.0_wp
+          ENDIF
+          IF ( ocean )  sums_wssas_ws_l = 0.0_wp
+
+       ENDIF
+
+    END SUBROUTINE ws_statistics
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Scalar advection - Call for grid point i,j
+!------------------------------------------------------------------------------!
+    SUBROUTINE advec_s_ws_ij( i, j, sk, sk_char, swap_flux_y_local,            &
+                              swap_diss_y_local, swap_flux_x_local,            &
+                              swap_diss_x_local, i_omp, tn )
+
+       USE arrays_3d,                                                          &
+           ONLY:  ddzw, tend, u, v, w
+
+       USE constants,                                                          &
+           ONLY:  adv_sca_1, adv_sca_3, adv_sca_5
+
+       USE control_parameters,                                                 &
+           ONLY:  intermediate_timestep_count, monotonic_adjustment, u_gtrans, &
+                  v_gtrans 
+
+       USE grid_variables,                                                     &
+           ONLY:  ddx, ddy
+
+       USE indices,                                                            &
+           ONLY:  nxl, nxlg, nxr, nxrg, nyn, nyng, nys, nysg, nzb, nzb_max,    &
+                  nzt, wall_flags_0
+
+       USE kinds
+
+       USE pegrid
+
+       USE statistics,                                                         &
+           ONLY:  sums_wsnrs_ws_l, sums_wspts_ws_l, sums_wsqrs_ws_l,           &
+                  sums_wsqs_ws_l, sums_wssas_ws_l, weight_substep
+
+       IMPLICIT NONE
+
+       CHARACTER (LEN = *), INTENT(IN) ::  sk_char !<
+       
+       INTEGER(iwp) ::  i     !<
+       INTEGER(iwp) ::  ibit0 !<
+       INTEGER(iwp) ::  ibit1 !<
+       INTEGER(iwp) ::  ibit2 !<
+       INTEGER(iwp) ::  ibit3 !<
+       INTEGER(iwp) ::  ibit4 !<
+       INTEGER(iwp) ::  ibit5 !<
+       INTEGER(iwp) ::  ibit6 !<
+       INTEGER(iwp) ::  ibit7 !<
+       INTEGER(iwp) ::  ibit8 !<
+       INTEGER(iwp) ::  i_omp !<
+       INTEGER(iwp) ::  j     !<
+       INTEGER(iwp) ::  k     !<
+       INTEGER(iwp) ::  k_mm  !<
+       INTEGER(iwp) ::  k_mmm !<
+       INTEGER(iwp) ::  k_pp  !<
+       INTEGER(iwp) ::  k_ppp !<
+       INTEGER(iwp) ::  tn    !<
+       
+       REAL(wp)     ::  diss_d !<
+       REAL(wp)     ::  div    !<
+       REAL(wp)     ::  flux_d !<
+       REAL(wp)     ::  fd_1   !<
+       REAL(wp)     ::  fl_1   !<
+       REAL(wp)     ::  fn_1   !<
+       REAL(wp)     ::  fr_1   !<
+       REAL(wp)     ::  fs_1   !<
+       REAL(wp)     ::  ft_1   !<
+       REAL(wp)     ::  phi_d  !<
+       REAL(wp)     ::  phi_l  !<
+       REAL(wp)     ::  phi_n  !<
+       REAL(wp)     ::  phi_r  !<
+       REAL(wp)     ::  phi_s  !<
+       REAL(wp)     ::  phi_t  !<
+       REAL(wp)     ::  rd     !<
+       REAL(wp)     ::  rl     !<
+       REAL(wp)     ::  rn     !<
+       REAL(wp)     ::  rr     !<
+       REAL(wp)     ::  rs     !<
+       REAL(wp)     ::  rt     !<
+       REAL(wp)     ::  u_comp !<
+       REAL(wp)     ::  v_comp !<
+       
+#if defined( __nopointer )
+       REAL(wp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ::  sk !<
+#else
+       REAL(wp), DIMENSION(:,:,:), POINTER    ::  sk     !<
+#endif
+       REAL(wp), DIMENSION(nzb:nzt+1)         ::  diss_n !<
+       REAL(wp), DIMENSION(nzb:nzt+1)         ::  diss_r !<
+       REAL(wp), DIMENSION(nzb:nzt+1)         ::  diss_t !<
+       REAL(wp), DIMENSION(nzb:nzt+1)         ::  flux_n !<
+       REAL(wp), DIMENSION(nzb:nzt+1)         ::  flux_r !<
+       REAL(wp), DIMENSION(nzb:nzt+1)         ::  flux_t !<
+       
+       REAL(wp), DIMENSION(nzb+1:nzt,0:threads_per_task-1) ::  swap_diss_y_local !<
+       REAL(wp), DIMENSION(nzb+1:nzt,0:threads_per_task-1) ::  swap_flux_y_local !<
+       
+       REAL(wp), DIMENSION(nzb+1:nzt,nys:nyn,0:threads_per_task-1) ::  swap_diss_x_local !<
+       REAL(wp), DIMENSION(nzb+1:nzt,nys:nyn,0:threads_per_task-1) ::  swap_flux_x_local !<
+       
+
+!
+!--    Compute southside fluxes of the respective PE bounds.
+       IF ( j == nys )  THEN
+!
+!--       Up to the top of the highest topography.
+          DO  k = nzb+1, nzb_max
+
+             ibit5 = IBITS(wall_flags_0(k,j-1,i),5,1)
+             ibit4 = IBITS(wall_flags_0(k,j-1,i),4,1)
+             ibit3 = IBITS(wall_flags_0(k,j-1,i),3,1)
+
+             v_comp                  = v(k,j,i) - v_gtrans
+             swap_flux_y_local(k,tn) = v_comp *         (                     &
+                                               ( 37.0_wp * ibit5 * adv_sca_5  &
+                                            +     7.0_wp * ibit4 * adv_sca_3  &
+                                            +              ibit3 * adv_sca_1  &
+                                               ) *                            &
+                                           ( sk(k,j,i)  + sk(k,j-1,i)     )   &
+                                         -     (  8.0_wp * ibit5 * adv_sca_5  &
+                                            +              ibit4 * adv_sca_3  &
+                                                ) *                           &
+                                           ( sk(k,j+1,i) + sk(k,j-2,i)    )   &
+                                         +     (           ibit5 * adv_sca_5  &
+                                               ) *                            &
+                                           ( sk(k,j+2,i) + sk(k,j-3,i)    )   &
+                                                        )
+
+             swap_diss_y_local(k,tn) = -ABS( v_comp ) * (                     &
+                                               ( 10.0_wp * ibit5 * adv_sca_5  &
+                                            +     3.0_wp * ibit4 * adv_sca_3  &
+                                            +              ibit3 * adv_sca_1  &
+                                               ) *                            &
+                                            ( sk(k,j,i)   - sk(k,j-1,i)  )    &
+                                        -      (  5.0_wp * ibit5 * adv_sca_5  &
+                                            +              ibit4 * adv_sca_3  &
+                                            ) *                               &
+                                            ( sk(k,j+1,i) - sk(k,j-2,i)  )    &
+                                        +      (           ibit5 * adv_sca_5  &
+                                               ) *                            &
+                                            ( sk(k,j+2,i) - sk(k,j-3,i)  )    &
+                                                        )
+
+          ENDDO
+!
+!--       Above to the top of the highest topography. No degradation necessary.
+          DO  k = nzb_max+1, nzt
+
+             v_comp                  = v(k,j,i) - v_gtrans
+             swap_flux_y_local(k,tn) = v_comp * (                             &
+                                    37.0_wp * ( sk(k,j,i)   + sk(k,j-1,i) )   &
+                                  -  8.0_wp * ( sk(k,j+1,i) + sk(k,j-2,i) )   &
+                                  +           ( sk(k,j+2,i) + sk(k,j-3,i) )   &
+                                                ) * adv_sca_5
+              swap_diss_y_local(k,tn) = -ABS( v_comp ) * (                    &
+                                    10.0_wp * ( sk(k,j,i)   - sk(k,j-1,i) )   &
+                                  -  5.0_wp * ( sk(k,j+1,i) - sk(k,j-2,i) )   &
+                                  +             sk(k,j+2,i) - sk(k,j-3,i)     &
+                                                         ) * adv_sca_5
+
+          ENDDO
+
+       ENDIF
+!
+!--    Compute leftside fluxes of the respective PE bounds.
+       IF ( i == i_omp )  THEN
+        
+          DO  k = nzb+1, nzb_max
+
+             ibit2 = IBITS(wall_flags_0(k,j,i-1),2,1)
+             ibit1 = IBITS(wall_flags_0(k,j,i-1),1,1)
+             ibit0 = IBITS(wall_flags_0(k,j,i-1),0,1)
+
+             u_comp                     = u(k,j,i) - u_gtrans
+             swap_flux_x_local(k,j,tn) = u_comp * (                           &
+                                               ( 37.0_wp * ibit2 * adv_sca_5  &
+                                            +     7.0_wp * ibit1 * adv_sca_3  &
+                                            +              ibit0 * adv_sca_1  &
+                                               ) *                            &
+                                            ( sk(k,j,i)   + sk(k,j,i-1)    )  &
+                                        -      (  8.0_wp * ibit2 * adv_sca_5  &
+                                            +              ibit1 * adv_sca_3  &
+                                               ) *                            &
+                                            ( sk(k,j,i+1) + sk(k,j,i-2)    )  &
+                                        +      (           ibit2 * adv_sca_5  &
+                                               ) *                            &
+                                            ( sk(k,j,i+2) + sk(k,j,i-3)    )  &
+                                                  )
+
+              swap_diss_x_local(k,j,tn) = -ABS( u_comp ) * (                  &
+                                               ( 10.0_wp * ibit2 * adv_sca_5  &
+                                            +     3.0_wp * ibit1 * adv_sca_3  &
+                                            +              ibit0 * adv_sca_1  &
+                                               ) *                            &
+                                            ( sk(k,j,i)   - sk(k,j,i-1)    )  &
+                                        -      (  5.0_wp * ibit2 * adv_sca_5  &
+                                            +              ibit1 * adv_sca_3  &
+                                               ) *                            &
+                                            ( sk(k,j,i+1) - sk(k,j,i-2)    )  &
+                                        +      (           ibit2 * adv_sca_5  &
+                                               ) *                            &
+                                            ( sk(k,j,i+2) - sk(k,j,i-3)    )  &
+                                                           )
+
+          ENDDO
+
+          DO  k = nzb_max+1, nzt
+
+             u_comp                 = u(k,j,i) - u_gtrans
+             swap_flux_x_local(k,j,tn) = u_comp * (                           &
+                                      37.0_wp * ( sk(k,j,i)   + sk(k,j,i-1) ) &
+                                    -  8.0_wp * ( sk(k,j,i+1) + sk(k,j,i-2) ) &
+                                    +           ( sk(k,j,i+2) + sk(k,j,i-3) ) &
+                                                  ) * adv_sca_5
+
+             swap_diss_x_local(k,j,tn) = -ABS( u_comp ) * (                   &
+                                      10.0_wp * ( sk(k,j,i)   - sk(k,j,i-1) ) &
+                                    -  5.0_wp * ( sk(k,j,i+1) - sk(k,j,i-2) ) &
+                                    +           ( sk(k,j,i+2) - sk(k,j,i-3) ) &
+                                                          ) * adv_sca_5
+
+          ENDDO
+           
+       ENDIF
+
+       flux_t(0) = 0.0_wp
+       diss_t(0) = 0.0_wp
+       flux_d    = 0.0_wp
+       diss_d    = 0.0_wp
+!        
+!--    Now compute the fluxes and tendency terms for the horizontal and
+!--    vertical parts up to the top of the highest topography.
+       DO  k = nzb+1, nzb_max
+!
+!--       Note: It is faster to conduct all multiplications explicitly, e.g.
+!--       * adv_sca_5 ... than to determine a factor and multiplicate the
+!--       flux at the end. 
+
+          ibit2 = IBITS(wall_flags_0(k,j,i),2,1)
+          ibit1 = IBITS(wall_flags_0(k,j,i),1,1)
+          ibit0 = IBITS(wall_flags_0(k,j,i),0,1)
+
+          u_comp    = u(k,j,i+1) - u_gtrans
+          flux_r(k) = u_comp * (                                              &
+                     ( 37.0_wp * ibit2 * adv_sca_5                            &
+                  +     7.0_wp * ibit1 * adv_sca_3                            &
+                  +              ibit0 * adv_sca_1                            &
+                     ) *                                                      &
+                             ( sk(k,j,i+1) + sk(k,j,i)   )                    &
+              -      (  8.0_wp * ibit2 * adv_sca_5                            &
+                  +              ibit1 * adv_sca_3                            &
+                     ) *                                                      &
+                             ( sk(k,j,i+2) + sk(k,j,i-1) )                    &
+              +      (           ibit2 * adv_sca_5                            &
+                     ) *                                                      &
+                             ( sk(k,j,i+3) + sk(k,j,i-2) )                    &
+                               )
+
+          diss_r(k) = -ABS( u_comp ) * (                                      &
+                     ( 10.0_wp * ibit2 * adv_sca_5                            &
+                  +     3.0_wp * ibit1 * adv_sca_3                            &
+                  +              ibit0 * adv_sca_1                            &
+                     ) *                                                      &
+                             ( sk(k,j,i+1) - sk(k,j,i)  )                     &
+              -      (  5.0_wp * ibit2 * adv_sca_5                            &
+                  +              ibit1 * adv_sca_3                            &
+                     ) *                                                      &
+                             ( sk(k,j,i+2) - sk(k,j,i-1) )                    &
+              +      (           ibit2 * adv_sca_5                            &
+                     ) *                                                      &
+                             ( sk(k,j,i+3) - sk(k,j,i-2) )                    &
+                                       )
+
+          ibit5 = IBITS(wall_flags_0(k,j,i),5,1)
+          ibit4 = IBITS(wall_flags_0(k,j,i),4,1)
+          ibit3 = IBITS(wall_flags_0(k,j,i),3,1)
+
+          v_comp    = v(k,j+1,i) - v_gtrans
+          flux_n(k) = v_comp * (                                              &
+                     ( 37.0_wp * ibit5 * adv_sca_5                            &
+                  +     7.0_wp * ibit4 * adv_sca_3                            &
+                  +              ibit3 * adv_sca_1                            &
+                     ) *                                                      &
+                             ( sk(k,j+1,i) + sk(k,j,i)   )                    &
+              -      (  8.0_wp * ibit5 * adv_sca_5                            &
+                  +              ibit4 * adv_sca_3                            &
+                     ) *                                                      &
+                             ( sk(k,j+2,i) + sk(k,j-1,i) )                    &
+              +      (           ibit5 * adv_sca_5                            &
+                     ) *                                                      &
+                             ( sk(k,j+3,i) + sk(k,j-2,i) )                    &
+                               )
+
+          diss_n(k) = -ABS( v_comp ) * (                                      &
+                     ( 10.0_wp * ibit5 * adv_sca_5                            &
+                  +     3.0_wp * ibit4 * adv_sca_3                            &
+                  +              ibit3 * adv_sca_1                            &
+                     ) *                                                      &
+                             ( sk(k,j+1,i) - sk(k,j,i)   )                    &
+              -      (  5.0_wp * ibit5 * adv_sca_5                            &
+                  +              ibit4 * adv_sca_3                            &
+                     ) *                                                      &
+                             ( sk(k,j+2,i) - sk(k,j-1,i) )                    &
+              +      (           ibit5 * adv_sca_5                            &
+                     ) *                                                      &
+                             ( sk(k,j+3,i) - sk(k,j-2,i) )                    &
+                                       )
+!
+!--       k index has to be modified near bottom and top, else array
+!--       subscripts will be exceeded.
+          ibit8 = IBITS(wall_flags_0(k,j,i),8,1)
+          ibit7 = IBITS(wall_flags_0(k,j,i),7,1)
+          ibit6 = IBITS(wall_flags_0(k,j,i),6,1)
+
+          k_ppp = k + 3 * ibit8
+          k_pp  = k + 2 * ( 1 - ibit6  )
+          k_mm  = k - 2 * ibit8
+
+
+          flux_t(k) = w(k,j,i) * (                                            &
+                     ( 37.0_wp * ibit8 * adv_sca_5                            &
+                  +     7.0_wp * ibit7 * adv_sca_3                            &
+                  +              ibit6 * adv_sca_1                            &
+                     ) *                                                      &
+                             ( sk(k+1,j,i)  + sk(k,j,i)    )                  &
+              -      (  8.0_wp * ibit8 * adv_sca_5                            &
+                  +              ibit7 * adv_sca_3                            &
+                     ) *                                                      &
+                             ( sk(k_pp,j,i) + sk(k-1,j,i)  )                  &
+              +      (           ibit8 * adv_sca_5                            &
+                     ) *     ( sk(k_ppp,j,i)+ sk(k_mm,j,i) )                  &
+                                 )
+
+          diss_t(k) = -ABS( w(k,j,i) ) * (                                    &
+                     ( 10.0_wp * ibit8 * adv_sca_5                            &
+                  +     3.0_wp * ibit7 * adv_sca_3                            &
+                  +              ibit6 * adv_sca_1                            &
+                     ) *                                                      &
+                             ( sk(k+1,j,i)   - sk(k,j,i)    )                 &
+              -      (  5.0_wp * ibit8 * adv_sca_5                            &
+                  +              ibit7 * adv_sca_3                            &
+                     ) *                                                      &
+                             ( sk(k_pp,j,i)  - sk(k-1,j,i)  )                 &
+              +      (           ibit8 * adv_sca_5                            &
+                     ) *                                                      &
+                             ( sk(k_ppp,j,i) - sk(k_mm,j,i) )                 &
+                                         )
+!
+!--       Apply monotonic adjustment.
+          IF ( monotonic_adjustment )  THEN
+!
+!--          At first, calculate first order fluxes.
+             u_comp = u(k,j,i) - u_gtrans
+             fl_1   =  ( u_comp   * ( sk(k,j,i) + sk(k,j,i-1) )               &
+                   -ABS( u_comp ) * ( sk(k,j,i) - sk(k,j,i-1) )               &
+                       ) * adv_sca_1 
+
+             u_comp = u(k,j,i+1) - u_gtrans
+             fr_1   =  ( u_comp   * ( sk(k,j,i+1) + sk(k,j,i) )               &
+                   -ABS( u_comp ) * ( sk(k,j,i+1) - sk(k,j,i) )               &
+                       ) * adv_sca_1 
+
+             v_comp = v(k,j,i) - v_gtrans
+             fs_1   =  ( v_comp   * ( sk(k,j,i) + sk(k,j-1,i) )               &
+                   -ABS( v_comp ) * ( sk(k,j,i) - sk(k,j-1,i) )               &
+                       ) * adv_sca_1 
+
+             v_comp = v(k,j+1,i) - v_gtrans
+             fn_1   =  ( v_comp   * ( sk(k,j+1,i) + sk(k,j,i) )               &
+                   -ABS( v_comp ) * ( sk(k,j+1,i) - sk(k,j,i) )               &
+                       ) * adv_sca_1 
+
+             fd_1   =  ( w(k-1,j,i)   * ( sk(k,j,i) + sk(k-1,j,i) )           &
+                   -ABS( w(k-1,j,i) ) * ( sk(k,j,i) - sk(k-1,j,i) )           &
+                       ) * adv_sca_1 
+
+             ft_1   =  ( w(k,j,i)   * ( sk(k+1,j,i) + sk(k,j,i) )             &
+                   -ABS( w(k,j,i) ) * ( sk(k+1,j,i) - sk(k,j,i) )             &
+                      ) * adv_sca_1 
+!
+!--          Calculate ratio of upwind gradients. Note, Min/Max is just to 
+!--          avoid if statements.
+             rl     = ( MAX( 0.0_wp, u(k,j,i) - u_gtrans ) *                  & 
+                           ABS( ( sk(k,j,i-1) - sk(k,j,i-2)            ) /    &
+                                ( sk(k,j,i)   - sk(k,j,i-1) + 1E-20_wp )      &
+                              ) +                                             & 
+                        MIN( 0.0_wp, u(k,j,i) - u_gtrans ) *                  &
+                           ABS( ( sk(k,j,i)   - sk(k,j,i+1)            ) /    &
+                                ( sk(k,j,i-1) - sk(k,j,i)   + 1E-20_wp )      &
+                              )                                               &
+                      ) / ABS( u(k,j,i) - u_gtrans + 1E-20_wp )
+
+             rr     = ( MAX( 0.0_wp, u(k,j,i+1) - u_gtrans ) *                & 
+                           ABS( ( sk(k,j,i)   - sk(k,j,i-1)            ) /    &
+                                ( sk(k,j,i+1) - sk(k,j,i)   + 1E-20_wp )      &
+                              ) +                                             & 
+                        MIN( 0.0_wp, u(k,j,i+1) - u_gtrans ) *                &
+                           ABS( ( sk(k,j,i+1) - sk(k,j,i+2)            ) /    &
+                                ( sk(k,j,i)   - sk(k,j,i+1) + 1E-20_wp )      &
+                              )                                               &
+                      ) / ABS( u(k,j,i+1) - u_gtrans + 1E-20_wp )
+
+             rs     = ( MAX( 0.0_wp, v(k,j,i) - v_gtrans ) *                  & 
+                           ABS( ( sk(k,j-1,i) - sk(k,j-2,i)            ) /    &
+                                ( sk(k,j,i)   - sk(k,j-1,i) + 1E-20_wp )      &
+                              ) +                                             & 
+                        MIN( 0.0_wp, v(k,j,i) - v_gtrans ) *                  &
+                           ABS( ( sk(k,j,i)   - sk(k,j+1,i)            ) /    &
+                                ( sk(k,j-1,i) - sk(k,j,i)   + 1E-20_wp )      &
+                              )                                               &
+                      ) / ABS( v(k,j,i) - v_gtrans + 1E-20_wp )
+
+             rn     = ( MAX( 0.0_wp, v(k,j+1,i) - v_gtrans ) *                & 
+                           ABS( ( sk(k,j,i)   - sk(k,j-1,i)            ) /    &
+                                ( sk(k,j+1,i) - sk(k,j,i)   + 1E-20_wp )      &
+                              ) +                                             & 
+                       MIN( 0.0_wp, v(k,j+1,i) - v_gtrans ) *                 &
+                           ABS( ( sk(k,j+1,i) - sk(k,j+2,i)            ) /    &
+                                ( sk(k,j,i)   - sk(k,j+1,i) + 1E-20_wp )      &
+                              )                                               &
+                      ) / ABS( v(k,j+1,i) - v_gtrans + 1E-20_wp )     
+!   
+!--          Reuse k_mm and compute k_mmm for the vertical gradient ratios. 
+!--          Note, for vertical advection below the third grid point above 
+!--          surface ( or below the model top) rd and rt are set to 0, i.e. 
+!--          use of first order scheme is enforced.
+             k_mmm  = k - 3 * ibit8
+
+             rd     = ( MAX( 0.0_wp, w(k-1,j,i) ) *                           & 
+                           ABS( ( sk(k_mm,j,i) - sk(k_mmm,j,i)           ) /  &
+                                ( sk(k-1,j,i)  - sk(k_mm,j,i) + 1E-20_wp )    &
+                              ) +                                             & 
+                        MIN( 0.0_wp, w(k-1,j,i) ) *                           &
+                           ABS( ( sk(k-1,j,i) - sk(k,j,i)            ) /      &
+                                ( sk(k_mm,j,i) - sk(k-1,j,i)   + 1E-20_wp )   &
+                              )                                               &
+                      ) * ibit8 / ABS( w(k-1,j,i) + 1E-20_wp ) 
+ 
+             rt     = ( MAX( 0.0_wp, w(k,j,i) ) *                             & 
+                           ABS( ( sk(k,j,i)   - sk(k-1,j,i)            ) /    &
+                                ( sk(k+1,j,i) - sk(k,j,i)   + 1E-20_wp )      &
+                              ) +                                             & 
+                        MIN( 0.0_wp, w(k,j,i) ) *                             &
+                           ABS( ( sk(k+1,j,i) - sk(k_pp,j,i)           ) /    &
+                                ( sk(k,j,i)   - sk(k+1,j,i) + 1E-20_wp )      &
+                              )                                               &
+                      ) * ibit8 / ABS( w(k,j,i) + 1E-20_wp )
+!
+!--           Calculate empirical limiter function (van Albada2 limiter).
+              phi_l = MIN( 1.0_wp, ( 2.0_wp * ABS( rl ) ) /                   &
+                                         ( rl**2 + 1.0_wp ) ) 
+              phi_r = MIN( 1.0_wp, ( 2.0_wp * ABS( rr ) ) /                   &
+                                         ( rr**2 + 1.0_wp ) ) 
+              phi_s = MIN( 1.0_wp, ( 2.0_wp * ABS( rs ) ) /                   &
+                                         ( rs**2 + 1.0_wp ) ) 
+              phi_n = MIN( 1.0_wp, ( 2.0_wp * ABS( rn ) ) /                   &
+                                         ( rn**2 + 1.0_wp ) ) 
+              phi_d = MIN( 1.0_wp, ( 2.0_wp * ABS( rd ) ) /                   &
+                                         ( rd**2 + 1.0_wp ) ) 
+              phi_t = MIN( 1.0_wp, ( 2.0_wp * ABS( rt ) ) /                   &
+                                         ( rt**2 + 1.0_wp ) ) 
+!
+!--           Calculate the resulting monotone flux. 
+              swap_flux_x_local(k,j,tn) = fl_1 - phi_l *                      &
+                                        ( fl_1 - swap_flux_x_local(k,j,tn)  )
+              flux_r(k)                 = fr_1 - phi_r *                      &
+                                        ( fr_1 - flux_r(k)                  )
+              swap_flux_y_local(k,tn)   = fs_1 - phi_s *                      &
+                                        ( fs_1 - swap_flux_y_local(k,tn)    )
+              flux_n(k)                 = fn_1 - phi_n *                      &
+                                        ( fn_1 - flux_n(k)                  )
+              flux_d                    = fd_1 - phi_d *                      &
+                                        ( fd_1 - flux_d                     )
+              flux_t(k)                 = ft_1 - phi_t *                      &
+                                        ( ft_1 - flux_t(k)                  )
+!
+!--          Moreover, modify dissipation flux according to the limiter. 
+             swap_diss_x_local(k,j,tn) = swap_diss_x_local(k,j,tn) * phi_l
+             diss_r(k)                 = diss_r(k)                 * phi_r
+             swap_diss_y_local(k,tn)   = swap_diss_y_local(k,tn)   * phi_s
+             diss_n(k)                 = diss_n(k)                 * phi_n
+             diss_d                    = diss_d                    * phi_d
+             diss_t(k)                 = diss_t(k)                 * phi_t
+
+          ENDIF
+!
+!--       Calculate the divergence of the velocity field. A respective
+!--       correction is needed to overcome numerical instabilities caused
+!--       by a not sufficient reduction of divergences near topography. 
+          div         =   ( u(k,j,i+1) * ( ibit0 + ibit1 + ibit2 )             &
+                          - u(k,j,i)   * ( IBITS(wall_flags_0(k,j,i-1),0,1)    &
+                                         + IBITS(wall_flags_0(k,j,i-1),1,1)    &
+                                         + IBITS(wall_flags_0(k,j,i-1),2,1)    &
+                                         )                                     &
+                          ) * ddx                                              &
+                        + ( v(k,j+1,i) * ( ibit3 + ibit4 + ibit5 )             &
+                          - v(k,j,i)   * ( IBITS(wall_flags_0(k,j-1,i),3,1)    &
+                                         + IBITS(wall_flags_0(k,j-1,i),4,1)    &
+                                         + IBITS(wall_flags_0(k,j-1,i),5,1)    &
+                                         )                                     &
+                          ) * ddy                                              &
+                        + ( w(k,j,i)   * ( ibit6 + ibit7 + ibit8 )             &
+                          - w(k-1,j,i) * ( IBITS(wall_flags_0(k-1,j,i),6,1)    &
+                                         + IBITS(wall_flags_0(k-1,j,i),7,1)    &
+                                         + IBITS(wall_flags_0(k-1,j,i),8,1)    &
+                                         )                                     &      
+                          ) * ddzw(k)
+
+
+          tend(k,j,i) = tend(k,j,i) - (                                       &
+                        ( flux_r(k) + diss_r(k) - swap_flux_x_local(k,j,tn) - &
+                          swap_diss_x_local(k,j,tn)            ) * ddx        &
+                      + ( flux_n(k) + diss_n(k) - swap_flux_y_local(k,tn)   - &
+                          swap_diss_y_local(k,tn)              ) * ddy        &
+                      + ( flux_t(k) + diss_t(k) - flux_d - diss_d             &
+                                                               ) * ddzw(k)    &
+                                      ) + sk(k,j,i) * div
+
+          swap_flux_y_local(k,tn)   = flux_n(k)
+          swap_diss_y_local(k,tn)   = diss_n(k)
+          swap_flux_x_local(k,j,tn) = flux_r(k)
+          swap_diss_x_local(k,j,tn) = diss_r(k)
+          flux_d                    = flux_t(k)
+          diss_d                    = diss_t(k)
+
+       ENDDO
+!
+!--    Now compute the fluxes and tendency terms for the horizontal and
+!--    vertical parts above the top of the highest topography. No degradation
+!--    for the horizontal parts, but for the vertical it is stell needed.
+       DO  k = nzb_max+1, nzt
+
+          u_comp    = u(k,j,i+1) - u_gtrans
+          flux_r(k) = u_comp * (                                              &
+                      37.0_wp * ( sk(k,j,i+1) + sk(k,j,i)   )                 &
+                    -  8.0_wp * ( sk(k,j,i+2) + sk(k,j,i-1) )                 &
+                    +           ( sk(k,j,i+3) + sk(k,j,i-2) ) ) * adv_sca_5
+          diss_r(k) = -ABS( u_comp ) * (                                      &
+                      10.0_wp * ( sk(k,j,i+1) - sk(k,j,i)   )                 &
+                    -  5.0_wp * ( sk(k,j,i+2) - sk(k,j,i-1) )                 &
+                    +           ( sk(k,j,i+3) - sk(k,j,i-2) ) ) * adv_sca_5
+
+          v_comp    = v(k,j+1,i) - v_gtrans
+          flux_n(k) = v_comp * (                                              &
+                      37.0_wp * ( sk(k,j+1,i) + sk(k,j,i)   )                 &
+                    -  8.0_wp * ( sk(k,j+2,i) + sk(k,j-1,i) )                 &
+                    +           ( sk(k,j+3,i) + sk(k,j-2,i) ) ) * adv_sca_5
+          diss_n(k) = -ABS( v_comp ) * (                                      &
+                      10.0_wp * ( sk(k,j+1,i) - sk(k,j,i)   )                 &
+                    -  5.0_wp * ( sk(k,j+2,i) - sk(k,j-1,i) )                 &
+                    +           ( sk(k,j+3,i) - sk(k,j-2,i) ) ) * adv_sca_5
+!
+!--       k index has to be modified near bottom and top, else array
+!--       subscripts will be exceeded.
+          ibit8 = IBITS(wall_flags_0(k,j,i),8,1)
+          ibit7 = IBITS(wall_flags_0(k,j,i),7,1)
+          ibit6 = IBITS(wall_flags_0(k,j,i),6,1)
+
+          k_ppp = k + 3 * ibit8
+          k_pp  = k + 2 * ( 1 - ibit6  )
+          k_mm  = k - 2 * ibit8
+
+          flux_t(k) = w(k,j,i) * (                                            &
+                    ( 37.0_wp * ibit8 * adv_sca_5                             &
+                 +     7.0_wp * ibit7 * adv_sca_3                             &
+                 +              ibit6 * adv_sca_1                             &
+                    ) *                                                       &
+                             ( sk(k+1,j,i)  + sk(k,j,i)   )                   &
+              -     (  8.0_wp * ibit8 * adv_sca_5                             &
+                  +              ibit7 * adv_sca_3                            &
+                    ) *                                                       &
+                             ( sk(k_pp,j,i) + sk(k-1,j,i) )                   &
+              +     (           ibit8 * adv_sca_5                             &
+                    ) *     ( sk(k_ppp,j,i)+ sk(k_mm,j,i) )                   &
+                                 )
+
+          diss_t(k) = -ABS( w(k,j,i) ) * (                                    &
+                    ( 10.0_wp * ibit8 * adv_sca_5                             &
+                 +     3.0_wp * ibit7 * adv_sca_3                             &
+                 +              ibit6 * adv_sca_1                             &
+                    ) *                                                       &
+                             ( sk(k+1,j,i)   - sk(k,j,i)    )                 &
+              -     (  5.0_wp * ibit8 * adv_sca_5                             &
+                 +              ibit7 * adv_sca_3                             &
+                    ) *                                                       &
+                             ( sk(k_pp,j,i)  - sk(k-1,j,i)  )                 &
+              +     (           ibit8 * adv_sca_5                             &
+                    ) *                                                       &
+                             ( sk(k_ppp,j,i) - sk(k_mm,j,i) )                 &
+                                         )
+
+
+!
+!--       Apply monotonic adjustment.
+          IF ( monotonic_adjustment )  THEN
+!
+!--          At first, calculate first order fluxes.
+             u_comp = u(k,j,i) - u_gtrans
+             fl_1   =  ( u_comp   * ( sk(k,j,i) + sk(k,j,i-1) )               &
+                   -ABS( u_comp ) * ( sk(k,j,i) - sk(k,j,i-1) )               &
+                       ) * adv_sca_1 
+
+             u_comp = u(k,j,i+1) - u_gtrans
+             fr_1   =  ( u_comp   * ( sk(k,j,i+1) + sk(k,j,i) )               &
+                   -ABS( u_comp ) * ( sk(k,j,i+1) - sk(k,j,i) )               &
+                       ) * adv_sca_1 
+
+             v_comp = v(k,j,i) - v_gtrans
+             fs_1   =  ( v_comp   * ( sk(k,j,i) + sk(k,j-1,i) )               &
+                   -ABS( v_comp ) * ( sk(k,j,i) - sk(k,j-1,i) )               &
+                       ) * adv_sca_1 
+
+             v_comp = v(k,j+1,i) - v_gtrans
+             fn_1   =  ( v_comp   * ( sk(k,j+1,i) + sk(k,j,i) )               &
+                   -ABS( v_comp ) * ( sk(k,j+1,i) - sk(k,j,i) )               &
+                       ) * adv_sca_1 
+
+             fd_1   =  ( w(k-1,j,i)   * ( sk(k,j,i) + sk(k-1,j,i) )           &
+                   -ABS( w(k-1,j,i) ) * ( sk(k,j,i) - sk(k-1,j,i) )           &
+                       ) * adv_sca_1 
+
+             ft_1   =  ( w(k,j,i)   * ( sk(k+1,j,i) + sk(k,j,i) )             &
+                   -ABS( w(k,j,i) ) * ( sk(k+1,j,i) - sk(k,j,i) )             &
+                       ) * adv_sca_1 
+!
+!--          Calculate ratio of upwind gradients. Note, Min/Max is just to 
+!--          avoid if statements. 
+             rl     = ( MAX( 0.0_wp, u(k,j,i) - u_gtrans ) *                  & 
+                           ABS( ( sk(k,j,i-1) - sk(k,j,i-2)            ) /    &
+                                ( sk(k,j,i)   - sk(k,j,i-1) + 1E-20_wp )      &
+                              ) +                                             & 
+                        MIN( 0.0_wp, u(k,j,i) - u_gtrans ) *                  &
+                           ABS( ( sk(k,j,i)   - sk(k,j,i+1)            ) /    &
+                                ( sk(k,j,i-1) - sk(k,j,i)   + 1E-20_wp )      &
+                              )                                               &
+                      ) / ABS( u(k,j,i) - u_gtrans + 1E-20_wp )
+
+             rr     = ( MAX( 0.0_wp, u(k,j,i+1) - u_gtrans ) *                & 
+                           ABS( ( sk(k,j,i)   - sk(k,j,i-1)            ) /    &
+                                ( sk(k,j,i+1) - sk(k,j,i)   + 1E-20_wp )      &
+                              ) +                                             & 
+                        MIN( 0.0_wp, u(k,j,i+1) - u_gtrans ) *                &
+                           ABS( ( sk(k,j,i+1) - sk(k,j,i+2)            ) /    &
+                                ( sk(k,j,i)   - sk(k,j,i+1) + 1E-20_wp )      &
+                              )                                               &
+                      ) / ABS( u(k,j,i+1) - u_gtrans + 1E-20_wp )
+
+             rs     = ( MAX( 0.0_wp, v(k,j,i) - v_gtrans ) *                  & 
+                           ABS( ( sk(k,j-1,i) - sk(k,j-2,i)            ) /    &
+                                ( sk(k,j,i)   - sk(k,j-1,i) + 1E-20_wp )      &
+                              ) +                                             & 
+                        MIN( 0.0_wp, v(k,j,i) - v_gtrans ) *                  &
+                           ABS( ( sk(k,j,i)   - sk(k,j+1,i)            ) /    &
+                                ( sk(k,j-1,i) - sk(k,j,i)   + 1E-20_wp )      &
+                              )                                               &
+                      ) / ABS( v(k,j,i) - v_gtrans + 1E-20_wp )
+
+             rn     = ( MAX( 0.0_wp, v(k,j+1,i) - v_gtrans ) *                & 
+                           ABS( ( sk(k,j,i)   - sk(k,j-1,i)            ) /    &
+                                ( sk(k,j+1,i) - sk(k,j,i)   + 1E-20_wp )      &
+                              ) +                                             & 
+                       MIN( 0.0_wp, v(k,j+1,i) - v_gtrans ) *                 &
+                           ABS( ( sk(k,j+1,i) - sk(k,j+2,i)            ) /    &
+                                ( sk(k,j,i)   - sk(k,j+1,i) + 1E-20_wp )      &
+                              )                                               &
+                      ) / ABS( v(k,j+1,i) - v_gtrans + 1E-20_wp )     
+!
+!--          Reuse k_mm and compute k_mmm for the vertical gradient ratios. 
+!--          Note, for vertical advection below the third grid point above 
+!--          surface ( or below the model top) rd and rt are set to 0, i.e. 
+!--          use of first order scheme is enforced.
+             k_mmm  = k - 3 * ibit8
+
+             rd     = ( MAX( 0.0_wp, w(k-1,j,i) ) *                           & 
+                           ABS( ( sk(k_mm,j,i) - sk(k_mmm,j,i)           ) /  &
+                                ( sk(k-1,j,i)  - sk(k_mm,j,i) + 1E-20_wp )    &
+                              ) +                                             & 
+                        MIN( 0.0_wp, w(k-1,j,i) ) *                           &
+                           ABS( ( sk(k-1,j,i) - sk(k,j,i)            ) /      &
+                                ( sk(k_mm,j,i) - sk(k-1,j,i)   + 1E-20_wp )   &
+                              )                                               &
+                      ) * ibit8 / ABS( w(k-1,j,i) + 1E-20_wp ) 
+ 
+             rt     = ( MAX( 0.0_wp, w(k,j,i) ) *                             & 
+                           ABS( ( sk(k,j,i)   - sk(k-1,j,i)            ) /    &
+                                ( sk(k+1,j,i) - sk(k,j,i)   + 1E-20_wp )      &
+                              ) +                                             & 
+                        MIN( 0.0_wp, w(k,j,i) ) *                             &
+                           ABS( ( sk(k+1,j,i) - sk(k_pp,j,i)           ) /    &
+                                ( sk(k,j,i)   - sk(k+1,j,i) + 1E-20_wp )      &
+                              )                                               &
+                      ) * ibit8 / ABS( w(k,j,i) + 1E-20_wp ) 
+!
+!--           Calculate empirical limiter function (van Albada2 limiter).
+              phi_l = MIN( 1.0_wp, ( 2.0_wp * ABS( rl ) ) /                   &
+                                         ( rl**2 + 1.0_wp ) ) 
+              phi_r = MIN( 1.0_wp, ( 2.0_wp * ABS( rr ) ) /                   &
+                                         ( rr**2 + 1.0_wp ) ) 
+              phi_s = MIN( 1.0_wp, ( 2.0_wp * ABS( rs ) ) /                   &
+                                         ( rs**2 + 1.0_wp ) ) 
+              phi_n = MIN( 1.0_wp, ( 2.0_wp * ABS( rn ) ) /                   &
+                                         ( rn**2 + 1.0_wp ) ) 
+              phi_d = MIN( 1.0_wp, ( 2.0_wp * ABS( rd ) ) /                   &
+                                         ( rd**2 + 1.0_wp ) ) 
+              phi_t = MIN( 1.0_wp, ( 2.0_wp * ABS( rt ) ) /                   &
+                                         ( rt**2 + 1.0_wp ) ) 
+!
+!--           Calculate the resulting monotone flux. 
+              swap_flux_x_local(k,j,tn) = fl_1 - phi_l *                      &
+                                        ( fl_1 - swap_flux_x_local(k,j,tn)  )
+              flux_r(k)                 = fr_1 - phi_r *                      &
+                                        ( fr_1 - flux_r(k)                  )
+              swap_flux_y_local(k,tn)   = fs_1 - phi_s *                      &
+                                        ( fs_1 - swap_flux_y_local(k,tn)    )
+              flux_n(k)                 = fn_1 - phi_n *                      &
+                                        ( fn_1 - flux_n(k)                  )
+              flux_d                    = fd_1 - phi_d *                      &
+                                        ( fd_1 - flux_d                     )
+              flux_t(k)                 = ft_1 - phi_t *                      &
+                                        ( ft_1 - flux_t(k)                  )
+!
+!--          Moreover, modify dissipation flux according to the limiter. 
+             swap_diss_x_local(k,j,tn) = swap_diss_x_local(k,j,tn) * phi_l
+             diss_r(k)                 = diss_r(k)                 * phi_r
+             swap_diss_y_local(k,tn)   = swap_diss_y_local(k,tn)   * phi_s
+             diss_n(k)                 = diss_n(k)                 * phi_n
+             diss_d                    = diss_d                    * phi_d
+             diss_t(k)                 = diss_t(k)                 * phi_t
+
+          ENDIF
+!
+!--       Calculate the divergence of the velocity field. A respective
+!--       correction is needed to overcome numerical instabilities introduced
+!--       by a not sufficient reduction of divergences near topography.
+          div         =   ( u(k,j,i+1) - u(k,j,i)   ) * ddx                   &
+                        + ( v(k,j+1,i) - v(k,j,i)   ) * ddy                   &
+                        + ( w(k,j,i)   - w(k-1,j,i) ) * ddzw(k)
+
+          tend(k,j,i) = tend(k,j,i) - (                                       &
+                        ( flux_r(k) + diss_r(k) - swap_flux_x_local(k,j,tn) - &
+                          swap_diss_x_local(k,j,tn)            ) * ddx        &
+                      + ( flux_n(k) + diss_n(k) - swap_flux_y_local(k,tn)   - &
+                          swap_diss_y_local(k,tn)              ) * ddy        &
+                      + ( flux_t(k) + diss_t(k) - flux_d - diss_d             &
+                                                               ) * ddzw(k)    &
+                                      ) + sk(k,j,i) * div
+
+
+          swap_flux_y_local(k,tn)   = flux_n(k)
+          swap_diss_y_local(k,tn)   = diss_n(k)
+          swap_flux_x_local(k,j,tn) = flux_r(k)
+          swap_diss_x_local(k,j,tn) = diss_r(k)
+          flux_d                    = flux_t(k)
+          diss_d                    = diss_t(k)
+
+       ENDDO
+
+!
+!--    Evaluation of statistics.
+       SELECT CASE ( sk_char )
+
+          CASE ( 'pt' )
+
+             DO  k = nzb, nzt
+                sums_wspts_ws_l(k,tn) = sums_wspts_ws_l(k,tn) +               &
+                                       ( flux_t(k) + diss_t(k) )              &
+                               * weight_substep(intermediate_timestep_count)
+             ENDDO
+            
+          CASE ( 'sa' )
+
+             DO  k = nzb, nzt
+                sums_wssas_ws_l(k,tn) = sums_wssas_ws_l(k,tn) +               &
+                                       ( flux_t(k) + diss_t(k) )              &
+                               * weight_substep(intermediate_timestep_count)
+             ENDDO
+            
+          CASE ( 'q' )
+
+             DO  k = nzb, nzt
+                sums_wsqs_ws_l(k,tn)  = sums_wsqs_ws_l(k,tn) +                &
+                                      ( flux_t(k) + diss_t(k) )               &
+                               * weight_substep(intermediate_timestep_count)
+             ENDDO
+
+          CASE ( 'qr' )
+
+             DO  k = nzb, nzt
+                sums_wsqrs_ws_l(k,tn)  = sums_wsqrs_ws_l(k,tn) +              &
+                                      ( flux_t(k) + diss_t(k) )               &
+                               * weight_substep(intermediate_timestep_count)
+             ENDDO
+
+          CASE ( 'nr' )
+
+             DO  k = nzb, nzt
+                sums_wsnrs_ws_l(k,tn)  = sums_wsnrs_ws_l(k,tn) +              &
+                                      ( flux_t(k) + diss_t(k) )               &
+                               * weight_substep(intermediate_timestep_count)
+             ENDDO
+
+         END SELECT
+         
+    END SUBROUTINE advec_s_ws_ij
+
+
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Advection of u-component - Call for grid point i,j
+!------------------------------------------------------------------------------!
+    SUBROUTINE advec_u_ws_ij( i, j, i_omp, tn )
+
+       USE arrays_3d,                                                         &
+           ONLY:  ddzw, diss_l_u, diss_s_u, flux_l_u, flux_s_u, tend, u, v, w
+
+       USE constants,                                                         &
+           ONLY:  adv_mom_1, adv_mom_3, adv_mom_5
+
+       USE control_parameters,                                                &
+           ONLY:  intermediate_timestep_count, u_gtrans, v_gtrans
+
+       USE grid_variables,                                                    &
+           ONLY:  ddx, ddy
+
+       USE indices,                                                           &
+           ONLY:  nxl, nxr, nyn, nys, nzb, nzb_max, nzt, wall_flags_0
+
+       USE kinds
+
+       USE statistics,                                                        &
+           ONLY:  hom, sums_us2_ws_l, sums_wsus_ws_l, weight_substep
+
+       IMPLICIT NONE
+
+       INTEGER(iwp) ::  i      !<
+       INTEGER(iwp) ::  ibit9  !<
+       INTEGER(iwp) ::  ibit10 !<
+       INTEGER(iwp) ::  ibit11 !<
+       INTEGER(iwp) ::  ibit12 !<
+       INTEGER(iwp) ::  ibit13 !<
+       INTEGER(iwp) ::  ibit14 !<
+       INTEGER(iwp) ::  ibit15 !<
+       INTEGER(iwp) ::  ibit16 !<
+       INTEGER(iwp) ::  ibit17 !<
+       INTEGER(iwp) ::  i_omp  !<
+       INTEGER(iwp) ::  j      !<
+       INTEGER(iwp) ::  k      !<
+       INTEGER(iwp) ::  k_mm   !<
+       INTEGER(iwp) ::  k_pp   !<
+       INTEGER(iwp) ::  k_ppp  !<
+       INTEGER(iwp) ::  tn     !<
+       
+       REAL(wp)    ::  diss_d   !<
+       REAL(wp)    ::  div      !<
+       REAL(wp)    ::  flux_d   !<
+       REAL(wp)    ::  gu       !<
+       REAL(wp)    ::  gv       !<
+       REAL(wp)    ::  u_comp_l !<
+       REAL(wp)    ::  v_comp   !<
+       REAL(wp)    ::  w_comp   !<
+       
+       REAL(wp), DIMENSION(nzb:nzt+1) ::  diss_n !<
+       REAL(wp), DIMENSION(nzb:nzt+1) ::  diss_r !<
+       REAL(wp), DIMENSION(nzb:nzt+1) ::  diss_t !<
+       REAL(wp), DIMENSION(nzb:nzt+1) ::  flux_n !<
+       REAL(wp), DIMENSION(nzb:nzt+1) ::  flux_r !<
+       REAL(wp), DIMENSION(nzb:nzt+1) ::  flux_t !<
+       REAL(wp), DIMENSION(nzb:nzt+1) ::  u_comp !<
+
+       gu = 2.0_wp * u_gtrans
+       gv = 2.0_wp * v_gtrans
+!
+!--    Compute southside fluxes for the respective boundary of PE
+       IF ( j == nys  )  THEN
+       
+          DO  k = nzb+1, nzb_max
+
+             ibit14 = IBITS(wall_flags_0(k,j-1,i),14,1)
+             ibit13 = IBITS(wall_flags_0(k,j-1,i),13,1)
+             ibit12 = IBITS(wall_flags_0(k,j-1,i),12,1)
+
+             v_comp      = v(k,j,i) + v(k,j,i-1) - gv
+             flux_s_u(k,tn) = v_comp * (                                      &
+                            ( 37.0_wp * ibit14 * adv_mom_5                    &
+                         +     7.0_wp * ibit13 * adv_mom_3                    &
+                         +              ibit12 * adv_mom_1                    &
+                            ) *                                               &
+                                        ( u(k,j,i)   + u(k,j-1,i) )           &
+                     -      (  8.0_wp * ibit14 * adv_mom_5                    &
+                         +              ibit13 * adv_mom_3                    &
+                            ) *                                               &
+                                        ( u(k,j+1,i) + u(k,j-2,i) )           &
+                     +      (           ibit14 * adv_mom_5                    &
+                            ) *                                               &
+                                        ( u(k,j+2,i) + u(k,j-3,i) )           &
+                                       )
+
+             diss_s_u(k,tn) = - ABS ( v_comp ) * (                            &
+                            ( 10.0_wp * ibit14 * adv_mom_5                    &
+                         +     3.0_wp * ibit13 * adv_mom_3                    &
+                         +              ibit12 * adv_mom_1                    &
+                            ) *                                               &
+                                        ( u(k,j,i)   - u(k,j-1,i) )           &
+                     -      (  5.0_wp * ibit14 * adv_mom_5                    &
+                         +              ibit13 * adv_mom_3                    &
+                            ) *                                               &
+                                        ( u(k,j+1,i) - u(k,j-2,i) )           &
+                     +      (           ibit14 * adv_mom_5                    &
+                            ) *                                               &
+                                        ( u(k,j+2,i) - u(k,j-3,i) )           &
+                                                 )
+
+          ENDDO
+
+          DO  k = nzb_max+1, nzt
+
+             v_comp         = v(k,j,i) + v(k,j,i-1) - gv
+             flux_s_u(k,tn) = v_comp * (                                      &
+                           37.0_wp * ( u(k,j,i) + u(k,j-1,i)   )              &
+                         -  8.0_wp * ( u(k,j+1,i) + u(k,j-2,i) )              &
+                         +           ( u(k,j+2,i) + u(k,j-3,i) ) ) * adv_mom_5
+             diss_s_u(k,tn) = - ABS(v_comp) * (                               &
+                           10.0_wp * ( u(k,j,i) - u(k,j-1,i)   )              &
+                         -  5.0_wp * ( u(k,j+1,i) - u(k,j-2,i) )              &
+                         +           ( u(k,j+2,i) - u(k,j-3,i) ) ) * adv_mom_5
+
+          ENDDO
+          
+       ENDIF
+!
+!--    Compute leftside fluxes for the respective boundary of PE
+       IF ( i == i_omp )  THEN
+       
+          DO  k = nzb+1, nzb_max
+
+             ibit11 = IBITS(wall_flags_0(k,j,i-1),11,1)
+             ibit10 = IBITS(wall_flags_0(k,j,i-1),10,1)
+             ibit9  = IBITS(wall_flags_0(k,j,i-1),9,1)
+
+             u_comp_l         = u(k,j,i) + u(k,j,i-1) - gu
+             flux_l_u(k,j,tn) = u_comp_l * (                                  &
+                              ( 37.0_wp * ibit11 * adv_mom_5                  &
+                           +     7.0_wp * ibit10 * adv_mom_3                  &
+                           +              ibit9  * adv_mom_1                  &
+                              ) *                                             &
+                                          ( u(k,j,i)   + u(k,j,i-1) )         &
+                       -      (  8.0_wp * ibit11 * adv_mom_5                  &
+                           +              ibit10 * adv_mom_3                  &
+                              ) *                                             &
+                                          ( u(k,j,i+1) + u(k,j,i-2) )         &
+                       +      (           ibit11 * adv_mom_5                  &
+                              ) *                                             &
+                                          ( u(k,j,i+2) + u(k,j,i-3) )         &
+                                           )
+
+              diss_l_u(k,j,tn) = - ABS( u_comp_l ) * (                        &
+                              ( 10.0_wp * ibit11 * adv_mom_5                  &
+                           +     3.0_wp * ibit10 * adv_mom_3                  &
+                           +              ibit9  * adv_mom_1                  &
+                              ) *                                             &
+                                        ( u(k,j,i)   - u(k,j,i-1) )           &
+                       -      (  5.0_wp * ibit11 * adv_mom_5                  &
+                           +              ibit10 * adv_mom_3                  &
+                              ) *                                             &
+                                        ( u(k,j,i+1) - u(k,j,i-2) )           &
+                       +      (           ibit11 * adv_mom_5                  &
+                              ) *                                             &
+                                        ( u(k,j,i+2) - u(k,j,i-3) )           &
+                                                     )
+
+          ENDDO
+
+          DO  k = nzb_max+1, nzt
+
+             u_comp_l         = u(k,j,i) + u(k,j,i-1) - gu
+             flux_l_u(k,j,tn) = u_comp_l * (                                   &
+                             37.0_wp * ( u(k,j,i) + u(k,j,i-1)   )             &
+                           -  8.0_wp * ( u(k,j,i+1) + u(k,j,i-2) )             &
+                           +           ( u(k,j,i+2) + u(k,j,i-3) ) ) * adv_mom_5
+             diss_l_u(k,j,tn) = - ABS(u_comp_l) * (                            &
+                             10.0_wp * ( u(k,j,i) - u(k,j,i-1)   )             &
+                           -  5.0_wp * ( u(k,j,i+1) - u(k,j,i-2) )             &
+                           +           ( u(k,j,i+2) - u(k,j,i-3) ) ) * adv_mom_5
+
+          ENDDO
+          
+       ENDIF
+
+       flux_t(0) = 0.0_wp
+       diss_t(0) = 0.0_wp
+       flux_d    = 0.0_wp
+       diss_d    = 0.0_wp
+!
+!--    Now compute the fluxes tendency terms for the horizontal and
+!--    vertical parts.
+       DO  k = nzb+1, nzb_max
+
+          ibit11 = IBITS(wall_flags_0(k,j,i),11,1)
+          ibit10 = IBITS(wall_flags_0(k,j,i),10,1)
+          ibit9  = IBITS(wall_flags_0(k,j,i),9,1)
+
+          u_comp(k) = u(k,j,i+1) + u(k,j,i)
+          flux_r(k) = ( u_comp(k) - gu ) * (                                  &
+                     ( 37.0_wp * ibit11 * adv_mom_5                           &
+                  +     7.0_wp * ibit10 * adv_mom_3                           &
+                  +              ibit9  * adv_mom_1                           &
+                     ) *                                                      &
+                                    ( u(k,j,i+1) + u(k,j,i)   )               &
+              -      (  8.0_wp * ibit11 * adv_mom_5                           &
+                  +              ibit10 * adv_mom_3                           & 
+                     ) *                                                      &
+                                    ( u(k,j,i+2) + u(k,j,i-1) )               &
+              +      (           ibit11 * adv_mom_5                           &
+                     ) *                                                      &
+                                    ( u(k,j,i+3) + u(k,j,i-2) )               &
+                                           )
+
+          diss_r(k) = - ABS( u_comp(k) - gu ) * (                             &
+                     ( 10.0_wp * ibit11 * adv_mom_5                           &
+                  +     3.0_wp * ibit10 * adv_mom_3                           &
+                  +              ibit9  * adv_mom_1                           &
+                     ) *                                                      &
+                                    ( u(k,j,i+1) - u(k,j,i)   )               &
+              -      (  5.0_wp * ibit11 * adv_mom_5                           &
+                  +              ibit10 * adv_mom_3                           &
+                     ) *                                                      &
+                                    ( u(k,j,i+2) - u(k,j,i-1) )               &
+              +      (           ibit11 * adv_mom_5                           &
+                     ) *                                                      &
+                                    ( u(k,j,i+3) - u(k,j,i-2) )               &
+                                                )
+
+          ibit14 = IBITS(wall_flags_0(k,j,i),14,1)
+          ibit13 = IBITS(wall_flags_0(k,j,i),13,1)
+          ibit12 = IBITS(wall_flags_0(k,j,i),12,1)
+
+          v_comp    = v(k,j+1,i) + v(k,j+1,i-1) - gv
+          flux_n(k) = v_comp * (                                              &
+                     ( 37.0_wp * ibit14 * adv_mom_5                           &
+                  +     7.0_wp * ibit13 * adv_mom_3                           &
+                  +              ibit12 * adv_mom_1                           &
+                     ) *                                                      &
+                                    ( u(k,j+1,i) + u(k,j,i)   )               &
+              -      (  8.0_wp * ibit14 * adv_mom_5                           &
+                  +              ibit13 * adv_mom_3                           &
+                     ) *                                                      &
+                                    ( u(k,j+2,i) + u(k,j-1,i) )               &
+              +      (           ibit14 * adv_mom_5                           &
+                     ) *                                                      &
+                                    ( u(k,j+3,i) + u(k,j-2,i) )               &
+                               )
+
+          diss_n(k) = - ABS ( v_comp ) * (                                    &
+                     ( 10.0_wp * ibit14 * adv_mom_5                           &
+                  +     3.0_wp * ibit13 * adv_mom_3                           &
+                  +              ibit12 * adv_mom_1                           &
+                     ) *                                                      &
+                                    ( u(k,j+1,i) - u(k,j,i)   )               &
+              -      (  5.0_wp * ibit14 * adv_mom_5                           &
+                  +              ibit13 * adv_mom_3                           &
+                     ) *                                                      &
+                                    ( u(k,j+2,i) - u(k,j-1,i) )               &
+              +      (           ibit14 * adv_mom_5                           &
+                     ) *                                                      &
+                                    ( u(k,j+3,i) - u(k,j-2,i) )               &
+                                         )
+!
+!--       k index has to be modified near bottom and top, else array
+!--       subscripts will be exceeded.
+          ibit17 = IBITS(wall_flags_0(k,j,i),17,1)
+          ibit16 = IBITS(wall_flags_0(k,j,i),16,1)
+          ibit15 = IBITS(wall_flags_0(k,j,i),15,1)
+
+          k_ppp = k + 3 * ibit17
+          k_pp  = k + 2 * ( 1 - ibit15 )
+          k_mm  = k - 2 * ibit17
+
+          w_comp    = w(k,j,i) + w(k,j,i-1)
+          flux_t(k) = w_comp  * (                                             &
+                     ( 37.0_wp * ibit17 * adv_mom_5                           &
+                  +     7.0_wp * ibit16 * adv_mom_3                           &
+                  +              ibit15 * adv_mom_1                           &
+                     ) *                                                      &
+                                ( u(k+1,j,i)  + u(k,j,i)     )                &
+              -      (  8.0_wp * ibit17 * adv_mom_5                           &
+                  +              ibit16 * adv_mom_3                           &
+                     ) *                                                      &
+                                ( u(k_pp,j,i) + u(k-1,j,i)   )                &
+              +      (           ibit17 * adv_mom_5                           &
+                     ) *                                                      &
+                                ( u(k_ppp,j,i) + u(k_mm,j,i) )                &
+                                 )
+
+          diss_t(k) = - ABS( w_comp ) * (                                     &
+                     ( 10.0_wp * ibit17 * adv_mom_5                           &
+                  +     3.0_wp * ibit16 * adv_mom_3                           &
+                  +              ibit15 * adv_mom_1                           &
+                     ) *                                                      &
+                                ( u(k+1,j,i)   - u(k,j,i)    )                &
+              -      (  5.0_wp * ibit17 * adv_mom_5                           &
+                  +              ibit16 * adv_mom_3                           &
+                     ) *                                                      &
+                                ( u(k_pp,j,i)  - u(k-1,j,i)  )                &
+              +      (           ibit17 * adv_mom_5                           &
+                     ) *                                                      &
+                                ( u(k_ppp,j,i) - u(k_mm,j,i) )                &
+                                         )
+!
+!--       Calculate the divergence of the velocity field. A respective
+!--       correction is needed to overcome numerical instabilities introduced
+!--       by a not sufficient reduction of divergences near topography. 
+          div = ( ( u_comp(k)       * ( ibit9 + ibit10 + ibit11 )             &
+                - ( u(k,j,i)   + u(k,j,i-1)   )                               &
+                                    * ( IBITS(wall_flags_0(k,j,i-1),9,1)      &
+                                      + IBITS(wall_flags_0(k,j,i-1),10,1)     &
+                                      + IBITS(wall_flags_0(k,j,i-1),11,1)     &
+                                      )                                       &   
+                  ) * ddx                                                     &
+               +  ( ( v_comp + gv ) * ( ibit12 + ibit13 + ibit14 )            &
+                  - ( v(k,j,i)   + v(k,j,i-1 )  )                             &
+                                    * ( IBITS(wall_flags_0(k,j-1,i),12,1)     &
+                                      + IBITS(wall_flags_0(k,j-1,i),13,1)     &
+                                      + IBITS(wall_flags_0(k,j-1,i),14,1)     &
+                                      )                                       &
+                  ) * ddy                                                     &
+               +  ( w_comp          * ( ibit15 + ibit16 + ibit17 )            &
+                - ( w(k-1,j,i) + w(k-1,j,i-1) )                               &
+                                    * ( IBITS(wall_flags_0(k-1,j,i),15,1)     &
+                                      + IBITS(wall_flags_0(k-1,j,i),16,1)     &
+                                      + IBITS(wall_flags_0(k-1,j,i),17,1)     &
+                                      )                                       &  
+                  ) * ddzw(k)   &
+                ) * 0.5_wp
+
+
+          tend(k,j,i) = tend(k,j,i) - (                                       &
+                            ( flux_r(k) + diss_r(k)                           &
+                          -   flux_l_u(k,j,tn) - diss_l_u(k,j,tn) ) * ddx     &
+                          + ( flux_n(k) + diss_n(k)                           &
+                          -   flux_s_u(k,tn) - diss_s_u(k,tn)     ) * ddy     &
+                          + ( flux_t(k) + diss_t(k)                           &
+                          -   flux_d    - diss_d                  ) * ddzw(k) &
+                                       ) + div * u(k,j,i)
+
+           flux_l_u(k,j,tn) = flux_r(k)
+           diss_l_u(k,j,tn) = diss_r(k)
+           flux_s_u(k,tn)   = flux_n(k)
+           diss_s_u(k,tn)   = diss_n(k)
+           flux_d           = flux_t(k)
+           diss_d           = diss_t(k)
+!
+!--        Statistical Evaluation of u'u'. The factor has to be applied for
+!--        right evaluation when gallilei_trans = .T. .
+           sums_us2_ws_l(k,tn) = sums_us2_ws_l(k,tn)                          &
+                              + ( flux_r(k) *                                 &
+                                ( u_comp(k) - 2.0_wp * hom(k,1,1,0) )         &
+                              / ( u_comp(k) - gu + 1.0E-20_wp   )             &
+                              +   diss_r(k) *                                 &
+                                  ABS( u_comp(k) - 2.0_wp * hom(k,1,1,0) )    &
+                              / ( ABS( u_comp(k) - gu ) + 1.0E-20_wp ) )      &
+                              *   weight_substep(intermediate_timestep_count)
+!
+!--        Statistical Evaluation of w'u'.
+           sums_wsus_ws_l(k,tn) = sums_wsus_ws_l(k,tn)                        &
+                              + ( flux_t(k) + diss_t(k) )                     &
+                              *   weight_substep(intermediate_timestep_count)
+       ENDDO
+
+       DO  k = nzb_max+1, nzt
+
+          u_comp(k) = u(k,j,i+1) + u(k,j,i)
+          flux_r(k) = ( u_comp(k) - gu ) * (                                  &
+                         37.0_wp * ( u(k,j,i+1) + u(k,j,i)   )                &
+                       -  8.0_wp * ( u(k,j,i+2) + u(k,j,i-1) )                &
+                       +           ( u(k,j,i+3) + u(k,j,i-2) ) ) * adv_mom_5
+             diss_r(k) = - ABS( u_comp(k) - gu ) * (                          &
+                         10.0_wp * ( u(k,j,i+1) - u(k,j,i)   )                &
+                       -  5.0_wp * ( u(k,j,i+2) - u(k,j,i-1) )                &
+                       +           ( u(k,j,i+3) - u(k,j,i-2) ) ) * adv_mom_5
+
+             v_comp    = v(k,j+1,i) + v(k,j+1,i-1) - gv
+             flux_n(k) = v_comp * (                                           &
+                         37.0_wp * ( u(k,j+1,i) + u(k,j,i)   )                &
+                       -  8.0_wp * ( u(k,j+2,i) + u(k,j-1,i) )                &
+                       +           ( u(k,j+3,i) + u(k,j-2,i) ) ) * adv_mom_5
+             diss_n(k) = - ABS( v_comp ) * (                                  &
+                         10.0_wp * ( u(k,j+1,i) - u(k,j,i)   )                &
+                       -  5.0_wp * ( u(k,j+2,i) - u(k,j-1,i) )                &
+                       +           ( u(k,j+3,i) - u(k,j-2,i) ) ) * adv_mom_5
+!
+!--       k index has to be modified near bottom and top, else array
+!--       subscripts will be exceeded.
+          ibit17 = IBITS(wall_flags_0(k,j,i),17,1)
+          ibit16 = IBITS(wall_flags_0(k,j,i),16,1)
+          ibit15 = IBITS(wall_flags_0(k,j,i),15,1)
+
+          k_ppp = k + 3 * ibit17
+          k_pp  = k + 2 * ( 1 - ibit15 )
+          k_mm  = k - 2 * ibit17
+
+          w_comp    = w(k,j,i) + w(k,j,i-1)
+          flux_t(k) = w_comp  * (                                             &
+                     ( 37.0_wp * ibit17 * adv_mom_5                           &
+                  +     7.0_wp * ibit16 * adv_mom_3                           &
+                  +              ibit15 * adv_mom_1                           &
+                     ) *                                                      &
+                                ( u(k+1,j,i)  + u(k,j,i)     )                &
+              -      (  8.0_wp * ibit17 * adv_mom_5                           &
+                  +              ibit16 * adv_mom_3                           &
+                     ) *                                                      &
+                                ( u(k_pp,j,i) + u(k-1,j,i)   )                &
+              +      (           ibit17 * adv_mom_5                           &
+                     ) *                                                      &
+                                ( u(k_ppp,j,i) + u(k_mm,j,i) )                &
+                                 )
+
+          diss_t(k) = - ABS( w_comp ) * (                                     &
+                     ( 10.0_wp * ibit17 * adv_mom_5                           &
+                  +     3.0_wp * ibit16 * adv_mom_3                           &
+                  +              ibit15 * adv_mom_1                           &
+                     ) *                                                      &
+                                ( u(k+1,j,i)   - u(k,j,i)    )                &
+              -      (  5.0_wp * ibit17 * adv_mom_5                           &
+                  +              ibit16 * adv_mom_3                           &
+                     ) *                                                      &
+                                ( u(k_pp,j,i)  - u(k-1,j,i)  )                &
+              +      (           ibit17 * adv_mom_5                           &
+                     ) *                                                      &
+                                ( u(k_ppp,j,i) - u(k_mm,j,i) )                &
+                                         )
+!
+!--       Calculate the divergence of the velocity field. A respective
+!--       correction is needed to overcome numerical instabilities introduced
+!--       by a not sufficient reduction of divergences near topography.
+          div = ( ( u_comp(k)   - ( u(k,j,i)   + u(k,j,i-1)   ) ) * ddx       &
+               +  ( v_comp + gv - ( v(k,j,i)   + v(k,j,i-1 )  ) ) * ddy       &
+               +  ( w_comp      - ( w(k-1,j,i) + w(k-1,j,i-1) ) ) * ddzw(k)   &
+                ) * 0.5_wp
+
+          tend(k,j,i) = tend(k,j,i) - (                                       &
+                            ( flux_r(k) + diss_r(k)                           &
+                          -   flux_l_u(k,j,tn) - diss_l_u(k,j,tn) ) * ddx     &
+                          + ( flux_n(k) + diss_n(k)                           &
+                          -   flux_s_u(k,tn) - diss_s_u(k,tn)     ) * ddy     &
+                          + ( flux_t(k) + diss_t(k)                           &
+                          -   flux_d    - diss_d                  ) * ddzw(k) &
+                                       ) + div * u(k,j,i)
+
+           flux_l_u(k,j,tn) = flux_r(k)
+           diss_l_u(k,j,tn) = diss_r(k)
+           flux_s_u(k,tn)   = flux_n(k)
+           diss_s_u(k,tn)   = diss_n(k)
+           flux_d           = flux_t(k)
+           diss_d           = diss_t(k)
+!
+!--        Statistical Evaluation of u'u'. The factor has to be applied for
+!--        right evaluation when gallilei_trans = .T. .
+           sums_us2_ws_l(k,tn) = sums_us2_ws_l(k,tn)                          &
+                              + ( flux_r(k) *                                 &
+                                ( u_comp(k) - 2.0_wp * hom(k,1,1,0)      )    &
+                              / ( u_comp(k) - gu + 1.0E-20_wp          )      &
+                              +   diss_r(k) *                                 &
+                                  ABS( u_comp(k) - 2.0_wp * hom(k,1,1,0) )    &
+                              / ( ABS( u_comp(k) - gu ) + 1.0E-20_wp ) )      &
+                              *   weight_substep(intermediate_timestep_count)
+!
+!--        Statistical Evaluation of w'u'.
+           sums_wsus_ws_l(k,tn) = sums_wsus_ws_l(k,tn)                        &
+                              + ( flux_t(k) + diss_t(k) )                     &
+                              *   weight_substep(intermediate_timestep_count)
+       ENDDO
+
+       sums_us2_ws_l(nzb,tn) = sums_us2_ws_l(nzb+1,tn)
+
+
+
+    END SUBROUTINE advec_u_ws_ij
+
+
+
+!-----------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Advection of v-component - Call for grid point i,j
+!-----------------------------------------------------------------------------!
+   SUBROUTINE advec_v_ws_ij( i, j, i_omp, tn )
+
+       USE arrays_3d,                                                          &
+           ONLY:  ddzw, diss_l_v, diss_s_v, flux_l_v, flux_s_v, tend, u, v, w
+
+       USE constants,                                                          &
+           ONLY:  adv_mom_1, adv_mom_3, adv_mom_5
+
+       USE control_parameters,                                                 &
+           ONLY:  intermediate_timestep_count, u_gtrans, v_gtrans
+
+       USE grid_variables,                                                     &
+           ONLY:  ddx, ddy
+
+       USE indices,                                                            &
+           ONLY:  nxl, nxr, nyn, nys, nysv, nzb, nzb_max, nzt, wall_flags_0
+
+       USE kinds
+
+       USE statistics,                                                         &
+           ONLY:  hom, sums_vs2_ws_l, sums_wsvs_ws_l, weight_substep
+
+       IMPLICIT NONE
+
+       INTEGER(iwp)  ::  i      !<
+       INTEGER(iwp)  ::  ibit18 !<
+       INTEGER(iwp)  ::  ibit19 !<
+       INTEGER(iwp)  ::  ibit20 !<
+       INTEGER(iwp)  ::  ibit21 !<
+       INTEGER(iwp)  ::  ibit22 !<
+       INTEGER(iwp)  ::  ibit23 !<
+       INTEGER(iwp)  ::  ibit24 !<
+       INTEGER(iwp)  ::  ibit25 !<
+       INTEGER(iwp)  ::  ibit26 !<
+       INTEGER(iwp)  ::  i_omp  !<
+       INTEGER(iwp)  ::  j      !<
+       INTEGER(iwp)  ::  k      !<
+       INTEGER(iwp)  ::  k_mm   !<
+       INTEGER(iwp)  ::  k_pp   !<
+       INTEGER(iwp)  ::  k_ppp  !<
+       INTEGER(iwp)  ::  tn     !<
+       
+       REAL(wp)     ::  diss_d   !<
+       REAL(wp)     ::  div      !<
+       REAL(wp)     ::  flux_d   !<
+       REAL(wp)     ::  gu       !<
+       REAL(wp)     ::  gv       !<
+       REAL(wp)     ::  u_comp   !<
+       REAL(wp)     ::  v_comp_l !<
+       REAL(wp)     ::  w_comp   !<
+       
+       REAL(wp), DIMENSION(nzb:nzt+1)  ::  diss_n !<
+       REAL(wp), DIMENSION(nzb:nzt+1)  ::  diss_r !<
+       REAL(wp), DIMENSION(nzb:nzt+1)  ::  diss_t !<
+       REAL(wp), DIMENSION(nzb:nzt+1)  ::  flux_n !<
+       REAL(wp), DIMENSION(nzb:nzt+1)  ::  flux_r !<
+       REAL(wp), DIMENSION(nzb:nzt+1)  ::  flux_t !<
+       REAL(wp), DIMENSION(nzb:nzt+1)  ::  v_comp !<
+
+       gu = 2.0_wp * u_gtrans
+       gv = 2.0_wp * v_gtrans
+
+!       
+!--    Compute leftside fluxes for the respective boundary.
+       IF ( i == i_omp )  THEN
+
+          DO  k = nzb+1, nzb_max
+
+             ibit20 = IBITS(wall_flags_0(k,j,i-1),20,1)
+             ibit19 = IBITS(wall_flags_0(k,j,i-1),19,1)
+             ibit18 = IBITS(wall_flags_0(k,j,i-1),18,1)
+
+             u_comp           = u(k,j-1,i) + u(k,j,i) - gu
+             flux_l_v(k,j,tn) = u_comp * (                                    &
+                              ( 37.0_wp * ibit20 * adv_mom_5                  &
+                           +     7.0_wp * ibit19 * adv_mom_3                  &
+                           +              ibit18 * adv_mom_1                  &
+                              ) *                                             &
+                                        ( v(k,j,i)   + v(k,j,i-1) )           &
+                       -      (  8.0_wp * ibit20 * adv_mom_5                  &
+                           +              ibit19 * adv_mom_3                  &
+                              ) *                                             &
+                                        ( v(k,j,i+1) + v(k,j,i-2) )           &
+                       +      (           ibit20 * adv_mom_5                  &
+                              ) *                                             &
+                                        ( v(k,j,i+2) + v(k,j,i-3) )           &
+                                         )
+
+              diss_l_v(k,j,tn) = - ABS( u_comp ) * (                          &
+                              ( 10.0_wp * ibit20 * adv_mom_5                  &
+                           +     3.0_wp * ibit19 * adv_mom_3                  &
+                           +              ibit18 * adv_mom_1                  &
+                              ) *                                             &
+                                        ( v(k,j,i)   - v(k,j,i-1) )           &
+                       -      (  5.0_wp * ibit20 * adv_mom_5                  &
+                           +              ibit19 * adv_mom_3                  &
+                              ) *                                             &
+                                        ( v(k,j,i+1) - v(k,j,i-2) )           &
+                       +      (           ibit20 * adv_mom_5                  &
+                              ) *                                             &
+                                        ( v(k,j,i+2) - v(k,j,i-3) )           &
+                                                   )
+
+          ENDDO
+
+          DO  k = nzb_max+1, nzt
+
+             u_comp           = u(k,j-1,i) + u(k,j,i) - gu
+             flux_l_v(k,j,tn) = u_comp * (                                    &
+                             37.0_wp * ( v(k,j,i) + v(k,j,i-1)   )            &
+                           -  8.0_wp * ( v(k,j,i+1) + v(k,j,i-2) )            &
+                           +           ( v(k,j,i+2) + v(k,j,i-3) ) ) * adv_mom_5
+             diss_l_v(k,j,tn) = - ABS( u_comp ) * (                           &
+                             10.0_wp * ( v(k,j,i) - v(k,j,i-1)   )            &
+                           -  5.0_wp * ( v(k,j,i+1) - v(k,j,i-2) )            &
+                           +           ( v(k,j,i+2) - v(k,j,i-3) ) ) * adv_mom_5
+
+          ENDDO
+          
+       ENDIF
+!
+!--    Compute southside fluxes for the respective boundary.
+       IF ( j == nysv )  THEN
+       
+          DO  k = nzb+1, nzb_max
+
+             ibit23 = IBITS(wall_flags_0(k,j-1,i),23,1)
+             ibit22 = IBITS(wall_flags_0(k,j-1,i),22,1)
+             ibit21 = IBITS(wall_flags_0(k,j-1,i),21,1)
+
+             v_comp_l       = v(k,j,i) + v(k,j-1,i) - gv
+             flux_s_v(k,tn) = v_comp_l * (                                    &
+                            ( 37.0_wp * ibit23 * adv_mom_5                    &
+                         +     7.0_wp * ibit22 * adv_mom_3                    &
+                         +              ibit21 * adv_mom_1                    &
+                            ) *                                               &
+                                        ( v(k,j,i)   + v(k,j-1,i) )           &
+                     -      (  8.0_wp * ibit23 * adv_mom_5                    &
+                         +              ibit22 * adv_mom_3                    &
+                            ) *                                               &
+                                        ( v(k,j+1,i) + v(k,j-2,i) )           &
+                     +      (           ibit23 * adv_mom_5                    &
+                            ) *                                               &
+                                        ( v(k,j+2,i) + v(k,j-3,i) )           &
+                                         )
+
+             diss_s_v(k,tn) = - ABS( v_comp_l ) * (                           &
+                            ( 10.0_wp * ibit23 * adv_mom_5                    &
+                         +     3.0_wp * ibit22 * adv_mom_3                    &
+                         +              ibit21 * adv_mom_1                    &
+                            ) *                                               &
+                                        ( v(k,j,i)   - v(k,j-1,i) )           &
+                     -      (  5.0_wp * ibit23 * adv_mom_5                    &
+                         +              ibit22 * adv_mom_3                    &
+                            ) *                                               &
+                                        ( v(k,j+1,i) - v(k,j-2,i) )           &
+                     +      (           ibit23 * adv_mom_5                    &
+                            ) *                                               &
+                                        ( v(k,j+2,i) - v(k,j-3,i) )           &
+                                                  )
+
+          ENDDO
+
+          DO  k = nzb_max+1, nzt
+
+             v_comp_l       = v(k,j,i) + v(k,j-1,i) - gv
+             flux_s_v(k,tn) = v_comp_l * (                                    &
+                           37.0_wp * ( v(k,j,i) + v(k,j-1,i)   )              &
+                         -  8.0_wp * ( v(k,j+1,i) + v(k,j-2,i) )              &
+                         +           ( v(k,j+2,i) + v(k,j-3,i) ) ) * adv_mom_5
+             diss_s_v(k,tn) = - ABS( v_comp_l ) * (                           &
+                           10.0_wp * ( v(k,j,i) - v(k,j-1,i)   )              &
+                         -  5.0_wp * ( v(k,j+1,i) - v(k,j-2,i) )              &
+                         +           ( v(k,j+2,i) - v(k,j-3,i) ) ) * adv_mom_5
+
+          ENDDO
+          
+       ENDIF
+
+       flux_t(0) = 0.0_wp
+       diss_t(0) = 0.0_wp
+       flux_d    = 0.0_wp
+       diss_d    = 0.0_wp
+!
+!--    Now compute the fluxes and tendency terms for the horizontal and
+!--    verical parts.
+       DO  k = nzb+1, nzb_max
+
+          ibit20 = IBITS(wall_flags_0(k,j,i),20,1)
+          ibit19 = IBITS(wall_flags_0(k,j,i),19,1)
+          ibit18 = IBITS(wall_flags_0(k,j,i),18,1)
+ 
+          u_comp    = u(k,j-1,i+1) + u(k,j,i+1) - gu
+          flux_r(k) = u_comp * (                                              &
+                     ( 37.0_wp * ibit20 * adv_mom_5                           &
+                  +     7.0_wp * ibit19 * adv_mom_3                           &
+                  +              ibit18 * adv_mom_1                           &
+                     ) *                                                      &
+                                    ( v(k,j,i+1) + v(k,j,i)   )               &
+              -      (  8.0_wp * ibit20 * adv_mom_5                           &
+                  +              ibit19 * adv_mom_3                           &
+                     ) *                                                      &
+                                    ( v(k,j,i+2) + v(k,j,i-1) )               &
+              +      (           ibit20 * adv_mom_5                           &
+                     ) *                                                      &
+                                    ( v(k,j,i+3) + v(k,j,i-2) )               &
+                               )
+
+          diss_r(k) = - ABS( u_comp ) * (                                     &
+                     ( 10.0_wp * ibit20 * adv_mom_5                           &
+                  +     3.0_wp * ibit19 * adv_mom_3                           &
+                  +              ibit18 * adv_mom_1                           &
+                     ) *                                                      &
+                                    ( v(k,j,i+1) - v(k,j,i)  )                &
+              -      (  5.0_wp * ibit20 * adv_mom_5                           &
+                  +              ibit19 * adv_mom_3                           &
+                     ) *                                                      &
+                                    ( v(k,j,i+2) - v(k,j,i-1) )               &
+              +      (           ibit20 * adv_mom_5                           &
+                     ) *                                                      &
+                                    ( v(k,j,i+3) - v(k,j,i-2) )               &
+                                        )
+
+          ibit23 = IBITS(wall_flags_0(k,j,i),23,1)
+          ibit22 = IBITS(wall_flags_0(k,j,i),22,1)
+          ibit21 = IBITS(wall_flags_0(k,j,i),21,1)
+
+
+          v_comp(k) = v(k,j+1,i) + v(k,j,i)
+          flux_n(k) = ( v_comp(k) - gv ) * (                                  &
+                     ( 37.0_wp * ibit23 * adv_mom_5                           &
+                  +     7.0_wp * ibit22 * adv_mom_3                           &
+                  +              ibit21 * adv_mom_1                           &
+                     ) *                                                      &
+                                    ( v(k,j+1,i) + v(k,j,i)   )               &
+              -      (  8.0_wp * ibit23 * adv_mom_5                           &
+                  +              ibit22 * adv_mom_3                           &
+                     ) *                                                      &
+                                    ( v(k,j+2,i) + v(k,j-1,i) )               &
+              +      (           ibit23 * adv_mom_5                           &
+                     ) *                                                      &
+                                    ( v(k,j+3,i) + v(k,j-2,i) )               &
+                                           )
+
+          diss_n(k) = - ABS( v_comp(k) - gv ) * (                             &
+                     ( 10.0_wp * ibit23 * adv_mom_5                           &
+                  +     3.0_wp * ibit22 * adv_mom_3                           &
+                  +              ibit21 * adv_mom_1                           &
+                     ) *                                                      &
+                                    ( v(k,j+1,i) - v(k,j,i)   )               &
+              -      (  5.0_wp * ibit23 * adv_mom_5                           &
+                  +              ibit22 * adv_mom_3                           &
+                     ) *                                                      &
+                                    ( v(k,j+2,i) - v(k,j-1,i) )               &
+              +      (           ibit23 * adv_mom_5                           &
+                     ) *                                                      &
+                                    ( v(k,j+3,i) - v(k,j-2,i) )               &
+                                                )
+!
+!--       k index has to be modified near bottom and top, else array
+!--       subscripts will be exceeded.
+          ibit26 = IBITS(wall_flags_0(k,j,i),26,1)
+          ibit25 = IBITS(wall_flags_0(k,j,i),25,1)
+          ibit24 = IBITS(wall_flags_0(k,j,i),24,1)
+
+          k_ppp = k + 3 * ibit26
+          k_pp  = k + 2 * ( 1 - ibit24  )
+          k_mm  = k - 2 * ibit26
+
+          w_comp    = w(k,j-1,i) + w(k,j,i)
+          flux_t(k) = w_comp  * (                                             &
+                     ( 37.0_wp * ibit26 * adv_mom_5                           &
+                  +     7.0_wp * ibit25 * adv_mom_3                           &
+                  +              ibit24 * adv_mom_1                           &
+                     ) *                                                      &
+                                ( v(k+1,j,i)   + v(k,j,i)    )                &
+              -      (  8.0_wp * ibit26 * adv_mom_5                           &
+                  +              ibit25 * adv_mom_3                           &
+                     ) *                                                      &
+                                ( v(k_pp,j,i)  + v(k-1,j,i)  )                &
+              +      (           ibit26 * adv_mom_5                           &
+                     ) *                                                      &
+                                ( v(k_ppp,j,i) + v(k_mm,j,i) )                &
+                                 )
+
+          diss_t(k) = - ABS( w_comp ) * (                                     &
+                     ( 10.0_wp * ibit26 * adv_mom_5                           &
+                  +     3.0_wp * ibit25 * adv_mom_3                           &
+                  +              ibit24 * adv_mom_1                           &
+                     ) *                                                      &
+                                ( v(k+1,j,i)   - v(k,j,i)    )                &
+              -      (  5.0_wp * ibit26 * adv_mom_5                           &
+                  +              ibit25 * adv_mom_3                           &
+                     ) *                                                      &
+                                ( v(k_pp,j,i)  - v(k-1,j,i)  )                &
+              +      (           ibit26 * adv_mom_5                           &
+                     ) *                                                      &
+                                ( v(k_ppp,j,i) - v(k_mm,j,i) )                &
+                                         )
+!
+!--       Calculate the divergence of the velocity field. A respective
+!--       correction is needed to overcome numerical instabilities introduced
+!--       by a not sufficient reduction of divergences near topography. 
+          div = ( ( ( u_comp     + gu )                                       &
+                                       * ( ibit18 + ibit19 + ibit20 )         &
+                  - ( u(k,j-1,i) + u(k,j,i) )                                 &
+                                       * ( IBITS(wall_flags_0(k,j,i-1),18,1)  &
+                                         + IBITS(wall_flags_0(k,j,i-1),19,1)  &
+                                         + IBITS(wall_flags_0(k,j,i-1),20,1)  &
+                                         )                                    &   
+                  ) * ddx                                                     &
+               +  ( v_comp(k)                                                 &
+                                       * ( ibit21 + ibit22 + ibit23 )         &
+                - ( v(k,j,i)     + v(k,j-1,i) )                               &
+                                       * ( IBITS(wall_flags_0(k,j-1,i),21,1)  &
+                                         + IBITS(wall_flags_0(k,j-1,i),22,1)  &
+                                         + IBITS(wall_flags_0(k,j-1,i),23,1)  &
+                                         )                                    &   
+                  ) * ddy                                                     &
+               +  ( w_comp                                                    &
+                                       * ( ibit24 + ibit25 + ibit26 )         &
+                - ( w(k-1,j-1,i) + w(k-1,j,i) )                               &
+                                       * ( IBITS(wall_flags_0(k-1,j,i),24,1)  &
+                                         + IBITS(wall_flags_0(k-1,j,i),25,1)  &
+                                         + IBITS(wall_flags_0(k-1,j,i),26,1)  &
+                                         )                                    &
+                   ) * ddzw(k)   &
+                ) * 0.5_wp
+
+
+          tend(k,j,i) = tend(k,j,i) - (                                       &
+                         ( flux_r(k) + diss_r(k)                              &
+                       -   flux_l_v(k,j,tn) - diss_l_v(k,j,tn)   ) * ddx      &
+                       + ( flux_n(k) + diss_n(k)                              &
+                       -   flux_s_v(k,tn) - diss_s_v(k,tn)       ) * ddy      &
+                       + ( flux_t(k) + diss_t(k)                              &
+                       -   flux_d    - diss_d                    ) * ddzw(k)  &
+                                      ) + v(k,j,i) * div
+
+           flux_l_v(k,j,tn) = flux_r(k)
+           diss_l_v(k,j,tn) = diss_r(k)
+           flux_s_v(k,tn)   = flux_n(k)
+           diss_s_v(k,tn)   = diss_n(k)
+           flux_d           = flux_t(k)
+           diss_d           = diss_t(k)
+
+!
+!--        Statistical Evaluation of v'v'. The factor has to be applied for
+!--        right evaluation when gallilei_trans = .T. .
+           sums_vs2_ws_l(k,tn) = sums_vs2_ws_l(k,tn)                          &
+             + ( flux_n(k)                                                    &
+             * ( v_comp(k) - 2.0_wp * hom(k,1,2,0)      )                     &
+             / ( v_comp(k) - gv + 1.0E-20_wp       )                          &
+             +   diss_n(k)                                                    &
+             *   ABS( v_comp(k) - 2.0_wp * hom(k,1,2,0) )                     &
+             / ( ABS( v_comp(k) - gv ) +1.0E-20_wp ) )                        &
+             *   weight_substep(intermediate_timestep_count)
+!
+!--        Statistical Evaluation of w'v'.
+           sums_wsvs_ws_l(k,tn) = sums_wsvs_ws_l(k,tn)                        &
+                              + ( flux_t(k) + diss_t(k) )                     &
+                              *   weight_substep(intermediate_timestep_count)
+
+       ENDDO
+
+       DO  k = nzb_max+1, nzt
+
+          u_comp    = u(k,j-1,i+1) + u(k,j,i+1) - gu
+          flux_r(k) = u_comp * (                                              &
+                      37.0_wp * ( v(k,j,i+1) + v(k,j,i)   )                   &
+                    -  8.0_wp * ( v(k,j,i+2) + v(k,j,i-1) )                   &
+                    +           ( v(k,j,i+3) + v(k,j,i-2) ) ) * adv_mom_5
+
+          diss_r(k) = - ABS( u_comp ) * (                                     &
+                      10.0_wp * ( v(k,j,i+1) - v(k,j,i) )                     &
+                    -  5.0_wp * ( v(k,j,i+2) - v(k,j,i-1) )                   &
+                    +           ( v(k,j,i+3) - v(k,j,i-2) ) ) * adv_mom_5
+
+
+          v_comp(k) = v(k,j+1,i) + v(k,j,i)
+          flux_n(k) = ( v_comp(k) - gv ) * (                                  &
+                      37.0_wp * ( v(k,j+1,i) + v(k,j,i)   )                   &
+                    -  8.0_wp * ( v(k,j+2,i) + v(k,j-1,i) )                   &
+                      +         ( v(k,j+3,i) + v(k,j-2,i) ) ) * adv_mom_5
+
+          diss_n(k) = - ABS( v_comp(k) - gv ) * (                             &
+                      10.0_wp * ( v(k,j+1,i) - v(k,j,i)   )                   &
+                    -  5.0_wp * ( v(k,j+2,i) - v(k,j-1,i) )                   &
+                    +           ( v(k,j+3,i) - v(k,j-2,i) ) ) * adv_mom_5
+!
+!--       k index has to be modified near bottom and top, else array
+!--       subscripts will be exceeded.
+          ibit26 = IBITS(wall_flags_0(k,j,i),26,1)
+          ibit25 = IBITS(wall_flags_0(k,j,i),25,1)
+          ibit24 = IBITS(wall_flags_0(k,j,i),24,1)
+
+          k_ppp = k + 3 * ibit26
+          k_pp  = k + 2 * ( 1 - ibit24  )
+          k_mm  = k - 2 * ibit26
+
+          w_comp    = w(k,j-1,i) + w(k,j,i)
+          flux_t(k) = w_comp  * (                                             &
+                     ( 37.0_wp * ibit26 * adv_mom_5                           &
+                  +     7.0_wp * ibit25 * adv_mom_3                           &
+                  +              ibit24 * adv_mom_1                           &
+                     ) *                                                      &
+                                ( v(k+1,j,i)   + v(k,j,i)    )                &
+              -      (  8.0_wp * ibit26 * adv_mom_5                           &
+                  +              ibit25 * adv_mom_3                           &
+                     ) *                                                      &
+                                ( v(k_pp,j,i)  + v(k-1,j,i)  )                &
+              +      (           ibit26 * adv_mom_5                           &
+                     ) *                                                      &
+                                ( v(k_ppp,j,i) + v(k_mm,j,i) )                &
+                                 )
+
+          diss_t(k) = - ABS( w_comp ) * (                                     &
+                     ( 10.0_wp * ibit26 * adv_mom_5                           &
+                  +     3.0_wp * ibit25 * adv_mom_3                           &
+                  +              ibit24 * adv_mom_1                           &
+                     ) *                                                      &
+                                ( v(k+1,j,i)   - v(k,j,i)    )                &
+              -      (  5.0_wp * ibit26 * adv_mom_5                           &
+                  +              ibit25 * adv_mom_3                           &
+                     ) *                                                      &
+                                ( v(k_pp,j,i)  - v(k-1,j,i)  )                &
+              +      (           ibit26 * adv_mom_5                           &
+                     ) *                                                      &
+                                ( v(k_ppp,j,i) - v(k_mm,j,i) )                &
+                                         )
+!
+!--       Calculate the divergence of the velocity field. A respective
+!--       correction is needed to overcome numerical instabilities introduced
+!--       by a not sufficient reduction of divergences near topography.
+          div = ( ( u_comp + gu - ( u(k,j-1,i)   + u(k,j,i)   ) ) * ddx       &
+               +  ( v_comp(k)   - ( v(k,j,i)     + v(k,j-1,i) ) ) * ddy       &
+               +  ( w_comp      - ( w(k-1,j-1,i) + w(k-1,j,i) ) ) * ddzw(k)   &
+                ) * 0.5_wp
+
+          tend(k,j,i) = tend(k,j,i) - (                                       &
+                         ( flux_r(k) + diss_r(k)                              &
+                       -   flux_l_v(k,j,tn) - diss_l_v(k,j,tn)   ) * ddx      &
+                       + ( flux_n(k) + diss_n(k)                              &
+                       -   flux_s_v(k,tn) - diss_s_v(k,tn)       ) * ddy      &
+                       + ( flux_t(k) + diss_t(k)                              &
+                       -   flux_d    - diss_d                    ) * ddzw(k)  &
+                                      ) + v(k,j,i) * div
+
+           flux_l_v(k,j,tn) = flux_r(k)
+           diss_l_v(k,j,tn) = diss_r(k)
+           flux_s_v(k,tn)   = flux_n(k)
+           diss_s_v(k,tn)   = diss_n(k)
+           flux_d           = flux_t(k)
+           diss_d           = diss_t(k)
+
+!
+!--        Statistical Evaluation of v'v'. The factor has to be applied for
+!--        right evaluation when gallilei_trans = .T. .
+           sums_vs2_ws_l(k,tn) = sums_vs2_ws_l(k,tn)                          &
+             + ( flux_n(k)                                                    &
+             * ( v_comp(k) - 2.0_wp * hom(k,1,2,0)      )                     &
+             / ( v_comp(k) - gv + 1.0E-20_wp       )                          &
+             +   diss_n(k)                                                    &
+             *   ABS( v_comp(k) - 2.0_wp * hom(k,1,2,0) )                     &
+             / ( ABS( v_comp(k) - gv ) +1.0E-20_wp ) )                        &
+             *   weight_substep(intermediate_timestep_count)
+!
+!--        Statistical Evaluation of w'v'.
+           sums_wsvs_ws_l(k,tn) = sums_wsvs_ws_l(k,tn)                        &
+                              + ( flux_t(k) + diss_t(k) )                     &
+                              *   weight_substep(intermediate_timestep_count)
+
+       ENDDO
+       sums_vs2_ws_l(nzb,tn) = sums_vs2_ws_l(nzb+1,tn)
+
+
+    END SUBROUTINE advec_v_ws_ij
+
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Advection of w-component - Call for grid point i,j
+!------------------------------------------------------------------------------!
+    SUBROUTINE advec_w_ws_ij( i, j, i_omp, tn )
+
+       USE arrays_3d,                                                         &
+           ONLY:  ddzu, diss_l_w, diss_s_w, flux_l_w, flux_s_w, tend, u, v, w
+
+       USE constants,                                                         &
+           ONLY:  adv_mom_1, adv_mom_3, adv_mom_5
+
+       USE control_parameters,                                                &
+           ONLY:  intermediate_timestep_count, u_gtrans, v_gtrans
+
+       USE grid_variables,                                                    &
+           ONLY:  ddx, ddy
+
+       USE indices,                                                           &
+           ONLY:  nxl, nxr, nyn, nys, nzb, nzb_max, nzt, wall_flags_0,        &
+                  wall_flags_00
+
+       USE kinds
+       
+       USE statistics,                                                        &
+           ONLY:  hom, sums_ws2_ws_l, weight_substep
+
+       IMPLICIT NONE
+
+       INTEGER(iwp) ::  i      !<
+       INTEGER(iwp) ::  ibit27 !<
+       INTEGER(iwp) ::  ibit28 !<
+       INTEGER(iwp) ::  ibit29 !<
+       INTEGER(iwp) ::  ibit30 !<
+       INTEGER(iwp) ::  ibit31 !<
+       INTEGER(iwp) ::  ibit32 !<
+       INTEGER(iwp) ::  ibit33 !<
+       INTEGER(iwp) ::  ibit34 !<
+       INTEGER(iwp) ::  ibit35 !<
+       INTEGER(iwp) ::  i_omp  !<
+       INTEGER(iwp) ::  j      !<
+       INTEGER(iwp) ::  k      !<
+       INTEGER(iwp) ::  k_mm   !<
+       INTEGER(iwp) ::  k_pp   !<
+       INTEGER(iwp) ::  k_ppp  !<
+       INTEGER(iwp) ::  tn     !<
+       
+       REAL(wp)    ::  diss_d  !<
+       REAL(wp)    ::  div     !<
+       REAL(wp)    ::  flux_d  !<
+       REAL(wp)    ::  gu      !<
+       REAL(wp)    ::  gv      !<
+       REAL(wp)    ::  u_comp  !<
+       REAL(wp)    ::  v_comp  !<
+       REAL(wp)    ::  w_comp  !<
+       
+       REAL(wp), DIMENSION(nzb:nzt+1)  ::  diss_n !<
+       REAL(wp), DIMENSION(nzb:nzt+1)  ::  diss_r !<
+       REAL(wp), DIMENSION(nzb:nzt+1)  ::  diss_t !<
+       REAL(wp), DIMENSION(nzb:nzt+1)  ::  flux_n !<
+       REAL(wp), DIMENSION(nzb:nzt+1)  ::  flux_r !<
+       REAL(wp), DIMENSION(nzb:nzt+1)  ::  flux_t !<
+
+       gu = 2.0_wp * u_gtrans
+       gv = 2.0_wp * v_gtrans
+
+!
+!--    Compute southside fluxes for the respective boundary.
+       IF ( j == nys )  THEN
+
+          DO  k = nzb+1, nzb_max
+             ibit32 = IBITS(wall_flags_00(k,j-1,i),0,1)
+             ibit31 = IBITS(wall_flags_0(k,j-1,i),31,1)
+             ibit30 = IBITS(wall_flags_0(k,j-1,i),30,1)
+
+             v_comp         = v(k+1,j,i) + v(k,j,i) - gv
+             flux_s_w(k,tn) = v_comp * (                                      &
+                            ( 37.0_wp * ibit32 * adv_mom_5                    &
+                         +     7.0_wp * ibit31 * adv_mom_3                    &
+                         +              ibit30 * adv_mom_1                    &
+                            ) *                                               &
+                                        ( w(k,j,i)   + w(k,j-1,i) )           &
+                     -      (  8.0_wp * ibit32 * adv_mom_5                    &
+                         +              ibit31 * adv_mom_3                    &
+                            ) *                                               &
+                                        ( w(k,j+1,i) + w(k,j-2,i) )           &
+                     +      (           ibit32 * adv_mom_5                    &
+                            ) *                                               &
+                                        ( w(k,j+2,i) + w(k,j-3,i) )           &
+                                       )
+
+             diss_s_w(k,tn) = - ABS( v_comp ) * (                             &
+                            ( 10.0_wp * ibit32 * adv_mom_5                    &
+                         +     3.0_wp * ibit31 * adv_mom_3                    &
+                         +              ibit30 * adv_mom_1                    &
+                            ) *                                               &
+                                        ( w(k,j,i)   - w(k,j-1,i) )           &
+                     -      (  5.0_wp * ibit32 * adv_mom_5                    &
+                         +              ibit31 * adv_mom_3                    &
+                            ) *                                               &
+                                        ( w(k,j+1,i) - w(k,j-2,i) )           &
+                     +      (           ibit32 * adv_mom_5                    &
+                            ) *                                               &
+                                        ( w(k,j+2,i) - w(k,j-3,i) )           &
+                                                )
+
+          ENDDO
+
+          DO  k = nzb_max+1, nzt
+
+             v_comp         = v(k+1,j,i) + v(k,j,i) - gv
+             flux_s_w(k,tn) = v_comp * (                                      &
+                           37.0_wp * ( w(k,j,i) + w(k,j-1,i)   )              &
+                         -  8.0_wp * ( w(k,j+1,i) +w(k,j-2,i)  )              &
+                         +           ( w(k,j+2,i) + w(k,j-3,i) ) ) * adv_mom_5
+             diss_s_w(k,tn) = - ABS( v_comp ) * (                             &
+                           10.0_wp * ( w(k,j,i) - w(k,j-1,i)   )              &
+                         -  5.0_wp * ( w(k,j+1,i) - w(k,j-2,i) )              &
+                         +           ( w(k,j+2,i) - w(k,j-3,i) ) ) * adv_mom_5
+
+          ENDDO
+
+       ENDIF
+!
+!--    Compute leftside fluxes for the respective boundary.
+       IF ( i == i_omp ) THEN
+
+          DO  k = nzb+1, nzb_max
+
+             ibit29 = IBITS(wall_flags_0(k,j,i-1),29,1)
+             ibit28 = IBITS(wall_flags_0(k,j,i-1),28,1)
+             ibit27 = IBITS(wall_flags_0(k,j,i-1),27,1)
+
+             u_comp           = u(k+1,j,i) + u(k,j,i) - gu
+             flux_l_w(k,j,tn) = u_comp * (                                    &
+                             ( 37.0_wp * ibit29 * adv_mom_5                   &
+                          +     7.0_wp * ibit28 * adv_mom_3                   &
+                          +              ibit27 * adv_mom_1                   &
+                             ) *                                              &
+                                        ( w(k,j,i)   + w(k,j,i-1) )           &
+                      -      (  8.0_wp * ibit29 * adv_mom_5                   &
+                          +              ibit28 * adv_mom_3                   &
+                             ) *                                              &
+                                        ( w(k,j,i+1) + w(k,j,i-2) )           &
+                      +      (           ibit29 * adv_mom_5                   &
+                             ) *                                              &
+                                        ( w(k,j,i+2) + w(k,j,i-3) )           &
+                                         )
+
+               diss_l_w(k,j,tn) = - ABS( u_comp ) * (                         &
+                             ( 10.0_wp * ibit29 * adv_mom_5                   &
+                          +     3.0_wp * ibit28 * adv_mom_3                   &
+                          +              ibit27 * adv_mom_1                   &
+                             ) *                                              &
+                                        ( w(k,j,i)   - w(k,j,i-1) )           &
+                      -      (  5.0_wp * ibit29 * adv_mom_5                   &
+                          +              ibit28 * adv_mom_3                   &
+                             ) *                                              &
+                                        ( w(k,j,i+1) - w(k,j,i-2) )           &
+                      +      (           ibit29 * adv_mom_5                   &
+                             ) *                                              &
+                                        ( w(k,j,i+2) - w(k,j,i-3) )           &
+                                                    )
+
+          ENDDO
+
+          DO  k = nzb_max+1, nzt
+
+             u_comp           = u(k+1,j,i) + u(k,j,i) - gu
+             flux_l_w(k,j,tn) = u_comp * (                                    &
+                            37.0_wp * ( w(k,j,i) + w(k,j,i-1)   )             &
+                          -  8.0_wp * ( w(k,j,i+1) + w(k,j,i-2) )             &
+                          +           ( w(k,j,i+2) + w(k,j,i-3) ) ) * adv_mom_5
+             diss_l_w(k,j,tn) = - ABS( u_comp ) * (                           &
+                            10.0_wp * ( w(k,j,i) - w(k,j,i-1)   )             &
+                          -  5.0_wp * ( w(k,j,i+1) - w(k,j,i-2) )             &
+                          +           ( w(k,j,i+2) - w(k,j,i-3) ) ) * adv_mom_5 
+
+          ENDDO
+
+       ENDIF
+!
+!--    The lower flux has to be calculated explicetely for the tendency at
+!--    the first w-level. For topography wall this is done implicitely by
+!--    wall_flags_0.
+       k         = nzb + 1
+       w_comp    = w(k,j,i) + w(k-1,j,i)
+       flux_t(0) = w_comp       * ( w(k,j,i) + w(k-1,j,i) ) * adv_mom_1
+       diss_t(0) = -ABS(w_comp) * ( w(k,j,i) - w(k-1,j,i) ) * adv_mom_1
+       flux_d    = flux_t(0)
+       diss_d    = diss_t(0)
+!
+!--    Now compute the fluxes and tendency terms for the horizontal
+!--    and vertical parts.
+       DO  k = nzb+1, nzb_max
+
+          ibit29 = IBITS(wall_flags_0(k,j,i),29,1)
+          ibit28 = IBITS(wall_flags_0(k,j,i),28,1)
+          ibit27 = IBITS(wall_flags_0(k,j,i),27,1)
+
+          u_comp    = u(k+1,j,i+1) + u(k,j,i+1) - gu
+          flux_r(k) = u_comp * (                                              &
+                     ( 37.0_wp * ibit29 * adv_mom_5                           &
+                  +     7.0_wp * ibit28 * adv_mom_3                           &
+                  +              ibit27 * adv_mom_1                           &
+                     ) *                                                      &
+                                    ( w(k,j,i+1) + w(k,j,i)   )               &
+              -      (  8.0_wp * ibit29 * adv_mom_5                           &
+                  +              ibit28 * adv_mom_3                           &
+                     ) *                                                      &
+                                    ( w(k,j,i+2) + w(k,j,i-1) )               &
+              +      (           ibit29 * adv_mom_5                           &
+                     ) *                                                      &
+                                    ( w(k,j,i+3) + w(k,j,i-2) )               &
+                               )
+
+          diss_r(k) = - ABS( u_comp ) * (                                     &
+                     ( 10.0_wp * ibit29 * adv_mom_5                           &
+                  +     3.0_wp * ibit28 * adv_mom_3                           &
+                  +              ibit27 * adv_mom_1                           &
+                     ) *                                                      &
+                                    ( w(k,j,i+1) - w(k,j,i)   )               &
+              -      (  5.0_wp * ibit29 * adv_mom_5                           &
+                  +              ibit28 * adv_mom_3                           &
+                     ) *                                                      &
+                                    ( w(k,j,i+2) - w(k,j,i-1) )               &
+              +      (           ibit29 * adv_mom_5                           &
+                     ) *                                                      &
+                                    ( w(k,j,i+3) - w(k,j,i-2) )               &
+                                        )
+
+          ibit32 = IBITS(wall_flags_00(k,j,i),0,1)
+          ibit31 = IBITS(wall_flags_0(k,j,i),31,1)
+          ibit30 = IBITS(wall_flags_0(k,j,i),30,1)
+
+          v_comp    = v(k+1,j+1,i) + v(k,j+1,i) - gv
+          flux_n(k) = v_comp * (                                              &
+                     ( 37.0_wp * ibit32 * adv_mom_5                           &
+                  +     7.0_wp * ibit31 * adv_mom_3                           &
+                  +              ibit30 * adv_mom_1                           &
+                     ) *                                                      &
+                                    ( w(k,j+1,i) + w(k,j,i)   )               &
+              -      (  8.0_wp * ibit32 * adv_mom_5                           &
+                  +              ibit31 * adv_mom_3                           &
+                     ) *                                                      &
+                                    ( w(k,j+2,i) + w(k,j-1,i) )               &
+              +      (           ibit32 * adv_mom_5                           &
+                     ) *                                                      &
+                                    ( w(k,j+3,i) + w(k,j-2,i) )               &
+                               )
+
+          diss_n(k) = - ABS( v_comp ) * (                                     &
+                     ( 10.0_wp * ibit32 * adv_mom_5                           &
+                  +     3.0_wp * ibit31 * adv_mom_3                           &
+                  +              ibit30 * adv_mom_1                           &
+                     ) *                                                      &
+                                    ( w(k,j+1,i) - w(k,j,i)  )                &
+              -      (  5.0_wp * ibit32 * adv_mom_5                           &
+                  +              ibit31 * adv_mom_3                           &
+                     ) *                                                      &
+                                   ( w(k,j+2,i) - w(k,j-1,i) )                &
+              +      (           ibit32 * adv_mom_5                           &
+                     ) *                                                      &
+                                   ( w(k,j+3,i) - w(k,j-2,i) )                &
+                                        )
+!
+!--       k index has to be modified near bottom and top, else array
+!--       subscripts will be exceeded.
+          ibit35 = IBITS(wall_flags_00(k,j,i),3,1)
+          ibit34 = IBITS(wall_flags_00(k,j,i),2,1)
+          ibit33 = IBITS(wall_flags_00(k,j,i),1,1)
+
+          k_ppp = k + 3 * ibit35
+          k_pp  = k + 2 * ( 1 - ibit33  )
+          k_mm  = k - 2 * ibit35
+
+          w_comp    = w(k+1,j,i) + w(k,j,i)
+          flux_t(k) = w_comp  * (                                             &
+                     ( 37.0_wp * ibit35 * adv_mom_5                           &
+                  +     7.0_wp * ibit34 * adv_mom_3                           &
+                  +              ibit33 * adv_mom_1                           &
+                     ) *                                                      &
+                                ( w(k+1,j,i)  + w(k,j,i)     )                &
+              -      (  8.0_wp * ibit35 * adv_mom_5                           &
+                  +              ibit34 * adv_mom_3                           &
+                     ) *                                                      &
+                                ( w(k_pp,j,i)  + w(k-1,j,i)  )                &
+              +      (           ibit35 * adv_mom_5                           &
+                     ) *                                                      &
+                                ( w(k_ppp,j,i) + w(k_mm,j,i) )                &
+                                )
+
+          diss_t(k) = - ABS( w_comp ) * (                                     &
+                     ( 10.0_wp * ibit35 * adv_mom_5                           &
+                  +     3.0_wp * ibit34 * adv_mom_3                           &
+                  +              ibit33 * adv_mom_1                           &
+                     ) *                                                      &
+                                ( w(k+1,j,i)   - w(k,j,i)    )                &
+              -      (  5.0_wp * ibit35 * adv_mom_5                           &
+                  +              ibit34 * adv_mom_3                           &
+                     ) *                                                      &
+                                ( w(k_pp,j,i)  - w(k-1,j,i)  )                &
+              +      (           ibit35 * adv_mom_5                           &
+                     ) *                                                      &
+                                ( w(k_ppp,j,i) - w(k_mm,j,i) )                &
+                                        )
+
+!
+!--       Calculate the divergence of the velocity field. A respective
+!--       correction is needed to overcome numerical instabilities introduced
+!--       by a not sufficient reduction of divergences near topography. 
+          div = ( ( ( u_comp + gu ) * ( ibit27 + ibit28 + ibit29 )            &
+                  - ( u(k+1,j,i) + u(k,j,i)   )                               & 
+                                    * ( IBITS(wall_flags_0(k,j,i-1),27,1)     &
+                                      + IBITS(wall_flags_0(k,j,i-1),28,1)     &
+                                      + IBITS(wall_flags_0(k,j,i-1),29,1)     &
+                                      )                                       &
+                  ) * ddx                                                     &
+              +   ( ( v_comp + gv ) * ( ibit30 + ibit31 + ibit32 )            & 
+                  - ( v(k+1,j,i) + v(k,j,i)   )                               &
+                                    * ( IBITS(wall_flags_0(k,j-1,i),30,1)     &
+                                      + IBITS(wall_flags_0(k,j-1,i),31,1)     &
+                                      + IBITS(wall_flags_00(k,j-1,i),0,1)     &
+                                      )                                       &
+                  ) * ddy                                                     &
+              +   ( w_comp          * ( ibit33 + ibit34 + ibit35 )            &
+                - ( w(k,j,i)   + w(k-1,j,i)   )                               &
+                                    * ( IBITS(wall_flags_00(k-1,j,i),1,1)     &
+                                      + IBITS(wall_flags_00(k-1,j,i),2,1)     &
+                                      + IBITS(wall_flags_00(k-1,j,i),3,1)     &
+                                      )                                       & 
+                  ) * ddzu(k+1)   &
+                ) * 0.5_wp
+
+
+          tend(k,j,i) = tend(k,j,i) - (                                       &
+                      ( flux_r(k) + diss_r(k)                                 &
+                    -   flux_l_w(k,j,tn) - diss_l_w(k,j,tn)   ) * ddx         &
+                    + ( flux_n(k) + diss_n(k)                                 &
+                    -   flux_s_w(k,tn) - diss_s_w(k,tn)       ) * ddy         &
+                    + ( flux_t(k) + diss_t(k)                                 &
+                    -   flux_d    - diss_d                    ) * ddzu(k+1)   &
+                                      ) + div * w(k,j,i)
+
+          flux_l_w(k,j,tn) = flux_r(k)
+          diss_l_w(k,j,tn) = diss_r(k)
+          flux_s_w(k,tn)   = flux_n(k)
+          diss_s_w(k,tn)   = diss_n(k)
+          flux_d           = flux_t(k)
+          diss_d           = diss_t(k)
+!
+!--        Statistical Evaluation of w'w'.
+          sums_ws2_ws_l(k,tn)  = sums_ws2_ws_l(k,tn)                          &
+                             + ( flux_t(k) + diss_t(k) )                      &
+                             *   weight_substep(intermediate_timestep_count)
+
+       ENDDO
+
+       DO  k = nzb_max+1, nzt
+
+          u_comp    = u(k+1,j,i+1) + u(k,j,i+1) - gu
+          flux_r(k) = u_comp * (                                              &
+                      37.0_wp * ( w(k,j,i+1) + w(k,j,i)   )                   &
+                    -  8.0_wp * ( w(k,j,i+2) + w(k,j,i-1) )                   &
+                    +           ( w(k,j,i+3) + w(k,j,i-2) ) ) * adv_mom_5
+
+          diss_r(k) = - ABS( u_comp ) * (                                     &
+                      10.0_wp * ( w(k,j,i+1) - w(k,j,i)   )                   &
+                    -  5.0_wp * ( w(k,j,i+2) - w(k,j,i-1) )                   &
+                    +           ( w(k,j,i+3) - w(k,j,i-2) ) ) * adv_mom_5
+
+          v_comp    = v(k+1,j+1,i) + v(k,j+1,i) - gv
+          flux_n(k) = v_comp * (                                              &
+                      37.0_wp * ( w(k,j+1,i) + w(k,j,i)   )                   &
+                    -  8.0_wp * ( w(k,j+2,i) + w(k,j-1,i) )                   &
+                    +           ( w(k,j+3,i) + w(k,j-2,i) ) ) * adv_mom_5
+
+          diss_n(k) = - ABS( v_comp ) * (                                     &
+                      10.0_wp * ( w(k,j+1,i) - w(k,j,i)   )                   &
+                    -  5.0_wp * ( w(k,j+2,i) - w(k,j-1,i) )                   &
+                    +           ( w(k,j+3,i) - w(k,j-2,i) ) ) * adv_mom_5
+!
+!--       k index has to be modified near bottom and top, else array
+!--       subscripts will be exceeded.
+          ibit35 = IBITS(wall_flags_00(k,j,i),3,1)
+          ibit34 = IBITS(wall_flags_00(k,j,i),2,1)
+          ibit33 = IBITS(wall_flags_00(k,j,i),1,1)
+
+          k_ppp = k + 3 * ibit35
+          k_pp  = k + 2 * ( 1 - ibit33  )
+          k_mm  = k - 2 * ibit35
+
+          w_comp    = w(k+1,j,i) + w(k,j,i)
+          flux_t(k) = w_comp  * (                                             &
+                     ( 37.0_wp * ibit35 * adv_mom_5                           &
+                  +     7.0_wp * ibit34 * adv_mom_3                           &
+                  +              ibit33 * adv_mom_1                           &
+                     ) *                                                      &
+                                ( w(k+1,j,i)  + w(k,j,i)     )                &
+              -      (  8.0_wp * ibit35 * adv_mom_5                           &
+                  +              ibit34 * adv_mom_3                           &
+                     ) *                                                      &
+                                ( w(k_pp,j,i)  + w(k-1,j,i)  )                &
+              +      (           ibit35 * adv_mom_5                           &
+                     ) *                                                      &
+                                ( w(k_ppp,j,i) + w(k_mm,j,i) )                &
+                                )
+
+          diss_t(k) = - ABS( w_comp ) * (                                     &
+                     ( 10.0_wp * ibit35 * adv_mom_5                           &
+                  +     3.0_wp * ibit34 * adv_mom_3                           &
+                  +              ibit33 * adv_mom_1                           &
+                     ) *                                                      &
+                                ( w(k+1,j,i)   - w(k,j,i)    )                &
+              -      (  5.0_wp * ibit35 * adv_mom_5                           &
+                  +              ibit34 * adv_mom_3                           &
+                     ) *                                                      &
+                                ( w(k_pp,j,i)  - w(k-1,j,i)  )                &
+              +      (           ibit35 * adv_mom_5                           &
+                     ) *                                                      &
+                                ( w(k_ppp,j,i) - w(k_mm,j,i) )                &
+                                        )
+!
+!--       Calculate the divergence of the velocity field. A respective
+!--       correction is needed to overcome numerical instabilities introduced
+!--       by a not sufficient reduction of divergences near topography.
+          div = ( ( u_comp + gu - ( u(k+1,j,i) + u(k,j,i)   ) ) * ddx         &
+              +   ( v_comp + gv - ( v(k+1,j,i) + v(k,j,i)   ) ) * ddy         &
+              +   ( w_comp      - ( w(k,j,i)   + w(k-1,j,i) ) ) * ddzu(k+1)   &
+                ) * 0.5_wp
+
+          tend(k,j,i) = tend(k,j,i) - (                                       &
+                      ( flux_r(k) + diss_r(k)                                 &
+                    -   flux_l_w(k,j,tn) - diss_l_w(k,j,tn)   ) * ddx         &
+                    + ( flux_n(k) + diss_n(k)                                 &
+                    -   flux_s_w(k,tn) - diss_s_w(k,tn)       ) * ddy         &
+                    + ( flux_t(k) + diss_t(k)                                 &
+                    -   flux_d    - diss_d                    ) * ddzu(k+1)   &
+                                      ) + div * w(k,j,i)
+
+          flux_l_w(k,j,tn) = flux_r(k)
+          diss_l_w(k,j,tn) = diss_r(k)
+          flux_s_w(k,tn)   = flux_n(k)
+          diss_s_w(k,tn)   = diss_n(k)
+          flux_d           = flux_t(k)
+          diss_d           = diss_t(k)
+!
+!--        Statistical Evaluation of w'w'.
+          sums_ws2_ws_l(k,tn)  = sums_ws2_ws_l(k,tn)                          &
+                             + ( flux_t(k) + diss_t(k) )                      &
+                             *   weight_substep(intermediate_timestep_count)
+
+       ENDDO
+
+
+    END SUBROUTINE advec_w_ws_ij
+    
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Scalar advection - Call for all grid points
+!------------------------------------------------------------------------------!
+    SUBROUTINE advec_s_ws( sk, sk_char )
+
+       USE arrays_3d,                                                         &
+           ONLY:  ddzw, tend, u, v, w
+
+       USE constants,                                                         &
+           ONLY:  adv_sca_1, adv_sca_3, adv_sca_5
+
+       USE control_parameters,                                                &
+           ONLY:  intermediate_timestep_count, monotonic_adjustment, u_gtrans,&
+                  v_gtrans 
+
+       USE grid_variables,                                                    &
+           ONLY:  ddx, ddy
+
+       USE indices,                                                           &
+           ONLY:  nxl, nxlg, nxr, nxrg, nyn, nyng, nys, nysg, nzb, nzb_max,   &
+                  nzt, wall_flags_0
+           
+       USE kinds
+       
+       USE statistics,                                                        &
+           ONLY:  sums_wspts_ws_l, sums_wsqs_ws_l, sums_wssas_ws_l,           &
+                  sums_wsqrs_ws_l, sums_wsnrs_ws_l, weight_substep
+
+       IMPLICIT NONE
+
+       CHARACTER (LEN = *), INTENT(IN)    ::  sk_char !<
+       
+       INTEGER(iwp) ::  i      !<
+       INTEGER(iwp) ::  ibit0  !<
+       INTEGER(iwp) ::  ibit1  !<
+       INTEGER(iwp) ::  ibit2  !<
+       INTEGER(iwp) ::  ibit3  !<
+       INTEGER(iwp) ::  ibit4  !<
+       INTEGER(iwp) ::  ibit5  !<
+       INTEGER(iwp) ::  ibit6  !<
+       INTEGER(iwp) ::  ibit7  !<
+       INTEGER(iwp) ::  ibit8  !<
+       INTEGER(iwp) ::  j      !<
+       INTEGER(iwp) ::  k      !<
+       INTEGER(iwp) ::  k_mm   !<
+       INTEGER(iwp) ::  k_mmm  !<
+       INTEGER(iwp) ::  k_pp   !<
+       INTEGER(iwp) ::  k_ppp  !<
+       INTEGER(iwp) ::  tn = 0 !<
+       
+#if defined( __nopointer )
+       REAL(wp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ::  sk !<
+#else
+       REAL(wp), DIMENSION(:,:,:), POINTER ::  sk !<
+#endif
+
+       REAL(wp) ::  diss_d !<
+       REAL(wp) ::  div    !<
+       REAL(wp) ::  flux_d !<
+       REAL(wp) ::  fd_1   !<
+       REAL(wp) ::  fl_1   !<
+       REAL(wp) ::  fn_1   !<
+       REAL(wp) ::  fr_1   !<
+       REAL(wp) ::  fs_1   !<
+       REAL(wp) ::  ft_1   !<
+       REAL(wp) ::  phi_d  !<
+       REAL(wp) ::  phi_l  !<
+       REAL(wp) ::  phi_n  !<
+       REAL(wp) ::  phi_r  !<
+       REAL(wp) ::  phi_s  !<
+       REAL(wp) ::  phi_t  !<
+       REAL(wp) ::  rd     !<
+       REAL(wp) ::  rl     !<
+       REAL(wp) ::  rn     !<
+       REAL(wp) ::  rr     !<
+       REAL(wp) ::  rs     !<
+       REAL(wp) ::  rt     !<
+       REAL(wp) ::  u_comp !<
+       REAL(wp) ::  v_comp !<
+       
+       REAL(wp), DIMENSION(nzb:nzt)   ::  diss_n !<
+       REAL(wp), DIMENSION(nzb:nzt)   ::  diss_r !<
+       REAL(wp), DIMENSION(nzb:nzt)   ::  diss_t !<
+       REAL(wp), DIMENSION(nzb:nzt)   ::  flux_n !<
+       REAL(wp), DIMENSION(nzb:nzt)   ::  flux_r !<
+       REAL(wp), DIMENSION(nzb:nzt)   ::  flux_t !<
+       
+       REAL(wp), DIMENSION(nzb+1:nzt) ::  swap_diss_y_local !<
+       REAL(wp), DIMENSION(nzb+1:nzt) ::  swap_flux_y_local !<
+       
+       REAL(wp), DIMENSION(nzb+1:nzt,nys:nyn) ::  swap_diss_x_local !<
+       REAL(wp), DIMENSION(nzb+1:nzt,nys:nyn) ::  swap_flux_x_local !<
+        
+
+!
+!--    Compute the fluxes for the whole left boundary of the processor domain.
+       i = nxl
+       DO  j = nys, nyn
+
+          DO  k = nzb+1, nzb_max
+
+             ibit2 = IBITS(wall_flags_0(k,j,i-1),2,1)
+             ibit1 = IBITS(wall_flags_0(k,j,i-1),1,1)
+             ibit0 = IBITS(wall_flags_0(k,j,i-1),0,1)
+
+             u_comp                 = u(k,j,i) - u_gtrans
+             swap_flux_x_local(k,j) = u_comp * (                              &
+                                             ( 37.0_wp * ibit2 * adv_sca_5    &
+                                          +     7.0_wp * ibit1 * adv_sca_3    &
+                                          +              ibit0 * adv_sca_1    &
+                                             ) *                              &
+                                          ( sk(k,j,i)   + sk(k,j,i-1)    )    &
+                                      -      (  8.0_wp * ibit2 * adv_sca_5    &
+                                          +              ibit1 * adv_sca_3    &
+                                             ) *                              &
+                                          ( sk(k,j,i+1) + sk(k,j,i-2)    )    &
+                                      +      (           ibit2 * adv_sca_5    & 
+                                             ) *                              &
+                                          ( sk(k,j,i+2) + sk(k,j,i-3)    )    &
+                                               )
+
+              swap_diss_x_local(k,j) = -ABS( u_comp ) * (                     &
+                                             ( 10.0_wp * ibit2 * adv_sca_5    &
+                                          +     3.0_wp * ibit1 * adv_sca_3    &
+                                          +              ibit0 * adv_sca_1    &
+                                             ) *                              &
+                                          ( sk(k,j,i)   - sk(k,j,i-1) )       &
+                                      -      (  5.0_wp * ibit2 * adv_sca_5    &
+                                          +              ibit1 * adv_sca_3    &
+                                             ) *                              &
+                                         ( sk(k,j,i+1) - sk(k,j,i-2)  )       &
+                                      +      (           ibit2 * adv_sca_5    &
+                                             ) *                              &
+                                          ( sk(k,j,i+2) - sk(k,j,i-3) )       &
+                                                        )
+
+          ENDDO
+
+          DO  k = nzb_max+1, nzt
+
+             u_comp                 = u(k,j,i) - u_gtrans
+             swap_flux_x_local(k,j) = u_comp * (                              &
+                                      37.0_wp * ( sk(k,j,i)   + sk(k,j,i-1) ) &
+                                    -  8.0_wp * ( sk(k,j,i+1) + sk(k,j,i-2) ) &
+                                    +           ( sk(k,j,i+2) + sk(k,j,i-3) ) &
+                                               ) * adv_sca_5
+
+             swap_diss_x_local(k,j) = -ABS( u_comp ) * (                      &
+                                      10.0_wp * ( sk(k,j,i)   - sk(k,j,i-1) ) &
+                                    -  5.0_wp * ( sk(k,j,i+1) - sk(k,j,i-2) ) &
+                                    +           ( sk(k,j,i+2) - sk(k,j,i-3) ) &
+                                                       ) * adv_sca_5
+
+          ENDDO
+
+       ENDDO
+
+       DO  i = nxl, nxr
+
+          j = nys
+          DO  k = nzb+1, nzb_max
+
+             ibit5 = IBITS(wall_flags_0(k,j-1,i),5,1)
+             ibit4 = IBITS(wall_flags_0(k,j-1,i),4,1)
+             ibit3 = IBITS(wall_flags_0(k,j-1,i),3,1)
+
+             v_comp               = v(k,j,i) - v_gtrans
+             swap_flux_y_local(k) = v_comp * (                                &
+                                             ( 37.0_wp * ibit5 * adv_sca_5    &
+                                          +     7.0_wp * ibit4 * adv_sca_3    &
+                                          +              ibit3 * adv_sca_1    &
+                                             ) *                              &
+                                         ( sk(k,j,i)  + sk(k,j-1,i)     )     &
+                                       -     (  8.0_wp * ibit5 * adv_sca_5    &
+                                          +              ibit4 * adv_sca_3    &
+                                              ) *                             &
+                                         ( sk(k,j+1,i) + sk(k,j-2,i)    )     &
+                                      +      (           ibit5 * adv_sca_5    &
+                                             ) *                              &
+                                        ( sk(k,j+2,i) + sk(k,j-3,i)     )     &
+                                             )
+
+             swap_diss_y_local(k) = -ABS( v_comp ) * (                        &
+                                             ( 10.0_wp * ibit5 * adv_sca_5    &
+                                          +     3.0_wp * ibit4 * adv_sca_3    &
+                                          +              ibit3 * adv_sca_1    &
+                                             ) *                              &
+                                          ( sk(k,j,i)   - sk(k,j-1,i)    )    &
+                                      -      (  5.0_wp * ibit5 * adv_sca_5    &
+                                          +              ibit4 * adv_sca_3    &
+                                             ) *                              &
+                                          ( sk(k,j+1,i) - sk(k,j-2,i)    )    &
+                                      +      (           ibit5 * adv_sca_5    &
+                                             ) *                              &
+                                          ( sk(k,j+2,i) - sk(k,j-3,i)    )    &
+                                                     )
+
+          ENDDO
+!
+!--       Above to the top of the highest topography. No degradation necessary.
+          DO  k = nzb_max+1, nzt
+
+             v_comp               = v(k,j,i) - v_gtrans
+             swap_flux_y_local(k) = v_comp * (                               &
+                                    37.0_wp * ( sk(k,j,i)   + sk(k,j-1,i) )  &
+                                  -  8.0_wp * ( sk(k,j+1,i) + sk(k,j-2,i) )  &
+                                  +           ( sk(k,j+2,i) + sk(k,j-3,i) )  &
+                                             ) * adv_sca_5
+              swap_diss_y_local(k) = -ABS( v_comp ) * (                      &
+                                    10.0_wp * ( sk(k,j,i)   - sk(k,j-1,i) )  &
+                                  -  5.0_wp * ( sk(k,j+1,i) - sk(k,j-2,i) )  &
+                                  +             sk(k,j+2,i) - sk(k,j-3,i)    &
+                                                      ) * adv_sca_5
+
+          ENDDO
+
+          DO  j = nys, nyn
+
+             flux_t(0) = 0.0_wp
+             diss_t(0) = 0.0_wp
+             flux_d    = 0.0_wp
+             diss_d    = 0.0_wp
+
+             DO  k = nzb+1, nzb_max
+
+                ibit2 = IBITS(wall_flags_0(k,j,i),2,1)
+                ibit1 = IBITS(wall_flags_0(k,j,i),1,1)
+                ibit0 = IBITS(wall_flags_0(k,j,i),0,1)
+
+                u_comp    = u(k,j,i+1) - u_gtrans
+                flux_r(k) = u_comp * (                                        &
+                          ( 37.0_wp * ibit2 * adv_sca_5                       &
+                      +      7.0_wp * ibit1 * adv_sca_3                       &
+                      +               ibit0 * adv_sca_1                       &
+                          ) *                                                 &
+                             ( sk(k,j,i+1) + sk(k,j,i)   )                    &
+                   -      (  8.0_wp * ibit2 * adv_sca_5                       &
+                       +              ibit1 * adv_sca_3                       &
+                          ) *                                                 &
+                             ( sk(k,j,i+2) + sk(k,j,i-1) )                    &
+                   +      (           ibit2 * adv_sca_5                       &
+                          ) *                                                 &
+                             ( sk(k,j,i+3) + sk(k,j,i-2) )                    &
+                                     )
+
+                diss_r(k) = -ABS( u_comp ) * (                                &
+                          ( 10.0_wp * ibit2 * adv_sca_5                       &
+                       +     3.0_wp * ibit1 * adv_sca_3                       &
+                       +              ibit0 * adv_sca_1                       &
+                          ) *                                                 &
+                             ( sk(k,j,i+1) - sk(k,j,i)   )                    &
+                   -      (  5.0_wp * ibit2 * adv_sca_5                       &
+                       +              ibit1 * adv_sca_3                       &
+                          ) *                                                 &
+                             ( sk(k,j,i+2) - sk(k,j,i-1) )                    &
+                   +      (           ibit2 * adv_sca_5                       &
+                          ) *                                                 &
+                             ( sk(k,j,i+3) - sk(k,j,i-2) )                    &
+                                             )
+
+                ibit5 = IBITS(wall_flags_0(k,j,i),5,1)
+                ibit4 = IBITS(wall_flags_0(k,j,i),4,1)
+                ibit3 = IBITS(wall_flags_0(k,j,i),3,1)
+
+                v_comp    = v(k,j+1,i) - v_gtrans
+                flux_n(k) = v_comp * (                                        &
+                          ( 37.0_wp * ibit5 * adv_sca_5                       &
+                       +     7.0_wp * ibit4 * adv_sca_3                       &
+                       +              ibit3 * adv_sca_1                       &
+                          ) *                                                 &
+                             ( sk(k,j+1,i) + sk(k,j,i)   )                    &
+                   -      (  8.0_wp * ibit5 * adv_sca_5                       &
+                       +              ibit4 * adv_sca_3                       &
+                          ) *                                                 &
+                             ( sk(k,j+2,i) + sk(k,j-1,i) )                    &
+                   +      (           ibit5 * adv_sca_5                       &
+                          ) *                                                 &
+                             ( sk(k,j+3,i) + sk(k,j-2,i) )                    &
+                                     )
+
+                diss_n(k) = -ABS( v_comp ) * (                                &
+                          ( 10.0_wp * ibit5 * adv_sca_5                       &
+                       +     3.0_wp * ibit4 * adv_sca_3                       &
+                       +              ibit3 * adv_sca_1                       &
+                          ) *                                                 &
+                             ( sk(k,j+1,i) - sk(k,j,i)    )                   &
+                   -      (  5.0_wp * ibit5 * adv_sca_5                       &
+                       +              ibit4 * adv_sca_3                       &
+                          ) *                                                 &
+                             ( sk(k,j+2,i) - sk(k,j-1,i)  )                   &
+                   +      (           ibit5 * adv_sca_5                       &
+                          ) *                                                 &
+                             ( sk(k,j+3,i) - sk(k,j-2,i) )                    &
+                                             )
+!
+!--             k index has to be modified near bottom and top, else array
+!--             subscripts will be exceeded.
+                ibit8 = IBITS(wall_flags_0(k,j,i),8,1)
+                ibit7 = IBITS(wall_flags_0(k,j,i),7,1)
+                ibit6 = IBITS(wall_flags_0(k,j,i),6,1)
+
+                k_ppp = k + 3 * ibit8
+                k_pp  = k + 2 * ( 1 - ibit6  )
+                k_mm  = k - 2 * ibit8
+
+
+                flux_t(k) = w(k,j,i) * (                                      &
+                           ( 37.0_wp * ibit8 * adv_sca_5                      &
+                        +     7.0_wp * ibit7 * adv_sca_3                      &
+                        +           ibit6 * adv_sca_1                         &
+                           ) *                                                &
+                                   ( sk(k+1,j,i)  + sk(k,j,i)    )            &
+                    -      (  8.0_wp * ibit8 * adv_sca_5                      &
+                        +              ibit7 * adv_sca_3                      &
+                           ) *                                                &
+                                   ( sk(k_pp,j,i) + sk(k-1,j,i)  )            &
+                    +      (           ibit8 * adv_sca_5                      &
+                           ) *     ( sk(k_ppp,j,i)+ sk(k_mm,j,i) )            &
+                                       )
+
+                diss_t(k) = -ABS( w(k,j,i) ) * (                              &
+                           ( 10.0_wp * ibit8 * adv_sca_5                      &
+                        +     3.0_wp * ibit7 * adv_sca_3                      &
+                        +              ibit6 * adv_sca_1                      &
+                           ) *                                                &
+                                   ( sk(k+1,j,i)   - sk(k,j,i)    )           &
+                    -      (  5.0_wp * ibit8 * adv_sca_5                      &
+                        +              ibit7 * adv_sca_3                      &
+                           ) *                                                &
+                                   ( sk(k_pp,j,i)  - sk(k-1,j,i)  )           &
+                    +      (           ibit8 * adv_sca_5                      &
+                           ) *                                                &
+                                   ( sk(k_ppp,j,i) - sk(k_mm,j,i) )           &
+                                               )
+!
+!--             Apply monotonic adjustment.
+                IF ( monotonic_adjustment )  THEN
+!
+!--                At first, calculate first order fluxes.
+                   u_comp = u(k,j,i) - u_gtrans
+                   fl_1   =  ( u_comp   * ( sk(k,j,i) + sk(k,j,i-1) )         &
+                         -ABS( u_comp ) * ( sk(k,j,i) - sk(k,j,i-1) )         &
+                             ) * adv_sca_1 
+
+                   u_comp = u(k,j,i+1) - u_gtrans
+                   fr_1   =  ( u_comp   * ( sk(k,j,i+1) + sk(k,j,i) )         &
+                         -ABS( u_comp ) * ( sk(k,j,i+1) - sk(k,j,i) )         &
+                             ) * adv_sca_1 
+
+                   v_comp = v(k,j,i) - v_gtrans
+                   fs_1   =  ( v_comp   * ( sk(k,j,i) + sk(k,j-1,i) )         &
+                         -ABS( v_comp ) * ( sk(k,j,i) - sk(k,j-1,i) )         &
+                             ) * adv_sca_1 
+
+                   v_comp = v(k,j+1,i) - v_gtrans
+                   fn_1   =  ( v_comp   * ( sk(k,j+1,i) + sk(k,j,i) )         &
+                         -ABS( v_comp ) * ( sk(k,j+1,i) - sk(k,j,i) )         &
+                             ) * adv_sca_1 
+
+                   fd_1   = (  w(k-1,j,i)   * ( sk(k,j,i) + sk(k-1,j,i) )     &
+                         -ABS( w(k-1,j,i) ) * ( sk(k,j,i) - sk(k-1,j,i) )     &
+                            ) * adv_sca_1 
+
+                   ft_1   = (  w(k,j,i)   * ( sk(k+1,j,i) + sk(k,j,i) )       &
+                         -ABS( w(k,j,i) ) * ( sk(k+1,j,i) - sk(k,j,i) )       &
+                            ) * adv_sca_1 
+!
+!--                Calculate ratio of upwind gradients. Note, Min/Max is just
+!--                to avoid if statements.
+                   rl     = ( MAX( 0.0_wp, u(k,j,i) - u_gtrans ) *            & 
+                               ABS( ( sk(k,j,i-1) - sk(k,j,i-2)            ) /&
+                                    ( sk(k,j,i)   - sk(k,j,i-1) + 1E-20_wp )  &
+                                  ) +                                         & 
+                              MIN( 0.0_wp, u(k,j,i) - u_gtrans ) *            &
+                               ABS( ( sk(k,j,i)   - sk(k,j,i+1)            ) /&
+                                    ( sk(k,j,i-1) - sk(k,j,i)   + 1E-20_wp )  &
+                                  )                                           &
+                            ) / ABS( u(k,j,i) - u_gtrans + 1E-20_wp )
+
+                   rr     = ( MAX( 0.0_wp, u(k,j,i+1) - u_gtrans ) *          & 
+                               ABS( ( sk(k,j,i)   - sk(k,j,i-1)            ) /&
+                                    ( sk(k,j,i+1) - sk(k,j,i)   + 1E-20_wp )  &
+                                  ) +                                         & 
+                              MIN( 0.0_wp, u(k,j,i+1) - u_gtrans ) *          &
+                               ABS( ( sk(k,j,i+1) - sk(k,j,i+2)            ) /&
+                                    ( sk(k,j,i)   - sk(k,j,i+1) + 1E-20_wp )  &
+                                  )                                           &
+                            ) / ABS( u(k,j,i+1) - u_gtrans + 1E-20_wp )
+
+                   rs     = ( MAX( 0.0_wp, v(k,j,i) - v_gtrans ) *            & 
+                               ABS( ( sk(k,j-1,i) - sk(k,j-2,i)            ) /&
+                                    ( sk(k,j,i)   - sk(k,j-1,i) + 1E-20_wp )  &
+                                  ) +                                         & 
+                              MIN( 0.0_wp, v(k,j,i) - v_gtrans ) *            &
+                               ABS( ( sk(k,j,i)   - sk(k,j+1,i)            ) /&
+                                    ( sk(k,j-1,i) - sk(k,j,i)   + 1E-20_wp )  &
+                                  )                                           &
+                            ) / ABS( v(k,j,i) - v_gtrans + 1E-20_wp )
+
+                   rn     = ( MAX( 0.0_wp, v(k,j+1,i) - v_gtrans ) *          & 
+                               ABS( ( sk(k,j,i)   - sk(k,j-1,i)            ) /&
+                                    ( sk(k,j+1,i) - sk(k,j,i)   + 1E-20_wp )  &
+                                  ) +                                         & 
+                              MIN( 0.0_wp, v(k,j+1,i) - v_gtrans ) *          &
+                               ABS( ( sk(k,j+1,i) - sk(k,j+2,i)            ) /&
+                                    ( sk(k,j,i)   - sk(k,j+1,i) + 1E-20_wp )  &
+                                  )                                           &
+                            ) / ABS( v(k,j+1,i) - v_gtrans + 1E-20_wp )     
+!   
+!--                Reuse k_mm and compute k_mmm for the vertical gradient ratios. 
+!--                Note, for vertical advection below the third grid point above 
+!--                surface ( or below the model top) rd and rt are set to 0, i.e. 
+!--                use of first order scheme is enforced.
+                   k_mmm  = k - 3 * ibit8
+
+                   rd     = ( MAX( 0.0_wp, w(k-1,j,i) ) *                     & 
+                            ABS( ( sk(k_mm,j,i) - sk(k_mmm,j,i)           ) / &
+                                 ( sk(k-1,j,i)  - sk(k_mm,j,i) + 1E-20_wp )   &
+                               ) +                                            & 
+                              MIN( 0.0_wp, w(k-1,j,i) ) *                     &
+                            ABS( ( sk(k-1,j,i) - sk(k,j,i)            ) /     &
+                                 ( sk(k_mm,j,i) - sk(k-1,j,i)   + 1E-20_wp )  &
+                               )                                              &
+                            ) * ibit8 / ABS( w(k-1,j,i) + 1E-20_wp ) 
+ 
+                   rt     = ( MAX( 0.0_wp, w(k,j,i) ) *                       & 
+                            ABS( ( sk(k,j,i)   - sk(k-1,j,i)            ) /   &
+                                 ( sk(k+1,j,i) - sk(k,j,i)   + 1E-20_wp )     &
+                               ) +                                            & 
+                              MIN( 0.0_wp, w(k,j,i) ) *                       &
+                            ABS( ( sk(k+1,j,i) - sk(k_pp,j,i)           ) /   &
+                                 ( sk(k,j,i)   - sk(k+1,j,i) + 1E-20_wp )     &
+                               )                                              &
+                            ) * ibit8 / ABS( w(k,j,i) + 1E-20_wp )
+!
+!--                Calculate empirical limiter function (van Albada2 limiter).
+                   phi_l = MIN( 1.0_wp, ( 2.0_wp * ABS( rl ) ) /              &
+                                        ( rl**2 + 1.0_wp ) ) 
+                   phi_r = MIN( 1.0_wp, ( 2.0_wp * ABS( rr ) ) /              &
+                                        ( rr**2 + 1.0_wp ) ) 
+                   phi_s = MIN( 1.0_wp, ( 2.0_wp * ABS( rs ) ) /              &
+                                        ( rs**2 + 1.0_wp ) ) 
+                   phi_n = MIN( 1.0_wp, ( 2.0_wp * ABS( rn ) ) /              &
+                                        ( rn**2 + 1.0_wp ) ) 
+                   phi_d = MIN( 1.0_wp, ( 2.0_wp * ABS( rd ) ) /              &
+                                        ( rd**2 + 1.0_wp ) ) 
+                   phi_t = MIN( 1.0_wp, ( 2.0_wp * ABS( rt ) ) /              &
+                                        ( rt**2 + 1.0_wp ) ) 
+!
+!--                Calculate the resulting monotone flux. 
+                   swap_flux_x_local(k,j) = fl_1 - phi_l *                    &
+                                          ( fl_1 - swap_flux_x_local(k,j) )
+                   flux_r(k)              = fr_1 - phi_r *                    &
+                                          ( fr_1 - flux_r(k)              )
+                   swap_flux_y_local(k)   = fs_1 - phi_s *                    &
+                                          ( fs_1 - swap_flux_y_local(k)   )
+                   flux_n(k)              = fn_1 - phi_n *                    &
+                                          ( fn_1 - flux_n(k)              )
+                   flux_d                 = fd_1 - phi_d *                    &
+                                          ( fd_1 - flux_d                 )
+                   flux_t(k)              = ft_1 - phi_t *                    &
+                                          ( ft_1 - flux_t(k)              )
+!
+!--                Moreover, modify dissipation flux according to the limiter. 
+                   swap_diss_x_local(k,j) = swap_diss_x_local(k,j) * phi_l
+                   diss_r(k)              = diss_r(k)              * phi_r
+                   swap_diss_y_local(k)   = swap_diss_y_local(k)   * phi_s
+                   diss_n(k)              = diss_n(k)              * phi_n
+                   diss_d                 = diss_d                 * phi_d
+                   diss_t(k)              = diss_t(k)              * phi_t
+
+                ENDIF
+!
+!--             Calculate the divergence of the velocity field. A respective
+!--             correction is needed to overcome numerical instabilities caused
+!--             by a not sufficient reduction of divergences near topography.
+                div   =   ( u(k,j,i+1) * ( ibit0 + ibit1 + ibit2 )             &
+                          - u(k,j,i)   * ( IBITS(wall_flags_0(k,j,i-1),0,1)    &
+                                         + IBITS(wall_flags_0(k,j,i-1),1,1)    &
+                                         + IBITS(wall_flags_0(k,j,i-1),2,1)    &
+                                         )                                     &
+                          ) * ddx                                              &
+                        + ( v(k,j+1,i) * ( ibit3 + ibit4 + ibit5 )             &
+                          - v(k,j,i)   * ( IBITS(wall_flags_0(k,j-1,i),3,1)    &
+                                         + IBITS(wall_flags_0(k,j-1,i),4,1)    &
+                                         + IBITS(wall_flags_0(k,j-1,i),5,1)    &
+                                         )                                     &
+                          ) * ddy                                              &
+                        + ( w(k,j,i)   * ( ibit6 + ibit7 + ibit8 )             &
+                          - w(k-1,j,i) * ( IBITS(wall_flags_0(k-1,j,i),6,1)    &
+                                         + IBITS(wall_flags_0(k-1,j,i),7,1)    &
+                                         + IBITS(wall_flags_0(k-1,j,i),8,1)    &
+                                         )                                     &      
+                          ) * ddzw(k)
+
+
+                tend(k,j,i) = tend(k,j,i) - (                                 &
+                        ( flux_r(k) + diss_r(k) - swap_flux_x_local(k,j) -    &
+                          swap_diss_x_local(k,j)            ) * ddx           &
+                      + ( flux_n(k) + diss_n(k) - swap_flux_y_local(k)   -    &
+                          swap_diss_y_local(k)              ) * ddy           &
+                      + ( flux_t(k) + diss_t(k) - flux_d - diss_d             &
+                                                               ) * ddzw(k)    &
+                                            ) + sk(k,j,i) * div
+
+                swap_flux_y_local(k)   = flux_n(k)
+                swap_diss_y_local(k)   = diss_n(k)
+                swap_flux_x_local(k,j) = flux_r(k)
+                swap_diss_x_local(k,j) = diss_r(k)
+                flux_d                 = flux_t(k)
+                diss_d                 = diss_t(k)
+
+             ENDDO
+
+             DO  k = nzb_max+1, nzt
+
+                u_comp    = u(k,j,i+1) - u_gtrans
+                flux_r(k) = u_comp * (                                        &
+                      37.0_wp * ( sk(k,j,i+1) + sk(k,j,i)   )                 &
+                    -  8.0_wp * ( sk(k,j,i+2) + sk(k,j,i-1) )                 &
+                    +           ( sk(k,j,i+3) + sk(k,j,i-2) ) ) * adv_sca_5
+                diss_r(k) = -ABS( u_comp ) * (                                &
+                      10.0_wp * ( sk(k,j,i+1) - sk(k,j,i)   )                 &
+                    -  5.0_wp * ( sk(k,j,i+2) - sk(k,j,i-1) )                 &
+                    +           ( sk(k,j,i+3) - sk(k,j,i-2) ) ) * adv_sca_5
+
+                v_comp    = v(k,j+1,i) - v_gtrans
+                flux_n(k) = v_comp * (                                        &
+                      37.0_wp * ( sk(k,j+1,i) + sk(k,j,i)   )                 &
+                    -  8.0_wp * ( sk(k,j+2,i) + sk(k,j-1,i) )                 &
+                    +           ( sk(k,j+3,i) + sk(k,j-2,i) ) ) * adv_sca_5
+                diss_n(k) = -ABS( v_comp ) * (                                &
+                      10.0_wp * ( sk(k,j+1,i) - sk(k,j,i)   )                 &
+                    -  5.0_wp * ( sk(k,j+2,i) - sk(k,j-1,i) )                 &
+                    +           ( sk(k,j+3,i) - sk(k,j-2,i) ) ) * adv_sca_5
+!
+!--             k index has to be modified near bottom and top, else array
+!--             subscripts will be exceeded.
+                ibit8 = IBITS(wall_flags_0(k,j,i),8,1)
+                ibit7 = IBITS(wall_flags_0(k,j,i),7,1)
+                ibit6 = IBITS(wall_flags_0(k,j,i),6,1)
+
+                k_ppp = k + 3 * ibit8
+                k_pp  = k + 2 * ( 1 - ibit6  )
+                k_mm  = k - 2 * ibit8
+
+
+                flux_t(k) = w(k,j,i) * (                                      &
+                           ( 37.0_wp * ibit8 * adv_sca_5                      &
+                        +     7.0_wp * ibit7 * adv_sca_3                      &
+                        +              ibit6 * adv_sca_1                      &
+                           ) *                                                &
+                                   ( sk(k+1,j,i)  + sk(k,j,i)     )           &
+                    -      (  8.0_wp * ibit8 * adv_sca_5                      &
+                        +              ibit7 * adv_sca_3                      &
+                           ) *                                                &
+                                   ( sk(k_pp,j,i) + sk(k-1,j,i)   )           &
+                    +      (           ibit8 * adv_sca_5                      &
+                           ) *     ( sk(k_ppp,j,i)+ sk(k_mm,j,i)  )           &
+                                       )
+
+                diss_t(k) = -ABS( w(k,j,i) ) * (                              &
+                           ( 10.0_wp * ibit8 * adv_sca_5                      &
+                        +     3.0_wp * ibit7 * adv_sca_3                      &
+                        +              ibit6 * adv_sca_1                      &
+                           ) *                                                &
+                                   ( sk(k+1,j,i)   - sk(k,j,i)    )           &
+                    -      (  5.0_wp * ibit8 * adv_sca_5                      &
+                        +              ibit7 * adv_sca_3                      &
+                           ) *                                                &
+                                   ( sk(k_pp,j,i)  - sk(k-1,j,i)  )           &
+                    +      (           ibit8 * adv_sca_5                      &
+                           ) *                                                &
+                                   ( sk(k_ppp,j,i) - sk(k_mm,j,i) )           &
+                                               )
+!
+!--             Apply monotonic adjustment.
+                IF ( monotonic_adjustment )  THEN
+!
+!--                At first, calculate first order fluxes.
+                   u_comp = u(k,j,i) - u_gtrans
+                   fl_1   =  ( u_comp   * ( sk(k,j,i) + sk(k,j,i-1) )         &
+                         -ABS( u_comp ) * ( sk(k,j,i) - sk(k,j,i-1) )         &
+                             ) * adv_sca_1 
+
+                   u_comp = u(k,j,i+1) - u_gtrans
+                   fr_1   =  ( u_comp   * ( sk(k,j,i+1) + sk(k,j,i) )         &
+                         -ABS( u_comp ) * ( sk(k,j,i+1) - sk(k,j,i) )         &
+                             ) * adv_sca_1 
+
+                   v_comp = v(k,j,i) - v_gtrans
+                   fs_1   =  ( v_comp   * ( sk(k,j,i) + sk(k,j-1,i) )         &
+                         -ABS( v_comp ) * ( sk(k,j,i) - sk(k,j-1,i) )         &
+                             ) * adv_sca_1 
+
+                   v_comp = v(k,j+1,i) - v_gtrans
+                   fn_1   =  ( v_comp   * ( sk(k,j+1,i) + sk(k,j,i) )         &
+                         -ABS( v_comp ) * ( sk(k,j+1,i) - sk(k,j,i) )         &
+                             ) * adv_sca_1 
+
+                   fd_1   = (  w(k-1,j,i)   * ( sk(k,j,i) + sk(k-1,j,i) )     &
+                         -ABS( w(k-1,j,i) ) * ( sk(k,j,i) - sk(k-1,j,i) )     &
+                            ) * adv_sca_1 
+
+                   ft_1   = (  w(k,j,i)   * ( sk(k+1,j,i) + sk(k,j,i) )       &
+                         -ABS( w(k,j,i) ) * ( sk(k+1,j,i) - sk(k,j,i) )       &
+                            ) * adv_sca_1 
+!
+!--                Calculate ratio of upwind gradients. Note, Min/Max is just
+!--                to avoid if statements.
+                   rl     = ( MAX( 0.0_wp, u(k,j,i) - u_gtrans ) *            & 
+                               ABS( ( sk(k,j,i-1) - sk(k,j,i-2)            ) /&
+                                    ( sk(k,j,i)   - sk(k,j,i-1) + 1E-20_wp )  &
+                                  ) +                                         & 
+                              MIN( 0.0_wp, u(k,j,i) - u_gtrans ) *            &
+                               ABS( ( sk(k,j,i)   - sk(k,j,i+1)            ) /&
+                                    ( sk(k,j,i-1) - sk(k,j,i)   + 1E-20_wp )  &
+                                  )                                           &
+                            ) / ABS( u(k,j,i) - u_gtrans + 1E-20_wp )
+
+                   rr     = ( MAX( 0.0_wp, u(k,j,i+1) - u_gtrans ) *          & 
+                               ABS( ( sk(k,j,i)   - sk(k,j,i-1)            ) /&
+                                    ( sk(k,j,i+1) - sk(k,j,i)   + 1E-20_wp )  &
+                                  ) +                                         & 
+                              MIN( 0.0_wp, u(k,j,i+1) - u_gtrans ) *          &
+                               ABS( ( sk(k,j,i+1) - sk(k,j,i+2)            ) /&
+                                    ( sk(k,j,i)   - sk(k,j,i+1) + 1E-20_wp )  &
+                                  )                                           &
+                            ) / ABS( u(k,j,i+1) - u_gtrans + 1E-20_wp )
+
+                   rs     = ( MAX( 0.0_wp, v(k,j,i) - v_gtrans ) *            & 
+                               ABS( ( sk(k,j-1,i) - sk(k,j-2,i)            ) /&
+                                    ( sk(k,j,i)   - sk(k,j-1,i) + 1E-20_wp )  &
+                                  ) +                                         & 
+                              MIN( 0.0_wp, v(k,j,i) - v_gtrans ) *            &
+                               ABS( ( sk(k,j,i)   - sk(k,j+1,i)            ) /&
+                                    ( sk(k,j-1,i) - sk(k,j,i)   + 1E-20_wp )  &
+                                  )                                           &
+                            ) / ABS( v(k,j,i) - v_gtrans + 1E-20_wp )
+
+                   rn     = ( MAX( 0.0_wp, v(k,j+1,i) - v_gtrans ) *          & 
+                               ABS( ( sk(k,j,i)   - sk(k,j-1,i)            ) /&
+                                    ( sk(k,j+1,i) - sk(k,j,i)   + 1E-20_wp )  &
+                                  ) +                                         & 
+                              MIN( 0.0_wp, v(k,j+1,i) - v_gtrans ) *          &
+                               ABS( ( sk(k,j+1,i) - sk(k,j+2,i)            ) /&
+                                    ( sk(k,j,i)   - sk(k,j+1,i) + 1E-20_wp )  &
+                                  )                                           &
+                            ) / ABS( v(k,j+1,i) - v_gtrans + 1E-20_wp )     
+!   
+!--                Reuse k_mm and compute k_mmm for the vertical gradient ratios. 
+!--                Note, for vertical advection below the third grid point above 
+!--                surface ( or below the model top) rd and rt are set to 0, i.e. 
+!--                use of first order scheme is enforced.
+                   k_mmm  = k - 3 * ibit8
+
+                   rd     = ( MAX( 0.0_wp, w(k-1,j,i) ) *                     & 
+                            ABS( ( sk(k_mm,j,i) - sk(k_mmm,j,i)           ) / &
+                                 ( sk(k-1,j,i)  - sk(k_mm,j,i) + 1E-20_wp )   &
+                               ) +                                            & 
+                              MIN( 0.0_wp, w(k-1,j,i) ) *                     &
+                            ABS( ( sk(k-1,j,i) - sk(k,j,i)            ) /     &
+                                 ( sk(k_mm,j,i) - sk(k-1,j,i)   + 1E-20_wp )  &
+                               )                                              &
+                            ) * ibit8 / ABS( w(k-1,j,i) + 1E-20_wp ) 
+ 
+                   rt     = ( MAX( 0.0_wp, w(k,j,i) ) *                       & 
+                            ABS( ( sk(k,j,i)   - sk(k-1,j,i)            ) /   &
+                                 ( sk(k+1,j,i) - sk(k,j,i)   + 1E-20_wp )     &
+                               ) +                                            & 
+                              MIN( 0.0_wp, w(k,j,i) ) *                       &
+                            ABS( ( sk(k+1,j,i) - sk(k_pp,j,i)           ) /   &
+                                 ( sk(k,j,i)   - sk(k+1,j,i) + 1E-20_wp )     &
+                               )                                              &
+                            ) * ibit8 / ABS( w(k,j,i) + 1E-20_wp ) 
+!
+!--                Calculate empirical limiter function (van Albada2 limiter).
+                   phi_l = MIN( 1.0_wp, ( 2.0_wp * ABS( rl ) ) /              &
+                                        ( rl**2 + 1.0_wp ) ) 
+                   phi_r = MIN( 1.0_wp, ( 2.0_wp * ABS( rr ) ) /              &
+                                        ( rr**2 + 1.0_wp ) ) 
+                   phi_s = MIN( 1.0_wp, ( 2.0_wp * ABS( rs ) ) /              &
+                                        ( rs**2 + 1.0_wp ) ) 
+                   phi_n = MIN( 1.0_wp, ( 2.0_wp * ABS( rn ) ) /              &
+                                        ( rn**2 + 1.0_wp ) ) 
+                   phi_d = MIN( 1.0_wp, ( 2.0_wp * ABS( rd ) ) /              &
+                                        ( rd**2 + 1.0_wp ) ) 
+                   phi_t = MIN( 1.0_wp, ( 2.0_wp * ABS( rt ) ) /              &
+                                        ( rt**2 + 1.0_wp ) ) 
+!
+!--                Calculate the resulting monotone flux. 
+                   swap_flux_x_local(k,j) = fl_1 - phi_l *                    &
+                                          ( fl_1 - swap_flux_x_local(k,j) )
+                   flux_r(k)              = fr_1 - phi_r *                    &
+                                          ( fr_1 - flux_r(k)              )
+                   swap_flux_y_local(k)   = fs_1 - phi_s *                    &
+                                          ( fs_1 - swap_flux_y_local(k)   )
+                   flux_n(k)              = fn_1 - phi_n *                    &
+                                          ( fn_1 - flux_n(k)              )
+                   flux_d                 = fd_1 - phi_d *                    &
+                                          ( fd_1 - flux_d                 )
+                   flux_t(k)              = ft_1 - phi_t *                    &
+                                          ( ft_1 - flux_t(k)              )
+!
+!--                Moreover, modify dissipation flux according to the limiter. 
+                   swap_diss_x_local(k,j) = swap_diss_x_local(k,j) * phi_l
+                   diss_r(k)              = diss_r(k)              * phi_r
+                   swap_diss_y_local(k)   = swap_diss_y_local(k)   * phi_s
+                   diss_n(k)              = diss_n(k)              * phi_n
+                   diss_d                 = diss_d                 * phi_d
+                   diss_t(k)              = diss_t(k)              * phi_t
+
+                ENDIF
+!
+!--             Calculate the divergence of the velocity field. A respective
+!--             correction is needed to overcome numerical instabilities introduced
+!--             by a not sufficient reduction of divergences near topography.
+                div         =   ( u(k,j,i+1) - u(k,j,i)   ) * ddx             &
+                              + ( v(k,j+1,i) - v(k,j,i)   ) * ddy             &
+                              + ( w(k,j,i)   - w(k-1,j,i) ) * ddzw(k)
+
+                tend(k,j,i) = tend(k,j,i) - (                                 &
+                        ( flux_r(k) + diss_r(k) - swap_flux_x_local(k,j) -    &
+                          swap_diss_x_local(k,j)            ) * ddx           &
+                      + ( flux_n(k) + diss_n(k) - swap_flux_y_local(k)   -    &
+                          swap_diss_y_local(k)              ) * ddy           &
+                      + ( flux_t(k) + diss_t(k) - flux_d - diss_d             &
+                                                               ) * ddzw(k)    &
+                                            ) + sk(k,j,i) * div
+
+                swap_flux_y_local(k)   = flux_n(k)
+                swap_diss_y_local(k)   = diss_n(k)
+                swap_flux_x_local(k,j) = flux_r(k)
+                swap_diss_x_local(k,j) = diss_r(k)
+                flux_d                 = flux_t(k)
+                diss_d                 = diss_t(k)
+
+             ENDDO
+!
+!--          Evaluation of statistics. 
+             SELECT CASE ( sk_char )
+
+                 CASE ( 'pt' )
+                    DO  k = nzb, nzt
+                       sums_wspts_ws_l(k,tn) = sums_wspts_ws_l(k,tn)          &
+                        + ( flux_t(k) + diss_t(k) )                           &
+                        *   weight_substep(intermediate_timestep_count)
+                    ENDDO
+                 CASE ( 'sa' )
+                    DO  k = nzb, nzt
+                       sums_wssas_ws_l(k,tn) = sums_wssas_ws_l(k,tn)          &
+                        + ( flux_t(k) + diss_t(k) )                           &
+                        *   weight_substep(intermediate_timestep_count)
+                    ENDDO
+                 CASE ( 'q' )
+                    DO  k = nzb, nzt
+                       sums_wsqs_ws_l(k,tn) = sums_wsqs_ws_l(k,tn)            &
+                        + ( flux_t(k) + diss_t(k) )                           &
+                        *   weight_substep(intermediate_timestep_count)
+                    ENDDO
+                 CASE ( 'qr' )
+                    DO  k = nzb, nzt
+                       sums_wsqrs_ws_l(k,tn) = sums_wsqrs_ws_l(k,tn)          &
+                        + ( flux_t(k) + diss_t(k) )                           &
+                        *   weight_substep(intermediate_timestep_count)
+                    ENDDO
+                 CASE ( 'nr' )
+                    DO  k = nzb, nzt
+                       sums_wsnrs_ws_l(k,tn) = sums_wsnrs_ws_l(k,tn)          &
+                        + ( flux_t(k) + diss_t(k) )                           &
+                        *   weight_substep(intermediate_timestep_count)
+                    ENDDO
+
+              END SELECT
+
+         ENDDO
+      ENDDO
+
+    END SUBROUTINE advec_s_ws
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Scalar advection - Call for all grid points - accelerator version
+!------------------------------------------------------------------------------!
+    SUBROUTINE advec_s_ws_acc ( sk, sk_char )
+
+       USE arrays_3d,                                                         &
+           ONLY:  ddzw, tend, u, v, w
+
+       USE constants,                                                         &
+           ONLY:  adv_sca_1, adv_sca_3, adv_sca_5
+
+       USE control_parameters,                                                &
+           ONLY:  intermediate_timestep_count, monotonic_adjustment, u_gtrans,&
+                  v_gtrans
+
+       USE grid_variables,                                                    &
+           ONLY:  ddx, ddy
+
+       USE indices,                                                           &
+           ONLY:  i_left, i_right, j_north, j_south, nxlg, nxrg, nyng, nysg,  &
+                  nzb, nzb_max, nzt, wall_flags_0
+
+       USE kinds
+       
+!        USE statistics,                                                       &
+!            ONLY:  sums_wspts_ws_l, sums_wsqs_ws_l, sums_wssas_ws_l,          &
+!                   sums_wsqrs_ws_l, sums_wsnrs_ws_l, weight_substep
+
+       IMPLICIT NONE
+
+       CHARACTER (LEN = *), INTENT(IN)    :: sk_char !<
+
+       INTEGER(iwp) ::  i      !<
+       INTEGER(iwp) ::  ibit0  !<
+       INTEGER(iwp) ::  ibit1  !<
+       INTEGER(iwp) ::  ibit2  !<
+       INTEGER(iwp) ::  ibit3  !<
+       INTEGER(iwp) ::  ibit4  !<
+       INTEGER(iwp) ::  ibit5  !<
+       INTEGER(iwp) ::  ibit6  !<
+       INTEGER(iwp) ::  ibit7  !<
+       INTEGER(iwp) ::  ibit8  !<
+       INTEGER(iwp) ::  j      !<
+       INTEGER(iwp) ::  k      !<
+       INTEGER(iwp) ::  k_mm   !<
+       INTEGER(iwp) ::  k_mmm  !<
+       INTEGER(iwp) ::  k_pp   !<
+       INTEGER(iwp) ::  k_ppp  !<
+       INTEGER(iwp) ::  tn = 0 !<
+
+       REAL(wp)    ::  diss_d !<
+       REAL(wp)    ::  diss_l !<
+       REAL(wp)    ::  diss_n !<
+       REAL(wp)    ::  diss_r !<
+       REAL(wp)    ::  diss_s !<
+       REAL(wp)    ::  diss_t !<
+       REAL(wp)    ::  div    !<
+       REAL(wp)    ::  flux_d !<
+       REAL(wp)    ::  flux_l !<
+       REAL(wp)    ::  flux_n !<
+       REAL(wp)    ::  flux_r !<
+       REAL(wp)    ::  flux_s !<
+       REAL(wp)    ::  flux_t !<
+       REAL(wp)    ::  fd_1   !<
+       REAL(wp)    ::  fl_1   !<
+       REAL(wp)    ::  fn_1   !<
+       REAL(wp)    ::  fr_1   !<
+       REAL(wp)    ::  fs_1   !<
+       REAL(wp)    ::  ft_1   !<
+       REAL(wp)    ::  phi_d  !<
+       REAL(wp)    ::  phi_l  !<
+       REAL(wp)    ::  phi_n  !<
+       REAL(wp)    ::  phi_r  !<
+       REAL(wp)    ::  phi_s  !<
+       REAL(wp)    ::  phi_t  !<
+       REAL(wp)    ::  rd     !<
+       REAL(wp)    ::  rl     !<
+       REAL(wp)    ::  rn     !<
+       REAL(wp)    ::  rr     !<
+       REAL(wp)    ::  rs     !<
+       REAL(wp)    ::  rt     !<
+       REAL(wp)    ::  u_comp !<
+       REAL(wp)    ::  v_comp !<
+
+       REAL(wp), INTENT(IN), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg)  ::  sk !<
+
+!
+!--    Computation of fluxes and tendency terms
+       !$acc kernels present( ddzw, sk, tend, u, v, w, wall_flags_0 )
+       DO  i = i_left, i_right
+          DO  j = j_south, j_north
+             DO  k = nzb+1, nzt
+
+                ibit2 = IBITS(wall_flags_0(k,j,i-1),2,1)
+                ibit1 = IBITS(wall_flags_0(k,j,i-1),1,1)
+                ibit0 = IBITS(wall_flags_0(k,j,i-1),0,1)
+
+                u_comp              = u(k,j,i) - u_gtrans
+                flux_l              = u_comp * (                              &
+                                               ( 37.0_wp * ibit2 * adv_sca_5  &
+                                            +     7.0_wp * ibit1 * adv_sca_3  &
+                                            +              ibit0 * adv_sca_1  &
+                                               ) *                            &
+                                         ( sk(k,j,i)   + sk(k,j,i-1)    )     &
+                                        -      (  8.0_wp * ibit2 * adv_sca_5  &
+                                            +              ibit1 * adv_sca_3  &
+                                               ) *                            &
+                                         ( sk(k,j,i+1) + sk(k,j,i-2)    )     &
+                                        +      (           ibit2 * adv_sca_5  &
+                                               ) *                            &
+                                         ( sk(k,j,i+2) + sk(k,j,i-3)    )     &
+                                               )
+
+                diss_l              = -ABS( u_comp ) * (                      &
+                                               ( 10.0_wp * ibit2 * adv_sca_5  &
+                                            +     3.0_wp * ibit1 * adv_sca_3  &
+                                            +              ibit0 * adv_sca_1  &
+                                               ) *                            &
+                                         ( sk(k,j,i)   - sk(k,j,i-1)    )     &
+                                        -      (  5.0_wp * ibit2 * adv_sca_5  &
+                                            +              ibit1 * adv_sca_3  &
+                                               ) *                            &
+                                         ( sk(k,j,i+1) - sk(k,j,i-2)    )     &
+                                        +      (           ibit2 * adv_sca_5  &
+                                               ) *                            &
+                                         ( sk(k,j,i+2) - sk(k,j,i-3)    )     &
+                                                        )
+
+                ibit2 = IBITS(wall_flags_0(k,j,i),2,1)
+                ibit1 = IBITS(wall_flags_0(k,j,i),1,1)
+                ibit0 = IBITS(wall_flags_0(k,j,i),0,1)
+
+                u_comp    = u(k,j,i+1) - u_gtrans
+                flux_r    = u_comp * (                                        &
+                          ( 37.0_wp * ibit2 * adv_sca_5                       &
+                      +      7.0_wp * ibit1 * adv_sca_3                       &
+                      +               ibit0 * adv_sca_1                       &
+                          ) *                                                 &
+                             ( sk(k,j,i+1) + sk(k,j,i)   )                    &
+                   -      (  8.0_wp * ibit2 * adv_sca_5                       &
+                       +              ibit1 * adv_sca_3                       &
+                          ) *                                                 &
+                             ( sk(k,j,i+2) + sk(k,j,i-1) )                    &
+                   +      (           ibit2 * adv_sca_5                       &
+                          ) *                                                 &
+                             ( sk(k,j,i+3) + sk(k,j,i-2) )                    &
+                                     )
+
+                diss_r    = -ABS( u_comp ) * (                                &
+                          ( 10.0_wp * ibit2 * adv_sca_5                       &
+                       +     3.0_wp * ibit1 * adv_sca_3                       &
+                       +              ibit0 * adv_sca_1                       &
+                          ) *                                                 &
+                             ( sk(k,j,i+1) - sk(k,j,i)   )                    &
+                   -      (  5.0_wp * ibit2 * adv_sca_5                       &
+                       +              ibit1 * adv_sca_3                       &
+                          ) *                                                 &
+                             ( sk(k,j,i+2) - sk(k,j,i-1) )                    &
+                   +      (           ibit2 * adv_sca_5                       &
+                          ) *                                                 &
+                             ( sk(k,j,i+3) - sk(k,j,i-2) )                    &
+                                             )
+
+                ibit5 = IBITS(wall_flags_0(k,j-1,i),5,1)
+                ibit4 = IBITS(wall_flags_0(k,j-1,i),4,1)
+                ibit3 = IBITS(wall_flags_0(k,j-1,i),3,1)
+
+                v_comp    = v(k,j,i) - v_gtrans
+                flux_s    = v_comp * (                                        &
+                          ( 37.0_wp * ibit5 * adv_sca_5                       &
+                       +     7.0_wp * ibit4 * adv_sca_3                       &
+                       +              ibit3 * adv_sca_1                       &
+                          ) *                                                 &
+                             ( sk(k,j,i)  + sk(k,j-1,i)     )                 &
+                    -     (  8.0_wp * ibit5 * adv_sca_5                       &
+                       +              ibit4 * adv_sca_3                       &
+                          ) *                                                 &
+                             ( sk(k,j+1,i) + sk(k,j-2,i)    )                 &
+                   +      (           ibit5 * adv_sca_5                       &
+                          ) *                                                 &
+                             ( sk(k,j+2,i) + sk(k,j-3,i)    )                 &
+                                     )
+
+                diss_s    = -ABS( v_comp ) * (                                &
+                          ( 10.0_wp * ibit5 * adv_sca_5                       &
+                       +     3.0_wp * ibit4 * adv_sca_3                       &
+                       +              ibit3 * adv_sca_1                       &
+                          ) *                                                 &
+                             ( sk(k,j,i)   - sk(k,j-1,i)  )                   &
+                   -      (  5.0_wp * ibit5 * adv_sca_5                       &
+                       +              ibit4 * adv_sca_3                       &
+                          ) *                                                 &
+                             ( sk(k,j+1,i) - sk(k,j-2,i)  )                   &
+                   +      (           ibit5 * adv_sca_5                       &
+                          ) *                                                 &
+                             ( sk(k,j+2,i) - sk(k,j-3,i)  )                   &
+                                             )
+
+                ibit5 = IBITS(wall_flags_0(k,j,i),5,1)
+                ibit4 = IBITS(wall_flags_0(k,j,i),4,1)
+                ibit3 = IBITS(wall_flags_0(k,j,i),3,1)
+
+                v_comp    = v(k,j+1,i) - v_gtrans
+                flux_n    = v_comp * (                                        &
+                          ( 37.0_wp * ibit5 * adv_sca_5                       &
+                       +     7.0_wp * ibit4 * adv_sca_3                       &
+                       +              ibit3 * adv_sca_1                       &
+                          ) *                                                 &
+                             ( sk(k,j+1,i) + sk(k,j,i)   )                    &
+                   -      (  8.0_wp * ibit5 * adv_sca_5                       &
+                       +              ibit4 * adv_sca_3                       &
+                          ) *                                                 &
+                             ( sk(k,j+2,i) + sk(k,j-1,i) )                    &
+                   +      (           ibit5 * adv_sca_5                       &
+                          ) *                                                 &
+                             ( sk(k,j+3,i) + sk(k,j-2,i) )                    &
+                                     )
+
+                diss_n    = -ABS( v_comp ) * (                                &
+                          ( 10.0_wp * ibit5 * adv_sca_5                       &
+                       +     3.0_wp * ibit4 * adv_sca_3                       &
+                       +              ibit3 * adv_sca_1                       &
+                          ) *                                                 &
+                             ( sk(k,j+1,i) - sk(k,j,i)    )                   &
+                   -      (  5.0_wp * ibit5 * adv_sca_5                       &
+                       +              ibit4 * adv_sca_3                       &
+                          ) *                                                 &
+                             ( sk(k,j+2,i) - sk(k,j-1,i)  )                   &
+                   +      (           ibit5 * adv_sca_5                       &
+                          ) *                                                 &
+                             ( sk(k,j+3,i) - sk(k,j-2,i)  )                   &
+                                             )
+
+!
+!--             indizes k_m, k_mm, ... should be known at these point
+                ibit8 = IBITS(wall_flags_0(k-1,j,i),8,1)
+                ibit7 = IBITS(wall_flags_0(k-1,j,i),7,1)
+                ibit6 = IBITS(wall_flags_0(k-1,j,i),6,1)
+
+                k_pp  = k + 2 * ibit8
+                k_mm  = k - 2 * ( ibit7 + ibit8 )
+                k_mmm = k - 3 * ibit8
+
+                flux_d    = w(k-1,j,i) * (                                    &
+                           ( 37.0_wp * ibit8 * adv_sca_5                      &
+                        +     7.0_wp * ibit7 * adv_sca_3                      &
+                        +              ibit6 * adv_sca_1                      &
+                           ) *                                                &
+                                   ( sk(k,j,i)    + sk(k-1,j,i)  )            &
+                    -      (  8.0_wp * ibit8 * adv_sca_5                      &
+                          +            ibit7 * adv_sca_3                      &
+                           ) *                                                &
+                                   ( sk(k+1,j,i) + sk(k_mm,j,i)  )            &
+                    +      (           ibit8 * adv_sca_5                      &
+                           ) *     ( sk(k_pp,j,i)+ sk(k_mmm,j,i) )            &
+                                         )
+
+                diss_d    = -ABS( w(k-1,j,i) ) * (                            &
+                           ( 10.0_wp * ibit8 * adv_sca_5                      &
+                        +     3.0_wp * ibit7 * adv_sca_3                      &
+                        +              ibit6 * adv_sca_1                      &
+                           ) *                                                &
+                                   ( sk(k,j,i)    - sk(k-1,j,i)   )           &
+                    -      (  5.0_wp * ibit8 * adv_sca_5                      &
+                        +              ibit7 * adv_sca_3                      &
+                           ) *                                                &
+                                   ( sk(k+1,j,i)  - sk(k_mm,j,i)  )           &
+                    +      (           ibit8 * adv_sca_5                      &
+                           ) *                                                &
+                                   ( sk(k_pp,j,i) - sk(k_mmm,j,i) )           &
+                                                 )
+
+                ibit8 = IBITS(wall_flags_0(k,j,i),8,1)
+                ibit7 = IBITS(wall_flags_0(k,j,i),7,1)
+                ibit6 = IBITS(wall_flags_0(k,j,i),6,1)
+
+                k_ppp = k + 3 * ibit8
+                k_pp  = k + 2 * ( 1 - ibit6  )
+                k_mm  = k - 2 * ibit8
+
+                flux_t    = w(k,j,i) * (                                      &
+                           ( 37.0_wp * ibit8 * adv_sca_5                      &
+                        +     7.0_wp * ibit7 * adv_sca_3                      &
+                        +              ibit6 * adv_sca_1                      &
+                           ) *                                                &
+                                   ( sk(k+1,j,i)  + sk(k,j,i)    )            &
+                    -      (  8.0_wp * ibit8 * adv_sca_5                      &
+                        +              ibit7 * adv_sca_3                      &
+                           ) *                                                &
+                                   ( sk(k_pp,j,i) + sk(k-1,j,i)  )            &
+                    +      (           ibit8 * adv_sca_5                      &
+                           ) *     ( sk(k_ppp,j,i)+ sk(k_mm,j,i) )            &
+                                       )
+
+                diss_t    = -ABS( w(k,j,i) ) * (                              &
+                           ( 10.0_wp * ibit8 * adv_sca_5                      &
+                        +     3.0_wp * ibit7 * adv_sca_3                      &
+                        +              ibit6 * adv_sca_1                      &
+                           ) *                                                &
+                                   ( sk(k+1,j,i)   - sk(k,j,i)    )           &
+                    -      (  5.0_wp * ibit8 * adv_sca_5                      &
+                        +              ibit7 * adv_sca_3                      &
+                           ) *                                                &
+                                   ( sk(k_pp,j,i)  - sk(k-1,j,i)  )           &
+                    +      (           ibit8 * adv_sca_5                      &
+                           ) *                                                &
+                                   ( sk(k_ppp,j,i) - sk(k_mm,j,i) )           &
+                                         )
+!
+!--             Apply monotonic adjustment.
+                IF ( monotonic_adjustment )  THEN
+!
+!--                At first, calculate first order fluxes.
+                   u_comp = u(k,j,i) - u_gtrans
+                   fl_1   =  ( u_comp   * ( sk(k,j,i) + sk(k,j,i-1) )         &
+                         -ABS( u_comp ) * ( sk(k,j,i) - sk(k,j,i-1) )         &
+                             ) * adv_sca_1 
+
+                   u_comp = u(k,j,i+1) - u_gtrans
+                   fr_1   =  ( u_comp   * ( sk(k,j,i+1) + sk(k,j,i) )         &
+                         -ABS( u_comp ) * ( sk(k,j,i+1) - sk(k,j,i) )         &
+                             ) * adv_sca_1 
+
+                   v_comp = v(k,j,i) - v_gtrans
+                   fs_1   =  ( v_comp   * ( sk(k,j,i) + sk(k,j-1,i) )         &
+                         -ABS( v_comp ) * ( sk(k,j,i) - sk(k,j-1,i) )         &
+                             ) * adv_sca_1 
+
+                   v_comp = v(k,j+1,i) - v_gtrans
+                   fn_1   =  ( v_comp   * ( sk(k,j+1,i) + sk(k,j,i) )         &
+                         -ABS( v_comp ) * ( sk(k,j+1,i) - sk(k,j,i) )         &
+                             ) * adv_sca_1 
+
+                   fd_1   = (  w(k-1,j,i)   * ( sk(k,j,i) + sk(k-1,j,i) )     &
+                        -ABS( w(k-1,j,i) ) * ( sk(k,j,i) - sk(k-1,j,i) )      &
+                            ) * adv_sca_1 
+
+                   ft_1   = (  w(k,j,i)   * ( sk(k+1,j,i) + sk(k,j,i) )       &
+                        -ABS( w(k,j,i) ) * ( sk(k+1,j,i) - sk(k,j,i) )        &
+                            ) * adv_sca_1 
+!
+!--                Calculate ratio of upwind gradients. Note, Min/Max is just
+!--                to avoid if statements.
+                   rl     = ( MAX( 0.0_wp, u(k,j,i) - u_gtrans ) *            & 
+                               ABS( ( sk(k,j,i-1) - sk(k,j,i-2)            ) /&
+                                    ( sk(k,j,i)   - sk(k,j,i-1) + 1E-20_wp )  &
+                                  ) +                                         & 
+                              MIN( 0.0_wp, u(k,j,i) - u_gtrans ) *            &
+                               ABS( ( sk(k,j,i)   - sk(k,j,i+1)            ) /&
+                                    ( sk(k,j,i-1) - sk(k,j,i)   + 1E-20_wp )  &
+                                  )                                           &
+                            ) / ABS( u(k,j,i) - u_gtrans + 1E-20_wp )
+
+                   rr     = ( MAX( 0.0_wp, u(k,j,i+1) - u_gtrans ) *          & 
+                               ABS( ( sk(k,j,i)   - sk(k,j,i-1)            ) /&
+                                    ( sk(k,j,i+1) - sk(k,j,i)   + 1E-20_wp )  &
+                                  ) +                                         & 
+                              MIN( 0.0_wp, u(k,j,i+1) - u_gtrans ) *          &
+                               ABS( ( sk(k,j,i+1) - sk(k,j,i+2)            ) /&
+                                    ( sk(k,j,i)   - sk(k,j,i+1) + 1E-20_wp )  &
+                                  )                                           &
+                            ) / ABS( u(k,j,i+1) - u_gtrans + 1E-20_wp )
+
+                   rs     = ( MAX( 0.0_wp, v(k,j,i) - v_gtrans ) *            & 
+                               ABS( ( sk(k,j-1,i) - sk(k,j-2,i)            ) /&
+                                    ( sk(k,j,i)   - sk(k,j-1,i) + 1E-20_wp )  &
+                                  ) +                                         & 
+                              MIN( 0.0_wp, v(k,j,i) - v_gtrans ) *            &
+                               ABS( ( sk(k,j,i)   - sk(k,j+1,i)            ) /&
+                                    ( sk(k,j-1,i) - sk(k,j,i)   + 1E-20_wp )  &
+                                  )                                           &
+                            ) / ABS( v(k,j,i) - v_gtrans + 1E-20_wp )
+
+                   rn     = ( MAX( 0.0_wp, v(k,j+1,i) - v_gtrans ) *          & 
+                               ABS( ( sk(k,j,i)   - sk(k,j-1,i)            ) /&
+                                    ( sk(k,j+1,i) - sk(k,j,i)   + 1E-20_wp )  &
+                                  ) +                                         & 
+                              MIN( 0.0_wp, v(k,j+1,i) - v_gtrans ) *          &
+                               ABS( ( sk(k,j+1,i) - sk(k,j+2,i)            ) /&
+                                    ( sk(k,j,i)   - sk(k,j+1,i) + 1E-20_wp )  &
+                                  )                                           &
+                            ) / ABS( v(k,j+1,i) - v_gtrans + 1E-20_wp )     
+!   
+!--                Reuse k_mm and compute k_mmm for the vertical gradient ratios. 
+!--                Note, for vertical advection below the third grid point above 
+!--                surface ( or below the model top) rd and rt are set to 0, i.e. 
+!--                use of first order scheme is enforced.
+                   k_mmm  = k - 3 * ibit8
+
+                   rd     = ( MAX( 0.0_wp, w(k-1,j,i) ) *                     & 
+                            ABS( ( sk(k_mm,j,i) - sk(k_mmm,j,i)           ) / &
+                                 ( sk(k-1,j,i)  - sk(k_mm,j,i) + 1E-20_wp )   &
+                               ) +                                            & 
+                              MIN( 0.0_wp, w(k-1,j,i) ) *                     &
+                            ABS( ( sk(k-1,j,i) - sk(k,j,i)            ) /     &
+                                 ( sk(k_mm,j,i) - sk(k-1,j,i)   + 1E-20_wp )  &
+                               )                                              &
+                            ) * ibit8 / ABS( w(k-1,j,i) + 1E-20_wp ) 
+ 
+                   rt     = ( MAX( 0.0_wp, w(k,j,i) ) *                       & 
+                            ABS( ( sk(k,j,i)   - sk(k-1,j,i)            ) /   &
+                                 ( sk(k+1,j,i) - sk(k,j,i)   + 1E-20_wp )     &
+                               ) +                                            & 
+                              MIN( 0.0_wp, w(k,j,i) ) *                       &
+                            ABS( ( sk(k+1,j,i) - sk(k_pp,j,i)           ) /   &
+                                 ( sk(k,j,i)   - sk(k+1,j,i) + 1E-20_wp )     &
+                               )                                              &
+                            ) * ibit8 / ABS( w(k,j,i) + 1E-20_wp )
+!
+!--                Calculate empirical limiter function (van Albada2 limiter).
+                   phi_l = MIN( 1.0_wp, ( 2.0_wp * ABS( rl ) ) /              &
+                                        ( rl**2 + 1.0_wp ) ) 
+                   phi_r = MIN( 1.0_wp, ( 2.0_wp * ABS( rr ) ) /              &
+                                        ( rr**2 + 1.0_wp ) ) 
+                   phi_s = MIN( 1.0_wp, ( 2.0_wp * ABS( rs ) ) /              &
+                                        ( rs**2 + 1.0_wp ) ) 
+                   phi_n = MIN( 1.0_wp, ( 2.0_wp * ABS( rn ) ) /              &
+                                        ( rn**2 + 1.0_wp ) ) 
+                   phi_d = MIN( 1.0_wp, ( 2.0_wp * ABS( rd ) ) /              &
+                                        ( rd**2 + 1.0_wp ) ) 
+                   phi_t = MIN( 1.0_wp, ( 2.0_wp * ABS( rt ) ) /              &
+                                        ( rt**2 + 1.0_wp ) ) 
+!
+!--                Calculate the resulting monotone flux. 
+                   flux_l = fl_1 - phi_l * ( fl_1 - flux_l )
+                   flux_r = fr_1 - phi_r * ( fr_1 - flux_r )
+                   flux_s = fs_1 - phi_s * ( fs_1 - flux_s )
+                   flux_n = fn_1 - phi_n * ( fn_1 - flux_n )
+                   flux_d = fd_1 - phi_d * ( fd_1 - flux_d )
+                   flux_t = ft_1 - phi_t * ( ft_1 - flux_t )
+!
+!--                Moreover, modify dissipation flux according to the limiter. 
+                   diss_l = diss_l * phi_l
+                   diss_r = diss_r * phi_r
+                   diss_s = diss_s * phi_s
+                   diss_n = diss_n * phi_n
+                   diss_d = diss_d * phi_d
+                   diss_t = diss_t * phi_t
+
+                ENDIF
+!
+!--             Calculate the divergence of the velocity field. A respective
+!--             correction is needed to overcome numerical instabilities caused
+!--             by a not sufficient reduction of divergences near topography.
+                div   =   ( u(k,j,i+1) * ( ibit0 + ibit1 + ibit2 )             &
+                          - u(k,j,i)   * ( IBITS(wall_flags_0(k,j,i-1),0,1)    &
+                                         + IBITS(wall_flags_0(k,j,i-1),1,1)    &
+                                         + IBITS(wall_flags_0(k,j,i-1),2,1)    &
+                                         )                                     &
+                          ) * ddx                                              &
+                        + ( v(k,j+1,i) * ( ibit3 + ibit4 + ibit5 )             &
+                          - v(k,j,i)   * ( IBITS(wall_flags_0(k,j-1,i),3,1)    &
+                                         + IBITS(wall_flags_0(k,j-1,i),4,1)    &
+                                         + IBITS(wall_flags_0(k,j-1,i),5,1)    &
+                                         )                                     &
+                          ) * ddy                                              &
+                        + ( w(k,j,i)   * ( ibit6 + ibit7 + ibit8 )             &
+                          - w(k-1,j,i) * ( IBITS(wall_flags_0(k-1,j,i),6,1)    &
+                                         + IBITS(wall_flags_0(k-1,j,i),7,1)    &
+                                         + IBITS(wall_flags_0(k-1,j,i),8,1)    &
+                                         )                                     &      
+                          ) * ddzw(k)
+
+
+                tend(k,j,i) = - (                                             &
+                               ( flux_r + diss_r - flux_l - diss_l ) * ddx    &
+                             + ( flux_n + diss_n - flux_s - diss_s ) * ddy    &
+                             + ( flux_t + diss_t - flux_d - diss_d ) * ddzw(k)&
+                                ) + div * sk(k,j,i)
+
+!++
+!--             Evaluation of statistics
+!                SELECT CASE ( sk_char )
+!
+!                   CASE ( 'pt' )
+!                      sums_wspts_ws_l(k,tn) = sums_wspts_ws_l(k,tn)         &
+!                       + ( flux_t + diss_t )                                &
+!                       *   weight_substep(intermediate_timestep_count)
+!                   CASE ( 'sa' )
+!                      sums_wssas_ws_l(k,tn) = sums_wssas_ws_l(k,tn)         &
+!                       + ( flux_t + diss_t )                                &
+!                       *   weight_substep(intermediate_timestep_count)
+!                   CASE ( 'q' )
+!                      sums_wsqs_ws_l(k,tn) = sums_wsqs_ws_l(k,tn)           &
+!                      + ( flux_t + diss_t )                                 &
+!                      *   weight_substep(intermediate_timestep_count)
+!                   CASE ( 'qr' )
+!                      sums_wsqrs_ws_l(k,tn) = sums_wsqrs_ws_l(k,tn)         &
+!                      + ( flux_t + diss_t )                                 &
+!                      *   weight_substep(intermediate_timestep_count)
+!                   CASE ( 'nr' )
+!                      sums_wsnrs_ws_l(k,tn) = sums_wsnrs_ws_l(k,tn)         &
+!                      + ( flux_t + diss_t )                                 &
+!                      *   weight_substep(intermediate_timestep_count)
+!
+!                END SELECT
+
+             ENDDO
+         ENDDO
+      ENDDO
+      !$acc end kernels
+
+    END SUBROUTINE advec_s_ws_acc
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Advection of u - Call for all grid points
+!------------------------------------------------------------------------------!
+    SUBROUTINE advec_u_ws
+
+       USE arrays_3d,                                                          &
+           ONLY:  ddzw, tend, u, v, w
+
+       USE constants,                                                          &
+           ONLY:  adv_mom_1, adv_mom_3, adv_mom_5
+
+       USE control_parameters,                                                 &
+           ONLY:  intermediate_timestep_count, u_gtrans, v_gtrans
+
+       USE grid_variables,                                                     &
+           ONLY:  ddx, ddy
+
+       USE indices,                                                            &
+           ONLY:  nxl, nxlu, nxr, nyn, nys, nzb, nzb_max, nzt, wall_flags_0
+           
+       USE kinds
+       
+       USE statistics,                                                         &
+           ONLY:  hom, sums_us2_ws_l, sums_wsus_ws_l, weight_substep
+
+       IMPLICIT NONE
+
+       INTEGER(iwp) ::  i      !<
+       INTEGER(iwp) ::  ibit9  !<
+       INTEGER(iwp) ::  ibit10 !<
+       INTEGER(iwp) ::  ibit11 !<
+       INTEGER(iwp) ::  ibit12 !<
+       INTEGER(iwp) ::  ibit13 !<
+       INTEGER(iwp) ::  ibit14 !<
+       INTEGER(iwp) ::  ibit15 !<
+       INTEGER(iwp) ::  ibit16 !<
+       INTEGER(iwp) ::  ibit17 !<
+       INTEGER(iwp) ::  j      !<
+       INTEGER(iwp) ::  k      !<
+       INTEGER(iwp) ::  k_mm   !<
+       INTEGER(iwp) ::  k_pp   !<
+       INTEGER(iwp) ::  k_ppp  !<
+       INTEGER(iwp) ::  tn = 0 !<
+       
+       REAL(wp)    ::  diss_d !<
+       REAL(wp)    ::  div    !<
+       REAL(wp)    ::  flux_d !<
+       REAL(wp)    ::  gu     !<
+       REAL(wp)    ::  gv     !<
+       REAL(wp)    ::  v_comp !<
+       REAL(wp)    ::  w_comp !<
+       
+       REAL(wp), DIMENSION(nzb+1:nzt) ::  swap_diss_y_local_u !<
+       REAL(wp), DIMENSION(nzb+1:nzt) ::  swap_flux_y_local_u !<
+       
+       REAL(wp), DIMENSION(nzb+1:nzt,nys:nyn) ::  swap_diss_x_local_u !<
+       REAL(wp), DIMENSION(nzb+1:nzt,nys:nyn) ::  swap_flux_x_local_u !<
+       
+       REAL(wp), DIMENSION(nzb:nzt) ::  diss_n !<
+       REAL(wp), DIMENSION(nzb:nzt) ::  diss_r !<
+       REAL(wp), DIMENSION(nzb:nzt) ::  diss_t !<
+       REAL(wp), DIMENSION(nzb:nzt) ::  flux_n !<
+       REAL(wp), DIMENSION(nzb:nzt) ::  flux_r !<
+       REAL(wp), DIMENSION(nzb:nzt) ::  flux_t !<
+       REAL(wp), DIMENSION(nzb:nzt) ::  u_comp !<
+ 
+       gu = 2.0_wp * u_gtrans
+       gv = 2.0_wp * v_gtrans
+
+!
+!--    Compute the fluxes for the whole left boundary of the processor domain.
+       i = nxlu
+       DO  j = nys, nyn
+          DO  k = nzb+1, nzb_max
+
+             ibit11 = IBITS(wall_flags_0(k,j,i-1),11,1)
+             ibit10 = IBITS(wall_flags_0(k,j,i-1),10,1)
+             ibit9  = IBITS(wall_flags_0(k,j,i-1),9,1)
+
+             u_comp(k)                = u(k,j,i) + u(k,j,i-1) - gu
+             swap_flux_x_local_u(k,j) = u_comp(k) * (                          &
+                                       ( 37.0_wp * ibit11 * adv_mom_5             &
+                                    +     7.0_wp * ibit10 * adv_mom_3             &
+                                    +              ibit9  * adv_mom_1             &
+                                       ) *                                     &
+                                     ( u(k,j,i)   + u(k,j,i-1) )               &
+                                -      (  8.0_wp * ibit11 * adv_mom_5             &
+                                    +              ibit10 * adv_mom_3             &
+                                       ) *                                     &
+                                     ( u(k,j,i+1) + u(k,j,i-2) )               &
+                                +      (           ibit11 * adv_mom_5             &
+                                       ) *                                     &
+                                     ( u(k,j,i+2) + u(k,j,i-3) )               &
+                                                   )
+
+              swap_diss_x_local_u(k,j) = - ABS( u_comp(k) ) * (                &
+                                       ( 10.0_wp * ibit11 * adv_mom_5             &
+                                    +     3.0_wp * ibit10 * adv_mom_3             &
+                                    +              ibit9  * adv_mom_1             &
+                                       ) *                                     &
+                                     ( u(k,j,i)   - u(k,j,i-1) )               &
+                                -      (  5.0_wp * ibit11 * adv_mom_5             &
+                                    +              ibit10 * adv_mom_3             &
+                                       ) *                                     &
+                                     ( u(k,j,i+1) - u(k,j,i-2) )               &
+                                +      (           ibit11 * adv_mom_5             &
+                                       ) *                                     &
+                                     ( u(k,j,i+2) - u(k,j,i-3) )               &
+                                                             )
+
+          ENDDO
+
+          DO  k = nzb_max+1, nzt
+
+             u_comp(k)         = u(k,j,i) + u(k,j,i-1) - gu
+             swap_flux_x_local_u(k,j) = u_comp(k) * (                          &
+                             37.0_wp * ( u(k,j,i) + u(k,j,i-1)   )                &
+                           -  8.0_wp * ( u(k,j,i+1) + u(k,j,i-2) )                &
+                           +           ( u(k,j,i+2) + u(k,j,i-3) ) ) * adv_mom_5
+             swap_diss_x_local_u(k,j) = - ABS(u_comp(k)) * (                   &
+                             10.0_wp * ( u(k,j,i) - u(k,j,i-1)   )                &
+                           -  5.0_wp * ( u(k,j,i+1) - u(k,j,i-2) )                &
+                           +           ( u(k,j,i+2) - u(k,j,i-3) ) ) * adv_mom_5
+
+          ENDDO
+       ENDDO
+
+       DO i = nxlu, nxr
+!       
+!--       The following loop computes the fluxes for the south boundary points
+          j = nys
+          DO  k = nzb+1, nzb_max
+
+             ibit14 = IBITS(wall_flags_0(k,j-1,i),14,1)
+             ibit13 = IBITS(wall_flags_0(k,j-1,i),13,1)
+             ibit12 = IBITS(wall_flags_0(k,j-1,i),12,1)
+
+             v_comp                 = v(k,j,i) + v(k,j,i-1) - gv
+             swap_flux_y_local_u(k) = v_comp * (                              &
+                                   ( 37.0_wp * ibit14 * adv_mom_5                &
+                                +     7.0_wp * ibit13 * adv_mom_3                &
+                                +              ibit12 * adv_mom_1                &
+                                   ) *                                        &
+                                     ( u(k,j,i)   + u(k,j-1,i) )              &
+                            -      (  8.0_wp * ibit14 * adv_mom_5                &
+                            +                  ibit13 * adv_mom_3                    &
+                                   ) *                                        &
+                                     ( u(k,j+1,i) + u(k,j-2,i) )              &
+                        +      (               ibit14 * adv_mom_5                    &
+                               ) *                                            &
+                                     ( u(k,j+2,i) + u(k,j-3,i) )              &
+                                               )
+
+             swap_diss_y_local_u(k) = - ABS ( v_comp ) * (                    &
+                                   ( 10.0_wp * ibit14 * adv_mom_5                &
+                                +     3.0_wp * ibit13 * adv_mom_3                &
+                                +              ibit12 * adv_mom_1                &
+                                   ) *                                        &
+                                     ( u(k,j,i)   - u(k,j-1,i) )              &
+                            -      (  5.0_wp * ibit14 * adv_mom_5                &
+                                +              ibit13 * adv_mom_3                &
+                                   ) *                                        &
+                                     ( u(k,j+1,i) - u(k,j-2,i) )              &
+                            +      (           ibit14 * adv_mom_5                &
+                                   ) *                                        &
+                                     ( u(k,j+2,i) - u(k,j-3,i) )              &
+                                                         )
+
+          ENDDO
+
+          DO  k = nzb_max+1, nzt
+
+             v_comp                 = v(k,j,i) + v(k,j,i-1) - gv
+             swap_flux_y_local_u(k) = v_comp * (                              &
+                           37.0_wp * ( u(k,j,i) + u(k,j-1,i)   )                 &
+                         -  8.0_wp * ( u(k,j+1,i) + u(k,j-2,i) )                 &
+                         +           ( u(k,j+2,i) + u(k,j-3,i) ) ) * adv_mom_5
+             swap_diss_y_local_u(k) = - ABS(v_comp) * (                       &
+                           10.0_wp * ( u(k,j,i) - u(k,j-1,i)   )                 &
+                         -  5.0_wp * ( u(k,j+1,i) - u(k,j-2,i) )                 &
+                         +           ( u(k,j+2,i) - u(k,j-3,i) ) ) * adv_mom_5
+
+          ENDDO
+!
+!--       Computation of interior fluxes and tendency terms
+          DO  j = nys, nyn
+
+             flux_t(0) = 0.0_wp
+             diss_t(0) = 0.0_wp
+             flux_d    = 0.0_wp
+             diss_d    = 0.0_wp
+
+             DO  k = nzb+1, nzb_max
+
+                ibit11 = IBITS(wall_flags_0(k,j,i),11,1)
+                ibit10 = IBITS(wall_flags_0(k,j,i),10,1)
+                ibit9  = IBITS(wall_flags_0(k,j,i),9,1)
+
+                u_comp(k) = u(k,j,i+1) + u(k,j,i)
+                flux_r(k) = ( u_comp(k) - gu ) * (                           &
+                          ( 37.0_wp * ibit11 * adv_mom_5                        &
+                       +     7.0_wp * ibit10 * adv_mom_3                        &
+                       +              ibit9  * adv_mom_1                        &
+                          ) *                                                &
+                                 ( u(k,j,i+1) + u(k,j,i)   )                 &
+                   -      (  8.0_wp * ibit11 * adv_mom_5                        &
+                       +              ibit10 * adv_mom_3                        &
+                          ) *                                                &
+                                 ( u(k,j,i+2) + u(k,j,i-1) )                 &
+                   +      (           ibit11 * adv_mom_5                        &
+                          ) *                                                &
+                                 ( u(k,j,i+3) + u(k,j,i-2) )                 &
+                                                 )
+
+                diss_r(k) = - ABS( u_comp(k) - gu ) * (                      &
+                          ( 10.0_wp * ibit11 * adv_mom_5                        &
+                       +     3.0_wp * ibit10 * adv_mom_3                        & 
+                       +              ibit9  * adv_mom_1                        &
+                          ) *                                                &
+                                 ( u(k,j,i+1) - u(k,j,i)  )                  &
+                   -      (  5.0_wp * ibit11 * adv_mom_5                        &
+                       +              ibit10 * adv_mom_3                        &
+                          ) *                                                &
+                                 ( u(k,j,i+2) - u(k,j,i-1) )                 &
+                   +      (           ibit11 * adv_mom_5                        &
+                          ) *                                                &
+                                 ( u(k,j,i+3) - u(k,j,i-2) )                 &
+                                                     )
+
+                ibit14 = IBITS(wall_flags_0(k,j,i),14,1)
+                ibit13 = IBITS(wall_flags_0(k,j,i),13,1)
+                ibit12 = IBITS(wall_flags_0(k,j,i),12,1)
+
+                v_comp    = v(k,j+1,i) + v(k,j+1,i-1) - gv
+                flux_n(k) = v_comp * (                                       &
+                          ( 37.0_wp * ibit14 * adv_mom_5                        &
+                       +     7.0_wp * ibit13 * adv_mom_3                        &
+                       +              ibit12 * adv_mom_1                        &
+                          ) *                                                &
+                                 ( u(k,j+1,i) + u(k,j,i)   )                 &
+                   -      (  8.0_wp * ibit14 * adv_mom_5                        &
+                       +              ibit13 * adv_mom_3                        &
+                          ) *                                                &
+                                 ( u(k,j+2,i) + u(k,j-1,i) )                 &
+                   +      (           ibit14 * adv_mom_5                        & 
+                          ) *                                                &
+                                 ( u(k,j+3,i) + u(k,j-2,i) )                 &
+                                                 )
+
+                diss_n(k) = - ABS ( v_comp ) * (                             &
+                          ( 10.0_wp * ibit14 * adv_mom_5                        &
+                       +     3.0_wp * ibit13 * adv_mom_3                        &
+                       +              ibit12 * adv_mom_1                        &
+                          ) *                                                &
+                                 ( u(k,j+1,i) - u(k,j,i)  )                  &
+                   -      (  5.0_wp * ibit14 * adv_mom_5                        &
+                       +              ibit13 * adv_mom_3                        &
+                          ) *                                                &
+                                 ( u(k,j+2,i) - u(k,j-1,i) )                 &
+                   +      (           ibit14 * adv_mom_5                        &
+                          ) *                                                &
+                                 ( u(k,j+3,i) - u(k,j-2,i) )                 &
+                                                      )
+!
+!--             k index has to be modified near bottom and top, else array
+!--             subscripts will be exceeded.
+                ibit17 = IBITS(wall_flags_0(k,j,i),17,1)
+                ibit16 = IBITS(wall_flags_0(k,j,i),16,1)
+                ibit15 = IBITS(wall_flags_0(k,j,i),15,1)
+
+                k_ppp = k + 3 * ibit17
+                k_pp  = k + 2 * ( 1 - ibit15  )
+                k_mm  = k - 2 * ibit17
+
+                w_comp    = w(k,j,i) + w(k,j,i-1)
+                flux_t(k) = w_comp  * (                                      &
+                          ( 37.0_wp * ibit17 * adv_mom_5                        &
+                       +     7.0_wp * ibit16 * adv_mom_3                        &
+                       +              ibit15 * adv_mom_1                        & 
+                          ) *                                                &
+                             ( u(k+1,j,i)  + u(k,j,i)     )                  &
+                   -      (  8.0_wp * ibit17 * adv_mom_5                        &
+                       +              ibit16 * adv_mom_3                        &
+                          ) *                                                &
+                             ( u(k_pp,j,i) + u(k-1,j,i)   )                  &
+                   +      (           ibit17 * adv_mom_5                        &
+                          ) *                                                &
+                             ( u(k_ppp,j,i) + u(k_mm,j,i) )                  &
+                                      )
+
+                diss_t(k) = - ABS( w_comp ) * (                              &
+                          ( 10.0_wp * ibit17 * adv_mom_5                        &
+                       +     3.0_wp * ibit16 * adv_mom_3                        &
+                       +              ibit15 * adv_mom_1                        &
+                          ) *                                                &
+                             ( u(k+1,j,i)   - u(k,j,i)    )                  &
+                   -      (  5.0_wp * ibit17 * adv_mom_5                        &
+                       +              ibit16 * adv_mom_3                        &
+                          ) *                                                &
+                             ( u(k_pp,j,i)  - u(k-1,j,i)  )                  &
+                   +      (           ibit17 * adv_mom_5                        &
+                           ) *                                               &
+                             ( u(k_ppp,j,i) - u(k_mm,j,i) )                  &
+                                              )
+!
+!--             Calculate the divergence of the velocity field. A respective
+!--             correction is needed to overcome numerical instabilities caused
+!--             by a not sufficient reduction of divergences near topography.
+                div = ( ( u_comp(k) * ( ibit9 + ibit10 + ibit11 )             &
+                - ( u(k,j,i)   + u(k,j,i-1)   )                               &
+                                    * ( IBITS(wall_flags_0(k,j,i-1),9,1)      &
+                                      + IBITS(wall_flags_0(k,j,i-1),10,1)     &
+                                      + IBITS(wall_flags_0(k,j,i-1),11,1)     &
+                                      )                                       &   
+                  ) * ddx                                                     &
+               +  ( ( v_comp + gv ) * ( ibit12 + ibit13 + ibit14 )            &
+                  - ( v(k,j,i)   + v(k,j,i-1 )  )                             &
+                                    * ( IBITS(wall_flags_0(k,j-1,i),12,1)     &
+                                      + IBITS(wall_flags_0(k,j-1,i),13,1)     &
+                                      + IBITS(wall_flags_0(k,j-1,i),14,1)     &
+                                      )                                       &
+                  ) * ddy                                                     &
+               +  ( w_comp          * ( ibit15 + ibit16 + ibit17 )            &
+                - ( w(k-1,j,i) + w(k-1,j,i-1) )                               &
+                                    * ( IBITS(wall_flags_0(k-1,j,i),15,1)     &
+                                      + IBITS(wall_flags_0(k-1,j,i),16,1)     &
+                                      + IBITS(wall_flags_0(k-1,j,i),17,1)     &
+                                      )                                       &  
+                  ) * ddzw(k)   &
+                ) * 0.5_wp
+
+
+
+                tend(k,j,i) = tend(k,j,i) - (                                  &
+                 ( flux_r(k) + diss_r(k)                                       &
+               -   swap_flux_x_local_u(k,j) - swap_diss_x_local_u(k,j) ) * ddx &
+               + ( flux_n(k) + diss_n(k)                                       &
+               -   swap_flux_y_local_u(k)   - swap_diss_y_local_u(k)   ) * ddy &
+               + ( flux_t(k) + diss_t(k)                                       &
+               -   flux_d    - diss_d                                          &
+                                                                  ) * ddzw(k)  &
+                                           ) + div * u(k,j,i)
+
+                swap_flux_x_local_u(k,j) = flux_r(k)
+                swap_diss_x_local_u(k,j) = diss_r(k)
+                swap_flux_y_local_u(k)   = flux_n(k)
+                swap_diss_y_local_u(k)   = diss_n(k)
+                flux_d                   = flux_t(k)
+                diss_d                   = diss_t(k)
+!
+!--             Statistical Evaluation of u'u'. The factor has to be applied
+!--             for right evaluation when gallilei_trans = .T. .
+                sums_us2_ws_l(k,tn) = sums_us2_ws_l(k,tn)                     &
+                              + ( flux_r(k) *                                 &
+                                ( u_comp(k) - 2.0_wp * hom(k,1,1,0) )            &
+                              / ( u_comp(k) - gu + 1.0E-20_wp    )            &
+                              +   diss_r(k) *                                 &
+                                  ABS( u_comp(k) - 2.0_wp * hom(k,1,1,0) )       &
+                              / ( ABS( u_comp(k) - gu ) + 1.0E-20_wp ) )      &
+                              *   weight_substep(intermediate_timestep_count)
+!
+!--             Statistical Evaluation of w'u'.
+                sums_wsus_ws_l(k,tn) = sums_wsus_ws_l(k,tn)                   &
+                              + ( flux_t(k) + diss_t(k) )                     &
+                              *   weight_substep(intermediate_timestep_count)
+             ENDDO
+
+             DO  k = nzb_max+1, nzt
+
+                u_comp(k) = u(k,j,i+1) + u(k,j,i)
+                flux_r(k) = ( u_comp(k) - gu ) * (                            &
+                         37.0_wp * ( u(k,j,i+1) + u(k,j,i)   )                   &
+                       -  8.0_wp * ( u(k,j,i+2) + u(k,j,i-1) )                   &
+                       +           ( u(k,j,i+3) + u(k,j,i-2) ) ) * adv_mom_5
+                diss_r(k) = - ABS( u_comp(k) - gu ) * (                       &
+                         10.0_wp * ( u(k,j,i+1) - u(k,j,i)   )                   &
+                       -  5.0_wp * ( u(k,j,i+2) - u(k,j,i-1) )                   &
+                       +           ( u(k,j,i+3) - u(k,j,i-2) ) ) * adv_mom_5
+
+                v_comp    = v(k,j+1,i) + v(k,j+1,i-1) - gv
+                flux_n(k) = v_comp * (                                        &
+                         37.0_wp * ( u(k,j+1,i) + u(k,j,i)   )                   &
+                       -  8.0_wp * ( u(k,j+2,i) + u(k,j-1,i) )                   &
+                       +           ( u(k,j+3,i) + u(k,j-2,i) ) ) * adv_mom_5
+                diss_n(k) = - ABS( v_comp ) * (                               &
+                         10.0_wp * ( u(k,j+1,i) - u(k,j,i)   )                   &
+                       -  5.0_wp * ( u(k,j+2,i) - u(k,j-1,i) )                   &
+                       +           ( u(k,j+3,i) - u(k,j-2,i) ) ) * adv_mom_5
+!
+!--             k index has to be modified near bottom and top, else array
+!--             subscripts will be exceeded.
+                ibit17 = IBITS(wall_flags_0(k,j,i),17,1)
+                ibit16 = IBITS(wall_flags_0(k,j,i),16,1)
+                ibit15 = IBITS(wall_flags_0(k,j,i),15,1)
+
+                k_ppp = k + 3 * ibit17
+                k_pp  = k + 2 * ( 1 - ibit15  )
+                k_mm  = k - 2 * ibit17
+
+                w_comp    = w(k,j,i) + w(k,j,i-1)
+                flux_t(k) = w_comp  * (                                      &
+                          ( 37.0_wp * ibit17 * adv_mom_5                        &
+                       +     7.0_wp * ibit16 * adv_mom_3                        &
+                       +              ibit15 * adv_mom_1                        &
+                          ) *                                                &
+                             ( u(k+1,j,i)  + u(k,j,i)     )                  &
+                   -      (  8.0_wp * ibit17 * adv_mom_5                        &
+                       +              ibit16 * adv_mom_3                        &
+                          ) *                                                &
+                             ( u(k_pp,j,i) + u(k-1,j,i)   )                  &
+                   +      (           ibit17 * adv_mom_5                        &
+                          ) *                                                &
+                             ( u(k_ppp,j,i) + u(k_mm,j,i) )                  &
+                                      )
+
+                diss_t(k) = - ABS( w_comp ) * (                              &
+                          ( 10.0_wp * ibit17 * adv_mom_5                        &
+                       +     3.0_wp * ibit16 * adv_mom_3                        &
+                       +              ibit15 * adv_mom_1                        &
+                          ) *                                                &
+                             ( u(k+1,j,i)   - u(k,j,i)    )                  &
+                   -      (  5.0_wp * ibit17 * adv_mom_5                        &
+                       +              ibit16 * adv_mom_3                        &
+                          ) *                                                &
+                             ( u(k_pp,j,i)  - u(k-1,j,i)  )                  &
+                   +      (           ibit17 * adv_mom_5                        &
+                           ) *                                               &
+                             ( u(k_ppp,j,i) - u(k_mm,j,i) )                  &
+                                              )
+!
+!--             Calculate the divergence of the velocity field. A respective
+!--             correction is needed to overcome numerical instabilities caused
+!--             by a not sufficient reduction of divergences near topography.
+                div = ( ( u_comp(k)   - ( u(k,j,i)   + u(k,j,i-1)   ) ) * ddx &
+                     +  ( v_comp + gv - ( v(k,j,i)   + v(k,j,i-1 )  ) ) * ddy &
+                     +  ( w_comp      - ( w(k-1,j,i) + w(k-1,j,i-1) ) )       &
+                                                                    * ddzw(k) &
+                      ) * 0.5_wp
+
+                 tend(k,j,i) = tend(k,j,i) - (                                 &
+                 ( flux_r(k) + diss_r(k)                                       &
+               -   swap_flux_x_local_u(k,j) - swap_diss_x_local_u(k,j) ) * ddx &
+               + ( flux_n(k) + diss_n(k)                                       &
+               -   swap_flux_y_local_u(k)   - swap_diss_y_local_u(k)   ) * ddy &
+               + ( flux_t(k) + diss_t(k)                                       &
+               -   flux_d    - diss_d                                          &
+                                                                  ) * ddzw(k)  &
+                                           ) + div * u(k,j,i)
+
+                 swap_flux_x_local_u(k,j) = flux_r(k)
+                 swap_diss_x_local_u(k,j) = diss_r(k)
+                 swap_flux_y_local_u(k)   = flux_n(k)
+                 swap_diss_y_local_u(k)   = diss_n(k)
+                 flux_d                   = flux_t(k)
+                 diss_d                   = diss_t(k)
+!
+!--              Statistical Evaluation of u'u'. The factor has to be applied
+!--              for right evaluation when gallilei_trans = .T. .
+                 sums_us2_ws_l(k,tn) = sums_us2_ws_l(k,tn)                    &
+                              + ( flux_r(k) *                                 &
+                                ( u_comp(k) - 2.0_wp * hom(k,1,1,0) )            &
+                              / ( u_comp(k) - gu + 1.0E-20_wp   )             &
+                              +   diss_r(k) *                                 &
+                                  ABS( u_comp(k) - 2.0_wp * hom(k,1,1,0) )       &
+                              / ( ABS( u_comp(k) - gu ) + 1.0E-20_wp ) )      &
+                              *   weight_substep(intermediate_timestep_count)
+!
+!--              Statistical Evaluation of w'u'.
+                 sums_wsus_ws_l(k,tn) = sums_wsus_ws_l(k,tn)                  &
+                              + ( flux_t(k) + diss_t(k) )                     &
+                              *   weight_substep(intermediate_timestep_count)
+       ENDDO
+          ENDDO
+       ENDDO
+       sums_us2_ws_l(nzb,tn) = sums_us2_ws_l(nzb+1,tn)
+
+
+    END SUBROUTINE advec_u_ws
+    
+    
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Advection of u - Call for all grid points - accelerator version
+!------------------------------------------------------------------------------!
+    SUBROUTINE advec_u_ws_acc
+
+       USE arrays_3d,                                                          &
+           ONLY:  ddzw, tend, u, v, w
+
+       USE constants,                                                          &
+           ONLY:  adv_mom_1, adv_mom_3, adv_mom_5
+
+       USE control_parameters,                                                 &
+           ONLY:  intermediate_timestep_count, u_gtrans, v_gtrans
+
+       USE grid_variables,                                                     &
+           ONLY:  ddx, ddy
+
+       USE indices,                                                            &
+           ONLY:  i_left, i_right, j_north, j_south, nxl, nxr, nyn, nys, nzb,  &
+                  nzb_max, nzt, wall_flags_0
+           
+       USE kinds
+       
+!        USE statistics,                                                       &
+!            ONLY:  hom, sums_us2_ws_l, sums_wsus_ws_l, weight_substep
+
+       IMPLICIT NONE
+
+       INTEGER(iwp) ::  i      !<
+       INTEGER(iwp) ::  ibit9  !<
+       INTEGER(iwp) ::  ibit10 !<
+       INTEGER(iwp) ::  ibit11 !<
+       INTEGER(iwp) ::  ibit12 !<
+       INTEGER(iwp) ::  ibit13 !<
+       INTEGER(iwp) ::  ibit14 !<
+       INTEGER(iwp) ::  ibit15 !<
+       INTEGER(iwp) ::  ibit16 !<
+       INTEGER(iwp) ::  ibit17 !<
+       INTEGER(iwp) ::  j      !<
+       INTEGER(iwp) ::  k      !<
+       INTEGER(iwp) ::  k_mmm  !<
+       INTEGER(iwp) ::  k_mm   !<
+       INTEGER(iwp) ::  k_pp   !<
+       INTEGER(iwp) ::  k_ppp  !<
+       INTEGER(iwp) ::  tn = 0 !<
+
+       REAL(wp)    ::  diss_d   !<
+       REAL(wp)    ::  diss_l   !<
+       REAL(wp)    ::  diss_n   !<
+       REAL(wp)    ::  diss_r   !<
+       REAL(wp)    ::  diss_s   !<
+       REAL(wp)    ::  diss_t   !<
+       REAL(wp)    ::  div      !<
+       REAL(wp)    ::  flux_d   !<
+       REAL(wp)    ::  flux_l   !<
+       REAL(wp)    ::  flux_n   !<
+       REAL(wp)    ::  flux_r   !<
+       REAL(wp)    ::  flux_s   !<
+       REAL(wp)    ::  flux_t   !<
+       REAL(wp)    ::  gu       !<
+       REAL(wp)    ::  gv       !<
+       REAL(wp)    ::  u_comp   !<
+       REAL(wp)    ::  u_comp_l !<
+       REAL(wp)    ::  v_comp   !<
+       REAL(wp)    ::  v_comp_s !<
+       REAL(wp)    ::  w_comp   !<
+
+
+       gu = 2.0_wp * u_gtrans
+       gv = 2.0_wp * v_gtrans
+
+!
+!--    Computation of fluxes and tendency terms
+       !$acc  kernels present( ddzw, tend, u, v, w, wall_flags_0 )
+       DO i = i_left, i_right
+          DO  j = j_south, j_north
+             DO  k = nzb+1, nzt
+
+                ibit11 = IBITS(wall_flags_0(k,j,i-1),11,1)
+                ibit10 = IBITS(wall_flags_0(k,j,i-1),10,1)
+                ibit9  = IBITS(wall_flags_0(k,j,i-1),9,1)
+
+                u_comp_l           = u(k,j,i) + u(k,j,i-1) - gu
+                flux_l             = u_comp_l * (                          &
+                                    ( 37.0_wp * ibit11 * adv_mom_5             &
+                                 +     7.0_wp * ibit10 * adv_mom_3             &
+                                 +              ibit9  * adv_mom_1             &
+                                    ) *                                     &
+                                  ( u(k,j,i)   + u(k,j,i-1) )               &
+                             -      (  8.0_wp * ibit11 * adv_mom_5             &
+                                 +              ibit10 * adv_mom_3             &
+                                    ) *                                     &
+                                  ( u(k,j,i+1) + u(k,j,i-2) )               &
+                             +      (           ibit11 * adv_mom_5             &
+                                    ) *                                     &
+                                  ( u(k,j,i+2) + u(k,j,i-3) )               &
+                                                )
+
+                diss_l             = - ABS( u_comp_l ) * (                &
+                                   ( 10.0_wp * ibit11 * adv_mom_5             &
+                                +     3.0_wp * ibit10 * adv_mom_3             &
+                                +              ibit9  * adv_mom_1             &
+                                   ) *                                     &
+                                 ( u(k,j,i)   - u(k,j,i-1) )               &
+                            -      (  5.0_wp * ibit11 * adv_mom_5             &
+                                +              ibit10 * adv_mom_3             &
+                                   ) *                                     &
+                                 ( u(k,j,i+1) - u(k,j,i-2) )               &
+                            +      (           ibit11 * adv_mom_5             &
+                                   ) *                                     &
+                                 ( u(k,j,i+2) - u(k,j,i-3) )               &
+                                                         )
+
+                ibit11 = IBITS(wall_flags_0(k,j,i),11,1)
+                ibit10 = IBITS(wall_flags_0(k,j,i),10,1)
+                ibit9  = IBITS(wall_flags_0(k,j,i),9,1)
+
+                u_comp    = u(k,j,i+1) + u(k,j,i)
+                flux_r    = ( u_comp   - gu ) * (                           &
+                          ( 37.0_wp * ibit11 * adv_mom_5                        &
+                       +     7.0_wp * ibit10 * adv_mom_3                        &
+                       +              ibit9  * adv_mom_1                        &
+                          ) *                                                &
+                                 ( u(k,j,i+1) + u(k,j,i)   )                 &
+                   -      (  8.0_wp * ibit11 * adv_mom_5                        &
+                       +              ibit10 * adv_mom_3                        &
+                          ) *                                                &
+                                 ( u(k,j,i+2) + u(k,j,i-1) )                 &
+                   +      (           ibit11 * adv_mom_5                        &
+                          ) *                                                &
+                                 ( u(k,j,i+3) + u(k,j,i-2) )                 &
+                                                 )
+
+                diss_r    = - ABS( u_comp    - gu ) * (                      &
+                          ( 10.0_wp * ibit11 * adv_mom_5                        &
+                       +     3.0_wp * ibit10 * adv_mom_3                        &
+                       +              ibit9  * adv_mom_1                        &
+                          ) *                                                &
+                                 ( u(k,j,i+1) - u(k,j,i)  )                  &
+                   -      (  5.0_wp * ibit11 * adv_mom_5                        &
+                       +              ibit10 * adv_mom_3                        &
+                          ) *                                                &
+                                 ( u(k,j,i+2) - u(k,j,i-1) )                 &
+                   +      (           ibit11 * adv_mom_5                        &
+                          ) *                                                &
+                                 ( u(k,j,i+3) - u(k,j,i-2) )                 &
+                                                     )
+
+                ibit14 = IBITS(wall_flags_0(k,j-1,i),14,1)
+                ibit13 = IBITS(wall_flags_0(k,j-1,i),13,1)
+                ibit12 = IBITS(wall_flags_0(k,j-1,i),12,1)
+
+                v_comp_s                 = v(k,j,i) + v(k,j,i-1) - gv
+                flux_s                   = v_comp_s * (                       &
+                                   ( 37.0_wp * ibit14 * adv_mom_5                &
+                                +     7.0_wp * ibit13 * adv_mom_3                &
+                                +              ibit12 * adv_mom_1                &
+                                   ) *                                         &
+                                     ( u(k,j,i)   + u(k,j-1,i) )              &
+                            -      (  8.0_wp * ibit14 * adv_mom_5                &
+                            +                  ibit13 * adv_mom_3                    &
+                                   ) *                                        &
+                                     ( u(k,j+1,i) + u(k,j-2,i) )              &
+                        +      (               ibit14 * adv_mom_5                    &
+                               ) *                                            &
+                                     ( u(k,j+2,i) + u(k,j-3,i) )              &
+                                               )
+
+                diss_s                  = - ABS ( v_comp_s ) * (              &
+                                   ( 10.0_wp * ibit14 * adv_mom_5                &
+                                +     3.0_wp * ibit13 * adv_mom_3                &
+                                +              ibit12 * adv_mom_1                &
+                                   ) *                                        &
+                                     ( u(k,j,i)   - u(k,j-1,i) )              &
+                            -      (  5.0_wp * ibit14 * adv_mom_5                &
+                                +              ibit13 * adv_mom_3                &
+                                   ) *                                        &
+                                     ( u(k,j+1,i) - u(k,j-2,i) )              &
+                            +      (           ibit14 * adv_mom_5                &
+                                   ) *                                        &
+                                     ( u(k,j+2,i) - u(k,j-3,i) )              &
+                                                         )
+
+
+                ibit14 = IBITS(wall_flags_0(k,j,i),14,1)
+                ibit13 = IBITS(wall_flags_0(k,j,i),13,1)
+                ibit12 = IBITS(wall_flags_0(k,j,i),12,1)
+
+                v_comp    = v(k,j+1,i) + v(k,j+1,i-1) - gv
+                flux_n    = v_comp * (                                       &
+                          ( 37.0_wp * ibit14 * adv_mom_5                        &
+                       +     7.0_wp * ibit13 * adv_mom_3                        &
+                       +              ibit12 * adv_mom_1                        &
+                          ) *                                                &
+                                 ( u(k,j+1,i) + u(k,j,i)   )                 &
+                   -      (  8.0_wp * ibit14 * adv_mom_5                        &
+                       +              ibit13 * adv_mom_3                        &
+                          ) *                                                &
+                                 ( u(k,j+2,i) + u(k,j-1,i) )                 &
+                   +      (           ibit14 * adv_mom_5                        &
+                          ) *                                                &
+                                 ( u(k,j+3,i) + u(k,j-2,i) )                 &
+                                                 )
+
+                diss_n    = - ABS ( v_comp ) * (                             &
+                          ( 10.0_wp * ibit14 * adv_mom_5                        &
+                       +     3.0_wp * ibit13 * adv_mom_3                        &
+                       +              ibit12 * adv_mom_1                        &
+                          ) *                                                &
+                                 ( u(k,j+1,i) - u(k,j,i)  )                  &
+                   -      (  5.0_wp * ibit14 * adv_mom_5                        &
+                       +              ibit13 * adv_mom_3                        &
+                          ) *                                                &
+                                 ( u(k,j+2,i) - u(k,j-1,i) )                 &
+                   +      (           ibit14 * adv_mom_5                        &
+                          ) *                                                &
+                                 ( u(k,j+3,i) - u(k,j-2,i) )                 &
+                                                      )
+
+                ibit17 = IBITS(wall_flags_0(k-1,j,i),17,1)
+                ibit16 = IBITS(wall_flags_0(k-1,j,i),16,1)
+                ibit15 = IBITS(wall_flags_0(k-1,j,i),15,1)
+
+                k_pp  = k + 2 * ibit17
+                k_mm  = k - 2 * ( ibit16 + ibit17 )
+                k_mmm = k - 3 * ibit17
+
+                w_comp    = w(k-1,j,i) + w(k-1,j,i-1)
+                flux_d    = w_comp  * (                                      &
+                          ( 37.0_wp * ibit17 * adv_mom_5                        &
+                       +     7.0_wp * ibit16 * adv_mom_3                        &
+                       +              ibit15 * adv_mom_1                        &
+                          ) *                                                &
+                             ( u(k,j,i)    + u(k-1,j,i)   )                  &
+                   -      (  8.0_wp * ibit17 * adv_mom_5                        &
+                       +              ibit16 * adv_mom_3                        &
+                          ) *                                                &
+                             ( u(k+1,j,i) + u(k_mm,j,i)   )                  &
+                   +      (           ibit17 * adv_mom_5                        &
+                          ) *                                                 &
+                             ( u(k_pp,j,i) + u(k_mmm,j,i) )                  &
+                                      )
+
+                diss_d    = - ABS( w_comp ) * (                              &
+                          ( 10.0_wp * ibit17 * adv_mom_5                        &
+                       +     3.0_wp * ibit16 * adv_mom_3                        &
+                       +              ibit15 * adv_mom_1                        &
+                          ) *                                                &
+                             ( u(k,j,i)     - u(k-1,j,i)  )                  &
+                   -      (  5.0_wp * ibit17 * adv_mom_5                        &
+                       +              ibit16 * adv_mom_3                        &
+                          ) *                                                &
+                             ( u(k+1,j,i)  - u(k_mm,j,i)  )                  &
+                   +      (           ibit17 * adv_mom_5                        &
+                           ) *                                               &
+                             ( u(k_pp,j,i) - u(k_mmm,j,i) )                  &
+                                              )
+!
+!--             k index has to be modified near bottom and top, else array
+!--             subscripts will be exceeded.
+                ibit17 = IBITS(wall_flags_0(k,j,i),17,1)
+                ibit16 = IBITS(wall_flags_0(k,j,i),16,1)
+                ibit15 = IBITS(wall_flags_0(k,j,i),15,1)
+
+                k_ppp = k + 3 * ibit17
+                k_pp  = k + 2 * ( 1 - ibit15  )
+                k_mm  = k - 2 * ibit17
+
+                w_comp    = w(k,j,i) + w(k,j,i-1)
+                flux_t    = w_comp  * (                                      &
+                          ( 37.0_wp * ibit17 * adv_mom_5                        &
+                       +     7.0_wp * ibit16 * adv_mom_3                        &
+                       +              ibit15 * adv_mom_1                        &
+                          ) *                                                &
+                             ( u(k+1,j,i)  + u(k,j,i)     )                  &
+                   -      (  8.0_wp * ibit17 * adv_mom_5                        &
+                       +              ibit16 * adv_mom_3                        &
+                          ) *                                                &
+                             ( u(k_pp,j,i) + u(k-1,j,i)   )                  &
+                   +      (           ibit17 * adv_mom_5                        &
+                          ) *                                                &
+                             ( u(k_ppp,j,i) + u(k_mm,j,i) )                  &
+                                      )
+
+                diss_t    = - ABS( w_comp ) * (                              &
+                          ( 10.0_wp * ibit17 * adv_mom_5                        &
+                       +     3.0_wp * ibit16 * adv_mom_3                        &
+                       +              ibit15 * adv_mom_1                        &
+                          ) *                                                &
+                             ( u(k+1,j,i)   - u(k,j,i)    )                  &
+                   -      (  5.0_wp * ibit17 * adv_mom_5                        &
+                       +              ibit16 * adv_mom_3                        &
+                          ) *                                                &
+                             ( u(k_pp,j,i)  - u(k-1,j,i)  )                  &
+                   +      (           ibit17 * adv_mom_5                        &
+                           ) *                                               &
+                             ( u(k_ppp,j,i) - u(k_mm,j,i) )                  &
+                                              )
+!
+!--             Calculate the divergence of the velocity field. A respective
+!--             correction is needed to overcome numerical instabilities caused
+!--             by a not sufficient reduction of divergences near topography.
+                div = ( ( u_comp    * ( ibit9 + ibit10 + ibit11 )             &
+                - ( u(k,j,i)   + u(k,j,i-1)   )                               &
+                                    * ( IBITS(wall_flags_0(k,j,i-1),9,1)      &
+                                      + IBITS(wall_flags_0(k,j,i-1),10,1)     &
+                                      + IBITS(wall_flags_0(k,j,i-1),11,1)     &
+                                      )                                       &   
+                  ) * ddx                                                     &
+               +  ( ( v_comp + gv ) * ( ibit12 + ibit13 + ibit14 )            &
+                  - ( v(k,j,i)   + v(k,j,i-1 )  )                             &
+                                    * ( IBITS(wall_flags_0(k,j-1,i),12,1)     &
+                                      + IBITS(wall_flags_0(k,j-1,i),13,1)     &
+                                      + IBITS(wall_flags_0(k,j-1,i),14,1)     &
+                                      )                                       &
+                  ) * ddy                                                     &
+               +  ( w_comp          * ( ibit15 + ibit16 + ibit17 )            &
+                - ( w(k-1,j,i) + w(k-1,j,i-1) )                               &
+                                    * ( IBITS(wall_flags_0(k-1,j,i),15,1)     &
+                                      + IBITS(wall_flags_0(k-1,j,i),16,1)     &
+                                      + IBITS(wall_flags_0(k-1,j,i),17,1)     &
+                                      )                                       &  
+                  ) * ddzw(k)   &
+                ) * 0.5_wp
+
+
+                tend(k,j,i) = - (                                              &
+                               ( flux_r + diss_r - flux_l - diss_l ) * ddx     &
+                             + ( flux_n + diss_n - flux_s - diss_s ) * ddy     &
+                             + ( flux_t + diss_t - flux_d - diss_d ) * ddzw(k) &
+                                ) + div * u(k,j,i)
+
+!++
+!--             Statistical Evaluation of u'u'. The factor has to be applied
+!--             for right evaluation when gallilei_trans = .T. .
+!                sums_us2_ws_l(k,tn) = sums_us2_ws_l(k,tn)                     &
+!                              + ( flux_r    *                                 &
+!                                ( u_comp    - 2.0_wp * hom(k,1,1,0) )            &
+!                              / ( u_comp    - gu + 1.0E-20_wp   )             &
+!                              +   diss_r    *                                 &
+!                                  ABS( u_comp    - 2.0_wp * hom(k,1,1,0) )       &
+!                              / ( ABS( u_comp    - gu ) + 1.0E-20_wp ) )      &
+!                              *   weight_substep(intermediate_timestep_count)
+!
+!--             Statistical Evaluation of w'u'.
+!                sums_wsus_ws_l(k,tn) = sums_wsus_ws_l(k,tn)                   &
+!                              + ( flux_t    + diss_t    )                     &
+!                              *   weight_substep(intermediate_timestep_count)
+             ENDDO
+          ENDDO
+       ENDDO
+       !$acc end kernels
+
+!++
+!       sums_us2_ws_l(nzb,tn) = sums_us2_ws_l(nzb+1,tn)
+
+    END SUBROUTINE advec_u_ws_acc
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Advection of v - Call for all grid points
+!------------------------------------------------------------------------------!
+    SUBROUTINE advec_v_ws
+
+       USE arrays_3d,                                                          &
+           ONLY:  ddzw, tend, u, v, w
+
+       USE constants,                                                          &
+           ONLY:  adv_mom_1, adv_mom_3, adv_mom_5
+
+       USE control_parameters,                                                 &
+           ONLY:  intermediate_timestep_count, u_gtrans, v_gtrans
+
+       USE grid_variables,                                                     &
+           ONLY:  ddx, ddy
+
+       USE indices,                                                            &
+           ONLY:  nxl, nxr, nyn, nys, nysv, nzb, nzb_max, nzt, wall_flags_0
+
+       USE kinds
+
+       USE statistics,                                                         &
+           ONLY:  hom, sums_vs2_ws_l, sums_wsvs_ws_l, weight_substep
+
+       IMPLICIT NONE
+
+
+       INTEGER(iwp) ::  i      !<
+       INTEGER(iwp) ::  ibit18 !<
+       INTEGER(iwp) ::  ibit19 !<
+       INTEGER(iwp) ::  ibit20 !<
+       INTEGER(iwp) ::  ibit21 !<
+       INTEGER(iwp) ::  ibit22 !<
+       INTEGER(iwp) ::  ibit23 !<
+       INTEGER(iwp) ::  ibit24 !<
+       INTEGER(iwp) ::  ibit25 !<
+       INTEGER(iwp) ::  ibit26 !<
+       INTEGER(iwp) ::  j      !<
+       INTEGER(iwp) ::  k      !<
+       INTEGER(iwp) ::  k_mm   !<
+       INTEGER(iwp) ::  k_pp   !<
+       INTEGER(iwp) ::  k_ppp  !<
+       INTEGER(iwp) ::  tn = 0 !<
+       
+       REAL(wp)    ::  diss_d !<
+       REAL(wp)    ::  div    !<
+       REAL(wp)    ::  flux_d !<
+       REAL(wp)    ::  gu     !<
+       REAL(wp)    ::  gv     !<
+       REAL(wp)    ::  u_comp !<
+       REAL(wp)    ::  w_comp !<
+       
+       REAL(wp), DIMENSION(nzb+1:nzt) ::  swap_diss_y_local_v !<
+       REAL(wp), DIMENSION(nzb+1:nzt) ::  swap_flux_y_local_v !<
+       
+       REAL(wp), DIMENSION(nzb+1:nzt,nys:nyn) ::  swap_diss_x_local_v !<
+       REAL(wp), DIMENSION(nzb+1:nzt,nys:nyn) ::  swap_flux_x_local_v !<
+       
+       REAL(wp), DIMENSION(nzb:nzt) ::  diss_n !<
+       REAL(wp), DIMENSION(nzb:nzt) ::  diss_r !<
+       REAL(wp), DIMENSION(nzb:nzt) ::  diss_t !<
+       REAL(wp), DIMENSION(nzb:nzt) ::  flux_n !<
+       REAL(wp), DIMENSION(nzb:nzt) ::  flux_r !<
+       REAL(wp), DIMENSION(nzb:nzt) ::  flux_t !<
+       REAL(wp), DIMENSION(nzb:nzt) ::  v_comp !<
+
+       gu = 2.0_wp * u_gtrans
+       gv = 2.0_wp * v_gtrans
+!
+!--    First compute the whole left boundary of the processor domain
+       i = nxl
+       DO  j = nysv, nyn
+          DO  k = nzb+1, nzb_max
+
+             ibit20 = IBITS(wall_flags_0(k,j,i-1),20,1)
+             ibit19 = IBITS(wall_flags_0(k,j,i-1),19,1)
+             ibit18 = IBITS(wall_flags_0(k,j,i-1),18,1)
+
+             u_comp                   = u(k,j-1,i) + u(k,j,i) - gu
+             swap_flux_x_local_v(k,j) = u_comp * (                             &
+                                      ( 37.0_wp * ibit20 * adv_mom_5              &
+                                   +     7.0_wp * ibit19 * adv_mom_3              &
+                                   +              ibit18 * adv_mom_1              &
+                                      ) *                                      &
+                                     ( v(k,j,i)   + v(k,j,i-1) )               &
+                               -      (  8.0_wp * ibit20 * adv_mom_5              &
+                                   +              ibit19 * adv_mom_3              &
+                                      ) *                                      &
+                                     ( v(k,j,i+1) + v(k,j,i-2) )               &
+                               +      (           ibit20 * adv_mom_5              &
+                                      ) *                                      &
+                                     ( v(k,j,i+2) + v(k,j,i-3) )               &
+                                                 )
+
+              swap_diss_x_local_v(k,j) = - ABS( u_comp ) * (                   &
+                                      ( 10.0_wp * ibit20 * adv_mom_5              &
+                                   +     3.0_wp * ibit19 * adv_mom_3              &
+                                   +              ibit18 * adv_mom_1              &
+                                      ) *                                      &
+                                     ( v(k,j,i)   - v(k,j,i-1) )               &
+                               -      (  5.0_wp * ibit20 * adv_mom_5              &
+                                   +              ibit19 * adv_mom_3              &
+                                      ) *                                      &
+                                     ( v(k,j,i+1) - v(k,j,i-2) )               &
+                               +      (           ibit20 * adv_mom_5              &
+                                      ) *                                      &
+                                     ( v(k,j,i+2) - v(k,j,i-3) )               &
+                                                           )
+
+          ENDDO
+
+          DO  k = nzb_max+1, nzt
+
+             u_comp                   = u(k,j-1,i) + u(k,j,i) - gu
+             swap_flux_x_local_v(k,j) = u_comp * (                            &
+                             37.0_wp * ( v(k,j,i) + v(k,j,i-1)   )               &
+                           -  8.0_wp * ( v(k,j,i+1) + v(k,j,i-2) )               &
+                           +           ( v(k,j,i+2) + v(k,j,i-3) ) ) * adv_mom_5
+             swap_diss_x_local_v(k,j) = - ABS( u_comp ) * (                   &
+                             10.0_wp * ( v(k,j,i) - v(k,j,i-1)   )               &
+                           -  5.0_wp * ( v(k,j,i+1) - v(k,j,i-2) )               &
+                           +           ( v(k,j,i+2) - v(k,j,i-3) ) ) * adv_mom_5
+
+          ENDDO
+
+       ENDDO
+
+       DO i = nxl, nxr
+
+          j = nysv
+          DO  k = nzb+1, nzb_max
+
+             ibit23 = IBITS(wall_flags_0(k,j-1,i),23,1)
+             ibit22 = IBITS(wall_flags_0(k,j-1,i),22,1)
+             ibit21 = IBITS(wall_flags_0(k,j-1,i),21,1)
+
+             v_comp(k)              = v(k,j,i) + v(k,j-1,i) - gv
+             swap_flux_y_local_v(k) = v_comp(k) * (                           &
+                                   ( 37.0_wp * ibit23 * adv_mom_5                &
+                                +     7.0_wp * ibit22 * adv_mom_3                &
+                                +              ibit21 * adv_mom_1                &
+                                   ) *                                        &
+                                     ( v(k,j,i)   + v(k,j-1,i) )              &
+                            -      (  8.0_wp * ibit23 * adv_mom_5                &
+                                +              ibit22 * adv_mom_3                &
+                                   ) *                                        &
+                                     ( v(k,j+1,i) + v(k,j-2,i) )              &
+                            +      (           ibit23 * adv_mom_5                &
+                                   ) *                                        &
+                                     ( v(k,j+2,i) + v(k,j-3,i) )              &
+                                                 )
+
+             swap_diss_y_local_v(k) = - ABS( v_comp(k) ) * (                  &
+                                   ( 10.0_wp * ibit23 * adv_mom_5                &
+                                +     3.0_wp * ibit22 * adv_mom_3                &
+                                +              ibit21 * adv_mom_1                &
+                                   ) *                                        &
+                                     ( v(k,j,i)   - v(k,j-1,i) )              &
+                            -      (  5.0_wp * ibit23 * adv_mom_5                &
+                                +              ibit22 * adv_mom_3                &
+                                   ) *                                        &
+                                     ( v(k,j+1,i) - v(k,j-2,i) )              &
+                            +      (           ibit23 * adv_mom_5                &
+                                   ) *                                        &
+                                     ( v(k,j+2,i) - v(k,j-3,i) )              &
+                                                          )
+
+          ENDDO
+
+          DO  k = nzb_max+1, nzt
+
+             v_comp(k)              = v(k,j,i) + v(k,j-1,i) - gv
+             swap_flux_y_local_v(k) = v_comp(k) * (                           &
+                           37.0_wp * ( v(k,j,i) + v(k,j-1,i)   )                 &
+                         -  8.0_wp * ( v(k,j+1,i) + v(k,j-2,i) )                 &
+                         +           ( v(k,j+2,i) + v(k,j-3,i) ) ) * adv_mom_5
+             swap_diss_y_local_v(k) = - ABS( v_comp(k) ) * (                  &
+                           10.0_wp * ( v(k,j,i) - v(k,j-1,i)   )                 &
+                         -  5.0_wp * ( v(k,j+1,i) - v(k,j-2,i) )                 &
+                         +           ( v(k,j+2,i) - v(k,j-3,i) ) ) * adv_mom_5
+
+          ENDDO
+
+          DO  j = nysv, nyn
+
+             flux_t(0) = 0.0_wp
+             diss_t(0) = 0.0_wp
+             flux_d    = 0.0_wp
+             diss_d    = 0.0_wp
+
+             DO  k = nzb+1, nzb_max
+
+                ibit20 = IBITS(wall_flags_0(k,j,i),20,1)
+                ibit19 = IBITS(wall_flags_0(k,j,i),19,1)
+                ibit18 = IBITS(wall_flags_0(k,j,i),18,1)
+
+                u_comp    = u(k,j-1,i+1) + u(k,j,i+1) - gu
+                flux_r(k) = u_comp * (                                       &
+                          ( 37.0_wp * ibit20 * adv_mom_5                        &
+                       +     7.0_wp * ibit19 * adv_mom_3                        &
+                       +              ibit18 * adv_mom_1                        &
+                          ) *                                                &
+                                 ( v(k,j,i+1) + v(k,j,i)   )                 &
+                   -      (  8.0_wp * ibit20 * adv_mom_5                        &
+                       +              ibit19 * adv_mom_3                        &
+                          ) *                                                &
+                                 ( v(k,j,i+2) + v(k,j,i-1) )                 &
+                   +      (           ibit20 * adv_mom_5                        &
+                          ) *                                                &
+                                 ( v(k,j,i+3) + v(k,j,i-2) )                 &
+                                     )
+
+                diss_r(k) = - ABS( u_comp ) * (                              &
+                          ( 10.0_wp * ibit20 * adv_mom_5                        &
+                       +     3.0_wp * ibit19 * adv_mom_3                        &
+                       +              ibit18 * adv_mom_1                        &
+                          ) *                                                &
+                                 ( v(k,j,i+1) - v(k,j,i)  )                  &
+                   -      (  5.0_wp * ibit20 * adv_mom_5                        &
+                       +              ibit19 * adv_mom_3                        &
+                          ) *                                                &
+                                 ( v(k,j,i+2) - v(k,j,i-1) )                 &
+                   +      (           ibit20 * adv_mom_5                        &
+                          ) *                                                &
+                                 ( v(k,j,i+3) - v(k,j,i-2) )                 &
+                                              )
+
+                ibit23 = IBITS(wall_flags_0(k,j,i),23,1)
+                ibit22 = IBITS(wall_flags_0(k,j,i),22,1)
+                ibit21 = IBITS(wall_flags_0(k,j,i),21,1)
+
+                v_comp(k) = v(k,j+1,i) + v(k,j,i)
+                flux_n(k) = ( v_comp(k) - gv ) * (                           &
+                          ( 37.0_wp * ibit23 * adv_mom_5                        &
+                       +     7.0_wp * ibit22 * adv_mom_3                        &
+                       +              ibit21 * adv_mom_1                        &
+                          ) *                                                &
+                                 ( v(k,j+1,i) + v(k,j,i)   )                 &
+                   -      (  8.0_wp * ibit23 * adv_mom_5                        &
+                       +              ibit22 * adv_mom_3                        &
+                          ) *                                                &
+                                 ( v(k,j+2,i) + v(k,j-1,i) )                 &
+                   +      (           ibit23 * adv_mom_5                        &
+                          ) *                                                &
+                                 ( v(k,j+3,i) + v(k,j-2,i) )                 &
+                                     )
+
+                diss_n(k) = - ABS( v_comp(k) - gv ) * (                      &
+                          ( 10.0_wp * ibit23 * adv_mom_5                        &
+                       +     3.0_wp * ibit22 * adv_mom_3                        &
+                       +              ibit21 * adv_mom_1                        &
+                          ) *                                                &
+                                 ( v(k,j+1,i) - v(k,j,i)  )                  &
+                   -      (  5.0_wp * ibit23 * adv_mom_5                        &
+                       +              ibit22 * adv_mom_3                        &
+                          ) *                                                &
+                                 ( v(k,j+2,i) - v(k,j-1,i) )                 &
+                   +      (           ibit23 * adv_mom_5                        &
+                          ) *                                                &
+                                 ( v(k,j+3,i) - v(k,j-2,i) )                 &
+                                                      )
+!
+!--             k index has to be modified near bottom and top, else array
+!--             subscripts will be exceeded.
+                ibit26 = IBITS(wall_flags_0(k,j,i),26,1)
+                ibit25 = IBITS(wall_flags_0(k,j,i),25,1)
+                ibit24 = IBITS(wall_flags_0(k,j,i),24,1)
+
+                k_ppp = k + 3 * ibit26
+                k_pp  = k + 2 * ( 1 - ibit24  )
+                k_mm  = k - 2 * ibit26
+
+                w_comp    = w(k,j-1,i) + w(k,j,i)
+                flux_t(k) = w_comp  * (                                      &
+                          ( 37.0_wp * ibit26 * adv_mom_5                        &
+                       +     7.0_wp * ibit25 * adv_mom_3                        &
+                       +              ibit24 * adv_mom_1                        &
+                          ) *                                                &
+                             ( v(k+1,j,i)   + v(k,j,i)    )                  &
+                   -      (  8.0_wp * ibit26 * adv_mom_5                        &
+                       +              ibit25 * adv_mom_3                        &
+                          ) *                                                &
+                             ( v(k_pp,j,i)  + v(k-1,j,i)  )                  &
+                   +      (           ibit26 * adv_mom_5                        &
+                          ) *                                                &
+                             ( v(k_ppp,j,i) + v(k_mm,j,i) )                  &
+                                      )
+
+                diss_t(k) = - ABS( w_comp ) * (                              &
+                          ( 10.0_wp * ibit26 * adv_mom_5                        &
+                       +     3.0_wp * ibit25 * adv_mom_3                        &
+                       +              ibit24 * adv_mom_1                        &
+                          ) *                                                &
+                             ( v(k+1,j,i)   - v(k,j,i)    )                  &
+                   -      (  5.0_wp * ibit26 * adv_mom_5                        &
+                       +              ibit25 * adv_mom_3                        &
+                          ) *                                                &
+                             ( v(k_pp,j,i)  - v(k-1,j,i)  )                  &
+                   +      (           ibit26 * adv_mom_5                        &
+                          ) *                                                &
+                             ( v(k_ppp,j,i) - v(k_mm,j,i) )                  &
+                                               )
+!
+!--             Calculate the divergence of the velocity field. A respective
+!--             correction is needed to overcome numerical instabilities caused
+!--             by a not sufficient reduction of divergences near topography.
+                div = ( ( ( u_comp     + gu )                                 &
+                                       * ( ibit18 + ibit19 + ibit20 )         &
+                - ( u(k,j-1,i)   + u(k,j,i) )                                 &
+                                       * ( IBITS(wall_flags_0(k,j,i-1),18,1)  &
+                                         + IBITS(wall_flags_0(k,j,i-1),19,1)  &
+                                         + IBITS(wall_flags_0(k,j,i-1),20,1)  &
+                                         )                                    &   
+                  ) * ddx                                                     &
+               +  ( v_comp(k)                                                 &
+                                       * ( ibit21 + ibit22 + ibit23 )         &
+                - ( v(k,j,i)     + v(k,j-1,i) )                               &
+                                       * ( IBITS(wall_flags_0(k,j-1,i),21,1)  &
+                                         + IBITS(wall_flags_0(k,j-1,i),22,1)  &
+                                         + IBITS(wall_flags_0(k,j-1,i),23,1)  &
+                                         )                                    &   
+                  ) * ddy                                                     &
+               +  ( w_comp                                                    &
+                                       * ( ibit24 + ibit25 + ibit26 )         &
+                - ( w(k-1,j-1,i) + w(k-1,j,i) )                               &
+                                       * ( IBITS(wall_flags_0(k-1,j,i),24,1)  &
+                                         + IBITS(wall_flags_0(k-1,j,i),25,1)  &
+                                         + IBITS(wall_flags_0(k-1,j,i),26,1)  &
+                                         )                                    &
+                   ) * ddzw(k)   &
+                ) * 0.5_wp
+
+
+                tend(k,j,i) = tend(k,j,i) - (                                 &
+                       ( flux_r(k) + diss_r(k)                                &
+                     -   swap_flux_x_local_v(k,j) - swap_diss_x_local_v(k,j)  &
+                       ) * ddx                                                &
+                     + ( flux_n(k) + diss_n(k)                                &
+                     -   swap_flux_y_local_v(k) - swap_diss_y_local_v(k)      &
+                       ) * ddy                                                &
+                     + ( flux_t(k) + diss_t(k)                                &
+                     -   flux_d    - diss_d                                   &
+                       ) * ddzw(k)                                            &
+                                            )  + v(k,j,i) * div
+
+                swap_flux_x_local_v(k,j) = flux_r(k)
+                swap_diss_x_local_v(k,j) = diss_r(k)
+                swap_flux_y_local_v(k)   = flux_n(k)
+                swap_diss_y_local_v(k)   = diss_n(k)
+                flux_d                   = flux_t(k)
+                diss_d                   = diss_t(k)
+
+!
+!--             Statistical Evaluation of v'v'. The factor has to be applied
+!--             for right evaluation when gallilei_trans = .T. .
+                sums_vs2_ws_l(k,tn) = sums_vs2_ws_l(k,tn)                     &
+                      + ( flux_n(k)                                           &
+                      * ( v_comp(k) - 2.0_wp * hom(k,1,2,0) )                    &
+                      / ( v_comp(k) - gv + 1.0E-20_wp )                       &
+                      +   diss_n(k)                                           &
+                      *   ABS( v_comp(k) - 2.0_wp * hom(k,1,2,0) )               &
+                      / ( ABS( v_comp(k) - gv ) +1.0E-20_wp ) )               &
+                      *   weight_substep(intermediate_timestep_count)
+!
+!--              Statistical Evaluation of w'v'.
+                 sums_wsvs_ws_l(k,tn) = sums_wsvs_ws_l(k,tn)                  &
+                              + ( flux_t(k) + diss_t(k) )                     &
+                              *   weight_substep(intermediate_timestep_count)
+
+             ENDDO
+
+             DO  k = nzb_max+1, nzt
+
+                u_comp    = u(k,j-1,i+1) + u(k,j,i+1) - gu
+                flux_r(k) = u_comp * (                                        &
+                      37.0_wp * ( v(k,j,i+1) + v(k,j,i)   )                      &
+                    -  8.0_wp * ( v(k,j,i+2) + v(k,j,i-1) )                      &
+                    +           ( v(k,j,i+3) + v(k,j,i-2) ) ) * adv_mom_5
+
+                diss_r(k) = - ABS( u_comp ) * (                               &
+                      10.0_wp * ( v(k,j,i+1) - v(k,j,i) )                        &
+                    -  5.0_wp * ( v(k,j,i+2) - v(k,j,i-1) )                      &
+                    +           ( v(k,j,i+3) - v(k,j,i-2) ) ) * adv_mom_5
+
+
+                v_comp(k) = v(k,j+1,i) + v(k,j,i)
+                flux_n(k) = ( v_comp(k) - gv ) * (                            &
+                      37.0_wp * ( v(k,j+1,i) + v(k,j,i)   )                      &
+                    -  8.0_wp * ( v(k,j+2,i) + v(k,j-1,i) )                      &
+                      +         ( v(k,j+3,i) + v(k,j-2,i) ) ) * adv_mom_5
+
+                diss_n(k) = - ABS( v_comp(k) - gv ) * (                       &
+                      10.0_wp * ( v(k,j+1,i) - v(k,j,i)   )                      &
+                    -  5.0_wp * ( v(k,j+2,i) - v(k,j-1,i) )                      &
+                    +           ( v(k,j+3,i) - v(k,j-2,i) ) ) * adv_mom_5
+!
+!--             k index has to be modified near bottom and top, else array
+!--             subscripts will be exceeded.
+                ibit26 = IBITS(wall_flags_0(k,j,i),26,1)
+                ibit25 = IBITS(wall_flags_0(k,j,i),25,1)
+                ibit24 = IBITS(wall_flags_0(k,j,i),24,1)
+
+                k_ppp = k + 3 * ibit26
+                k_pp  = k + 2 * ( 1 - ibit24  )
+                k_mm  = k - 2 * ibit26
+
+                w_comp    = w(k,j-1,i) + w(k,j,i)
+                flux_t(k) = w_comp  * (                                      &
+                          ( 37.0_wp * ibit26 * adv_mom_5                        &
+                       +     7.0_wp * ibit25 * adv_mom_3                        &
+                       +              ibit24 * adv_mom_1                        &
+                          ) *                                                &
+                             ( v(k+1,j,i)   + v(k,j,i)    )                  &
+                   -      (  8.0_wp * ibit26 * adv_mom_5                        &
+                       +              ibit25 * adv_mom_3                        &
+                          ) *                                                &
+                             ( v(k_pp,j,i)  + v(k-1,j,i)  )                  &
+                   +      (           ibit26 * adv_mom_5                        &
+                          ) *                                                &
+                             ( v(k_ppp,j,i) + v(k_mm,j,i) )                  &
+                                      )
+
+                diss_t(k) = - ABS( w_comp ) * (                              &
+                          ( 10.0_wp * ibit26 * adv_mom_5                        &
+                       +     3.0_wp * ibit25 * adv_mom_3                        &
+                       +              ibit24 * adv_mom_1                        &
+                          ) *                                                &
+                             ( v(k+1,j,i)   - v(k,j,i)    )                  &
+                   -      (  5.0_wp * ibit26 * adv_mom_5                        &
+                       +              ibit25 * adv_mom_3                        &
+                          ) *                                                &
+                             ( v(k_pp,j,i)  - v(k-1,j,i)  )                  &
+                   +      (           ibit26 * adv_mom_5                        &
+                          ) *                                                &
+                             ( v(k_ppp,j,i) - v(k_mm,j,i) )                  &
+                                               )
+!
+!--             Calculate the divergence of the velocity field. A respective
+!--             correction is needed to overcome numerical instabilities caused
+!--             by a not sufficient reduction of divergences near topography.
+                div = ( ( u_comp + gu - ( u(k,j-1,i)   + u(k,j,i)   ) ) * ddx &
+                     +  ( v_comp(k)   - ( v(k,j,i)     + v(k,j-1,i) ) ) * ddy &
+                     +  ( w_comp      - ( w(k-1,j-1,i) + w(k-1,j,i) ) )       &
+                                                                    * ddzw(k) &
+                      ) * 0.5_wp
+ 
+                tend(k,j,i) = tend(k,j,i) - (                                 &
+                       ( flux_r(k) + diss_r(k)                                &
+                     -   swap_flux_x_local_v(k,j) - swap_diss_x_local_v(k,j)  &
+                       ) * ddx                                                &
+                     + ( flux_n(k) + diss_n(k)                                &
+                     -   swap_flux_y_local_v(k) - swap_diss_y_local_v(k)      &
+                       ) * ddy                                                &
+                     + ( flux_t(k) + diss_t(k)                                &
+                     -   flux_d    - diss_d                                   &
+                       ) * ddzw(k)                                            &
+                                            )  + v(k,j,i) * div
+
+                swap_flux_x_local_v(k,j) = flux_r(k)
+                swap_diss_x_local_v(k,j) = diss_r(k)
+                swap_flux_y_local_v(k)   = flux_n(k)
+                swap_diss_y_local_v(k)   = diss_n(k)
+                flux_d                   = flux_t(k)
+                diss_d                   = diss_t(k)
+
+!
+!--             Statistical Evaluation of v'v'. The factor has to be applied
+!--             for right evaluation when gallilei_trans = .T. .
+                sums_vs2_ws_l(k,tn) = sums_vs2_ws_l(k,tn)                     &
+                         + ( flux_n(k)                                        &
+                         * ( v_comp(k) - 2.0_wp * hom(k,1,2,0) )                 &
+                         / ( v_comp(k) - gv + 1.0E-20_wp )                    &
+                         +   diss_n(k)                                        &
+                         *   ABS( v_comp(k) - 2.0_wp * hom(k,1,2,0) )            &
+                         / ( ABS( v_comp(k) - gv ) +1.0E-20_wp ) )            &
+                         *   weight_substep(intermediate_timestep_count)
+!
+!--             Statistical Evaluation of w'v'.
+                sums_wsvs_ws_l(k,tn) = sums_wsvs_ws_l(k,tn)                    &
+                              + ( flux_t(k) + diss_t(k) )                      &
+                              *   weight_substep(intermediate_timestep_count)
+
+             ENDDO
+          ENDDO
+       ENDDO
+       sums_vs2_ws_l(nzb,tn) = sums_vs2_ws_l(nzb+1,tn)
+
+
+    END SUBROUTINE advec_v_ws
+    
+    
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Advection of v - Call for all grid points - accelerator version
+!------------------------------------------------------------------------------!
+    SUBROUTINE advec_v_ws_acc
+
+       USE arrays_3d,                                                          &
+           ONLY:  ddzw, tend, u, v, w
+
+       USE constants,                                                          &
+           ONLY:  adv_mom_1, adv_mom_3, adv_mom_5
+
+       USE control_parameters,                                                 &
+           ONLY:  intermediate_timestep_count, u_gtrans, v_gtrans
+
+       USE grid_variables,                                                     &
+           ONLY:  ddx, ddy
+
+       USE indices,                                                            &
+           ONLY:  i_left, i_right, j_north, j_south, nxl, nxr, nyn, nys, nzb,  &
+                  nzb_max, nzt, wall_flags_0
+           
+       USE kinds
+       
+!        USE statistics,                                                       &
+!            ONLY:  hom, sums_vs2_ws_l, sums_wsvs_ws_l, weight_substep
+
+       IMPLICIT NONE
+
+
+       INTEGER(iwp) ::  i      !<
+       INTEGER(iwp) ::  ibit18 !<
+       INTEGER(iwp) ::  ibit19 !<
+       INTEGER(iwp) ::  ibit20 !<
+       INTEGER(iwp) ::  ibit21 !<
+       INTEGER(iwp) ::  ibit22 !<
+       INTEGER(iwp) ::  ibit23 !<
+       INTEGER(iwp) ::  ibit24 !<
+       INTEGER(iwp) ::  ibit25 !<
+       INTEGER(iwp) ::  ibit26 !<
+       INTEGER(iwp) ::  j      !<
+       INTEGER(iwp) ::  k      !<
+       INTEGER(iwp) ::  k_mm   !<
+       INTEGER(iwp) ::  k_mmm  !<
+       INTEGER(iwp) ::  k_pp   !<
+       INTEGER(iwp) ::  k_ppp  !<
+       INTEGER(iwp) ::  tn = 0 !<
+
+       REAL(wp)    ::  diss_d   !<
+       REAL(wp)    ::  diss_l   !<
+       REAL(wp)    ::  diss_n   !<
+       REAL(wp)    ::  diss_r   !<
+       REAL(wp)    ::  diss_s   !<
+       REAL(wp)    ::  diss_t   !<
+       REAL(wp)    ::  div      !<
+       REAL(wp)    ::  flux_d   !<
+       REAL(wp)    ::  flux_l   !<
+       REAL(wp)    ::  flux_n   !<
+       REAL(wp)    ::  flux_r   !<
+       REAL(wp)    ::  flux_s   !<
+       REAL(wp)    ::  flux_t   !<
+       REAL(wp)    ::  gu       !<
+       REAL(wp)    ::  gv       !<
+       REAL(wp)    ::  u_comp   !<
+       REAL(wp)    ::  u_comp_l !<
+       REAL(wp)    ::  v_comp   !<
+       REAL(wp)    ::  v_comp_s !<
+       REAL(wp)    ::  w_comp   !<
+
+       gu = 2.0_wp * u_gtrans
+       gv = 2.0_wp * v_gtrans
+
+!
+!--    Computation of fluxes and tendency terms
+       !$acc kernels present( ddzw, tend, u, v, w, wall_flags_0 )
+       DO  i = i_left, i_right
+          DO  j = j_south, j_north
+             DO  k = nzb+1, nzt
+
+                ibit20 = IBITS(wall_flags_0(k,j,i-1),20,1)
+                ibit19 = IBITS(wall_flags_0(k,j,i-1),19,1)
+                ibit18 = IBITS(wall_flags_0(k,j,i-1),18,1)
+
+                u_comp_l                 = u(k,j-1,i) + u(k,j,i) - gu
+                flux_l                   = u_comp_l * (                          &
+                                      ( 37.0_wp * ibit20 * adv_mom_5              &
+                                   +     7.0_wp * ibit19 * adv_mom_3              &
+                                   +              ibit18 * adv_mom_1              &
+                                      ) *                                      &
+                                     ( v(k,j,i)   + v(k,j,i-1) )               &
+                               -      (  8.0_wp * ibit20 * adv_mom_5              &
+                                   +              ibit19 * adv_mom_3              &
+                                      ) *                                      &
+                                     ( v(k,j,i+1) + v(k,j,i-2) )               &
+                               +      (           ibit20 * adv_mom_5              &
+                                      ) *                                      &
+                                     ( v(k,j,i+2) + v(k,j,i-3) )               &
+                                                 )
+
+                diss_l                   = - ABS( u_comp_l ) * (                 &
+                                      ( 10.0_wp * ibit20 * adv_mom_5              &
+                                   +     3.0_wp * ibit19 * adv_mom_3              &
+                                   +              ibit18 * adv_mom_1              &
+                                      ) *                                      &
+                                     ( v(k,j,i)   - v(k,j,i-1) )               &
+                               -      (  5.0_wp * ibit20 * adv_mom_5              &
+                                   +              ibit19 * adv_mom_3              &
+                                      ) *                                      &
+                                     ( v(k,j,i+1) - v(k,j,i-2) )               &
+                               +      (           ibit20 * adv_mom_5              &
+                                      ) *                                      &
+                                     ( v(k,j,i+2) - v(k,j,i-3) )               &
+                                                           )
+
+                ibit20 = IBITS(wall_flags_0(k,j,i),20,1)
+                ibit19 = IBITS(wall_flags_0(k,j,i),19,1)
+                ibit18 = IBITS(wall_flags_0(k,j,i),18,1)
+
+                u_comp    = u(k,j-1,i+1) + u(k,j,i+1) - gu
+                flux_r    = u_comp * (                                       &
+                          ( 37.0_wp * ibit20 * adv_mom_5                        &
+                       +     7.0_wp * ibit19 * adv_mom_3                        &
+                       +              ibit18 * adv_mom_1                        &
+                          ) *                                                &
+                                 ( v(k,j,i+1) + v(k,j,i)   )                 &
+                   -      (  8.0_wp * ibit20 * adv_mom_5                        &
+                       +              ibit19 * adv_mom_3                        &
+                          ) *                                                &
+                                 ( v(k,j,i+2) + v(k,j,i-1) )                 &
+                   +      (           ibit20 * adv_mom_5                        &
+                          ) *                                                &
+                                 ( v(k,j,i+3) + v(k,j,i-2) )                 &
+                                     )
+
+                diss_r    = - ABS( u_comp ) * (                              &
+                          ( 10.0_wp * ibit20 * adv_mom_5                        &
+                       +     3.0_wp * ibit19 * adv_mom_3                        &
+                       +              ibit18 * adv_mom_1                        &
+                          ) *                                                &
+                                 ( v(k,j,i+1) - v(k,j,i)  )                  &
+                   -      (  5.0_wp * ibit20 * adv_mom_5                        &
+                       +              ibit19 * adv_mom_3                        &
+                          ) *                                                &
+                                 ( v(k,j,i+2) - v(k,j,i-1) )                 &
+                   +      (           ibit20 * adv_mom_5                        &
+                          ) *                                                &
+                                 ( v(k,j,i+3) - v(k,j,i-2) )                 &
+                                              )
+
+                ibit23 = IBITS(wall_flags_0(k,j-1,i),23,1)
+                ibit22 = IBITS(wall_flags_0(k,j-1,i),22,1)
+                ibit21 = IBITS(wall_flags_0(k,j-1,i),21,1)
+
+
+                v_comp_s              = v(k,j,i) + v(k,j-1,i) - gv
+                flux_s                = v_comp_s    * (                       &
+                                   ( 37.0_wp * ibit23 * adv_mom_5                &
+                                +     7.0_wp * ibit22 * adv_mom_3                &
+                                +              ibit21 * adv_mom_1                &
+                                   ) *                                        &
+                                     ( v(k,j,i)   + v(k,j-1,i) )              &
+                            -      (  8.0_wp * ibit23 * adv_mom_5                &
+                                +              ibit22 * adv_mom_3                &
+                                   ) *                                        &
+                                     ( v(k,j+1,i) + v(k,j-2,i) )              &
+                            +      (           ibit23 * adv_mom_5                &
+                                   ) *                                        &
+                                     ( v(k,j+2,i) + v(k,j-3,i) )              &
+                                                 )
+
+                diss_s                = - ABS( v_comp_s ) * (                 &
+                                   ( 10.0_wp * ibit23 * adv_mom_5                &
+                                +     3.0_wp * ibit22 * adv_mom_3                &
+                                +              ibit21 * adv_mom_1                &
+                                   ) *                                        &
+                                     ( v(k,j,i)   - v(k,j-1,i) )              &
+                            -      (  5.0_wp * ibit23 * adv_mom_5                &
+                                +              ibit22 * adv_mom_3                &
+                                   ) *                                        &
+                                     ( v(k,j+1,i) - v(k,j-2,i) )              &
+                            +      (           ibit23 * adv_mom_5                &
+                                   ) *                                        &
+                                     ( v(k,j+2,i) - v(k,j-3,i) )              &
+                                                          )
+
+                ibit23 = IBITS(wall_flags_0(k,j,i),23,1)
+                ibit22 = IBITS(wall_flags_0(k,j,i),22,1)
+                ibit21 = IBITS(wall_flags_0(k,j,i),21,1)
+
+                v_comp = v(k,j+1,i) + v(k,j,i)
+                flux_n = ( v_comp - gv ) * (                                 &
+                          ( 37.0_wp * ibit23 * adv_mom_5                        &
+                       +     7.0_wp * ibit22 * adv_mom_3                        &
+                       +              ibit21 * adv_mom_1                        &
+                          ) *                                                &
+                                 ( v(k,j+1,i) + v(k,j,i)   )                 &
+                   -      (  8.0_wp * ibit23 * adv_mom_5                        &
+                       +              ibit22 * adv_mom_3                        &
+                          ) *                                                &
+                                 ( v(k,j+2,i) + v(k,j-1,i) )                 &
+                   +      (           ibit23 * adv_mom_5                        &
+                          ) *                                                &
+                                 ( v(k,j+3,i) + v(k,j-2,i) )                 &
+                                     )
+
+                diss_n = - ABS( v_comp - gv ) * (                         &
+                          ( 10.0_wp * ibit23 * adv_mom_5                        &
+                       +     3.0_wp * ibit22 * adv_mom_3                        &
+                       +              ibit21 * adv_mom_1                        &
+                          ) *                                                &
+                                 ( v(k,j+1,i) - v(k,j,i)  )                  &
+                   -      (  5.0_wp * ibit23 * adv_mom_5                        &
+                       +              ibit22 * adv_mom_3                        &
+                          ) *                                                &
+                                 ( v(k,j+2,i) - v(k,j-1,i) )                 &
+                   +      (           ibit23 * adv_mom_5                        &
+                          ) *                                                &
+                                 ( v(k,j+3,i) - v(k,j-2,i) )                 &
+                                                     )
+
+                ibit26 = IBITS(wall_flags_0(k-1,j,i),26,1)
+                ibit25 = IBITS(wall_flags_0(k-1,j,i),25,1)
+                ibit24 = IBITS(wall_flags_0(k-1,j,i),24,1)
+
+                k_pp  = k + 2 * ibit26
+                k_mm  = k - 2 * ( ibit25 + ibit26 )
+                k_mmm = k - 3 * ibit26
+
+                w_comp    = w(k-1,j-1,i) + w(k-1,j,i)
+                flux_d    = w_comp  * (                                      &
+                          ( 37.0_wp * ibit26 * adv_mom_5                        &
+                       +     7.0_wp * ibit25 * adv_mom_3                        &
+                       +              ibit24 * adv_mom_1                        &
+                          ) *                                                &
+                             ( v(k,j,i)     + v(k-1,j,i)  )                  &
+                   -      (  8.0_wp * ibit26 * adv_mom_5                        &
+                       +              ibit25 * adv_mom_3                        &
+                          ) *                                                &
+                             ( v(k+1,j,i)  + v(k_mm,j,i)  )                  &
+                   +      (           ibit26 * adv_mom_5                        &
+                          ) *                                                &
+                             ( v(k_pp,j,i) + v(k_mmm,j,i) )                  &
+                                      )
+
+                diss_d    = - ABS( w_comp ) * (                              &
+                          ( 10.0_wp * ibit26 * adv_mom_5                        &
+                       +     3.0_wp * ibit25 * adv_mom_3                        &
+                       +              ibit24 * adv_mom_1                        &
+                          ) *                                                &
+                             ( v(k,j,i)     - v(k-1,j,i)  )                  &
+                   -      (  5.0_wp * ibit26 * adv_mom_5                        &
+                       +              ibit25 * adv_mom_3                        &
+                          ) *                                                &
+                             ( v(k+1,j,i)  - v(k_mm,j,i)  )                  &
+                   +      (           ibit26 * adv_mom_5                        &
+                          ) *                                                &
+                             ( v(k_pp,j,i) - v(k_mmm,j,i) )                  &
+                                               )
+!
+!--             k index has to be modified near bottom and top, else array
+!--             subscripts will be exceeded.
+                ibit26 = IBITS(wall_flags_0(k,j,i),26,1)
+                ibit25 = IBITS(wall_flags_0(k,j,i),25,1)
+                ibit24 = IBITS(wall_flags_0(k,j,i),24,1)
+
+                k_ppp = k + 3 * ibit26
+                k_pp  = k + 2 * ( 1 - ibit24  )
+                k_mm  = k - 2 * ibit26
+
+                w_comp    = w(k,j-1,i) + w(k,j,i)
+                flux_t    = w_comp  * (                                      &
+                          ( 37.0_wp * ibit26 * adv_mom_5                        &
+                       +     7.0_wp * ibit25 * adv_mom_3                        &
+                       +              ibit24 * adv_mom_1                        &
+                          ) *                                                &
+                             ( v(k+1,j,i)   + v(k,j,i)    )                  &
+                   -      (  8.0_wp * ibit26 * adv_mom_5                        &
+                       +              ibit25 * adv_mom_3                        &
+                          ) *                                                &
+                             ( v(k_pp,j,i)  + v(k-1,j,i)  )                  &
+                   +      (           ibit26 * adv_mom_5                        &
+                          ) *                                                &
+                             ( v(k_ppp,j,i) + v(k_mm,j,i) )                  &
+                                      )
+
+                diss_t    = - ABS( w_comp ) * (                              &
+                          ( 10.0_wp * ibit26 * adv_mom_5                        &
+                       +     3.0_wp * ibit25 * adv_mom_3                        &
+                       +              ibit24 * adv_mom_1                        &
+                          ) *                                                &
+                             ( v(k+1,j,i)   - v(k,j,i)    )                  &
+                   -      (  5.0_wp * ibit26 * adv_mom_5                        &
+                       +              ibit25 * adv_mom_3                        &
+                          ) *                                                &
+                             ( v(k_pp,j,i)  - v(k-1,j,i)  )                  &
+                   +      (           ibit26 * adv_mom_5                        &
+                          ) *                                                &
+                             ( v(k_ppp,j,i) - v(k_mm,j,i) )                  &
+                                               )
+!
+!--             Calculate the divergence of the velocity field. A respective
+!--             correction is needed to overcome numerical instabilities caused
+!--             by a not sufficient reduction of divergences near topography.
+                div = ( ( ( u_comp     + gu )                                 &
+                                       * ( ibit18 + ibit19 + ibit20 )         &
+                - ( u(k,j-1,i)   + u(k,j,i) )                                 &
+                                       * ( IBITS(wall_flags_0(k,j,i-1),18,1)  &
+                                         + IBITS(wall_flags_0(k,j,i-1),19,1)  &
+                                         + IBITS(wall_flags_0(k,j,i-1),20,1)  &
+                                         )                                    &   
+                  ) * ddx                                                     &
+               +  ( v_comp                                                    &
+                                       * ( ibit21 + ibit22 + ibit23 )         &
+                - ( v(k,j,i)     + v(k,j-1,i) )                               &
+                                       * ( IBITS(wall_flags_0(k,j-1,i),21,1)  &
+                                         + IBITS(wall_flags_0(k,j-1,i),22,1)  &
+                                         + IBITS(wall_flags_0(k,j-1,i),23,1)  &
+                                         )                                    &   
+                  ) * ddy                                                     &
+               +  ( w_comp                                                    &
+                                       * ( ibit24 + ibit25 + ibit26 )         &
+                - ( w(k-1,j-1,i) + w(k-1,j,i) )                               &
+                                       * ( IBITS(wall_flags_0(k-1,j,i),24,1)  &
+                                         + IBITS(wall_flags_0(k-1,j,i),25,1)  &
+                                         + IBITS(wall_flags_0(k-1,j,i),26,1)  &
+                                         )                                    &
+                   ) * ddzw(k)   &
+                ) * 0.5_wp
+
+
+                tend(k,j,i) = - (                                              &
+                               ( flux_r + diss_r - flux_l - diss_l ) * ddx     &
+                             + ( flux_n + diss_n - flux_s - diss_s ) * ddy     &
+                             + ( flux_t + diss_t - flux_d - diss_d ) * ddzw(k) &
+                                ) + div * v(k,j,i)
+
+
+!++
+!--             Statistical Evaluation of v'v'. The factor has to be applied
+!--             for right evaluation when gallilei_trans = .T. .
+!                sums_vs2_ws_l(k,tn) = sums_vs2_ws_l(k,tn)                  &
+!                      + ( flux_n                                           &
+!                      * ( v_comp - 2.0_wp * hom(k,1,2,0) )                    &
+!                      / ( v_comp - gv + 1.0E-20_wp )                       &
+!                      +   diss_n                                           &
+!                      *   ABS( v_comp - 2.0_wp * hom(k,1,2,0) )               &
+!                      / ( ABS( v_comp - gv ) +1.0E-20_wp ) )               &
+!                      *   weight_substep(intermediate_timestep_count)
+!
+!--              Statistical Evaluation of w'v'.
+!                 sums_wsvs_ws_l(k,tn) = sums_wsvs_ws_l(k,tn)                &
+!                              + ( flux_t + diss_t )                         &
+!                              *   weight_substep(intermediate_timestep_count)
+
+             ENDDO
+          ENDDO
+       ENDDO
+       !$acc end kernels
+
+!++
+!       sums_vs2_ws_l(nzb,tn) = sums_vs2_ws_l(nzb+1,tn)
+
+    END SUBROUTINE advec_v_ws_acc
+    
+    
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Advection of w - Call for all grid points
+!------------------------------------------------------------------------------!
+    SUBROUTINE advec_w_ws
+
+       USE arrays_3d,                                                          &
+           ONLY:  ddzu, tend, u, v, w
+
+       USE constants,                                                          &
+           ONLY:  adv_mom_1, adv_mom_3, adv_mom_5
+
+       USE control_parameters,                                                 &
+           ONLY:  intermediate_timestep_count, u_gtrans, v_gtrans
+
+       USE grid_variables,                                                     &
+           ONLY:  ddx, ddy
+
+       USE indices,                                                            &
+           ONLY:  nxl, nxr, nyn, nys, nzb, nzb_max, nzt, wall_flags_0,         &
+                  wall_flags_00
+
+       USE kinds
+       
+       USE statistics,                                                         &
+           ONLY:  hom, sums_ws2_ws_l, weight_substep
+
+       IMPLICIT NONE
+
+       INTEGER(iwp) ::  i      !<
+       INTEGER(iwp) ::  ibit27 !<
+       INTEGER(iwp) ::  ibit28 !<
+       INTEGER(iwp) ::  ibit29 !<
+       INTEGER(iwp) ::  ibit30 !<
+       INTEGER(iwp) ::  ibit31 !<
+       INTEGER(iwp) ::  ibit32 !<
+       INTEGER(iwp) ::  ibit33 !<
+       INTEGER(iwp) ::  ibit34 !<
+       INTEGER(iwp) ::  ibit35 !<
+       INTEGER(iwp) ::  j      !<
+       INTEGER(iwp) ::  k      !<
+       INTEGER(iwp) ::  k_mm   !<
+       INTEGER(iwp) ::  k_pp   !<
+       INTEGER(iwp) ::  k_ppp  !<
+       INTEGER(iwp) ::  tn = 0 !<
+       
+       REAL(wp)    ::  diss_d !<
+       REAL(wp)    ::  div    !<
+       REAL(wp)    ::  flux_d !<
+       REAL(wp)    ::  gu     !<
+       REAL(wp)    ::  gv     !<
+       REAL(wp)    ::  u_comp !<
+       REAL(wp)    ::  v_comp !<
+       REAL(wp)    ::  w_comp !<
+       
+       REAL(wp), DIMENSION(nzb:nzt)    ::  diss_t !<
+       REAL(wp), DIMENSION(nzb:nzt)    ::  flux_t !<
+       
+       REAL(wp), DIMENSION(nzb+1:nzt)  ::  diss_n !<
+       REAL(wp), DIMENSION(nzb+1:nzt)  ::  diss_r !<
+       REAL(wp), DIMENSION(nzb+1:nzt)  ::  flux_n !<
+       REAL(wp), DIMENSION(nzb+1:nzt)  ::  flux_r !<
+       REAL(wp), DIMENSION(nzb+1:nzt)  ::  swap_diss_y_local_w !<
+       REAL(wp), DIMENSION(nzb+1:nzt)  ::  swap_flux_y_local_w !<
+       
+       REAL(wp), DIMENSION(nzb+1:nzt,nys:nyn) ::  swap_diss_x_local_w !<
+       REAL(wp), DIMENSION(nzb+1:nzt,nys:nyn) ::  swap_flux_x_local_w !<
+ 
+       gu = 2.0_wp * u_gtrans
+       gv = 2.0_wp * v_gtrans
+!
+!--   compute the whole left boundary of the processor domain
+       i = nxl
+       DO  j = nys, nyn
+          DO  k = nzb+1, nzb_max
+
+             ibit29 = IBITS(wall_flags_0(k,j,i-1),29,1)
+             ibit28 = IBITS(wall_flags_0(k,j,i-1),28,1)
+             ibit27 = IBITS(wall_flags_0(k,j,i-1),27,1)
+
+             u_comp                   = u(k+1,j,i) + u(k,j,i) - gu
+             swap_flux_x_local_w(k,j) = u_comp * (                             &
+                                      ( 37.0_wp * ibit29 * adv_mom_5              &
+                                   +     7.0_wp * ibit28 * adv_mom_3              &
+                                   +              ibit27 * adv_mom_1              &
+                                      ) *                                      &
+                                     ( w(k,j,i)   + w(k,j,i-1) )               &
+                               -      (  8.0_wp * ibit29 * adv_mom_5              &
+                                   +              ibit28 * adv_mom_3              &
+                                      ) *                                      &
+                                     ( w(k,j,i+1) + w(k,j,i-2) )               &
+                               +      (           ibit29 * adv_mom_5              &
+                                      ) *                                      &
+                                     ( w(k,j,i+2) + w(k,j,i-3) )               &
+                                                 )
+
+               swap_diss_x_local_w(k,j) = - ABS( u_comp ) * (                  &
+                                        ( 10.0_wp * ibit29 * adv_mom_5            &
+                                     +     3.0_wp * ibit28 * adv_mom_3            &
+                                     +              ibit27 * adv_mom_1            &
+                                        ) *                                    &
+                                     ( w(k,j,i)   - w(k,j,i-1) )               &
+                                 -      (  5.0_wp * ibit29 * adv_mom_5            &
+                                     +              ibit28 * adv_mom_3            &
+                                        ) *                                    &
+                                     ( w(k,j,i+1) - w(k,j,i-2) )               &
+                                 +      (           ibit29 * adv_mom_5            &
+                                        ) *                                    &
+                                     ( w(k,j,i+2) - w(k,j,i-3) )               &
+                                                            )
+
+          ENDDO
+
+          DO  k = nzb_max+1, nzt
+
+             u_comp                   = u(k+1,j,i) + u(k,j,i) - gu
+             swap_flux_x_local_w(k,j) = u_comp * (                             &
+                            37.0_wp * ( w(k,j,i) + w(k,j,i-1)   )                 &
+                          -  8.0_wp * ( w(k,j,i+1) + w(k,j,i-2) )                 &
+                          +           ( w(k,j,i+2) + w(k,j,i-3) ) ) * adv_mom_5
+             swap_diss_x_local_w(k,j) = - ABS( u_comp ) * (                    &
+                            10.0_wp * ( w(k,j,i) - w(k,j,i-1)   )                 &
+                          -  5.0_wp * ( w(k,j,i+1) - w(k,j,i-2) )                 &
+                          +           ( w(k,j,i+2) - w(k,j,i-3) ) ) * adv_mom_5
+
+          ENDDO
+
+       ENDDO
+
+       DO i = nxl, nxr
+
+          j = nys
+          DO  k = nzb+1, nzb_max
+
+             ibit32 = IBITS(wall_flags_00(k,j-1,i),0,1)
+             ibit31 = IBITS(wall_flags_0(k,j-1,i),31,1)
+             ibit30 = IBITS(wall_flags_0(k,j-1,i),30,1)
+
+             v_comp                 = v(k+1,j,i) + v(k,j,i) - gv
+             swap_flux_y_local_w(k) = v_comp * (                              &
+                                    ( 37.0_wp * ibit32 * adv_mom_5               &
+                                 +     7.0_wp * ibit31 * adv_mom_3               &
+                                 +              ibit30 * adv_mom_1               &
+                                    ) *                                        &
+                                     ( w(k,j,i)   + w(k,j-1,i) )              &
+                             -      (  8.0_wp * ibit32 * adv_mom_5               &
+                                 +              ibit31 * adv_mom_3               &
+                                    ) *                                       &
+                                     ( w(k,j+1,i) + w(k,j-2,i) )              &
+                             +      (           ibit32 * adv_mom_5               &
+                                    ) *                                       &
+                                     ( w(k,j+2,i) + w(k,j-3,i) )              &
+                                               )
+
+             swap_diss_y_local_w(k) = - ABS( v_comp ) * (                     &
+                                    ( 10.0_wp * ibit32 * adv_mom_5               &
+                                 +     3.0_wp * ibit31 * adv_mom_3               &
+                                 +              ibit30 * adv_mom_1               &
+                                    ) *                                       &
+                                     ( w(k,j,i)   - w(k,j-1,i) )              &
+                             -      (  5.0_wp * ibit32 * adv_mom_5               &
+                                 +              ibit31 * adv_mom_3               &
+                                    ) *                                       &
+                                     ( w(k,j+1,i) - w(k,j-2,i) )              &
+                             +      (           ibit32 * adv_mom_5               &
+                                    ) *                                       &
+                                     ( w(k,j+2,i) - w(k,j-3,i) )              &
+                                                        )
+
+          ENDDO
+
+          DO  k = nzb_max+1, nzt
+
+             v_comp                 = v(k+1,j,i) + v(k,j,i) - gv
+             swap_flux_y_local_w(k) = v_comp * (                              &
+                           37.0_wp * ( w(k,j,i) + w(k,j-1,i)   )                 &
+                         -  8.0_wp * ( w(k,j+1,i) +w(k,j-2,i)  )                 &
+                         +           ( w(k,j+2,i) + w(k,j-3,i) ) ) * adv_mom_5
+             swap_diss_y_local_w(k) = - ABS( v_comp ) * (                     &
+                           10.0_wp * ( w(k,j,i) - w(k,j-1,i)   )                 &
+                         -  5.0_wp * ( w(k,j+1,i) - w(k,j-2,i) )                 &
+                         +           ( w(k,j+2,i) - w(k,j-3,i) ) ) * adv_mom_5
+
+          ENDDO
+
+          DO  j = nys, nyn
+
+!
+!--          The lower flux has to be calculated explicetely for the tendency
+!--          at the first w-level. For topography wall this is done implicitely
+!--          by wall_flags_0.
+             k         = nzb + 1
+             w_comp    = w(k,j,i) + w(k-1,j,i)
+             flux_t(0) = w_comp       * ( w(k,j,i) + w(k-1,j,i) ) * adv_mom_1
+             diss_t(0) = -ABS(w_comp) * ( w(k,j,i) - w(k-1,j,i) ) * adv_mom_1
+             flux_d    = flux_t(0)
+             diss_d    = diss_t(0)
+
+             DO  k = nzb+1, nzb_max
+
+                ibit29 = IBITS(wall_flags_0(k,j,i),29,1)
+                ibit28 = IBITS(wall_flags_0(k,j,i),28,1)
+                ibit27 = IBITS(wall_flags_0(k,j,i),27,1)
+
+                u_comp    = u(k+1,j,i+1) + u(k,j,i+1) - gu
+                flux_r(k) = u_comp * (                                       &
+                          ( 37.0_wp * ibit29 * adv_mom_5                        &
+                       +     7.0_wp * ibit28 * adv_mom_3                        &
+                       +              ibit27 * adv_mom_1                        &
+                          ) *                                                &
+                                 ( w(k,j,i+1) + w(k,j,i)   )                 &
+                   -      (  8.0_wp * ibit29 * adv_mom_5                        &
+                       +              ibit28 * adv_mom_3                        &
+                          ) *                                                &
+                                 ( w(k,j,i+2) + w(k,j,i-1) )                 &
+                   +      (           ibit29 * adv_mom_5                        &
+                          ) *                                                &
+                                 ( w(k,j,i+3) + w(k,j,i-2) )                 &
+                                     )
+
+                diss_r(k) = - ABS( u_comp ) * (                              &
+                          ( 10.0_wp * ibit29 * adv_mom_5                        &
+                       +     3.0_wp * ibit28 * adv_mom_3                        &
+                       +              ibit27 * adv_mom_1                        &
+                          ) *                                                &
+                                 ( w(k,j,i+1) - w(k,j,i)  )                  &
+                   -      (  5.0_wp * ibit29 * adv_mom_5                        &
+                       +              ibit28 * adv_mom_3                        &
+                          ) *                                                &
+                                 ( w(k,j,i+2) - w(k,j,i-1) )                 &
+                   +      (           ibit29 * adv_mom_5                        &
+                          ) *                                                &
+                                 ( w(k,j,i+3) - w(k,j,i-2) )                 &
+                                              )
+
+                ibit32 = IBITS(wall_flags_00(k,j,i),0,1)
+                ibit31 = IBITS(wall_flags_0(k,j,i),31,1)
+                ibit30 = IBITS(wall_flags_0(k,j,i),30,1)
+
+                v_comp    = v(k+1,j+1,i) + v(k,j+1,i) - gv
+                flux_n(k) = v_comp * (                                       &
+                          ( 37.0_wp * ibit32 * adv_mom_5                        &
+                       +     7.0_wp * ibit31 * adv_mom_3                        &
+                       +              ibit30 * adv_mom_1                        &
+                          ) *                                                &
+                                 ( w(k,j+1,i) + w(k,j,i)   )                 &
+                   -      (  8.0_wp * ibit32 * adv_mom_5                        &
+                       +              ibit31 * adv_mom_3                        &
+                          ) *                                                 &
+                                 ( w(k,j+2,i) + w(k,j-1,i) )                 &
+                   +      (           ibit32 * adv_mom_5                        &
+                          ) *                                                &
+                                 ( w(k,j+3,i) + w(k,j-2,i) )                 &
+                                     )
+
+                diss_n(k) = - ABS( v_comp ) * (                              &
+                          ( 10.0_wp * ibit32 * adv_mom_5                        &
+                       +     3.0_wp * ibit31 * adv_mom_3                        &
+                       +              ibit30 * adv_mom_1                        &
+                          ) *                                                &
+                                 ( w(k,j+1,i) - w(k,j,i)  )                  &
+                   -      (  5.0_wp * ibit32 * adv_mom_5                        &
+                       +              ibit31 * adv_mom_3                        &
+                          ) *                                                &
+                                 ( w(k,j+2,i) - w(k,j-1,i) )                 &
+                   +      (           ibit32 * adv_mom_5                        &
+                          ) *                                                &
+                                 ( w(k,j+3,i) - w(k,j-2,i) )                 &
+                                              )
+!
+!--             k index has to be modified near bottom and top, else array
+!--             subscripts will be exceeded.
+                ibit35 = IBITS(wall_flags_00(k,j,i),3,1)
+                ibit34 = IBITS(wall_flags_00(k,j,i),2,1)
+                ibit33 = IBITS(wall_flags_00(k,j,i),1,1)
+
+                k_ppp = k + 3 * ibit35
+                k_pp  = k + 2 * ( 1 - ibit33  )
+                k_mm  = k - 2 * ibit35
+
+                w_comp    = w(k+1,j,i) + w(k,j,i)
+                flux_t(k) = w_comp  * (                                      &
+                          ( 37.0_wp * ibit35 * adv_mom_5                        &
+                       +     7.0_wp * ibit34 * adv_mom_3                        &
+                       +              ibit33 * adv_mom_1                        &
+                          ) *                                                &
+                             ( w(k+1,j,i)  + w(k,j,i)     )                  &
+                   -      (  8.0_wp * ibit35 * adv_mom_5                        &
+                       +              ibit34 * adv_mom_3                        &
+                          ) *                                                &
+                             ( w(k_pp,j,i)  + w(k-1,j,i)  )                  &
+                   +      (           ibit35 * adv_mom_5                        &
+                          ) *                                                &
+                             ( w(k_ppp,j,i) + w(k_mm,j,i) )                  &
+                                       )
+
+                diss_t(k) = - ABS( w_comp ) * (                              &
+                          ( 10.0_wp * ibit35 * adv_mom_5                        &
+                       +     3.0_wp * ibit34 * adv_mom_3                        &
+                       +              ibit33 * adv_mom_1                        &
+                          ) *                                                &
+                             ( w(k+1,j,i)   - w(k,j,i)    )                  &
+                   -      (  5.0_wp * ibit35 * adv_mom_5                        &
+                       +              ibit34 * adv_mom_3                        &
+                          ) *                                                &
+                             ( w(k_pp,j,i)  - w(k-1,j,i)  )                  &
+                   +      (           ibit35 * adv_mom_5                        &
+                          ) *                                                &
+                             ( w(k_ppp,j,i) - w(k_mm,j,i) )                  &
+                                               )
+!
+!--             Calculate the divergence of the velocity field. A respective
+!--             correction is needed to overcome numerical instabilities caused
+!--             by a not sufficient reduction of divergences near topography.
+                div = ( ( ( u_comp + gu ) * ( ibit27 + ibit28 + ibit29 )      &
+                  - ( u(k+1,j,i) + u(k,j,i)   )                               & 
+                                    * ( IBITS(wall_flags_0(k,j,i-1),27,1)     &
+                                      + IBITS(wall_flags_0(k,j,i-1),28,1)     &
+                                      + IBITS(wall_flags_0(k,j,i-1),29,1)     &
+                                      )                                       &
+                  ) * ddx                                                     &
+              +   ( ( v_comp + gv ) * ( ibit30 + ibit31 + ibit32 )            & 
+                  - ( v(k+1,j,i) + v(k,j,i)   )                               &
+                                    * ( IBITS(wall_flags_0(k,j-1,i),30,1)     &
+                                      + IBITS(wall_flags_0(k,j-1,i),31,1)     &
+                                      + IBITS(wall_flags_00(k,j-1,i),0,1)     &
+                                      )                                       &
+                  ) * ddy                                                     &
+              +   ( w_comp          * ( ibit33 + ibit34 + ibit35 )            &
+                - ( w(k,j,i)   + w(k-1,j,i)   )                               &
+                                    * ( IBITS(wall_flags_00(k-1,j,i),1,1)     &
+                                      + IBITS(wall_flags_00(k-1,j,i),2,1)     &
+                                      + IBITS(wall_flags_00(k-1,j,i),3,1)     &
+                                      )                                       & 
+                  ) * ddzu(k+1)   &
+                ) * 0.5_wp
+
+
+
+                tend(k,j,i) = tend(k,j,i) - (                                 &
+                      ( flux_r(k) + diss_r(k)                                 &
+                    -   swap_flux_x_local_w(k,j) - swap_diss_x_local_w(k,j)   &
+                      ) * ddx                                                 &
+                    + ( flux_n(k) + diss_n(k)                                 &
+                    -   swap_flux_y_local_w(k)   - swap_diss_y_local_w(k)     &
+                      ) * ddy                                                 &
+                    + ( flux_t(k) + diss_t(k)                                 &
+                    -   flux_d    - diss_d                                    &
+                      ) * ddzu(k+1)                                           &
+                                            )  + div * w(k,j,i)
+
+                swap_flux_x_local_w(k,j) = flux_r(k)
+                swap_diss_x_local_w(k,j) = diss_r(k)
+                swap_flux_y_local_w(k)   = flux_n(k)
+                swap_diss_y_local_w(k)   = diss_n(k)
+                flux_d                   = flux_t(k)
+                diss_d                   = diss_t(k)
+
+                sums_ws2_ws_l(k,tn)  = sums_ws2_ws_l(k,tn)                    &
+                               + ( flux_t(k) + diss_t(k) )                    &
+                               *   weight_substep(intermediate_timestep_count)
+
+             ENDDO
+
+             DO  k = nzb_max+1, nzt
+
+                u_comp    = u(k+1,j,i+1) + u(k,j,i+1) - gu
+                flux_r(k) = u_comp * (                                      &
+                      37.0_wp * ( w(k,j,i+1) + w(k,j,i)   )                    &
+                    -  8.0_wp * ( w(k,j,i+2) + w(k,j,i-1) )                    &
+                    +           ( w(k,j,i+3) + w(k,j,i-2) ) ) * adv_mom_5
+
+                diss_r(k) = - ABS( u_comp ) * (                             &
+                      10.0_wp * ( w(k,j,i+1) - w(k,j,i)   )                    &
+                    -  5.0_wp * ( w(k,j,i+2) - w(k,j,i-1) )                    &
+                    +           ( w(k,j,i+3) - w(k,j,i-2) ) ) * adv_mom_5
+
+                v_comp    = v(k+1,j+1,i) + v(k,j+1,i) - gv
+                flux_n(k) = v_comp * (                                      &
+                      37.0_wp * ( w(k,j+1,i) + w(k,j,i)   )                    &
+                    -  8.0_wp * ( w(k,j+2,i) + w(k,j-1,i) )                    &
+                    +           ( w(k,j+3,i) + w(k,j-2,i) ) ) * adv_mom_5
+
+                diss_n(k) = - ABS( v_comp ) * (                             &
+                      10.0_wp * ( w(k,j+1,i) - w(k,j,i)   )                    &
+                    -  5.0_wp * ( w(k,j+2,i) - w(k,j-1,i) )                    &
+                    +           ( w(k,j+3,i) - w(k,j-2,i) ) ) * adv_mom_5
+!
+!--             k index has to be modified near bottom and top, else array
+!--             subscripts will be exceeded.
+                ibit35 = IBITS(wall_flags_00(k,j,i),3,1)
+                ibit34 = IBITS(wall_flags_00(k,j,i),2,1)
+                ibit33 = IBITS(wall_flags_00(k,j,i),1,1)
+
+                k_ppp = k + 3 * ibit35
+                k_pp  = k + 2 * ( 1 - ibit33  )
+                k_mm  = k - 2 * ibit35
+
+                w_comp    = w(k+1,j,i) + w(k,j,i)
+                flux_t(k) = w_comp  * (                                      &
+                          ( 37.0_wp * ibit35 * adv_mom_5                        &
+                       +     7.0_wp * ibit34 * adv_mom_3                        &
+                       +              ibit33 * adv_mom_1                        &
+                          ) *                                                &
+                             ( w(k+1,j,i)  + w(k,j,i)     )                  &
+                   -      (  8.0_wp * ibit35 * adv_mom_5                        &
+                       +              ibit34 * adv_mom_3                        &
+                          ) *                                                &
+                             ( w(k_pp,j,i)  + w(k-1,j,i)  )                  &
+                   +      (           ibit35 * adv_mom_5                        &
+                          ) *                                                &
+                             ( w(k_ppp,j,i) + w(k_mm,j,i) )                  &
+                                       )
+
+                diss_t(k) = - ABS( w_comp ) * (                              &
+                          ( 10.0_wp * ibit35 * adv_mom_5                        &
+                       +     3.0_wp * ibit34 * adv_mom_3                        &
+                       +              ibit33 * adv_mom_1                        &
+                          ) *                                                &
+                             ( w(k+1,j,i)   - w(k,j,i)    )                  &
+                   -      (  5.0_wp * ibit35 * adv_mom_5                        &
+                       +              ibit34 * adv_mom_3                        &
+                          ) *                                                &
+                             ( w(k_pp,j,i)  - w(k-1,j,i)  )                  &
+                   +      (           ibit35 * adv_mom_5                        &
+                          ) *                                                &
+                             ( w(k_ppp,j,i) - w(k_mm,j,i) )                  &
+                                               )
+!
+!--             Calculate the divergence of the velocity field. A respective
+!--             correction is needed to overcome numerical instabilities caused
+!--             by a not sufficient reduction of divergences near topography.
+                div = ( ( u_comp + gu - ( u(k+1,j,i) + u(k,j,i)   ) ) * ddx  &
+                    +   ( v_comp + gv - ( v(k+1,j,i) + v(k,j,i)   ) ) * ddy  &
+                    +   ( w_comp      - ( w(k,j,i)   + w(k-1,j,i) ) )        &
+                                                                 * ddzu(k+1) &
+                      ) * 0.5_wp
+
+                tend(k,j,i) = tend(k,j,i) - (                                 &
+                      ( flux_r(k) + diss_r(k)                                 &
+                    -   swap_flux_x_local_w(k,j) - swap_diss_x_local_w(k,j)   &
+                      ) * ddx                                                 &
+                    + ( flux_n(k) + diss_n(k)                                 &
+                    -   swap_flux_y_local_w(k)   - swap_diss_y_local_w(k)     &
+                      ) * ddy                                                 &
+                    + ( flux_t(k) + diss_t(k)                                 &
+                    -   flux_d    - diss_d                                    &
+                      ) * ddzu(k+1)                                           &
+                                            )  + div * w(k,j,i)
+
+                swap_flux_x_local_w(k,j) = flux_r(k)
+                swap_diss_x_local_w(k,j) = diss_r(k)
+                swap_flux_y_local_w(k)   = flux_n(k)
+                swap_diss_y_local_w(k)   = diss_n(k)
+                flux_d                   = flux_t(k)
+                diss_d                   = diss_t(k)
+
+                sums_ws2_ws_l(k,tn)  = sums_ws2_ws_l(k,tn)                    &
+                               + ( flux_t(k) + diss_t(k) )                    &
+                               *   weight_substep(intermediate_timestep_count)
+
+             ENDDO
+          ENDDO
+       ENDDO
+
+    END SUBROUTINE advec_w_ws
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Advection of w - Call for all grid points - accelerator version
+!------------------------------------------------------------------------------!
+    SUBROUTINE advec_w_ws_acc
+
+       USE arrays_3d,                                                          &
+           ONLY:  ddzu, tend, u, v, w
+
+       USE constants,                                                          &
+           ONLY:  adv_mom_1, adv_mom_3, adv_mom_5
+
+       USE control_parameters,                                                 &
+           ONLY:  intermediate_timestep_count, u_gtrans, v_gtrans
+
+       USE grid_variables,                                                     &
+           ONLY:  ddx, ddy
+
+       USE indices,                                                            &
+           ONLY:  i_left, i_right, j_north, j_south, nxl, nxr, nyn, nys, nzb,  &
+                  nzb_max, nzt, wall_flags_0, wall_flags_00
+           
+       USE kinds
+       
+!        USE statistics,                                                       &
+!            ONLY:  hom, sums_ws2_ws_l, weight_substep
+
+       IMPLICIT NONE
+
+       INTEGER(iwp) ::  i      !<
+       INTEGER(iwp) ::  ibit27 !<
+       INTEGER(iwp) ::  ibit28 !<
+       INTEGER(iwp) ::  ibit29 !<
+       INTEGER(iwp) ::  ibit30 !<
+       INTEGER(iwp) ::  ibit31 !<
+       INTEGER(iwp) ::  ibit32 !<
+       INTEGER(iwp) ::  ibit33 !<
+       INTEGER(iwp) ::  ibit34 !<
+       INTEGER(iwp) ::  ibit35 !<
+       INTEGER(iwp) ::  j      !<
+       INTEGER(iwp) ::  k      !<
+       INTEGER(iwp) ::  k_mmm  !<
+       INTEGER(iwp) ::  k_mm   !<
+       INTEGER(iwp) ::  k_pp   !<
+       INTEGER(iwp) ::  k_ppp  !<
+       INTEGER(iwp) ::  tn = 0 !<
+
+       REAL(wp)    ::  diss_d   !<
+       REAL(wp)    ::  diss_l   !<
+       REAL(wp)    ::  diss_n   !<
+       REAL(wp)    ::  diss_r   !<
+       REAL(wp)    ::  diss_s   !<
+       REAL(wp)    ::  diss_t   !<
+       REAL(wp)    ::  div      !<
+       REAL(wp)    ::  flux_d   !<
+       REAL(wp)    ::  flux_l   !<
+       REAL(wp)    ::  flux_n   !<
+       REAL(wp)    ::  flux_r   !<
+       REAL(wp)    ::  flux_s   !<
+       REAL(wp)    ::  flux_t   !<
+       REAL(wp)    ::  gu       !<
+       REAL(wp)    ::  gv       !<
+       REAL(wp)    ::  u_comp   !<
+       REAL(wp)    ::  u_comp_l !<
+       REAL(wp)    ::  v_comp   !<
+       REAL(wp)    ::  v_comp_s !<
+       REAL(wp)    ::  w_comp   !<
+
+       gu = 2.0_wp * u_gtrans
+       gv = 2.0_wp * v_gtrans
+
+
+!
+!--    Computation of fluxes and tendency terms
+       !$acc kernels present( ddzu, tend, u, v, w, wall_flags_0, wall_flags_00 )
+       DO i = i_left, i_right
+          DO  j = j_south, j_north
+             DO  k = nzb+1, nzt
+
+                ibit27 = IBITS(wall_flags_0(k,j,i-1),27,1)
+                ibit28 = IBITS(wall_flags_0(k,j,i-1),28,1)
+                ibit29 = IBITS(wall_flags_0(k,j,i-1),29,1)
+
+                u_comp_l                 = u(k+1,j,i) + u(k,j,i) - gu
+                flux_l                   = u_comp_l * (                        &
+                                      ( 37.0_wp * ibit29 * adv_mom_5              &
+                                   +     7.0_wp * ibit28 * adv_mom_3              &
+                                   +              ibit27 * adv_mom_1              &
+                                      ) *                                      &
+                                     ( w(k,j,i)   + w(k,j,i-1) )               &
+                               -      (  8.0_wp * ibit29 * adv_mom_5              &
+                                   +              ibit28 * adv_mom_3              &
+                                      ) *                                      &
+                                     ( w(k,j,i+1) + w(k,j,i-2) )               &
+                               +      (           ibit29 * adv_mom_5              &
+                                      ) *                                      &
+                                     ( w(k,j,i+2) + w(k,j,i-3) )               &
+                                                 )
+
+                diss_l                    = - ABS( u_comp_l ) * (              &
+                                        ( 10.0_wp * ibit29 * adv_mom_5            &
+                                     +     3.0_wp * ibit28 * adv_mom_3            &
+                                     +              ibit27 * adv_mom_1            &
+                                        ) *                                    &
+                                     ( w(k,j,i)   - w(k,j,i-1) )               &
+                                 -      (  5.0_wp * ibit29 * adv_mom_5            &
+                                     +              ibit28 * adv_mom_3            &
+                                        ) *                                    &
+                                     ( w(k,j,i+1) - w(k,j,i-2) )               &
+                                 +      (           ibit29 * adv_mom_5            &
+                                        ) *                                    &
+                                     ( w(k,j,i+2) - w(k,j,i-3) )               &
+                                                            )
+
+                ibit27 = IBITS(wall_flags_0(k,j,i),27,1)
+                ibit28 = IBITS(wall_flags_0(k,j,i),28,1)
+                ibit29 = IBITS(wall_flags_0(k,j,i),29,1)
+
+                u_comp    = u(k+1,j,i+1) + u(k,j,i+1) - gu
+                flux_r    = u_comp * (                                       &
+                          ( 37.0_wp * ibit29 * adv_mom_5                        &
+                       +     7.0_wp * ibit28 * adv_mom_3                        &
+                       +              ibit27 * adv_mom_1                        &
+                          ) *                                                &
+                                 ( w(k,j,i+1) + w(k,j,i)   )                 &
+                   -      (  8.0_wp * ibit29 * adv_mom_5                        &
+                       +              ibit28 * adv_mom_3                        &
+                          ) *                                                &
+                                 ( w(k,j,i+2) + w(k,j,i-1) )                 &
+                   +      (           ibit29 * adv_mom_5                        &
+                          ) *                                                &
+                                 ( w(k,j,i+3) + w(k,j,i-2) )                 &
+                                     )
+
+                diss_r    = - ABS( u_comp ) * (                              &
+                          ( 10.0_wp * ibit29 * adv_mom_5                        &
+                       +     3.0_wp * ibit28 * adv_mom_3                        &
+                       +              ibit27 * adv_mom_1                        &
+                          ) *                                                &
+                                 ( w(k,j,i+1) - w(k,j,i)  )                  &
+                   -      (  5.0_wp * ibit29 * adv_mom_5                        &
+                       +              ibit28 * adv_mom_3                        &
+                          ) *                                                &
+                                 ( w(k,j,i+2) - w(k,j,i-1) )                 &
+                   +      (           ibit29 * adv_mom_5                        &
+                          ) *                                                &
+                                 ( w(k,j,i+3) - w(k,j,i-2) )                 &
+                                              )
+                ibit32 = IBITS(wall_flags_00(k,j-1,i),0,1)
+                ibit31 = IBITS(wall_flags_0(k,j-1,i),31,1)
+                ibit30 = IBITS(wall_flags_0(k,j-1,i),30,1)
+
+                v_comp_s               = v(k+1,j,i) + v(k,j,i) - gv
+                flux_s                 = v_comp_s * (                         &
+                                    ( 37.0_wp * ibit32 * adv_mom_5               &
+                                 +     7.0_wp * ibit31 * adv_mom_3               &
+                                 +              ibit30 * adv_mom_1               &
+                                    ) *                                       &
+                                     ( w(k,j,i)   + w(k,j-1,i) )              &
+                             -      (  8.0_wp * ibit32 * adv_mom_5               &
+                                 +              ibit31 * adv_mom_3               &
+                                    ) *                                       &
+                                     ( w(k,j+1,i) + w(k,j-2,i) )              &
+                             +      (           ibit32 * adv_mom_5               &
+                                    ) *                                       &
+                                     ( w(k,j+2,i) + w(k,j-3,i) )              &
+                                               )
+
+                diss_s                 = - ABS( v_comp_s ) * (                &
+                                    ( 10.0_wp * ibit32 * adv_mom_5               &
+                                 +     3.0_wp * ibit31 * adv_mom_3               &
+                                 +              ibit30 * adv_mom_1               &
+                                    ) *                                       &
+                                     ( w(k,j,i)   - w(k,j-1,i) )              &
+                             -      (  5.0_wp * ibit32 * adv_mom_5               &
+                                 +              ibit31 * adv_mom_3               &
+                                    ) *                                       &
+                                     ( w(k,j+1,i) - w(k,j-2,i) )              &
+                             +      (           ibit32 * adv_mom_5               &
+                                    ) *                                       &
+                                     ( w(k,j+2,i) - w(k,j-3,i) )              &
+                                                        )
+
+                ibit32 = IBITS(wall_flags_00(k,j,i),0,1)
+                ibit31 = IBITS(wall_flags_0(k,j,i),31,1)
+                ibit30 = IBITS(wall_flags_0(k,j,i),30,1)
+
+                v_comp    = v(k+1,j+1,i) + v(k,j+1,i) - gv
+                flux_n    = v_comp * (                                       &
+                          ( 37.0_wp * ibit32 * adv_mom_5                        &
+                       +     7.0_wp * ibit31 * adv_mom_3                        &
+                       +              ibit30 * adv_mom_1                        &
+                          ) *                                                 &
+                                 ( w(k,j+1,i) + w(k,j,i)   )                 &
+                   -      (  8.0_wp * ibit32 * adv_mom_5                        &
+                       +              ibit31 * adv_mom_3                        &
+                          ) *                                                &
+                                 ( w(k,j+2,i) + w(k,j-1,i) )                 &
+                   +      (           ibit32 * adv_mom_5                        &
+                          ) *                                                &
+                                 ( w(k,j+3,i) + w(k,j-2,i) )                 &
+                                     )
+
+                diss_n    = - ABS( v_comp ) * (                              &
+                          ( 10.0_wp * ibit32 * adv_mom_5                        &
+                       +     3.0_wp * ibit31 * adv_mom_3                        &
+                       +              ibit30 * adv_mom_1                        &
+                          ) *                                                &
+                                 ( w(k,j+1,i) - w(k,j,i)  )                  &
+                   -      (  5.0_wp * ibit32 * adv_mom_5                        &
+                       +              ibit31 * adv_mom_3                        &
+                          ) *                                                &
+                                 ( w(k,j+2,i) - w(k,j-1,i) )                 &
+                   +      (           ibit32 * adv_mom_5                        &
+                          ) *                                                &
+                                 ( w(k,j+3,i) - w(k,j-2,i) )                 &
+                                              )
+
+                ibit35 = IBITS(wall_flags_00(k-1,j,i),3,1)
+                ibit34 = IBITS(wall_flags_00(k-1,j,i),2,1)
+                ibit33 = IBITS(wall_flags_00(k-1,j,i),1,1)
+
+                k_pp  = k + 2 * ibit35
+                k_mm  = k - 2 * ( ibit34 + ibit35 )
+                k_mmm = k - 3 * ibit35
+
+                w_comp    = w(k,j,i) + w(k-1,j,i)
+                flux_d    = w_comp  * (                                      &
+                          ( 37.0_wp * ibit35 * adv_mom_5                        &
+                       +     7.0_wp * ibit34 * adv_mom_3                        &
+                       +              ibit33 * adv_mom_1                        &
+                          ) *                                                &
+                             ( w(k,j,i)    + w(k-1,j,i)   )                  &
+                   -      (  8.0_wp * ibit35 * adv_mom_5                        &
+                       +              ibit34 * adv_mom_3                        &
+                          ) *                                                &
+                             ( w(k+1,j,i)  + w(k_mm,j,i)  )                  &
+                   +      (           ibit35 * adv_mom_5                        &
+                          ) *                                                &
+                             ( w(k_pp,j,i) + w(k_mmm,j,i) )                  &
+                                       )
+
+                diss_d    = - ABS( w_comp ) * (                              &
+                          ( 10.0_wp * ibit35 * adv_mom_5                        &
+                       +     3.0_wp * ibit34 * adv_mom_3                        &
+                       +              ibit33 * adv_mom_1                        &
+                          ) *                                                &
+                             ( w(k,j,i)    - w(k-1,j,i)   )                  &
+                   -      (  5.0_wp * ibit35 * adv_mom_5                        &
+                       +              ibit34 * adv_mom_3                        &
+                          ) *                                                &
+                             ( w(k+1,j,i)  - w(k_mm,j,i)  )                  &
+                   +      (           ibit35 * adv_mom_5                        &
+                          ) *                                                &
+                             ( w(k_pp,j,i) - w(k_mmm,j,i) )                  &
+                                               )
+
+!
+!--             k index has to be modified near bottom and top, else array
+!--             subscripts will be exceeded.
+                ibit35 = IBITS(wall_flags_00(k,j,i),3,1)
+                ibit34 = IBITS(wall_flags_00(k,j,i),2,1)
+                ibit33 = IBITS(wall_flags_00(k,j,i),1,1)
+
+                k_ppp = k + 3 * ibit35
+                k_pp  = k + 2 * ( 1 - ibit33  )
+                k_mm  = k - 2 * ibit35
+
+                w_comp    = w(k+1,j,i) + w(k,j,i)
+                flux_t    = w_comp  * (                                      &
+                          ( 37.0_wp * ibit35 * adv_mom_5                        &
+                       +     7.0_wp * ibit34 * adv_mom_3                        &
+                       +              ibit33 * adv_mom_1                        &
+                          ) *                                                &
+                             ( w(k+1,j,i)  + w(k,j,i)     )                  &
+                   -      (  8.0_wp * ibit35 * adv_mom_5                        &
+                       +              ibit34 * adv_mom_3                        &
+                          ) *                                                &
+                             ( w(k_pp,j,i)  + w(k-1,j,i)  )                  &
+                   +      (           ibit35 * adv_mom_5                        &
+                          ) *                                                &
+                             ( w(k_ppp,j,i) + w(k_mm,j,i) )                  &
+                                       )
+
+                diss_t    = - ABS( w_comp ) * (                              &
+                          ( 10.0_wp * ibit35 * adv_mom_5                        &
+                       +     3.0_wp * ibit34 * adv_mom_3                        &
+                       +              ibit33 * adv_mom_1                        &
+                          ) *                                                &
+                             ( w(k+1,j,i)   - w(k,j,i)    )                  &
+                   -      (  5.0_wp * ibit35 * adv_mom_5                        &
+                       +              ibit34 * adv_mom_3                        &
+                          ) *                                                &
+                             ( w(k_pp,j,i)  - w(k-1,j,i)  )                  &
+                   +      (           ibit35 * adv_mom_5                        &
+                          ) *                                                &
+                             ( w(k_ppp,j,i) - w(k_mm,j,i) )                  &
+                                               )
+!
+!--             Calculate the divergence of the velocity field. A respective
+!--             correction is needed to overcome numerical instabilities caused
+!--             by a not sufficient reduction of divergences near topography.
+                div = ( ( ( u_comp + gu ) * ( ibit27 + ibit28 + ibit29 )      &
+                  - ( u(k+1,j,i) + u(k,j,i)   )                               & 
+                                    * ( IBITS(wall_flags_0(k,j,i-1),27,1)     &
+                                      + IBITS(wall_flags_0(k,j,i-1),28,1)     &
+                                      + IBITS(wall_flags_0(k,j,i-1),29,1)     &
+                                      )                                       &
+                  ) * ddx                                                     &
+              +   ( ( v_comp + gv ) * ( ibit30 + ibit31 + ibit32 )            & 
+                  - ( v(k+1,j,i) + v(k,j,i)   )                               &
+                                    * ( IBITS(wall_flags_0(k,j-1,i),30,1)     &
+                                      + IBITS(wall_flags_0(k,j-1,i),31,1)     &
+                                      + IBITS(wall_flags_00(k,j-1,i),0,1)     &
+                                      )                                       &
+                  ) * ddy                                                     &
+              +   ( w_comp          * ( ibit33 + ibit34 + ibit35 )            &
+                - ( w(k,j,i)   + w(k-1,j,i)   )                               &
+                                    * ( IBITS(wall_flags_00(k-1,j,i),1,1)     &
+                                      + IBITS(wall_flags_00(k-1,j,i),2,1)     &
+                                      + IBITS(wall_flags_00(k-1,j,i),3,1)     &
+                                      )                                       & 
+                  ) * ddzu(k+1)   &
+                ) * 0.5_wp
+
+
+                tend(k,j,i) = - (                                                &
+                               ( flux_r + diss_r - flux_l - diss_l ) * ddx       &
+                             + ( flux_n + diss_n - flux_s - diss_s ) * ddy       &
+                             + ( flux_t + diss_t - flux_d - diss_d ) * ddzu(k+1) &
+                                 ) + div * w(k,j,i)
+
+
+!++
+!--             Statistical Evaluation of w'w'.
+!                sums_ws2_ws_l(k,tn)  = sums_ws2_ws_l(k,tn)                    &
+!                               + ( flux_t + diss_t )                    &
+!                               *   weight_substep(intermediate_timestep_count)
+
+             ENDDO
+          ENDDO
+       ENDDO
+       !$acc end kernels
+
+    END SUBROUTINE advec_w_ws_acc
+
+ END MODULE advec_ws
Index: lm/trunk/SOURCE/buoyancy.f90
===================================================================
--- /palm/trunk/SOURCE/buoyancy.f90	(revision 1849)
+++ 	(revision )
@@ -1,393 +1,0 @@
-!> @file buoyancy.f90
-!--------------------------------------------------------------------------------!
-! This file is part of PALM.
-!
-! PALM is free software: you can redistribute it and/or modify it under the terms
-! of the GNU General Public License as published by the Free Software Foundation,
-! either version 3 of the License, or (at your option) any later version.
-!
-! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
-! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
-! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along with
-! PALM. If not, see <http://www.gnu.org/licenses/>.
-!
-! Copyright 1997-2016 Leibniz Universitaet Hannover
-!--------------------------------------------------------------------------------!
-!
-! Current revisions:
-! ------------------
-! 
-! 
-! Former revisions:
-! -----------------
-! $Id$
-!
-! 1682 2015-10-07 23:56:08Z knoop
-! Code annotations made doxygen readable 
-! 
-! 1374 2014-04-25 12:55:07Z raasch
-! missing variables added to ONLY list
-! 
-! 1365 2014-04-22 15:03:56Z boeske
-! Calculation of reference state in subroutine calc_mean_profile moved to
-! subroutine time_integration,
-! subroutine calc_mean_profile moved to new file calc_mean_profile.f90
-! 
-! 1353 2014-04-08 15:21:23Z heinze
-! REAL constants provided with KIND-attribute
-!
-! 1320 2014-03-20 08:40:49Z raasch
-! ONLY-attribute added to USE-statements,
-! kind-parameters added to all INTEGER and REAL declaration statements,
-! kinds are defined in new module kinds,
-! revision history before 2012 removed,
-! comment fields (!:) to be used for variable explanations added to
-! all variable declaration statements
-!
-! 1257 2013-11-08 15:18:40Z raasch
-! vector length (32) removed from openacc clause
-!
-! 1241 2013-10-30 11:36:58Z heinze
-! Generalize calc_mean_profile for wider use: use additional steering 
-! character loc 
-!
-! 1179 2013-06-14 05:57:58Z raasch
-! steering of reference state revised (var_reference and pr removed from
-! parameter list), use_reference renamed use_single_reference_value
-!
-! 1171 2013-05-30 11:27:45Z raasch
-! openacc statements added to use_reference-case in accelerator version
-!
-! 1153 2013-05-10 14:33:08Z raasch
-! code adjustments of accelerator version required by PGI 12.3 / CUDA 5.0
-!
-! 1128 2013-04-12 06:19:32Z raasch
-! loop index bounds in accelerator version replaced by i_left, i_right, j_south,
-! j_north
-!
-! 1036 2012-10-22 13:43:42Z raasch
-! code put under GPL (PALM 3.9)
-!
-! 1015 2012-09-27 09:23:24Z raasch
-! accelerator version (*_acc) added
-!
-! 1010 2012-09-20 07:59:54Z raasch
-! cpp switch __nopointer added for pointer free version
-!
-! Revision 1.1  1997/08/29 08:56:48  raasch
-! Initial revision
-!
-!
-! Description:
-! ------------
-!> Buoyancy term of the third component of the equation of motion.
-!> @attention Humidity is not regarded when using a sloping surface!
-!------------------------------------------------------------------------------!
- MODULE buoyancy_mod
- 
-
-    PRIVATE
-    PUBLIC buoyancy, buoyancy_acc
-
-    INTERFACE buoyancy
-       MODULE PROCEDURE buoyancy
-       MODULE PROCEDURE buoyancy_ij
-    END INTERFACE buoyancy
-
-    INTERFACE buoyancy_acc
-       MODULE PROCEDURE buoyancy_acc
-    END INTERFACE buoyancy_acc
-
- CONTAINS
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Call for all grid points
-!------------------------------------------------------------------------------!
-    SUBROUTINE buoyancy( var, wind_component )
-
-       USE arrays_3d,                                                          &
-           ONLY:  pt, pt_slope_ref, ref_state, tend
-
-       USE control_parameters,                                                 &
-           ONLY:  atmos_ocean_sign, cos_alpha_surface, g, message_string,      &
-                  pt_surface, sin_alpha_surface, sloping_surface
-
-       USE indices,                                                            &
-           ONLY:  nxl, nxlg, nxlu, nxr, nxrg, nyn, nyng, nys, nysg, nzb,       &
-                  nzb_s_inner, nzt
-
-       USE kinds
-
-       USE pegrid
-
-
-       IMPLICIT NONE
-
-       INTEGER(iwp) ::  i              !<
-       INTEGER(iwp) ::  j              !<
-       INTEGER(iwp) ::  k              !<
-       INTEGER(iwp) ::  wind_component !<
-       
-#if defined( __nopointer )
-       REAL(wp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ::  var !<
-#else
-       REAL(wp), DIMENSION(:,:,:), POINTER ::  var
-#endif
-
-
-       IF ( .NOT. sloping_surface )  THEN
-!
-!--       Normal case: horizontal surface
-          DO  i = nxl, nxr
-             DO  j = nys, nyn
-                DO  k = nzb_s_inner(j,i)+1, nzt-1
-                   tend(k,j,i) = tend(k,j,i) + atmos_ocean_sign * g * 0.5_wp * &
-                          (                                                    &
-                             ( var(k,j,i)   - ref_state(k) )   / ref_state(k) + &
-                             ( var(k+1,j,i) - ref_state(k+1) ) / ref_state(k+1) &
-                          )
-                ENDDO
-             ENDDO
-          ENDDO
-
-       ELSE
-!
-!--       Buoyancy term for a surface with a slope in x-direction. The equations
-!--       for both the u and w velocity-component contain proportionate terms.
-!--       Temperature field at time t=0 serves as environmental temperature.
-!--       Reference temperature (pt_surface) is the one at the lower left corner
-!--       of the total domain.
-          IF ( wind_component == 1 )  THEN
-
-             DO  i = nxlu, nxr
-                DO  j = nys, nyn
-                   DO  k = nzb_s_inner(j,i)+1, nzt-1
-                      tend(k,j,i) = tend(k,j,i) + g * sin_alpha_surface *      &
-                           0.5_wp * ( ( pt(k,j,i-1)         + pt(k,j,i)         ) &
-                                    - ( pt_slope_ref(k,i-1) + pt_slope_ref(k,i) ) &
-                                    ) / pt_surface
-                   ENDDO
-                ENDDO
-             ENDDO
-
-          ELSEIF ( wind_component == 3 )  THEN
-
-             DO  i = nxl, nxr
-                DO  j = nys, nyn
-                   DO  k = nzb_s_inner(j,i)+1, nzt-1
-                      tend(k,j,i) = tend(k,j,i) + g * cos_alpha_surface *      &
-                           0.5_wp * ( ( pt(k,j,i)         + pt(k+1,j,i)         ) &
-                                    - ( pt_slope_ref(k,i) + pt_slope_ref(k+1,i) ) &
-                                    ) / pt_surface
-                   ENDDO
-                ENDDO
-            ENDDO
-
-          ELSE
-             
-             WRITE( message_string, * ) 'no term for component "',             &
-                                       wind_component,'"'
-             CALL message( 'buoyancy', 'PA0159', 1, 2, 0, 6, 0 )
-
-          ENDIF
-
-       ENDIF
-
-    END SUBROUTINE buoyancy
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Call for all grid points - accelerator version
-!------------------------------------------------------------------------------!
-    SUBROUTINE buoyancy_acc( var, wind_component )
-
-       USE arrays_3d,                                                          &
-           ONLY:  pt, pt_slope_ref, ref_state, tend
-
-       USE control_parameters,                                                 &
-           ONLY:  atmos_ocean_sign, cos_alpha_surface, g, message_string,      &
-                  pt_surface, sin_alpha_surface, sloping_surface
-
-       USE indices,                                                            &
-           ONLY:  i_left, i_right, j_north, j_south, nxl, nxlg, nxlu, nxr,     &
-                  nxrg, nyn, nyng, nys, nysg, nzb, nzb_s_inner, nzt
-
-       USE kinds
-
-       USE pegrid
-
-
-       IMPLICIT NONE
-
-       INTEGER(iwp) ::  i              !<
-       INTEGER(iwp) ::  j              !<
-       INTEGER(iwp) ::  k              !<
-       INTEGER(iwp) ::  wind_component !<
-       
-#if defined( __nopointer )
-       REAL(wp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ::  var !<
-#else
-       REAL(wp), DIMENSION(:,:,:), POINTER ::  var
-#endif
-
-
-       IF ( .NOT. sloping_surface )  THEN
-!
-!--       Normal case: horizontal surface
-          !$acc kernels present( nzb_s_inner, ref_state, tend, var )
-          !$acc loop
-          DO  i = i_left, i_right
-             DO  j = j_south, j_north
-                !$acc loop independent vector
-                DO  k = nzb_s_inner(j,i)+1, nzt-1
-                   tend(k,j,i) = tend(k,j,i) + atmos_ocean_sign * g * 0.5_wp * &
-                          (                                                    &
-                             ( var(k,j,i)   - ref_state(k) )   / ref_state(k) + &
-                             ( var(k+1,j,i) - ref_state(k+1) ) / ref_state(k+1) &
-                          )
-                ENDDO
-             ENDDO
-          ENDDO
-          !$acc end kernels
-
-       ELSE
-!
-!--       Buoyancy term for a surface with a slope in x-direction. The equations
-!--       for both the u and w velocity-component contain proportionate terms.
-!--       Temperature field at time t=0 serves as environmental temperature.
-!--       Reference temperature (pt_surface) is the one at the lower left corner
-!--       of the total domain.
-          IF ( wind_component == 1 )  THEN
-
-             DO  i = nxlu, nxr
-                DO  j = nys, nyn
-                   DO  k = nzb_s_inner(j,i)+1, nzt-1
-                      tend(k,j,i) = tend(k,j,i) + g * sin_alpha_surface *      &
-                           0.5_wp * ( ( pt(k,j,i-1)         + pt(k,j,i)         ) &
-                                    - ( pt_slope_ref(k,i-1) + pt_slope_ref(k,i) ) &
-                                    ) / pt_surface
-                   ENDDO
-                ENDDO
-             ENDDO
-
-          ELSEIF ( wind_component == 3 )  THEN
-
-             DO  i = nxl, nxr
-                DO  j = nys, nyn
-                   DO  k = nzb_s_inner(j,i)+1, nzt-1
-                      tend(k,j,i) = tend(k,j,i) + g * cos_alpha_surface *      &
-                           0.5_wp * ( ( pt(k,j,i)         + pt(k+1,j,i)         ) &
-                                    - ( pt_slope_ref(k,i) + pt_slope_ref(k+1,i) ) &
-                                    ) / pt_surface
-                   ENDDO
-                ENDDO
-            ENDDO
-
-          ELSE
-
-             WRITE( message_string, * ) 'no term for component "',             &
-                                       wind_component,'"'
-             CALL message( 'buoyancy', 'PA0159', 1, 2, 0, 6, 0 )
-
-          ENDIF
-
-       ENDIF
-
-    END SUBROUTINE buoyancy_acc
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Call for grid point i,j
-!> @attention PGI-compiler creates SIGFPE if opt>1 is used! Therefore, opt=1 is
-!>            forced by compiler-directive.
-!------------------------------------------------------------------------------!
-!pgi$r opt=1
-    SUBROUTINE buoyancy_ij( i, j, var, wind_component )
-
-       USE arrays_3d,                                                          &
-           ONLY:  pt, pt_slope_ref, ref_state, tend
-
-       USE control_parameters,                                                 &
-           ONLY:  atmos_ocean_sign, cos_alpha_surface, g, message_string,      &
-                  pt_surface, sin_alpha_surface, sloping_surface
-
-       USE indices,                                                            &
-           ONLY:  nxlg, nxrg, nyng, nysg, nzb, nzb_s_inner, nzt
-
-       USE kinds
-
-       USE pegrid
-
-
-       IMPLICIT NONE
-
-       INTEGER(iwp) ::  i              !<
-       INTEGER(iwp) ::  j              !<
-       INTEGER(iwp) ::  k              !<
-       INTEGER(iwp) ::  pr             !<
-       INTEGER(iwp) ::  wind_component !<
-       
-#if defined( __nopointer )
-       REAL(wp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ::  var !<
-#else
-       REAL(wp), DIMENSION(:,:,:), POINTER ::  var
-#endif
-
-
-       IF ( .NOT. sloping_surface )  THEN
-!
-!--       Normal case: horizontal surface
-          DO  k = nzb_s_inner(j,i)+1, nzt-1
-              tend(k,j,i) = tend(k,j,i) + atmos_ocean_sign * g * 0.5_wp * (    &
-                        ( var(k,j,i)   - ref_state(k)   ) / ref_state(k)   +   &
-                        ( var(k+1,j,i) - ref_state(k+1) ) / ref_state(k+1)     &
-                                                                          )
-          ENDDO
-
-       ELSE
-!
-!--       Buoyancy term for a surface with a slope in x-direction. The equations
-!--       for both the u and w velocity-component contain proportionate terms.
-!--       Temperature field at time t=0 serves as environmental temperature.
-!--       Reference temperature (pt_surface) is the one at the lower left corner
-!--       of the total domain.
-          IF ( wind_component == 1 )  THEN
-
-             DO  k = nzb_s_inner(j,i)+1, nzt-1
-                tend(k,j,i) = tend(k,j,i) + g * sin_alpha_surface *            &
-                           0.5_wp * ( ( pt(k,j,i-1)         + pt(k,j,i)         ) &
-                                    - ( pt_slope_ref(k,i-1) + pt_slope_ref(k,i) ) &
-                                    ) / pt_surface
-             ENDDO
-
-          ELSEIF ( wind_component == 3 )  THEN
-
-             DO  k = nzb_s_inner(j,i)+1, nzt-1
-                tend(k,j,i) = tend(k,j,i) + g * cos_alpha_surface *            &
-                           0.5_wp * ( ( pt(k,j,i)         + pt(k+1,j,i)         ) &
-                                    - ( pt_slope_ref(k,i) + pt_slope_ref(k+1,i) ) &
-                                    ) / pt_surface
-             ENDDO
-
-          ELSE
-
-             WRITE( message_string, * ) 'no term for component "',             &
-                                       wind_component,'"'
-             CALL message( 'buoyancy', 'PA0159', 1, 2, 0, 6, 0 )
-
-          ENDIF
-
-       ENDIF
-
-    END SUBROUTINE buoyancy_ij
-
- END MODULE buoyancy_mod
Index: /palm/trunk/SOURCE/buoyancy_mod.f90
===================================================================
--- /palm/trunk/SOURCE/buoyancy_mod.f90	(revision 1850)
+++ /palm/trunk/SOURCE/buoyancy_mod.f90	(revision 1850)
@@ -0,0 +1,394 @@
+!> @file buoyancy_mod.f90
+!--------------------------------------------------------------------------------!
+! This file is part of PALM.
+!
+! PALM is free software: you can redistribute it and/or modify it under the terms
+! of the GNU General Public License as published by the Free Software Foundation,
+! either version 3 of the License, or (at your option) any later version.
+!
+! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
+! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
+! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along with
+! PALM. If not, see <http://www.gnu.org/licenses/>.
+!
+! Copyright 1997-2016 Leibniz Universitaet Hannover
+!--------------------------------------------------------------------------------!
+!
+! Current revisions:
+! ------------------
+! Module renamed
+! 
+! 
+! Former revisions:
+! -----------------
+! $Id$
+!
+! 1682 2015-10-07 23:56:08Z knoop
+! Code annotations made doxygen readable 
+! 
+! 1374 2014-04-25 12:55:07Z raasch
+! missing variables added to ONLY list
+! 
+! 1365 2014-04-22 15:03:56Z boeske
+! Calculation of reference state in subroutine calc_mean_profile moved to
+! subroutine time_integration,
+! subroutine calc_mean_profile moved to new file calc_mean_profile.f90
+! 
+! 1353 2014-04-08 15:21:23Z heinze
+! REAL constants provided with KIND-attribute
+!
+! 1320 2014-03-20 08:40:49Z raasch
+! ONLY-attribute added to USE-statements,
+! kind-parameters added to all INTEGER and REAL declaration statements,
+! kinds are defined in new module kinds,
+! revision history before 2012 removed,
+! comment fields (!:) to be used for variable explanations added to
+! all variable declaration statements
+!
+! 1257 2013-11-08 15:18:40Z raasch
+! vector length (32) removed from openacc clause
+!
+! 1241 2013-10-30 11:36:58Z heinze
+! Generalize calc_mean_profile for wider use: use additional steering 
+! character loc 
+!
+! 1179 2013-06-14 05:57:58Z raasch
+! steering of reference state revised (var_reference and pr removed from
+! parameter list), use_reference renamed use_single_reference_value
+!
+! 1171 2013-05-30 11:27:45Z raasch
+! openacc statements added to use_reference-case in accelerator version
+!
+! 1153 2013-05-10 14:33:08Z raasch
+! code adjustments of accelerator version required by PGI 12.3 / CUDA 5.0
+!
+! 1128 2013-04-12 06:19:32Z raasch
+! loop index bounds in accelerator version replaced by i_left, i_right, j_south,
+! j_north
+!
+! 1036 2012-10-22 13:43:42Z raasch
+! code put under GPL (PALM 3.9)
+!
+! 1015 2012-09-27 09:23:24Z raasch
+! accelerator version (*_acc) added
+!
+! 1010 2012-09-20 07:59:54Z raasch
+! cpp switch __nopointer added for pointer free version
+!
+! Revision 1.1  1997/08/29 08:56:48  raasch
+! Initial revision
+!
+!
+! Description:
+! ------------
+!> Buoyancy term of the third component of the equation of motion.
+!> @attention Humidity is not regarded when using a sloping surface!
+!------------------------------------------------------------------------------!
+ MODULE buoyancy_mod
+ 
+
+    PRIVATE
+    PUBLIC buoyancy, buoyancy_acc
+
+    INTERFACE buoyancy
+       MODULE PROCEDURE buoyancy
+       MODULE PROCEDURE buoyancy_ij
+    END INTERFACE buoyancy
+
+    INTERFACE buoyancy_acc
+       MODULE PROCEDURE buoyancy_acc
+    END INTERFACE buoyancy_acc
+
+ CONTAINS
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Call for all grid points
+!------------------------------------------------------------------------------!
+    SUBROUTINE buoyancy( var, wind_component )
+
+       USE arrays_3d,                                                          &
+           ONLY:  pt, pt_slope_ref, ref_state, tend
+
+       USE control_parameters,                                                 &
+           ONLY:  atmos_ocean_sign, cos_alpha_surface, g, message_string,      &
+                  pt_surface, sin_alpha_surface, sloping_surface
+
+       USE indices,                                                            &
+           ONLY:  nxl, nxlg, nxlu, nxr, nxrg, nyn, nyng, nys, nysg, nzb,       &
+                  nzb_s_inner, nzt
+
+       USE kinds
+
+       USE pegrid
+
+
+       IMPLICIT NONE
+
+       INTEGER(iwp) ::  i              !<
+       INTEGER(iwp) ::  j              !<
+       INTEGER(iwp) ::  k              !<
+       INTEGER(iwp) ::  wind_component !<
+       
+#if defined( __nopointer )
+       REAL(wp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ::  var !<
+#else
+       REAL(wp), DIMENSION(:,:,:), POINTER ::  var
+#endif
+
+
+       IF ( .NOT. sloping_surface )  THEN
+!
+!--       Normal case: horizontal surface
+          DO  i = nxl, nxr
+             DO  j = nys, nyn
+                DO  k = nzb_s_inner(j,i)+1, nzt-1
+                   tend(k,j,i) = tend(k,j,i) + atmos_ocean_sign * g * 0.5_wp * &
+                          (                                                    &
+                             ( var(k,j,i)   - ref_state(k) )   / ref_state(k) + &
+                             ( var(k+1,j,i) - ref_state(k+1) ) / ref_state(k+1) &
+                          )
+                ENDDO
+             ENDDO
+          ENDDO
+
+       ELSE
+!
+!--       Buoyancy term for a surface with a slope in x-direction. The equations
+!--       for both the u and w velocity-component contain proportionate terms.
+!--       Temperature field at time t=0 serves as environmental temperature.
+!--       Reference temperature (pt_surface) is the one at the lower left corner
+!--       of the total domain.
+          IF ( wind_component == 1 )  THEN
+
+             DO  i = nxlu, nxr
+                DO  j = nys, nyn
+                   DO  k = nzb_s_inner(j,i)+1, nzt-1
+                      tend(k,j,i) = tend(k,j,i) + g * sin_alpha_surface *      &
+                           0.5_wp * ( ( pt(k,j,i-1)         + pt(k,j,i)         ) &
+                                    - ( pt_slope_ref(k,i-1) + pt_slope_ref(k,i) ) &
+                                    ) / pt_surface
+                   ENDDO
+                ENDDO
+             ENDDO
+
+          ELSEIF ( wind_component == 3 )  THEN
+
+             DO  i = nxl, nxr
+                DO  j = nys, nyn
+                   DO  k = nzb_s_inner(j,i)+1, nzt-1
+                      tend(k,j,i) = tend(k,j,i) + g * cos_alpha_surface *      &
+                           0.5_wp * ( ( pt(k,j,i)         + pt(k+1,j,i)         ) &
+                                    - ( pt_slope_ref(k,i) + pt_slope_ref(k+1,i) ) &
+                                    ) / pt_surface
+                   ENDDO
+                ENDDO
+            ENDDO
+
+          ELSE
+             
+             WRITE( message_string, * ) 'no term for component "',             &
+                                       wind_component,'"'
+             CALL message( 'buoyancy', 'PA0159', 1, 2, 0, 6, 0 )
+
+          ENDIF
+
+       ENDIF
+
+    END SUBROUTINE buoyancy
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Call for all grid points - accelerator version
+!------------------------------------------------------------------------------!
+    SUBROUTINE buoyancy_acc( var, wind_component )
+
+       USE arrays_3d,                                                          &
+           ONLY:  pt, pt_slope_ref, ref_state, tend
+
+       USE control_parameters,                                                 &
+           ONLY:  atmos_ocean_sign, cos_alpha_surface, g, message_string,      &
+                  pt_surface, sin_alpha_surface, sloping_surface
+
+       USE indices,                                                            &
+           ONLY:  i_left, i_right, j_north, j_south, nxl, nxlg, nxlu, nxr,     &
+                  nxrg, nyn, nyng, nys, nysg, nzb, nzb_s_inner, nzt
+
+       USE kinds
+
+       USE pegrid
+
+
+       IMPLICIT NONE
+
+       INTEGER(iwp) ::  i              !<
+       INTEGER(iwp) ::  j              !<
+       INTEGER(iwp) ::  k              !<
+       INTEGER(iwp) ::  wind_component !<
+       
+#if defined( __nopointer )
+       REAL(wp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ::  var !<
+#else
+       REAL(wp), DIMENSION(:,:,:), POINTER ::  var
+#endif
+
+
+       IF ( .NOT. sloping_surface )  THEN
+!
+!--       Normal case: horizontal surface
+          !$acc kernels present( nzb_s_inner, ref_state, tend, var )
+          !$acc loop
+          DO  i = i_left, i_right
+             DO  j = j_south, j_north
+                !$acc loop independent vector
+                DO  k = nzb_s_inner(j,i)+1, nzt-1
+                   tend(k,j,i) = tend(k,j,i) + atmos_ocean_sign * g * 0.5_wp * &
+                          (                                                    &
+                             ( var(k,j,i)   - ref_state(k) )   / ref_state(k) + &
+                             ( var(k+1,j,i) - ref_state(k+1) ) / ref_state(k+1) &
+                          )
+                ENDDO
+             ENDDO
+          ENDDO
+          !$acc end kernels
+
+       ELSE
+!
+!--       Buoyancy term for a surface with a slope in x-direction. The equations
+!--       for both the u and w velocity-component contain proportionate terms.
+!--       Temperature field at time t=0 serves as environmental temperature.
+!--       Reference temperature (pt_surface) is the one at the lower left corner
+!--       of the total domain.
+          IF ( wind_component == 1 )  THEN
+
+             DO  i = nxlu, nxr
+                DO  j = nys, nyn
+                   DO  k = nzb_s_inner(j,i)+1, nzt-1
+                      tend(k,j,i) = tend(k,j,i) + g * sin_alpha_surface *      &
+                           0.5_wp * ( ( pt(k,j,i-1)         + pt(k,j,i)         ) &
+                                    - ( pt_slope_ref(k,i-1) + pt_slope_ref(k,i) ) &
+                                    ) / pt_surface
+                   ENDDO
+                ENDDO
+             ENDDO
+
+          ELSEIF ( wind_component == 3 )  THEN
+
+             DO  i = nxl, nxr
+                DO  j = nys, nyn
+                   DO  k = nzb_s_inner(j,i)+1, nzt-1
+                      tend(k,j,i) = tend(k,j,i) + g * cos_alpha_surface *      &
+                           0.5_wp * ( ( pt(k,j,i)         + pt(k+1,j,i)         ) &
+                                    - ( pt_slope_ref(k,i) + pt_slope_ref(k+1,i) ) &
+                                    ) / pt_surface
+                   ENDDO
+                ENDDO
+            ENDDO
+
+          ELSE
+
+             WRITE( message_string, * ) 'no term for component "',             &
+                                       wind_component,'"'
+             CALL message( 'buoyancy', 'PA0159', 1, 2, 0, 6, 0 )
+
+          ENDIF
+
+       ENDIF
+
+    END SUBROUTINE buoyancy_acc
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Call for grid point i,j
+!> @attention PGI-compiler creates SIGFPE if opt>1 is used! Therefore, opt=1 is
+!>            forced by compiler-directive.
+!------------------------------------------------------------------------------!
+!pgi$r opt=1
+    SUBROUTINE buoyancy_ij( i, j, var, wind_component )
+
+       USE arrays_3d,                                                          &
+           ONLY:  pt, pt_slope_ref, ref_state, tend
+
+       USE control_parameters,                                                 &
+           ONLY:  atmos_ocean_sign, cos_alpha_surface, g, message_string,      &
+                  pt_surface, sin_alpha_surface, sloping_surface
+
+       USE indices,                                                            &
+           ONLY:  nxlg, nxrg, nyng, nysg, nzb, nzb_s_inner, nzt
+
+       USE kinds
+
+       USE pegrid
+
+
+       IMPLICIT NONE
+
+       INTEGER(iwp) ::  i              !<
+       INTEGER(iwp) ::  j              !<
+       INTEGER(iwp) ::  k              !<
+       INTEGER(iwp) ::  pr             !<
+       INTEGER(iwp) ::  wind_component !<
+       
+#if defined( __nopointer )
+       REAL(wp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ::  var !<
+#else
+       REAL(wp), DIMENSION(:,:,:), POINTER ::  var
+#endif
+
+
+       IF ( .NOT. sloping_surface )  THEN
+!
+!--       Normal case: horizontal surface
+          DO  k = nzb_s_inner(j,i)+1, nzt-1
+              tend(k,j,i) = tend(k,j,i) + atmos_ocean_sign * g * 0.5_wp * (    &
+                        ( var(k,j,i)   - ref_state(k)   ) / ref_state(k)   +   &
+                        ( var(k+1,j,i) - ref_state(k+1) ) / ref_state(k+1)     &
+                                                                          )
+          ENDDO
+
+       ELSE
+!
+!--       Buoyancy term for a surface with a slope in x-direction. The equations
+!--       for both the u and w velocity-component contain proportionate terms.
+!--       Temperature field at time t=0 serves as environmental temperature.
+!--       Reference temperature (pt_surface) is the one at the lower left corner
+!--       of the total domain.
+          IF ( wind_component == 1 )  THEN
+
+             DO  k = nzb_s_inner(j,i)+1, nzt-1
+                tend(k,j,i) = tend(k,j,i) + g * sin_alpha_surface *            &
+                           0.5_wp * ( ( pt(k,j,i-1)         + pt(k,j,i)         ) &
+                                    - ( pt_slope_ref(k,i-1) + pt_slope_ref(k,i) ) &
+                                    ) / pt_surface
+             ENDDO
+
+          ELSEIF ( wind_component == 3 )  THEN
+
+             DO  k = nzb_s_inner(j,i)+1, nzt-1
+                tend(k,j,i) = tend(k,j,i) + g * cos_alpha_surface *            &
+                           0.5_wp * ( ( pt(k,j,i)         + pt(k+1,j,i)         ) &
+                                    - ( pt_slope_ref(k,i) + pt_slope_ref(k+1,i) ) &
+                                    ) / pt_surface
+             ENDDO
+
+          ELSE
+
+             WRITE( message_string, * ) 'no term for component "',             &
+                                       wind_component,'"'
+             CALL message( 'buoyancy', 'PA0159', 1, 2, 0, 6, 0 )
+
+          ENDIF
+
+       ENDIF
+
+    END SUBROUTINE buoyancy_ij
+
+ END MODULE buoyancy_mod
Index: lm/trunk/SOURCE/calc_mean_profile.f90
===================================================================
--- /palm/trunk/SOURCE/calc_mean_profile.f90	(revision 1849)
+++ 	(revision )
@@ -1,142 +1,0 @@
-!> @file calc_mean_profile.f90
-!--------------------------------------------------------------------------------!
-! This file is part of PALM.
-!
-! PALM is free software: you can redistribute it and/or modify it under the terms
-! of the GNU General Public License as published by the Free Software Foundation,
-! either version 3 of the License, or (at your option) any later version.
-!
-! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
-! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
-! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along with
-! PALM. If not, see <http://www.gnu.org/licenses/>.
-!
-! Copyright 1997-2016 Leibniz Universitaet Hannover
-!--------------------------------------------------------------------------------!
-!
-! Current revisions:
-! -----------------
-! 
-!
-! Former revisions:
-! -----------------
-! $Id$
-!
-! 1738 2015-12-18 13:56:05Z raasch
-! bugfix: if a layer is completely filled with topography, no mean is calculated
-!
-! 1682 2015-10-07 23:56:08Z knoop
-! Code annotations made doxygen readable 
-! 
-! 1365 2014-04-22 15:03:56Z boeske
-! Initial revision
-!
-! Description:
-! ------------
-!> Calculate the horizontally averaged vertical temperature profile (pr=4 in case
-!> of potential temperature, 44 in case of virtual potential temperature, and 64
-!> in case of density (ocean runs)).
-!------------------------------------------------------------------------------!
- MODULE calc_mean_profile_mod
- 
-
-    PRIVATE
-    PUBLIC calc_mean_profile
-
-    INTERFACE calc_mean_profile
-       MODULE PROCEDURE calc_mean_profile
-    END INTERFACE calc_mean_profile
-
- CONTAINS
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> @todo Missing subroutine description.
-!------------------------------------------------------------------------------!
-    SUBROUTINE calc_mean_profile( var, pr )
-
-       USE control_parameters,                                                 &
-           ONLY:  intermediate_timestep_count, message_string
-
-       USE indices,                                                            &
-           ONLY:  ngp_2dh_s_inner, nxl, nxr, nyn, nys, nzb, nzb_s_inner, nzt
-
-       USE kinds
-
-       USE pegrid
-
-       USE statistics,                                                         &
-           ONLY:  flow_statistics_called, hom, sums, sums_l
-
-
-       IMPLICIT NONE
-       
-       INTEGER(iwp) ::  i                  !<
-       INTEGER(iwp) ::  j                  !<
-       INTEGER(iwp) ::  k                  !<
-       INTEGER(iwp) ::  pr                 !< 
-       INTEGER(iwp) ::  omp_get_thread_num !<
-       INTEGER(iwp) ::  tn                 !<
-       
-#if defined( __nopointer )
-       REAL(wp), DIMENSION(:,:,:) ::  var  !<
-#else
-       REAL(wp), DIMENSION(:,:,:), POINTER ::  var
-#endif
-
-!
-!--    Computation of the horizontally averaged profile of variable var, unless
-!--    already done by the relevant call from flow_statistics. The calculation
-!--    is done only for the first respective intermediate timestep in order to
-!--    spare communication time and to produce identical model results with jobs
-!--    which are calling flow_statistics at different time intervals.
-       IF ( .NOT. flow_statistics_called  .AND.                                &
-            intermediate_timestep_count == 1 )  THEN
-
-!
-!--       Horizontal average of variable var
-          tn           =   0  ! Default thread number in case of one thread
-          !$OMP PARALLEL PRIVATE( i, j, k, tn )
-!$        tn = omp_get_thread_num()
-          sums_l(:,pr,tn) = 0.0_wp
-          !$OMP DO
-          DO  i = nxl, nxr
-             DO  j =  nys, nyn
-                DO  k = nzb_s_inner(j,i), nzt+1
-                   sums_l(k,pr,tn) = sums_l(k,pr,tn) + var(k,j,i)
-                ENDDO
-             ENDDO
-          ENDDO
-          !$OMP END PARALLEL
-
-          DO  i = 1, threads_per_task-1
-             sums_l(:,pr,0) = sums_l(:,pr,0) + sums_l(:,pr,i)
-          ENDDO
-
-#if defined( __parallel )
-
-          IF ( collective_wait )  CALL MPI_BARRIER( comm2d, ierr )
-          CALL MPI_ALLREDUCE( sums_l(nzb,pr,0), sums(nzb,pr), nzt+2-nzb,       &
-                              MPI_REAL, MPI_SUM, comm2d, ierr )
-
-#else
-
-          sums(:,pr) = sums_l(:,pr,0)
-
-#endif
-
-          DO  k = nzb, nzt+1
-             IF ( ngp_2dh_s_inner(k,0) /= 0 )  THEN
-                hom(k,1,pr,0) = sums(k,pr) / ngp_2dh_s_inner(k,0)
-             ENDIF
-          ENDDO
-
-       ENDIF
-
-
-    END SUBROUTINE calc_mean_profile
-
- END MODULE calc_mean_profile_mod
Index: /palm/trunk/SOURCE/calc_mean_profile_mod.f90
===================================================================
--- /palm/trunk/SOURCE/calc_mean_profile_mod.f90	(revision 1850)
+++ /palm/trunk/SOURCE/calc_mean_profile_mod.f90	(revision 1850)
@@ -0,0 +1,143 @@
+!> @file calc_mean_profile_mod.f90
+!--------------------------------------------------------------------------------!
+! This file is part of PALM.
+!
+! PALM is free software: you can redistribute it and/or modify it under the terms
+! of the GNU General Public License as published by the Free Software Foundation,
+! either version 3 of the License, or (at your option) any later version.
+!
+! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
+! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
+! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along with
+! PALM. If not, see <http://www.gnu.org/licenses/>.
+!
+! Copyright 1997-2016 Leibniz Universitaet Hannover
+!--------------------------------------------------------------------------------!
+!
+! Current revisions:
+! -----------------
+! Module renamed
+! 
+!
+! Former revisions:
+! -----------------
+! $Id$
+!
+! 1738 2015-12-18 13:56:05Z raasch
+! bugfix: if a layer is completely filled with topography, no mean is calculated
+!
+! 1682 2015-10-07 23:56:08Z knoop
+! Code annotations made doxygen readable 
+! 
+! 1365 2014-04-22 15:03:56Z boeske
+! Initial revision
+!
+! Description:
+! ------------
+!> Calculate the horizontally averaged vertical temperature profile (pr=4 in case
+!> of potential temperature, 44 in case of virtual potential temperature, and 64
+!> in case of density (ocean runs)).
+!------------------------------------------------------------------------------!
+ MODULE calc_mean_profile_mod
+ 
+
+    PRIVATE
+    PUBLIC calc_mean_profile
+
+    INTERFACE calc_mean_profile
+       MODULE PROCEDURE calc_mean_profile
+    END INTERFACE calc_mean_profile
+
+ CONTAINS
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> @todo Missing subroutine description.
+!------------------------------------------------------------------------------!
+    SUBROUTINE calc_mean_profile( var, pr )
+
+       USE control_parameters,                                                 &
+           ONLY:  intermediate_timestep_count, message_string
+
+       USE indices,                                                            &
+           ONLY:  ngp_2dh_s_inner, nxl, nxr, nyn, nys, nzb, nzb_s_inner, nzt
+
+       USE kinds
+
+       USE pegrid
+
+       USE statistics,                                                         &
+           ONLY:  flow_statistics_called, hom, sums, sums_l
+
+
+       IMPLICIT NONE
+       
+       INTEGER(iwp) ::  i                  !<
+       INTEGER(iwp) ::  j                  !<
+       INTEGER(iwp) ::  k                  !<
+       INTEGER(iwp) ::  pr                 !< 
+       INTEGER(iwp) ::  omp_get_thread_num !<
+       INTEGER(iwp) ::  tn                 !<
+       
+#if defined( __nopointer )
+       REAL(wp), DIMENSION(:,:,:) ::  var  !<
+#else
+       REAL(wp), DIMENSION(:,:,:), POINTER ::  var
+#endif
+
+!
+!--    Computation of the horizontally averaged profile of variable var, unless
+!--    already done by the relevant call from flow_statistics. The calculation
+!--    is done only for the first respective intermediate timestep in order to
+!--    spare communication time and to produce identical model results with jobs
+!--    which are calling flow_statistics at different time intervals.
+       IF ( .NOT. flow_statistics_called  .AND.                                &
+            intermediate_timestep_count == 1 )  THEN
+
+!
+!--       Horizontal average of variable var
+          tn           =   0  ! Default thread number in case of one thread
+          !$OMP PARALLEL PRIVATE( i, j, k, tn )
+!$        tn = omp_get_thread_num()
+          sums_l(:,pr,tn) = 0.0_wp
+          !$OMP DO
+          DO  i = nxl, nxr
+             DO  j =  nys, nyn
+                DO  k = nzb_s_inner(j,i), nzt+1
+                   sums_l(k,pr,tn) = sums_l(k,pr,tn) + var(k,j,i)
+                ENDDO
+             ENDDO
+          ENDDO
+          !$OMP END PARALLEL
+
+          DO  i = 1, threads_per_task-1
+             sums_l(:,pr,0) = sums_l(:,pr,0) + sums_l(:,pr,i)
+          ENDDO
+
+#if defined( __parallel )
+
+          IF ( collective_wait )  CALL MPI_BARRIER( comm2d, ierr )
+          CALL MPI_ALLREDUCE( sums_l(nzb,pr,0), sums(nzb,pr), nzt+2-nzb,       &
+                              MPI_REAL, MPI_SUM, comm2d, ierr )
+
+#else
+
+          sums(:,pr) = sums_l(:,pr,0)
+
+#endif
+
+          DO  k = nzb, nzt+1
+             IF ( ngp_2dh_s_inner(k,0) /= 0 )  THEN
+                hom(k,1,pr,0) = sums(k,pr) / ngp_2dh_s_inner(k,0)
+             ENDIF
+          ENDDO
+
+       ENDIF
+
+
+    END SUBROUTINE calc_mean_profile
+
+ END MODULE calc_mean_profile_mod
Index: lm/trunk/SOURCE/calc_radiation.f90
===================================================================
--- /palm/trunk/SOURCE/calc_radiation.f90	(revision 1849)
+++ 	(revision )
@@ -1,354 +1,0 @@
-!> @file calc_radiation.f90
-!--------------------------------------------------------------------------------!
-! This file is part of PALM.
-!
-! PALM is free software: you can redistribute it and/or modify it under the terms
-! of the GNU General Public License as published by the Free Software Foundation,
-! either version 3 of the License, or (at your option) any later version.
-!
-! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
-! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
-! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along with
-! PALM. If not, see <http://www.gnu.org/licenses/>.
-!
-! Copyright 1997-2016 Leibniz Universitaet Hannover
-!--------------------------------------------------------------------------------!
-!
-! Current revisions:
-! -----------------
-! 
-! 
-! Former revisions:
-! -----------------
-! $Id$
-!
-! 1682 2015-10-07 23:56:08Z knoop
-! Code annotations made doxygen readable 
-! 
-! 1353 2014-04-08 15:21:23Z heinze
-! REAL constants provided with KIND-attribute
-!
-! 1322 2014-03-20 16:38:49Z raasch
-! exponent 4.0 changed to integer
-!
-! 1320 2014-03-20 08:40:49Z raasch
-! ONLY-attribute added to USE-statements,
-! kind-parameters added to all INTEGER and REAL declaration statements,
-! kinds are defined in new module kinds,
-! revision history before 2012 removed,
-! comment fields (!:) to be used for variable explanations added to
-! all variable declaration statements
-!
-! 1036 2012-10-22 13:43:42Z raasch
-! code put under GPL (PALM 3.9)
-!
-! Revision 1.1  2000/04/13 14:42:45  schroeter
-! Initial revision
-!
-!
-! Description:
-! -------------
-!> Calculation of the vertical divergences of the long-wave radiation-fluxes
-!> based on the parameterization of the cloud effective emissivity
-!------------------------------------------------------------------------------!
- MODULE calc_radiation_mod
- 
-    USE kinds
-    
-    PRIVATE
-    PUBLIC calc_radiation
-    
-    LOGICAL, SAVE ::  first_call = .TRUE. !<
-    REAL(wp), SAVE ::  sigma = 5.67E-08_wp   !<
-
-    REAL(wp), DIMENSION(:), ALLOCATABLE, SAVE ::  lwp_ground         !<
-    REAL(wp), DIMENSION(:), ALLOCATABLE, SAVE ::  lwp_top            !<
-    REAL(wp), DIMENSION(:), ALLOCATABLE, SAVE ::  blackbody_emission !<
-
-    INTERFACE calc_radiation
-       MODULE PROCEDURE calc_radiation
-       MODULE PROCEDURE calc_radiation_ij
-    END INTERFACE calc_radiation
- 
- CONTAINS
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Call for all grid points
-!------------------------------------------------------------------------------!
-    SUBROUTINE calc_radiation
-
-       USE arrays_3d,                                                          &
-           ONLY:  dzw, pt, ql, tend
-
-       USE cloud_parameters,                                                   &
-           ONLY:  cp, l_d_cp, pt_d_t, t_d_pt
-
-       USE control_parameters,                                                 &
-           ONLY:  rho_surface
-
-       USE indices,                                                            &
-           ONLY:  nxl, nxr, nyn, nys, nzb, nzb_s_inner, nzt
-
-       USE kinds
-
-       USE pegrid
-
-
-       IMPLICIT NONE
-
-       INTEGER(iwp) ::  i      !<
-       INTEGER(iwp) ::  j      !<
-       INTEGER(iwp) ::  k      !<
-       INTEGER(iwp) ::  k_help !<
- 
-       REAL(wp) :: df_p                      !<
-       REAL(wp) :: df_m                      !<
-       REAL(wp) :: effective_emission_up_m   !<
-       REAL(wp) :: effective_emission_up_p   !<
-       REAL(wp) :: effective_emission_down_m !<
-       REAL(wp) :: effective_emission_down_p !<
-       REAL(wp) :: f_up_m                    !<
-       REAL(wp) :: f_up_p                    !<
-       REAL(wp) :: f_down_m                  !<
-       REAL(wp) :: f_down_p                  !<
-       REAL(wp) :: impinging_flux_at_top     !<
-       REAL(wp) :: temperature               !<
-
-
-!
-!--    On first call, allocate temporary arrays
-       IF ( first_call )  THEN
-          ALLOCATE( blackbody_emission(nzb:nzt+1), lwp_ground(nzb:nzt+1),      &
-                    lwp_top(nzb:nzt+1) )
-          first_call = .FALSE.
-       ENDIF
-
-
-       DO  i = nxl, nxr
-          DO  j = nys, nyn
-!
-!--          Compute the liquid water path (LWP) and blackbody_emission
-!--          at all vertical levels
-             lwp_ground(nzb) = 0.0_wp
-             lwp_top(nzt+1)  = rho_surface * ql(nzt+1,j,i) * dzw(nzt+1)
-
-             temperature     = pt(nzb,j,i) * t_d_pt(nzb) + l_d_cp * ql(nzb,j,i)
-             blackbody_emission(nzb) = sigma * temperature**4
-
-             DO  k = nzb_s_inner(j,i)+1, nzt
-
-                k_help = ( nzt+nzb+1 ) - k
-                lwp_ground(k)   = lwp_ground(k-1) + rho_surface * ql(k,j,i) *  &
-                                  dzw(k)
-
-                lwp_top(k_help) = lwp_top(k_help+1) +                          &
-                                  rho_surface * ql(k_help,j,i) * dzw(k_help)
-
-                temperature     = pt(k,j,i) * t_d_pt(k) + l_d_cp * ql(k,j,i)
-                blackbody_emission(k) = sigma * temperature**4
-
-             ENDDO
-
-             lwp_ground(nzt+1) = lwp_ground(nzt) +                             &
-                                 rho_surface * ql(nzt+1,j,i) * dzw(nzt+1)
-             lwp_top(nzb)      = lwp_top(nzb+1)
-
-             temperature       = pt(nzt+1,j,i) * t_d_pt(nzt+1) + l_d_cp *      &
-                                 ql(nzt+1,j,i)
-             blackbody_emission(nzt+1) = sigma * temperature**4
-
-!
-!--          See Chlond '92, this is just a first guess
-             impinging_flux_at_top = blackbody_emission(nzb) - 100.0_wp
-
-             DO  k = nzb_s_inner(j,i)+1, nzt
-!
-!--             Save some computational time, but this may cause load
-!--             imbalances if ql is not distributed uniformly
-                IF ( ql(k,j,i) /= 0.0_wp ) THEN
-!
-!--                Compute effective emissivities
-                   effective_emission_up_p   = 1.0_wp -                        &
-                                               EXP( -130.0_wp * lwp_ground(k+1) )
-                   effective_emission_up_m   = 1.0_wp -                        &
-                                               EXP( -130.0_wp * lwp_ground(k-1) )
-                   effective_emission_down_p = 1.0_wp -                        &
-                                               EXP( -158.0_wp * lwp_top(k+1) )
-                   effective_emission_down_m = 1.0_wp -                        &
-                                               EXP( -158.0_wp * lwp_top(k-1) )  
-
-!
-!--                Compute vertical long wave radiation fluxes
-                   f_up_p = blackbody_emission(nzb) +                          &
-                            effective_emission_up_p *                          &
-                           ( blackbody_emission(k) - blackbody_emission(nzb) )
-
-                   f_up_m = blackbody_emission(nzb) +                          &
-                            effective_emission_up_m *                          &
-                           ( blackbody_emission(k-1) - blackbody_emission(nzb) )
-
-                   f_down_p = impinging_flux_at_top +                          &
-                              effective_emission_down_p *                      &
-                             ( blackbody_emission(k) - impinging_flux_at_top )
-
-                   f_down_m = impinging_flux_at_top +                          &
-                              effective_emission_down_m *                      &
-                             ( blackbody_emission(k-1) - impinging_flux_at_top )
-
-!
-!--                Divergence of vertical long wave radiation fluxes
-                   df_p = f_up_p - f_down_p
-                   df_m = f_up_m - f_down_m
-
-!
-!--                Compute tendency term         
-                   tend(k,j,i) = tend(k,j,i) -                                 &
-                                ( pt_d_t(k) / ( rho_surface * cp ) *           &
-                                  ( df_p - df_m ) / dzw(k) )
-
-                ENDIF
-
-             ENDDO
-          ENDDO
-       ENDDO
-
-    END SUBROUTINE calc_radiation
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Call for grid point i,j
-!------------------------------------------------------------------------------!
-    SUBROUTINE calc_radiation_ij( i, j )
-
-       USE arrays_3d,                                                          &
-           ONLY:  dzw, pt, ql, tend
-
-       USE cloud_parameters,                                                   &
-           ONLY:  cp, l_d_cp, pt_d_t, t_d_pt
-
-       USE control_parameters,                                                 &
-           ONLY:  rho_surface
-
-       USE indices,                                                            &
-           ONLY:  nzb, nzb_s_inner, nzt
-
-       USE kinds
-
-       USE pegrid
-
-   
-       IMPLICIT NONE
-
-       INTEGER(iwp) ::  i      !<
-       INTEGER(iwp) ::  j      !<
-       INTEGER(iwp) ::  k      !<
-       INTEGER(iwp) ::  k_help !<
-
-       REAL(wp) :: df_p                      !<
-       REAL(wp) :: df_m                      !<
-       REAL(wp) :: effective_emission_up_m   !<
-       REAL(wp) :: effective_emission_up_p   !<
-       REAL(wp) :: effective_emission_down_m !<
-       REAL(wp) :: effective_emission_down_p !<
-       REAL(wp) :: f_up_m                    !<
-       REAL(wp) :: f_up_p                    !<
-       REAL(wp) :: f_down_m                  !<
-       REAL(wp) :: f_down_p                  !<
-       REAL(wp) :: impinging_flux_at_top     !<
-       REAL(wp) :: temperature               !<
-
-       
-!
-!--    On first call, allocate temporary arrays
-       IF ( first_call )  THEN
-          ALLOCATE( blackbody_emission(nzb:nzt+1), lwp_ground(nzb:nzt+1),      &
-                    lwp_top(nzb:nzt+1) )
-          first_call = .FALSE.
-       ENDIF
-
-!
-!--    Compute the liquid water path (LWP) and blackbody_emission
-!--    at all vertical levels
-       lwp_ground(nzb) = 0.0_wp
-       lwp_top(nzt+1)  = rho_surface * ql(nzt+1,j,i) * dzw(nzt+1)
-
-       temperature     = pt(nzb,j,i) * t_d_pt(nzb) + l_d_cp * ql(nzb,j,i)
-       blackbody_emission(nzb) = sigma * temperature**4
-
-       DO  k = nzb_s_inner(j,i)+1, nzt
-          k_help = ( nzt+nzb+1 ) - k
-          lwp_ground(k)   = lwp_ground(k-1) + rho_surface * ql(k,j,i) * dzw(k)
-
-          lwp_top(k_help) = lwp_top(k_help+1) +                                &
-                            rho_surface * ql(k_help,j,i) * dzw(k_help)
-
-          temperature     = pt(k,j,i) * t_d_pt(k) + l_d_cp * ql(k,j,i)
-          blackbody_emission(k) = sigma * temperature**4
-
-       ENDDO
-       lwp_ground(nzt+1) = lwp_ground(nzt) +                                   &
-                           rho_surface * ql(nzt+1,j,i) * dzw(nzt+1)
-       lwp_top(nzb)      = lwp_top(nzb+1)
-
-       temperature       = pt(nzt+1,j,i) * t_d_pt(nzt+1) + l_d_cp *            &
-                           ql(nzt+1,j,i)
-       blackbody_emission(nzt+1) = sigma * temperature**4
-
-!
-!--    See Chlond '92, this is just a first guess
-       impinging_flux_at_top = blackbody_emission(nzb) - 100.0_wp
-
-       DO  k = nzb_s_inner(j,i)+1, nzt
-!
-!--       Store some computational time,
-!--       this may cause load imbalances if ql is not distributed uniformly
-          IF ( ql(k,j,i) /= 0.0_wp ) THEN
-!
-!--          Compute effective emissivities
-             effective_emission_up_p   = 1.0_wp -                              &
-                                         EXP( -130.0_wp * lwp_ground(k+1) )
-             effective_emission_up_m   = 1.0_wp -                              &
-                                         EXP( -130.0_wp * lwp_ground(k-1) )
-             effective_emission_down_p = 1.0_wp -                              &
-                                         EXP( -158.0_wp * lwp_top(k+1) )
-             effective_emission_down_m = 1.0_wp -                              &
-                                         EXP( -158.0_wp * lwp_top(k-1) )  
-             
-!
-!--          Compute vertical long wave radiation fluxes
-             f_up_p = blackbody_emission(nzb) + effective_emission_up_p *      &
-                     ( blackbody_emission(k) - blackbody_emission(nzb) )
-
-             f_up_m = blackbody_emission(nzb) + effective_emission_up_m *      &
-                     ( blackbody_emission(k-1) - blackbody_emission(nzb) )
-
-             f_down_p = impinging_flux_at_top + effective_emission_down_p *    &
-                       ( blackbody_emission(k) - impinging_flux_at_top )
-
-             f_down_m = impinging_flux_at_top + effective_emission_down_m *    &
-                       ( blackbody_emission(k-1) - impinging_flux_at_top )
-
-!
-!-           Divergence of vertical long wave radiation fluxes
-             df_p = f_up_p - f_down_p
-             df_m = f_up_m - f_down_m
-
-!
-!--          Compute tendency term         
-             tend(k,j,i) = tend(k,j,i) - ( pt_d_t(k) / ( rho_surface * cp ) *  &
-                                         ( df_p - df_m ) / dzw(k) )
-
-          ENDIF
-
-       ENDDO
-
-    END SUBROUTINE calc_radiation_ij
-
- END MODULE calc_radiation_mod
Index: /palm/trunk/SOURCE/calc_radiation_mod.f90
===================================================================
--- /palm/trunk/SOURCE/calc_radiation_mod.f90	(revision 1850)
+++ /palm/trunk/SOURCE/calc_radiation_mod.f90	(revision 1850)
@@ -0,0 +1,355 @@
+!> @file calc_radiation_mod.f90
+!--------------------------------------------------------------------------------!
+! This file is part of PALM.
+!
+! PALM is free software: you can redistribute it and/or modify it under the terms
+! of the GNU General Public License as published by the Free Software Foundation,
+! either version 3 of the License, or (at your option) any later version.
+!
+! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
+! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
+! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along with
+! PALM. If not, see <http://www.gnu.org/licenses/>.
+!
+! Copyright 1997-2016 Leibniz Universitaet Hannover
+!--------------------------------------------------------------------------------!
+!
+! Current revisions:
+! -----------------
+! Module renamed
+! 
+! 
+! Former revisions:
+! -----------------
+! $Id$
+!
+! 1682 2015-10-07 23:56:08Z knoop
+! Code annotations made doxygen readable 
+! 
+! 1353 2014-04-08 15:21:23Z heinze
+! REAL constants provided with KIND-attribute
+!
+! 1322 2014-03-20 16:38:49Z raasch
+! exponent 4.0 changed to integer
+!
+! 1320 2014-03-20 08:40:49Z raasch
+! ONLY-attribute added to USE-statements,
+! kind-parameters added to all INTEGER and REAL declaration statements,
+! kinds are defined in new module kinds,
+! revision history before 2012 removed,
+! comment fields (!:) to be used for variable explanations added to
+! all variable declaration statements
+!
+! 1036 2012-10-22 13:43:42Z raasch
+! code put under GPL (PALM 3.9)
+!
+! Revision 1.1  2000/04/13 14:42:45  schroeter
+! Initial revision
+!
+!
+! Description:
+! -------------
+!> Calculation of the vertical divergences of the long-wave radiation-fluxes
+!> based on the parameterization of the cloud effective emissivity
+!------------------------------------------------------------------------------!
+ MODULE calc_radiation_mod
+ 
+    USE kinds
+    
+    PRIVATE
+    PUBLIC calc_radiation
+    
+    LOGICAL, SAVE ::  first_call = .TRUE. !<
+    REAL(wp), SAVE ::  sigma = 5.67E-08_wp   !<
+
+    REAL(wp), DIMENSION(:), ALLOCATABLE, SAVE ::  lwp_ground         !<
+    REAL(wp), DIMENSION(:), ALLOCATABLE, SAVE ::  lwp_top            !<
+    REAL(wp), DIMENSION(:), ALLOCATABLE, SAVE ::  blackbody_emission !<
+
+    INTERFACE calc_radiation
+       MODULE PROCEDURE calc_radiation
+       MODULE PROCEDURE calc_radiation_ij
+    END INTERFACE calc_radiation
+ 
+ CONTAINS
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Call for all grid points
+!------------------------------------------------------------------------------!
+    SUBROUTINE calc_radiation
+
+       USE arrays_3d,                                                          &
+           ONLY:  dzw, pt, ql, tend
+
+       USE cloud_parameters,                                                   &
+           ONLY:  cp, l_d_cp, pt_d_t, t_d_pt
+
+       USE control_parameters,                                                 &
+           ONLY:  rho_surface
+
+       USE indices,                                                            &
+           ONLY:  nxl, nxr, nyn, nys, nzb, nzb_s_inner, nzt
+
+       USE kinds
+
+       USE pegrid
+
+
+       IMPLICIT NONE
+
+       INTEGER(iwp) ::  i      !<
+       INTEGER(iwp) ::  j      !<
+       INTEGER(iwp) ::  k      !<
+       INTEGER(iwp) ::  k_help !<
+ 
+       REAL(wp) :: df_p                      !<
+       REAL(wp) :: df_m                      !<
+       REAL(wp) :: effective_emission_up_m   !<
+       REAL(wp) :: effective_emission_up_p   !<
+       REAL(wp) :: effective_emission_down_m !<
+       REAL(wp) :: effective_emission_down_p !<
+       REAL(wp) :: f_up_m                    !<
+       REAL(wp) :: f_up_p                    !<
+       REAL(wp) :: f_down_m                  !<
+       REAL(wp) :: f_down_p                  !<
+       REAL(wp) :: impinging_flux_at_top     !<
+       REAL(wp) :: temperature               !<
+
+
+!
+!--    On first call, allocate temporary arrays
+       IF ( first_call )  THEN
+          ALLOCATE( blackbody_emission(nzb:nzt+1), lwp_ground(nzb:nzt+1),      &
+                    lwp_top(nzb:nzt+1) )
+          first_call = .FALSE.
+       ENDIF
+
+
+       DO  i = nxl, nxr
+          DO  j = nys, nyn
+!
+!--          Compute the liquid water path (LWP) and blackbody_emission
+!--          at all vertical levels
+             lwp_ground(nzb) = 0.0_wp
+             lwp_top(nzt+1)  = rho_surface * ql(nzt+1,j,i) * dzw(nzt+1)
+
+             temperature     = pt(nzb,j,i) * t_d_pt(nzb) + l_d_cp * ql(nzb,j,i)
+             blackbody_emission(nzb) = sigma * temperature**4
+
+             DO  k = nzb_s_inner(j,i)+1, nzt
+
+                k_help = ( nzt+nzb+1 ) - k
+                lwp_ground(k)   = lwp_ground(k-1) + rho_surface * ql(k,j,i) *  &
+                                  dzw(k)
+
+                lwp_top(k_help) = lwp_top(k_help+1) +                          &
+                                  rho_surface * ql(k_help,j,i) * dzw(k_help)
+
+                temperature     = pt(k,j,i) * t_d_pt(k) + l_d_cp * ql(k,j,i)
+                blackbody_emission(k) = sigma * temperature**4
+
+             ENDDO
+
+             lwp_ground(nzt+1) = lwp_ground(nzt) +                             &
+                                 rho_surface * ql(nzt+1,j,i) * dzw(nzt+1)
+             lwp_top(nzb)      = lwp_top(nzb+1)
+
+             temperature       = pt(nzt+1,j,i) * t_d_pt(nzt+1) + l_d_cp *      &
+                                 ql(nzt+1,j,i)
+             blackbody_emission(nzt+1) = sigma * temperature**4
+
+!
+!--          See Chlond '92, this is just a first guess
+             impinging_flux_at_top = blackbody_emission(nzb) - 100.0_wp
+
+             DO  k = nzb_s_inner(j,i)+1, nzt
+!
+!--             Save some computational time, but this may cause load
+!--             imbalances if ql is not distributed uniformly
+                IF ( ql(k,j,i) /= 0.0_wp ) THEN
+!
+!--                Compute effective emissivities
+                   effective_emission_up_p   = 1.0_wp -                        &
+                                               EXP( -130.0_wp * lwp_ground(k+1) )
+                   effective_emission_up_m   = 1.0_wp -                        &
+                                               EXP( -130.0_wp * lwp_ground(k-1) )
+                   effective_emission_down_p = 1.0_wp -                        &
+                                               EXP( -158.0_wp * lwp_top(k+1) )
+                   effective_emission_down_m = 1.0_wp -                        &
+                                               EXP( -158.0_wp * lwp_top(k-1) )  
+
+!
+!--                Compute vertical long wave radiation fluxes
+                   f_up_p = blackbody_emission(nzb) +                          &
+                            effective_emission_up_p *                          &
+                           ( blackbody_emission(k) - blackbody_emission(nzb) )
+
+                   f_up_m = blackbody_emission(nzb) +                          &
+                            effective_emission_up_m *                          &
+                           ( blackbody_emission(k-1) - blackbody_emission(nzb) )
+
+                   f_down_p = impinging_flux_at_top +                          &
+                              effective_emission_down_p *                      &
+                             ( blackbody_emission(k) - impinging_flux_at_top )
+
+                   f_down_m = impinging_flux_at_top +                          &
+                              effective_emission_down_m *                      &
+                             ( blackbody_emission(k-1) - impinging_flux_at_top )
+
+!
+!--                Divergence of vertical long wave radiation fluxes
+                   df_p = f_up_p - f_down_p
+                   df_m = f_up_m - f_down_m
+
+!
+!--                Compute tendency term         
+                   tend(k,j,i) = tend(k,j,i) -                                 &
+                                ( pt_d_t(k) / ( rho_surface * cp ) *           &
+                                  ( df_p - df_m ) / dzw(k) )
+
+                ENDIF
+
+             ENDDO
+          ENDDO
+       ENDDO
+
+    END SUBROUTINE calc_radiation
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Call for grid point i,j
+!------------------------------------------------------------------------------!
+    SUBROUTINE calc_radiation_ij( i, j )
+
+       USE arrays_3d,                                                          &
+           ONLY:  dzw, pt, ql, tend
+
+       USE cloud_parameters,                                                   &
+           ONLY:  cp, l_d_cp, pt_d_t, t_d_pt
+
+       USE control_parameters,                                                 &
+           ONLY:  rho_surface
+
+       USE indices,                                                            &
+           ONLY:  nzb, nzb_s_inner, nzt
+
+       USE kinds
+
+       USE pegrid
+
+   
+       IMPLICIT NONE
+
+       INTEGER(iwp) ::  i      !<
+       INTEGER(iwp) ::  j      !<
+       INTEGER(iwp) ::  k      !<
+       INTEGER(iwp) ::  k_help !<
+
+       REAL(wp) :: df_p                      !<
+       REAL(wp) :: df_m                      !<
+       REAL(wp) :: effective_emission_up_m   !<
+       REAL(wp) :: effective_emission_up_p   !<
+       REAL(wp) :: effective_emission_down_m !<
+       REAL(wp) :: effective_emission_down_p !<
+       REAL(wp) :: f_up_m                    !<
+       REAL(wp) :: f_up_p                    !<
+       REAL(wp) :: f_down_m                  !<
+       REAL(wp) :: f_down_p                  !<
+       REAL(wp) :: impinging_flux_at_top     !<
+       REAL(wp) :: temperature               !<
+
+       
+!
+!--    On first call, allocate temporary arrays
+       IF ( first_call )  THEN
+          ALLOCATE( blackbody_emission(nzb:nzt+1), lwp_ground(nzb:nzt+1),      &
+                    lwp_top(nzb:nzt+1) )
+          first_call = .FALSE.
+       ENDIF
+
+!
+!--    Compute the liquid water path (LWP) and blackbody_emission
+!--    at all vertical levels
+       lwp_ground(nzb) = 0.0_wp
+       lwp_top(nzt+1)  = rho_surface * ql(nzt+1,j,i) * dzw(nzt+1)
+
+       temperature     = pt(nzb,j,i) * t_d_pt(nzb) + l_d_cp * ql(nzb,j,i)
+       blackbody_emission(nzb) = sigma * temperature**4
+
+       DO  k = nzb_s_inner(j,i)+1, nzt
+          k_help = ( nzt+nzb+1 ) - k
+          lwp_ground(k)   = lwp_ground(k-1) + rho_surface * ql(k,j,i) * dzw(k)
+
+          lwp_top(k_help) = lwp_top(k_help+1) +                                &
+                            rho_surface * ql(k_help,j,i) * dzw(k_help)
+
+          temperature     = pt(k,j,i) * t_d_pt(k) + l_d_cp * ql(k,j,i)
+          blackbody_emission(k) = sigma * temperature**4
+
+       ENDDO
+       lwp_ground(nzt+1) = lwp_ground(nzt) +                                   &
+                           rho_surface * ql(nzt+1,j,i) * dzw(nzt+1)
+       lwp_top(nzb)      = lwp_top(nzb+1)
+
+       temperature       = pt(nzt+1,j,i) * t_d_pt(nzt+1) + l_d_cp *            &
+                           ql(nzt+1,j,i)
+       blackbody_emission(nzt+1) = sigma * temperature**4
+
+!
+!--    See Chlond '92, this is just a first guess
+       impinging_flux_at_top = blackbody_emission(nzb) - 100.0_wp
+
+       DO  k = nzb_s_inner(j,i)+1, nzt
+!
+!--       Store some computational time,
+!--       this may cause load imbalances if ql is not distributed uniformly
+          IF ( ql(k,j,i) /= 0.0_wp ) THEN
+!
+!--          Compute effective emissivities
+             effective_emission_up_p   = 1.0_wp -                              &
+                                         EXP( -130.0_wp * lwp_ground(k+1) )
+             effective_emission_up_m   = 1.0_wp -                              &
+                                         EXP( -130.0_wp * lwp_ground(k-1) )
+             effective_emission_down_p = 1.0_wp -                              &
+                                         EXP( -158.0_wp * lwp_top(k+1) )
+             effective_emission_down_m = 1.0_wp -                              &
+                                         EXP( -158.0_wp * lwp_top(k-1) )  
+             
+!
+!--          Compute vertical long wave radiation fluxes
+             f_up_p = blackbody_emission(nzb) + effective_emission_up_p *      &
+                     ( blackbody_emission(k) - blackbody_emission(nzb) )
+
+             f_up_m = blackbody_emission(nzb) + effective_emission_up_m *      &
+                     ( blackbody_emission(k-1) - blackbody_emission(nzb) )
+
+             f_down_p = impinging_flux_at_top + effective_emission_down_p *    &
+                       ( blackbody_emission(k) - impinging_flux_at_top )
+
+             f_down_m = impinging_flux_at_top + effective_emission_down_m *    &
+                       ( blackbody_emission(k-1) - impinging_flux_at_top )
+
+!
+!-           Divergence of vertical long wave radiation fluxes
+             df_p = f_up_p - f_down_p
+             df_m = f_up_m - f_down_m
+
+!
+!--          Compute tendency term         
+             tend(k,j,i) = tend(k,j,i) - ( pt_d_t(k) / ( rho_surface * cp ) *  &
+                                         ( df_p - df_m ) / dzw(k) )
+
+          ENDIF
+
+       ENDDO
+
+    END SUBROUTINE calc_radiation_ij
+
+ END MODULE calc_radiation_mod
Index: lm/trunk/SOURCE/coriolis.f90
===================================================================
--- /palm/trunk/SOURCE/coriolis.f90	(revision 1849)
+++ 	(revision )
@@ -1,328 +1,0 @@
-!> @file coriolis.f90
-!--------------------------------------------------------------------------------!
-! This file is part of PALM.
-!
-! PALM is free software: you can redistribute it and/or modify it under the terms
-! of the GNU General Public License as published by the Free Software Foundation,
-! either version 3 of the License, or (at your option) any later version.
-!
-! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
-! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
-! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along with
-! PALM. If not, see <http://www.gnu.org/licenses/>.
-!
-! Copyright 1997-2016 Leibniz Universitaet Hannover
-!--------------------------------------------------------------------------------!
-!
-! Current revisions:
-! -----------------
-! 
-! 
-! Former revisions:
-! -----------------
-! $Id$
-!
-! 1682 2015-10-07 23:56:08Z knoop
-! Code annotations made doxygen readable 
-! 
-! 1353 2014-04-08 15:21:23Z heinze
-! REAL constants provided with KIND-attribute
-!
-! 1320 2014-03-20 08:40:49Z raasch
-! ONLY-attribute added to USE-statements,
-! kind-parameters added to all INTEGER and REAL declaration statements,
-! kinds are defined in new module kinds,
-! revision history before 2012 removed,
-! comment fields (!:) to be used for variable explanations added to
-! all variable declaration statements
-! 
-! 1257 2013-11-08 15:18:40Z raasch
-! openacc loop and loop vector clauses removed
-!
-! 1128 2013-04-12 06:19:32Z raasch
-! loop index bounds in accelerator version replaced by i_left, i_right, j_south,
-! j_north
-!
-! 1036 2012-10-22 13:43:42Z raasch
-! code put under GPL (PALM 3.9)
-!
-! 1015 2012-09-27 09:23:24Z raasch
-! accelerator version (*_acc) added
-!
-! Revision 1.1  1997/08/29 08:57:38  raasch
-! Initial revision
-!
-!
-! Description:
-! ------------
-!> Computation of all Coriolis terms in the equations of motion.
-!------------------------------------------------------------------------------!
- MODULE coriolis_mod
- 
-
-    PRIVATE
-    PUBLIC coriolis, coriolis_acc
-
-    INTERFACE coriolis
-       MODULE PROCEDURE coriolis
-       MODULE PROCEDURE coriolis_ij
-    END INTERFACE coriolis
-
-    INTERFACE coriolis_acc
-       MODULE PROCEDURE coriolis_acc
-    END INTERFACE coriolis_acc
-
- CONTAINS
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Call for all grid points
-!------------------------------------------------------------------------------!
-    SUBROUTINE coriolis( component )
-
-       USE arrays_3d,                                                          &
-           ONLY:  tend, u, ug, v, vg, w 
-           
-       USE control_parameters,                                                 &
-           ONLY:  f, fs, message_string
-           
-       USE indices,                                                            &
-           ONLY:  nxl, nxlu, nxr, nyn, nys, nysv, nzb_u_inner, nzb_v_inner,    &
-                  nzb_w_inner, nzt
-                   
-       USE kinds
-
-       IMPLICIT NONE
-
-       INTEGER(iwp) ::  component  !< 
-       INTEGER(iwp) ::  i          !< 
-       INTEGER(iwp) ::  j          !< 
-       INTEGER(iwp) ::  k          !< 
-
-
-!
-!--    Compute Coriolis terms for the three velocity components
-       SELECT CASE ( component )
-
-!
-!--       u-component
-          CASE ( 1 )
-             DO  i = nxlu, nxr
-                DO  j = nys, nyn
-                   DO  k = nzb_u_inner(j,i)+1, nzt
-                      tend(k,j,i) = tend(k,j,i) + f  *    ( 0.25_wp *          &
-                                   ( v(k,j,i-1) + v(k,j,i) + v(k,j+1,i-1) +    &
-                                     v(k,j+1,i) ) - vg(k) )                    &
-                                                - fs *    ( 0.25_wp *          &
-                                   ( w(k-1,j,i-1) + w(k-1,j,i) + w(k,j,i-1) +  &
-                                     w(k,j,i)   ) &
-                                                          )
-                   ENDDO
-                ENDDO
-             ENDDO
-
-!
-!--       v-component
-          CASE ( 2 )
-             DO  i = nxl, nxr
-                DO  j = nysv, nyn
-                   DO  k = nzb_v_inner(j,i)+1, nzt
-                      tend(k,j,i) = tend(k,j,i) - f *     ( 0.25_wp *          &
-                                   ( u(k,j-1,i) + u(k,j,i) + u(k,j-1,i+1) +    &
-                                     u(k,j,i+1) ) - ug(k) )
-                   ENDDO
-                ENDDO
-             ENDDO
-
-!
-!--       w-component
-          CASE ( 3 )
-             DO  i = nxl, nxr
-                DO  j = nys, nyn
-                   DO  k = nzb_w_inner(j,i)+1, nzt
-                      tend(k,j,i) = tend(k,j,i) + fs * 0.25_wp *               &
-                                   ( u(k,j,i) + u(k+1,j,i) + u(k,j,i+1) +      &
-                                     u(k+1,j,i+1) )
-                   ENDDO
-                ENDDO
-             ENDDO
-
-          CASE DEFAULT
-
-             WRITE( message_string, * ) ' wrong component: ', component
-             CALL message( 'coriolis', 'PA0173', 1, 2, 0, 6, 0 )
-
-       END SELECT
-
-    END SUBROUTINE coriolis
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Call for all grid points - accelerator version
-!------------------------------------------------------------------------------!
-    SUBROUTINE coriolis_acc( component )
-
-       USE arrays_3d,                                                          &
-           ONLY:  tend, u, ug, v, vg, w 
-           
-       USE control_parameters,                                                 &
-           ONLY:  f, fs, message_string
-           
-       USE indices,                                                            &
-           ONLY:  i_left, i_right, j_north, j_south, nzb_u_inner,              &
-                  nzb_v_inner, nzb_w_inner, nzt
-                   
-       USE kinds
-
-       IMPLICIT NONE
-
-       INTEGER(iwp) ::  component  !< 
-       INTEGER(iwp) ::  i          !<
-       INTEGER(iwp) ::  j          !< 
-       INTEGER(iwp) ::  k          !<
-
-
-!
-!--    Compute Coriolis terms for the three velocity components
-       SELECT CASE ( component )
-
-!
-!--       u-component
-          CASE ( 1 )
-             !$acc  kernels present( nzb_u_inner, tend, v, vg, w )
-             DO  i = i_left, i_right
-                DO  j = j_south, j_north
-                   DO  k = 1, nzt
-                      IF  ( k > nzb_u_inner(j,i) )  THEN
-                         tend(k,j,i) = tend(k,j,i) + f  *    ( 0.25_wp *       &
-                                      ( v(k,j,i-1) + v(k,j,i) + v(k,j+1,i-1) + &
-                                        v(k,j+1,i) ) - vg(k) )                 &
-                                                   - fs *    ( 0.25_wp *       &
-                                      ( w(k-1,j,i-1) + w(k-1,j,i) + w(k,j,i-1) &
-                                        + w(k,j,i)   )                         &
-                                                             )
-                      ENDIF
-                   ENDDO
-                ENDDO
-             ENDDO
-             !$acc end kernels
-
-!
-!--       v-component
-          CASE ( 2 )
-             !$acc  kernels present( nzb_v_inner, tend, u, ug )
-             DO  i = i_left, i_right
-                DO  j = j_south, j_north
-                   DO  k = 1, nzt
-                      IF  ( k > nzb_v_inner(j,i) )  THEN
-                         tend(k,j,i) = tend(k,j,i) - f *     ( 0.25_wp *       &
-                                      ( u(k,j-1,i) + u(k,j,i) + u(k,j-1,i+1) + &
-                                        u(k,j,i+1) ) - ug(k) )
-                      ENDIF
-                   ENDDO
-                ENDDO
-             ENDDO
-             !$acc end kernels
-
-!
-!--       w-component
-          CASE ( 3 )
-             !$acc  kernels present( nzb_w_inner, tend, u )
-             DO  i = i_left, i_right
-                DO  j = j_south, j_north
-                   DO  k = 1, nzt
-                      IF  ( k > nzb_w_inner(j,i) )  THEN
-                         tend(k,j,i) = tend(k,j,i) + fs * 0.25_wp *            &
-                                      ( u(k,j,i) + u(k+1,j,i) + u(k,j,i+1) +   &
-                                        u(k+1,j,i+1) )
-                      ENDIF
-                   ENDDO
-                ENDDO
-             ENDDO
-             !$acc end kernels
-
-          CASE DEFAULT
-
-             WRITE( message_string, * ) ' wrong component: ', component
-             CALL message( 'coriolis', 'PA0173', 1, 2, 0, 6, 0 )
-
-       END SELECT
-
-    END SUBROUTINE coriolis_acc
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Call for grid point i,j
-!------------------------------------------------------------------------------!
-    SUBROUTINE coriolis_ij( i, j, component )
-
-       USE arrays_3d,                                                          &
-           ONLY:  tend, u, ug, v, vg, w 
-           
-       USE control_parameters,                                                 &
-           ONLY:  f, fs, message_string
-           
-       USE indices,                                                            &
-           ONLY:  nzb_u_inner, nzb_v_inner, nzb_w_inner, nzt
-           
-       USE kinds
-       
-       IMPLICIT NONE
-
-       INTEGER(iwp) ::  component  !< 
-       INTEGER(iwp) ::  i          !<
-       INTEGER(iwp) ::  j          !< 
-       INTEGER(iwp) ::  k          !<
-
-!
-!--    Compute Coriolis terms for the three velocity components
-       SELECT CASE ( component )
-
-!
-!--       u-component
-          CASE ( 1 )
-             DO  k = nzb_u_inner(j,i)+1, nzt
-                tend(k,j,i) = tend(k,j,i) + f  *    ( 0.25_wp *                &
-                                ( v(k,j,i-1) + v(k,j,i) + v(k,j+1,i-1) +       &
-                                  v(k,j+1,i) ) - vg(k) )                       &
-                                          - fs *    ( 0.25_wp *                &
-                                ( w(k-1,j,i-1) + w(k-1,j,i) + w(k,j,i-1) +     &
-                                  w(k,j,i)   ) )
-             ENDDO
-
-!
-!--       v-component
-          CASE ( 2 )
-             DO  k = nzb_v_inner(j,i)+1, nzt
-                tend(k,j,i) = tend(k,j,i) - f *     ( 0.25_wp *                &
-                                ( u(k,j-1,i) + u(k,j,i) + u(k,j-1,i+1) +       &
-                                  u(k,j,i+1) ) - ug(k) )
-             ENDDO
-
-!
-!--       w-component
-          CASE ( 3 )
-             DO  k = nzb_w_inner(j,i)+1, nzt
-                tend(k,j,i) = tend(k,j,i) + fs * 0.25_wp *                     &
-                                ( u(k,j,i) + u(k+1,j,i) + u(k,j,i+1) +         &
-                                  u(k+1,j,i+1) )
-             ENDDO
-
-          CASE DEFAULT
-
-             WRITE( message_string, * ) ' wrong component: ', component
-             CALL message( 'coriolis', 'PA0173', 1, 2, 0, 6, 0 )
-
-       END SELECT
-
-    END SUBROUTINE coriolis_ij
-
- END MODULE coriolis_mod
Index: /palm/trunk/SOURCE/coriolis_mod.f90
===================================================================
--- /palm/trunk/SOURCE/coriolis_mod.f90	(revision 1850)
+++ /palm/trunk/SOURCE/coriolis_mod.f90	(revision 1850)
@@ -0,0 +1,329 @@
+!> @file coriolis_mod.f90
+!--------------------------------------------------------------------------------!
+! This file is part of PALM.
+!
+! PALM is free software: you can redistribute it and/or modify it under the terms
+! of the GNU General Public License as published by the Free Software Foundation,
+! either version 3 of the License, or (at your option) any later version.
+!
+! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
+! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
+! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along with
+! PALM. If not, see <http://www.gnu.org/licenses/>.
+!
+! Copyright 1997-2016 Leibniz Universitaet Hannover
+!--------------------------------------------------------------------------------!
+!
+! Current revisions:
+! -----------------
+! Module renamed
+! 
+! 
+! Former revisions:
+! -----------------
+! $Id$
+!
+! 1682 2015-10-07 23:56:08Z knoop
+! Code annotations made doxygen readable 
+! 
+! 1353 2014-04-08 15:21:23Z heinze
+! REAL constants provided with KIND-attribute
+!
+! 1320 2014-03-20 08:40:49Z raasch
+! ONLY-attribute added to USE-statements,
+! kind-parameters added to all INTEGER and REAL declaration statements,
+! kinds are defined in new module kinds,
+! revision history before 2012 removed,
+! comment fields (!:) to be used for variable explanations added to
+! all variable declaration statements
+! 
+! 1257 2013-11-08 15:18:40Z raasch
+! openacc loop and loop vector clauses removed
+!
+! 1128 2013-04-12 06:19:32Z raasch
+! loop index bounds in accelerator version replaced by i_left, i_right, j_south,
+! j_north
+!
+! 1036 2012-10-22 13:43:42Z raasch
+! code put under GPL (PALM 3.9)
+!
+! 1015 2012-09-27 09:23:24Z raasch
+! accelerator version (*_acc) added
+!
+! Revision 1.1  1997/08/29 08:57:38  raasch
+! Initial revision
+!
+!
+! Description:
+! ------------
+!> Computation of all Coriolis terms in the equations of motion.
+!------------------------------------------------------------------------------!
+ MODULE coriolis_mod
+ 
+
+    PRIVATE
+    PUBLIC coriolis, coriolis_acc
+
+    INTERFACE coriolis
+       MODULE PROCEDURE coriolis
+       MODULE PROCEDURE coriolis_ij
+    END INTERFACE coriolis
+
+    INTERFACE coriolis_acc
+       MODULE PROCEDURE coriolis_acc
+    END INTERFACE coriolis_acc
+
+ CONTAINS
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Call for all grid points
+!------------------------------------------------------------------------------!
+    SUBROUTINE coriolis( component )
+
+       USE arrays_3d,                                                          &
+           ONLY:  tend, u, ug, v, vg, w 
+           
+       USE control_parameters,                                                 &
+           ONLY:  f, fs, message_string
+           
+       USE indices,                                                            &
+           ONLY:  nxl, nxlu, nxr, nyn, nys, nysv, nzb_u_inner, nzb_v_inner,    &
+                  nzb_w_inner, nzt
+                   
+       USE kinds
+
+       IMPLICIT NONE
+
+       INTEGER(iwp) ::  component  !< 
+       INTEGER(iwp) ::  i          !< 
+       INTEGER(iwp) ::  j          !< 
+       INTEGER(iwp) ::  k          !< 
+
+
+!
+!--    Compute Coriolis terms for the three velocity components
+       SELECT CASE ( component )
+
+!
+!--       u-component
+          CASE ( 1 )
+             DO  i = nxlu, nxr
+                DO  j = nys, nyn
+                   DO  k = nzb_u_inner(j,i)+1, nzt
+                      tend(k,j,i) = tend(k,j,i) + f  *    ( 0.25_wp *          &
+                                   ( v(k,j,i-1) + v(k,j,i) + v(k,j+1,i-1) +    &
+                                     v(k,j+1,i) ) - vg(k) )                    &
+                                                - fs *    ( 0.25_wp *          &
+                                   ( w(k-1,j,i-1) + w(k-1,j,i) + w(k,j,i-1) +  &
+                                     w(k,j,i)   ) &
+                                                          )
+                   ENDDO
+                ENDDO
+             ENDDO
+
+!
+!--       v-component
+          CASE ( 2 )
+             DO  i = nxl, nxr
+                DO  j = nysv, nyn
+                   DO  k = nzb_v_inner(j,i)+1, nzt
+                      tend(k,j,i) = tend(k,j,i) - f *     ( 0.25_wp *          &
+                                   ( u(k,j-1,i) + u(k,j,i) + u(k,j-1,i+1) +    &
+                                     u(k,j,i+1) ) - ug(k) )
+                   ENDDO
+                ENDDO
+             ENDDO
+
+!
+!--       w-component
+          CASE ( 3 )
+             DO  i = nxl, nxr
+                DO  j = nys, nyn
+                   DO  k = nzb_w_inner(j,i)+1, nzt
+                      tend(k,j,i) = tend(k,j,i) + fs * 0.25_wp *               &
+                                   ( u(k,j,i) + u(k+1,j,i) + u(k,j,i+1) +      &
+                                     u(k+1,j,i+1) )
+                   ENDDO
+                ENDDO
+             ENDDO
+
+          CASE DEFAULT
+
+             WRITE( message_string, * ) ' wrong component: ', component
+             CALL message( 'coriolis', 'PA0173', 1, 2, 0, 6, 0 )
+
+       END SELECT
+
+    END SUBROUTINE coriolis
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Call for all grid points - accelerator version
+!------------------------------------------------------------------------------!
+    SUBROUTINE coriolis_acc( component )
+
+       USE arrays_3d,                                                          &
+           ONLY:  tend, u, ug, v, vg, w 
+           
+       USE control_parameters,                                                 &
+           ONLY:  f, fs, message_string
+           
+       USE indices,                                                            &
+           ONLY:  i_left, i_right, j_north, j_south, nzb_u_inner,              &
+                  nzb_v_inner, nzb_w_inner, nzt
+                   
+       USE kinds
+
+       IMPLICIT NONE
+
+       INTEGER(iwp) ::  component  !< 
+       INTEGER(iwp) ::  i          !<
+       INTEGER(iwp) ::  j          !< 
+       INTEGER(iwp) ::  k          !<
+
+
+!
+!--    Compute Coriolis terms for the three velocity components
+       SELECT CASE ( component )
+
+!
+!--       u-component
+          CASE ( 1 )
+             !$acc  kernels present( nzb_u_inner, tend, v, vg, w )
+             DO  i = i_left, i_right
+                DO  j = j_south, j_north
+                   DO  k = 1, nzt
+                      IF  ( k > nzb_u_inner(j,i) )  THEN
+                         tend(k,j,i) = tend(k,j,i) + f  *    ( 0.25_wp *       &
+                                      ( v(k,j,i-1) + v(k,j,i) + v(k,j+1,i-1) + &
+                                        v(k,j+1,i) ) - vg(k) )                 &
+                                                   - fs *    ( 0.25_wp *       &
+                                      ( w(k-1,j,i-1) + w(k-1,j,i) + w(k,j,i-1) &
+                                        + w(k,j,i)   )                         &
+                                                             )
+                      ENDIF
+                   ENDDO
+                ENDDO
+             ENDDO
+             !$acc end kernels
+
+!
+!--       v-component
+          CASE ( 2 )
+             !$acc  kernels present( nzb_v_inner, tend, u, ug )
+             DO  i = i_left, i_right
+                DO  j = j_south, j_north
+                   DO  k = 1, nzt
+                      IF  ( k > nzb_v_inner(j,i) )  THEN
+                         tend(k,j,i) = tend(k,j,i) - f *     ( 0.25_wp *       &
+                                      ( u(k,j-1,i) + u(k,j,i) + u(k,j-1,i+1) + &
+                                        u(k,j,i+1) ) - ug(k) )
+                      ENDIF
+                   ENDDO
+                ENDDO
+             ENDDO
+             !$acc end kernels
+
+!
+!--       w-component
+          CASE ( 3 )
+             !$acc  kernels present( nzb_w_inner, tend, u )
+             DO  i = i_left, i_right
+                DO  j = j_south, j_north
+                   DO  k = 1, nzt
+                      IF  ( k > nzb_w_inner(j,i) )  THEN
+                         tend(k,j,i) = tend(k,j,i) + fs * 0.25_wp *            &
+                                      ( u(k,j,i) + u(k+1,j,i) + u(k,j,i+1) +   &
+                                        u(k+1,j,i+1) )
+                      ENDIF
+                   ENDDO
+                ENDDO
+             ENDDO
+             !$acc end kernels
+
+          CASE DEFAULT
+
+             WRITE( message_string, * ) ' wrong component: ', component
+             CALL message( 'coriolis', 'PA0173', 1, 2, 0, 6, 0 )
+
+       END SELECT
+
+    END SUBROUTINE coriolis_acc
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Call for grid point i,j
+!------------------------------------------------------------------------------!
+    SUBROUTINE coriolis_ij( i, j, component )
+
+       USE arrays_3d,                                                          &
+           ONLY:  tend, u, ug, v, vg, w 
+           
+       USE control_parameters,                                                 &
+           ONLY:  f, fs, message_string
+           
+       USE indices,                                                            &
+           ONLY:  nzb_u_inner, nzb_v_inner, nzb_w_inner, nzt
+           
+       USE kinds
+       
+       IMPLICIT NONE
+
+       INTEGER(iwp) ::  component  !< 
+       INTEGER(iwp) ::  i          !<
+       INTEGER(iwp) ::  j          !< 
+       INTEGER(iwp) ::  k          !<
+
+!
+!--    Compute Coriolis terms for the three velocity components
+       SELECT CASE ( component )
+
+!
+!--       u-component
+          CASE ( 1 )
+             DO  k = nzb_u_inner(j,i)+1, nzt
+                tend(k,j,i) = tend(k,j,i) + f  *    ( 0.25_wp *                &
+                                ( v(k,j,i-1) + v(k,j,i) + v(k,j+1,i-1) +       &
+                                  v(k,j+1,i) ) - vg(k) )                       &
+                                          - fs *    ( 0.25_wp *                &
+                                ( w(k-1,j,i-1) + w(k-1,j,i) + w(k,j,i-1) +     &
+                                  w(k,j,i)   ) )
+             ENDDO
+
+!
+!--       v-component
+          CASE ( 2 )
+             DO  k = nzb_v_inner(j,i)+1, nzt
+                tend(k,j,i) = tend(k,j,i) - f *     ( 0.25_wp *                &
+                                ( u(k,j-1,i) + u(k,j,i) + u(k,j-1,i+1) +       &
+                                  u(k,j,i+1) ) - ug(k) )
+             ENDDO
+
+!
+!--       w-component
+          CASE ( 3 )
+             DO  k = nzb_w_inner(j,i)+1, nzt
+                tend(k,j,i) = tend(k,j,i) + fs * 0.25_wp *                     &
+                                ( u(k,j,i) + u(k+1,j,i) + u(k,j,i+1) +         &
+                                  u(k+1,j,i+1) )
+             ENDDO
+
+          CASE DEFAULT
+
+             WRITE( message_string, * ) ' wrong component: ', component
+             CALL message( 'coriolis', 'PA0173', 1, 2, 0, 6, 0 )
+
+       END SELECT
+
+    END SUBROUTINE coriolis_ij
+
+ END MODULE coriolis_mod
Index: lm/trunk/SOURCE/cpulog.f90
===================================================================
--- /palm/trunk/SOURCE/cpulog.f90	(revision 1849)
+++ 	(revision )
@@ -1,570 +1,0 @@
-!> @file cpulog.f90
-!--------------------------------------------------------------------------------!
-! This file is part of PALM.
-!
-! PALM is free software: you can redistribute it and/or modify it under the terms
-! of the GNU General Public License as published by the Free Software Foundation,
-! either version 3 of the License, or (at your option) any later version.
-!
-! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
-! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
-! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along with
-! PALM. If not, see <http://www.gnu.org/licenses/>.
-!
-! Copyright 1997-2016 Leibniz Universitaet Hannover
-!--------------------------------------------------------------------------------!
-!
-! Current revisions:
-! -----------------
-! 
-!
-! Former revisions:
-! -----------------
-! $Id$
-!
-! 1808 2016-04-05 19:44:00Z raasch
-! cpu measurements are done with standard FORTRAN routine on every machine
-!
-! 1682 2015-10-07 23:56:08Z knoop
-! Code annotations made doxygen readable 
-! 
-! 1402 2014-05-09 14:25:13Z raasch
-! location messages added
-!
-! 1369 2014-04-24 05:57:38Z raasch
-! routine description added
-!
-! 1353 2014-04-08 15:21:23Z heinze
-! REAL constants provided with KIND-attribute
-!
-! 1322 2014-03-20 16:38:49Z raasch
-! REAL functions provided with KIND-attribute
-!
-! 1320 2014-03-20 08:40:49Z raasch
-! ONLY-attribute added to USE-statements,
-! kind-parameters added to all INTEGER and REAL declaration statements,
-! kinds are defined in new module kinds,
-! revision history before 2012 removed,
-! comment fields (!:) to be used for variable explanations added to
-! all variable declaration statements
-! 
-! 1318 2014-03-17 13:35:16Z raasch
-! former files/routines cpu_log and cpu_statistics combined to one module,
-! which also includes the former data module cpulog from the modules-file
-!
-! 1036 2012-10-22 13:43:42Z raasch
-! code put under GPL (PALM 3.9)
-!
-! Revision 1.1  1997/07/24 11:12:29  raasch
-! Initial revision
-!
-!
-! Description:
-! ------------
-!> CPU-time measurements for any program part whatever. Results of the
-!> measurements are output at the end of the run in local file CPU_MEASURES.
-!>
-!> To measure the CPU-time (better to say the wallclock time) of a specific code
-!> segment, two calls of cpu_log have to be used as brackets in front and at the
-!> end of the segment:
-!>
-!>     CALL cpu_log( log_point(n), 'any identifier', 'start' )
-!>       ... code segment ...
-!>     CALL cpu_log( log_point(n), 'any identifier', 'stop' )
-!>
-!> Parts of the code segment can be excluded from the measurement by additional
-!> call of cpu_log:
-!>
-!>       ... first segment to be measured
-!>     CALL cpu_log( log_point(n), 'any identifier', 'pause' )
-!>       ... oart of segment to be excluded from measurement
-!>     CALL cpu_log( log_point(n), 'any identifier', 'continue' )
-!>       ... second segment to be mesasured
-!>
-!> n is an INTEGER within the interval [1,100] defining the id of the specific
-!> code segment, 'any identifier' is a string describing the code segment to be
-!> measured. It can be freely chosen and results will appear under this name in
-!> file CPU_MEASURES. ids can only be used once. If you like to do a
-!> measurement of a new part of the code, please look for an id which is unused
-!> ao far.
-!>
-!> d3par-parameter cpu_log_barrierwait can be used to set an MPI barrier at the
-!> beginning of the measurement (modus 'start' or 'continue'), to avoid that
-!> idle times (due to MPI calls in the code segment, which are
-!> waiting for other processes to be finished) affect the measurements.
-!> If barriers shall not be used at all, a fourth, optional parameter has to be
-!> given:
-!>
-!>     CALL cpu_log( ..., ..., 'start', cpu_log_nowait )
-!>
-!> Variable log_point should be used for non-overlapping code segments, and they
-!> should sum up to the total cpu-time required by the complete run.
-!> Variable log_point_s can be used for any other special (s) measurements.
-!------------------------------------------------------------------------------!
- MODULE cpulog
- 
-
-    USE control_parameters,                                                    &
-        ONLY: message_string, nr_timesteps_this_run, run_description_header,   &
-              synchronous_exchange
-               
-    USE indices,                                                               &
-        ONLY: nx, ny, nz
-        
-    USE kinds
-    
-    USE pegrid
-
-    IMPLICIT NONE
-
-    PRIVATE
-    PUBLIC   cpu_log, cpu_log_barrierwait, cpu_log_nowait, cpu_statistics,     &
-             initial_wallclock_time, log_point, log_point_s
-
-    INTERFACE cpu_log
-       MODULE PROCEDURE cpu_log
-    END INTERFACE cpu_log
-
-    INTERFACE cpu_statistics
-       MODULE PROCEDURE cpu_statistics
-    END INTERFACE cpu_statistics
-
-    INTEGER(iwp), PARAMETER ::  cpu_log_continue = 0  !< 
-    INTEGER(iwp), PARAMETER ::  cpu_log_pause = 1     !< 
-    INTEGER(iwp), PARAMETER ::  cpu_log_start = 2     !< 
-    INTEGER(iwp), PARAMETER ::  cpu_log_stop = 3      !< 
-
-    LOGICAL            ::  cpu_log_barrierwait = .FALSE.  !< 
-    LOGICAL, PARAMETER ::  cpu_log_nowait = .FALSE.       !< 
-
-    REAL(wp) ::  initial_wallclock_time  !< 
-
-    TYPE logpoint
-       REAL(wp)           ::  isum       !< 
-       REAL(wp)           ::  ivect      !< 
-       REAL(wp)           ::  mean       !< 
-       REAL(wp)           ::  mtime      !< 
-       REAL(wp)           ::  mtimevec   !< 
-       REAL(wp)           ::  sum        !< 
-       REAL(wp)           ::  vector     !< 
-       INTEGER(iwp)       ::  counts     !< 
-       CHARACTER (LEN=20) ::  place      !< 
-    END TYPE logpoint
-
-    TYPE(logpoint), DIMENSION(100) ::  log_point = logpoint( 0.0_wp, 0.0_wp,   &
-                                       0.0_wp, 0.0_wp, 0.0_wp, 0.0_wp, 0.0_wp, &
-                                       0, ' ' ),                               &
-                                       log_point_s = logpoint( 0.0_wp, 0.0_wp, &
-                                       0.0_wp, 0.0_wp, 0.0_wp, 0.0_wp, 0.0_wp, &
-                                       0, ' ' )
-
-    SAVE
-
- CONTAINS
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> @todo Missing subroutine description.
-!------------------------------------------------------------------------------!
-    SUBROUTINE cpu_log( log_event, place, modus, barrierwait )
-
-       IMPLICIT NONE
-
-       CHARACTER (LEN=*) ::  modus              !< 
-       CHARACTER (LEN=*) ::  place              !< 
-       
-       LOGICAL           ::  wait_allowed       !< 
-       LOGICAL, OPTIONAL ::  barrierwait        !< 
-       LOGICAL, SAVE     ::  first = .TRUE.     !< 
-       
-       REAL(wp)          ::  mtime = 0.0_wp     !< 
-       REAL(wp)          ::  mtimevec = 0.0_wp  !< 
-       TYPE(logpoint)    ::  log_event          !< 
-
-       INTEGER(idp)     ::  count        !< 
-       INTEGER(idp)     ::  count_rate   !< 
-
-
-!
-!--    Initialize and check, respectively, point of measurement
-       IF ( log_event%place == ' ' )  THEN
-          log_event%place = place
-       ELSEIF ( log_event%place /= place )  THEN
-          WRITE( message_string, * ) 'wrong argument & expected: ',            &
-                            TRIM(log_event%place), '  given: ',  TRIM( place )
-          CALL message( 'cpu_log', 'PA0174', 1, 2, 0, 6, 0 )
-       ENDIF
-
-!
-!--    Determine, if barriers are allowed to set
-       IF ( PRESENT( barrierwait ) )  THEN
-          wait_allowed = barrierwait
-       ELSE
-          wait_allowed = .TRUE.
-       ENDIF
-
-!
-!--    MPI barrier, if requested, in order to avoid measuring wait times
-!--    caused by MPI routines waiting for other MPI routines of other
-!--    PEs that have not yet finished
-#if defined( __parallel )
-       IF ( cpu_log_barrierwait  .AND.  wait_allowed  .AND.                    &
-            ( modus == 'start'  .OR.  modus == 'continue' ) )  THEN
-          CALL MPI_BARRIER( comm2d, ierr )
-       ENDIF
-#endif
-
-!
-!--    Take current time
-       CALL SYSTEM_CLOCK( count, count_rate )
-       mtime = REAL( count, KIND=wp ) / REAL( count_rate, KIND=wp )
-
-!
-!--    Start, stop or pause measurement
-       IF ( modus == 'start'  .OR.  modus == 'continue' )  THEN
-          log_event%mtime    = mtime
-          log_event%mtimevec = mtimevec
-       ELSEIF ( modus == 'pause' )  THEN
-          IF ( ( mtime - log_event%mtime ) < 0.0  .AND.  first )  THEN
-             WRITE( message_string, * ) 'negative time interval occured',      &
-                         ' &PE',myid,' L=PAUSE "',TRIM(log_event%place),       &
-                         '" new=', mtime,' last=',log_event%mtime
-             CALL message( 'cpu_log', 'PA0176', 0, 1, -1, 6, 0 )
-             first = .FALSE.
-          ENDIF
-          log_event%isum     = log_event%isum + mtime - log_event%mtime
-          log_event%ivect    = log_event%ivect  + mtimevec - log_event%mtimevec
-       ELSEIF ( modus == 'stop' )  THEN
-          IF ( ( mtime - log_event%mtime + log_event%isum ) < 0.0  .AND.       &
-               first )  THEN
-             WRITE( message_string, * ) 'negative time interval occured',      &
-                         ' &PE',myid,' L=STOP "',TRIM(log_event%place),'" new=', &
-                         mtime,' last=',log_event%mtime,' isum=',log_event%isum
-             CALL message( 'cpu_log', 'PA0177', 0, 1, -1, 6, 0 )
-             first = .FALSE.
-          ENDIF
-          log_event%mtime    = mtime    - log_event%mtime    + log_event%isum
-          log_event%mtimevec = mtimevec - log_event%mtimevec + log_event%ivect
-          log_event%sum      = log_event%sum  + log_event%mtime
-          IF ( log_event%sum < 0.0  .AND.  first )  THEN
-             WRITE( message_string, * ) 'negative time interval occured',      &
-                         ' &PE',myid,' L=STOP "',TRIM(log_event%place),'" sum=', &
-                                         log_event%sum,' mtime=',log_event%mtime
-             CALL message( 'cpu_log', 'PA0178', 0, 1, -1, 6, 0 )
-             first = .FALSE.
-          ENDIF
-          log_event%vector   = log_event%vector + log_event%mtimevec
-          log_event%counts   = log_event%counts + 1
-          log_event%isum     = 0.0_wp
-          log_event%ivect    = 0.0_wp
-       ELSE
-          message_string = 'unknown modus of time measurement: ' // TRIM( modus )
-          CALL message( 'cpu_log', 'PA0179', 0, 1, -1, 6, 0 )
-       ENDIF
-
-    END SUBROUTINE cpu_log
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Analysis and output of the cpu-times measured. All PE results are collected
-!> on PE0 in order to calculate the mean cpu-time over all PEs and other
-!> statistics. The output is sorted according to the amount of cpu-time consumed
-!> and output on PE0.
-!------------------------------------------------------------------------------!
- 
-    SUBROUTINE cpu_statistics
-
-       IMPLICIT NONE
-
-       INTEGER(iwp)    ::  i               !< 
-       INTEGER(iwp)    ::  ii(1)           !< 
-       INTEGER(iwp)    ::  iii             !< 
-       INTEGER(iwp)    ::  sender          !< 
-       REAL(wp)       ::  average_cputime  !< 
-       REAL(wp), SAVE ::  norm = 1.0_wp    !< 
-       REAL(wp), DIMENSION(:),   ALLOCATABLE ::  pe_max        !< 
-       REAL(wp), DIMENSION(:),   ALLOCATABLE ::  pe_min        !< 
-       REAL(wp), DIMENSION(:),   ALLOCATABLE ::  pe_rms        !< 
-       REAL(wp), DIMENSION(:),   ALLOCATABLE ::  sum           !< 
-       REAL(wp), DIMENSION(:,:), ALLOCATABLE ::  pe_log_points !< 
-
-
-       CALL location_message( 'calculating cpu statistics', .FALSE. )
-
-!
-!--    Compute cpu-times in seconds
-       log_point%mtime  = log_point%mtime  / norm
-       log_point%sum    = log_point%sum    / norm
-       log_point%vector = log_point%vector / norm
-       WHERE ( log_point%counts /= 0 )
-          log_point%mean = log_point%sum / log_point%counts
-       END WHERE
-
-
-!
-!--    Collect cpu-times from all PEs and calculate statistics
-       IF ( myid == 0 )  THEN
-!
-!--       Allocate and initialize temporary arrays needed for statistics
-          ALLOCATE( pe_max( SIZE( log_point ) ), pe_min( SIZE( log_point ) ),  &
-                    pe_rms( SIZE( log_point ) ),                               &
-                    pe_log_points( SIZE( log_point ), 0:numprocs-1 ) )
-          pe_min = log_point%sum
-          pe_max = log_point%sum    ! need to be set in case of 1 PE
-          pe_rms = 0.0_wp
-
-#if defined( __parallel )
-!
-!--       Receive data from all PEs
-          DO  i = 1, numprocs-1
-             CALL MPI_RECV( pe_max(1), SIZE( log_point ), MPI_REAL,            &
-                            i, i, comm2d, status, ierr )
-             sender = status(MPI_SOURCE)
-             pe_log_points(:,sender) = pe_max
-          ENDDO
-          pe_log_points(:,0) = log_point%sum   ! Results from PE0
-!
-!--       Calculate mean of all PEs, store it on log_point%sum
-!--       and find minimum and maximum
-          DO  iii = 1, SIZE( log_point )
-             DO  i = 1, numprocs-1
-                log_point(iii)%sum = log_point(iii)%sum + pe_log_points(iii,i)
-                pe_min(iii) = MIN( pe_min(iii), pe_log_points(iii,i) )
-                pe_max(iii) = MAX( pe_max(iii), pe_log_points(iii,i) )
-             ENDDO
-             log_point(iii)%sum = log_point(iii)%sum / numprocs
-!
-!--          Calculate rms
-             DO  i = 0, numprocs-1
-                pe_rms(iii) = pe_rms(iii) + (                                  &
-                                    pe_log_points(iii,i) - log_point(iii)%sum  &
-                                            )**2
-             ENDDO
-             pe_rms(iii) = SQRT( pe_rms(iii) / numprocs )
-          ENDDO
-       ELSE
-!
-!--       Send data to PE0 (pe_max is used as temporary storage to send
-!--       the data in order to avoid sending the data type log)
-          ALLOCATE( pe_max( SIZE( log_point ) ) )
-          pe_max = log_point%sum
-          CALL MPI_SEND( pe_max(1), SIZE( log_point ), MPI_REAL, 0, myid, comm2d, &
-                         ierr )
-#endif
-
-       ENDIF
-
-!
-!--    Write cpu-times
-       IF ( myid == 0 )  THEN
-!
-!--       Re-store sums
-          ALLOCATE( sum( SIZE( log_point ) ) )
-          WHERE ( log_point%counts /= 0 )
-             sum = log_point%sum
-          ELSEWHERE
-             sum = -1.0_wp
-          ENDWHERE
-
-!
-!--       Get total time in order to calculate CPU-time per gridpoint and timestep
-          IF ( nr_timesteps_this_run /= 0 )  THEN
-             average_cputime = log_point(1)%sum / REAL( (nx+1) * (ny+1) * nz, KIND=wp ) / &
-                               REAL( nr_timesteps_this_run, KIND=wp ) * 1E6_wp  ! in micro-sec
-          ELSE
-             average_cputime = -1.0_wp
-          ENDIF
-
-!
-!--       Write cpu-times sorted by size
-          CALL check_open( 18 )
-#if defined( __parallel )
-          WRITE ( 18, 100 )  TRIM( run_description_header ),                          &
-                             numprocs * threads_per_task, pdims(1), pdims(2),         &
-                             threads_per_task, nx+1, ny+1, nz, nr_timesteps_this_run, &
-                             average_cputime
-
-          IF ( num_acc_per_node /= 0 )  WRITE ( 18, 108 )  num_acc_per_node
-          WRITE ( 18, 110 )
-#else
-          WRITE ( 18, 100 )  TRIM( run_description_header ),                          &
-                             numprocs * threads_per_task, 1, 1,                       &
-                             threads_per_task, nx+1, ny+1, nz, nr_timesteps_this_run, &
-                             average_cputime
-
-          IF ( num_acc_per_node /= 0 )  WRITE ( 18, 109 )  num_acc_per_node
-          WRITE ( 18, 110 )
-#endif
-          DO
-             ii = MAXLOC( sum )
-             i = ii(1)
-             IF ( sum(i) /= -1.0_wp )  THEN
-                WRITE ( 18, 102 ) &
-              log_point(i)%place, log_point(i)%sum,                            &
-                   log_point(i)%sum / log_point(1)%sum * 100.0_wp,             &
-                   log_point(i)%counts, pe_min(i), pe_max(i), pe_rms(i)
-                sum(i) = -1.0_wp
-             ELSE
-                EXIT
-             ENDIF
-          ENDDO
-       ENDIF
-
-
-!
-!--    The same procedure again for the individual measurements.
-!
-!--    Compute cpu-times in seconds
-       log_point_s%mtime  = log_point_s%mtime  / norm
-       log_point_s%sum    = log_point_s%sum    / norm
-       log_point_s%vector = log_point_s%vector / norm
-       WHERE ( log_point_s%counts /= 0 )
-          log_point_s%mean = log_point_s%sum / log_point_s%counts
-       END WHERE
-
-!
-!--    Collect cpu-times from all PEs and calculate statistics
-#if defined( __parallel )
-!
-!--    Set barrier in order to avoid that PE0 receives log_point_s-data
-!--    while still busy with receiving log_point-data (see above)
-       CALL MPI_BARRIER( comm2d, ierr )
-#endif
-       IF ( myid == 0 )  THEN
-!
-!--       Initialize temporary arrays needed for statistics
-          pe_min = log_point_s%sum
-          pe_max = log_point_s%sum    ! need to be set in case of 1 PE
-          pe_rms = 0.0_wp
-
-#if defined( __parallel )
-!
-!--       Receive data from all PEs
-          DO  i = 1, numprocs-1
-             CALL MPI_RECV( pe_max(1), SIZE( log_point ), MPI_REAL, &
-                            MPI_ANY_SOURCE, MPI_ANY_TAG, comm2d, status, ierr )
-             sender = status(MPI_SOURCE)
-             pe_log_points(:,sender) = pe_max
-          ENDDO
-          pe_log_points(:,0) = log_point_s%sum   ! Results from PE0
-!
-!--       Calculate mean of all PEs, store it on log_point_s%sum
-!--       and find minimum and maximum
-          DO  iii = 1, SIZE( log_point )
-             DO  i = 1, numprocs-1
-                log_point_s(iii)%sum = log_point_s(iii)%sum + pe_log_points(iii,i)
-                pe_min(iii) = MIN( pe_min(iii), pe_log_points(iii,i) )
-                pe_max(iii) = MAX( pe_max(iii), pe_log_points(iii,i) )
-             ENDDO
-             log_point_s(iii)%sum = log_point_s(iii)%sum / numprocs
-!
-!--          Calculate rms
-             DO  i = 0, numprocs-1
-                pe_rms(iii) = pe_rms(iii) + (                                  &
-                                    pe_log_points(iii,i) - log_point_s(iii)%sum &
-                                            )**2
-             ENDDO
-             pe_rms(iii) = SQRT( pe_rms(iii) / numprocs )
-          ENDDO
-       ELSE
-!
-!--       Send data to PE0 (pe_max is used as temporary storage to send
-!--       the data in order to avoid sending the data type log)
-          pe_max = log_point_s%sum
-          CALL MPI_SEND( pe_max(1), SIZE( log_point ), MPI_REAL, 0, 0, comm2d, &
-                         ierr )
-#endif
-
-       ENDIF
-
-!
-!--    Write cpu-times
-       IF ( myid == 0 )  THEN
-!
-!--       Re-store sums
-          WHERE ( log_point_s%counts /= 0 )
-             sum = log_point_s%sum
-          ELSEWHERE
-             sum = -1.0_wp
-          ENDWHERE
-
-!
-!--       Write cpu-times sorted by size
-          WRITE ( 18, 101 )
-          DO
-             ii = MAXLOC( sum )
-             i = ii(1)
-             IF ( sum(i) /= -1.0_wp )  THEN
-                WRITE ( 18, 102 )                                              &
-                   log_point_s(i)%place, log_point_s(i)%sum,                   &
-                   log_point_s(i)%sum / log_point(1)%sum * 100.0_wp,           &
-                   log_point_s(i)%counts, pe_min(i), pe_max(i), pe_rms(i)
-                sum(i) = -1.0_wp
-             ELSE
-                EXIT
-             ENDIF
-          ENDDO
-
-!
-!--       Output of handling of MPI operations
-          IF ( collective_wait )  THEN
-             WRITE ( 18, 103 )
-          ELSE
-             WRITE ( 18, 104 )
-          ENDIF
-          IF ( cpu_log_barrierwait )  WRITE ( 18, 111 )
-          IF ( synchronous_exchange )  THEN
-             WRITE ( 18, 105 )
-          ELSE
-             WRITE ( 18, 106 )
-          ENDIF
-
-!
-!--       Empty lines in order to create a gap to the results of the model
-!--       continuation runs
-          WRITE ( 18, 107 )
-
-!
-!--       Unit 18 is not needed anymore
-          CALL close_file( 18 )
-
-       ENDIF
-
-       CALL location_message( 'finished', .TRUE. )
-
-   100 FORMAT (A/11('-')//'CPU measures for ',I5,' PEs (',I5,'(x) * ',I5,'(y', &
-               &') tasks *',I5,' threads):'//                                  &
-               'gridpoints (x/y/z): ',20X,I5,' * ',I5,' * ',I5/                &
-               'nr of timesteps: ',22X,I6/                                     &
-               'cpu time per grid point and timestep: ',5X,F8.5,' * 10**-6 s')
-
-   101 FORMAT (/'special measures:'/ &
-               &'-----------------------------------------------------------', &
-               &'--------------------')
-
-   102 FORMAT (A20,2X,F9.3,2X,F7.2,1X,I7,3(1X,F9.3))
-   103 FORMAT (/'Barriers are set in front of collective operations')
-   104 FORMAT (/'No barriers are set in front of collective operations')
-   105 FORMAT (/'Exchange of ghostpoints via MPI_SENDRCV')
-   106 FORMAT (/'Exchange of ghostpoints via MPI_ISEND/MPI_IRECV')
-   107 FORMAT (//)
-   108 FORMAT ('Accelerator boards per node: ',14X,I2)
-   109 FORMAT ('Accelerator boards: ',23X,I2)
-   110 FORMAT ('----------------------------------------------------------',   &
-               &'------------'//&
-               &'place:                        mean        counts      min  ', &
-               &'     max       rms'/ &
-               &'                           sec.      %                sec. ', &
-               &'     sec.      sec.'/  &
-               &'-----------------------------------------------------------', &
-               &'-------------------')
-   111 FORMAT (/'Barriers are set at beginning (start/continue) of measurements')
-
-    END SUBROUTINE cpu_statistics
-
- END MODULE cpulog
Index: /palm/trunk/SOURCE/cpulog_mod.f90
===================================================================
--- /palm/trunk/SOURCE/cpulog_mod.f90	(revision 1850)
+++ /palm/trunk/SOURCE/cpulog_mod.f90	(revision 1850)
@@ -0,0 +1,571 @@
+!> @file cpulog_mod.f90
+!--------------------------------------------------------------------------------!
+! This file is part of PALM.
+!
+! PALM is free software: you can redistribute it and/or modify it under the terms
+! of the GNU General Public License as published by the Free Software Foundation,
+! either version 3 of the License, or (at your option) any later version.
+!
+! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
+! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
+! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along with
+! PALM. If not, see <http://www.gnu.org/licenses/>.
+!
+! Copyright 1997-2016 Leibniz Universitaet Hannover
+!--------------------------------------------------------------------------------!
+!
+! Current revisions:
+! -----------------
+! Module renamed
+! 
+!
+! Former revisions:
+! -----------------
+! $Id$
+!
+! 1808 2016-04-05 19:44:00Z raasch
+! cpu measurements are done with standard FORTRAN routine on every machine
+!
+! 1682 2015-10-07 23:56:08Z knoop
+! Code annotations made doxygen readable 
+! 
+! 1402 2014-05-09 14:25:13Z raasch
+! location messages added
+!
+! 1369 2014-04-24 05:57:38Z raasch
+! routine description added
+!
+! 1353 2014-04-08 15:21:23Z heinze
+! REAL constants provided with KIND-attribute
+!
+! 1322 2014-03-20 16:38:49Z raasch
+! REAL functions provided with KIND-attribute
+!
+! 1320 2014-03-20 08:40:49Z raasch
+! ONLY-attribute added to USE-statements,
+! kind-parameters added to all INTEGER and REAL declaration statements,
+! kinds are defined in new module kinds,
+! revision history before 2012 removed,
+! comment fields (!:) to be used for variable explanations added to
+! all variable declaration statements
+! 
+! 1318 2014-03-17 13:35:16Z raasch
+! former files/routines cpu_log and cpu_statistics combined to one module,
+! which also includes the former data module cpulog from the modules-file
+!
+! 1036 2012-10-22 13:43:42Z raasch
+! code put under GPL (PALM 3.9)
+!
+! Revision 1.1  1997/07/24 11:12:29  raasch
+! Initial revision
+!
+!
+! Description:
+! ------------
+!> CPU-time measurements for any program part whatever. Results of the
+!> measurements are output at the end of the run in local file CPU_MEASURES.
+!>
+!> To measure the CPU-time (better to say the wallclock time) of a specific code
+!> segment, two calls of cpu_log have to be used as brackets in front and at the
+!> end of the segment:
+!>
+!>     CALL cpu_log( log_point(n), 'any identifier', 'start' )
+!>       ... code segment ...
+!>     CALL cpu_log( log_point(n), 'any identifier', 'stop' )
+!>
+!> Parts of the code segment can be excluded from the measurement by additional
+!> call of cpu_log:
+!>
+!>       ... first segment to be measured
+!>     CALL cpu_log( log_point(n), 'any identifier', 'pause' )
+!>       ... oart of segment to be excluded from measurement
+!>     CALL cpu_log( log_point(n), 'any identifier', 'continue' )
+!>       ... second segment to be mesasured
+!>
+!> n is an INTEGER within the interval [1,100] defining the id of the specific
+!> code segment, 'any identifier' is a string describing the code segment to be
+!> measured. It can be freely chosen and results will appear under this name in
+!> file CPU_MEASURES. ids can only be used once. If you like to do a
+!> measurement of a new part of the code, please look for an id which is unused
+!> ao far.
+!>
+!> d3par-parameter cpu_log_barrierwait can be used to set an MPI barrier at the
+!> beginning of the measurement (modus 'start' or 'continue'), to avoid that
+!> idle times (due to MPI calls in the code segment, which are
+!> waiting for other processes to be finished) affect the measurements.
+!> If barriers shall not be used at all, a fourth, optional parameter has to be
+!> given:
+!>
+!>     CALL cpu_log( ..., ..., 'start', cpu_log_nowait )
+!>
+!> Variable log_point should be used for non-overlapping code segments, and they
+!> should sum up to the total cpu-time required by the complete run.
+!> Variable log_point_s can be used for any other special (s) measurements.
+!------------------------------------------------------------------------------!
+ MODULE cpulog
+ 
+
+    USE control_parameters,                                                    &
+        ONLY: message_string, nr_timesteps_this_run, run_description_header,   &
+              synchronous_exchange
+               
+    USE indices,                                                               &
+        ONLY: nx, ny, nz
+        
+    USE kinds
+    
+    USE pegrid
+
+    IMPLICIT NONE
+
+    PRIVATE
+    PUBLIC   cpu_log, cpu_log_barrierwait, cpu_log_nowait, cpu_statistics,     &
+             initial_wallclock_time, log_point, log_point_s
+
+    INTERFACE cpu_log
+       MODULE PROCEDURE cpu_log
+    END INTERFACE cpu_log
+
+    INTERFACE cpu_statistics
+       MODULE PROCEDURE cpu_statistics
+    END INTERFACE cpu_statistics
+
+    INTEGER(iwp), PARAMETER ::  cpu_log_continue = 0  !< 
+    INTEGER(iwp), PARAMETER ::  cpu_log_pause = 1     !< 
+    INTEGER(iwp), PARAMETER ::  cpu_log_start = 2     !< 
+    INTEGER(iwp), PARAMETER ::  cpu_log_stop = 3      !< 
+
+    LOGICAL            ::  cpu_log_barrierwait = .FALSE.  !< 
+    LOGICAL, PARAMETER ::  cpu_log_nowait = .FALSE.       !< 
+
+    REAL(wp) ::  initial_wallclock_time  !< 
+
+    TYPE logpoint
+       REAL(wp)           ::  isum       !< 
+       REAL(wp)           ::  ivect      !< 
+       REAL(wp)           ::  mean       !< 
+       REAL(wp)           ::  mtime      !< 
+       REAL(wp)           ::  mtimevec   !< 
+       REAL(wp)           ::  sum        !< 
+       REAL(wp)           ::  vector     !< 
+       INTEGER(iwp)       ::  counts     !< 
+       CHARACTER (LEN=20) ::  place      !< 
+    END TYPE logpoint
+
+    TYPE(logpoint), DIMENSION(100) ::  log_point = logpoint( 0.0_wp, 0.0_wp,   &
+                                       0.0_wp, 0.0_wp, 0.0_wp, 0.0_wp, 0.0_wp, &
+                                       0, ' ' ),                               &
+                                       log_point_s = logpoint( 0.0_wp, 0.0_wp, &
+                                       0.0_wp, 0.0_wp, 0.0_wp, 0.0_wp, 0.0_wp, &
+                                       0, ' ' )
+
+    SAVE
+
+ CONTAINS
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> @todo Missing subroutine description.
+!------------------------------------------------------------------------------!
+    SUBROUTINE cpu_log( log_event, place, modus, barrierwait )
+
+       IMPLICIT NONE
+
+       CHARACTER (LEN=*) ::  modus              !< 
+       CHARACTER (LEN=*) ::  place              !< 
+       
+       LOGICAL           ::  wait_allowed       !< 
+       LOGICAL, OPTIONAL ::  barrierwait        !< 
+       LOGICAL, SAVE     ::  first = .TRUE.     !< 
+       
+       REAL(wp)          ::  mtime = 0.0_wp     !< 
+       REAL(wp)          ::  mtimevec = 0.0_wp  !< 
+       TYPE(logpoint)    ::  log_event          !< 
+
+       INTEGER(idp)     ::  count        !< 
+       INTEGER(idp)     ::  count_rate   !< 
+
+
+!
+!--    Initialize and check, respectively, point of measurement
+       IF ( log_event%place == ' ' )  THEN
+          log_event%place = place
+       ELSEIF ( log_event%place /= place )  THEN
+          WRITE( message_string, * ) 'wrong argument & expected: ',            &
+                            TRIM(log_event%place), '  given: ',  TRIM( place )
+          CALL message( 'cpu_log', 'PA0174', 1, 2, 0, 6, 0 )
+       ENDIF
+
+!
+!--    Determine, if barriers are allowed to set
+       IF ( PRESENT( barrierwait ) )  THEN
+          wait_allowed = barrierwait
+       ELSE
+          wait_allowed = .TRUE.
+       ENDIF
+
+!
+!--    MPI barrier, if requested, in order to avoid measuring wait times
+!--    caused by MPI routines waiting for other MPI routines of other
+!--    PEs that have not yet finished
+#if defined( __parallel )
+       IF ( cpu_log_barrierwait  .AND.  wait_allowed  .AND.                    &
+            ( modus == 'start'  .OR.  modus == 'continue' ) )  THEN
+          CALL MPI_BARRIER( comm2d, ierr )
+       ENDIF
+#endif
+
+!
+!--    Take current time
+       CALL SYSTEM_CLOCK( count, count_rate )
+       mtime = REAL( count, KIND=wp ) / REAL( count_rate, KIND=wp )
+
+!
+!--    Start, stop or pause measurement
+       IF ( modus == 'start'  .OR.  modus == 'continue' )  THEN
+          log_event%mtime    = mtime
+          log_event%mtimevec = mtimevec
+       ELSEIF ( modus == 'pause' )  THEN
+          IF ( ( mtime - log_event%mtime ) < 0.0  .AND.  first )  THEN
+             WRITE( message_string, * ) 'negative time interval occured',      &
+                         ' &PE',myid,' L=PAUSE "',TRIM(log_event%place),       &
+                         '" new=', mtime,' last=',log_event%mtime
+             CALL message( 'cpu_log', 'PA0176', 0, 1, -1, 6, 0 )
+             first = .FALSE.
+          ENDIF
+          log_event%isum     = log_event%isum + mtime - log_event%mtime
+          log_event%ivect    = log_event%ivect  + mtimevec - log_event%mtimevec
+       ELSEIF ( modus == 'stop' )  THEN
+          IF ( ( mtime - log_event%mtime + log_event%isum ) < 0.0  .AND.       &
+               first )  THEN
+             WRITE( message_string, * ) 'negative time interval occured',      &
+                         ' &PE',myid,' L=STOP "',TRIM(log_event%place),'" new=', &
+                         mtime,' last=',log_event%mtime,' isum=',log_event%isum
+             CALL message( 'cpu_log', 'PA0177', 0, 1, -1, 6, 0 )
+             first = .FALSE.
+          ENDIF
+          log_event%mtime    = mtime    - log_event%mtime    + log_event%isum
+          log_event%mtimevec = mtimevec - log_event%mtimevec + log_event%ivect
+          log_event%sum      = log_event%sum  + log_event%mtime
+          IF ( log_event%sum < 0.0  .AND.  first )  THEN
+             WRITE( message_string, * ) 'negative time interval occured',      &
+                         ' &PE',myid,' L=STOP "',TRIM(log_event%place),'" sum=', &
+                                         log_event%sum,' mtime=',log_event%mtime
+             CALL message( 'cpu_log', 'PA0178', 0, 1, -1, 6, 0 )
+             first = .FALSE.
+          ENDIF
+          log_event%vector   = log_event%vector + log_event%mtimevec
+          log_event%counts   = log_event%counts + 1
+          log_event%isum     = 0.0_wp
+          log_event%ivect    = 0.0_wp
+       ELSE
+          message_string = 'unknown modus of time measurement: ' // TRIM( modus )
+          CALL message( 'cpu_log', 'PA0179', 0, 1, -1, 6, 0 )
+       ENDIF
+
+    END SUBROUTINE cpu_log
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Analysis and output of the cpu-times measured. All PE results are collected
+!> on PE0 in order to calculate the mean cpu-time over all PEs and other
+!> statistics. The output is sorted according to the amount of cpu-time consumed
+!> and output on PE0.
+!------------------------------------------------------------------------------!
+ 
+    SUBROUTINE cpu_statistics
+
+       IMPLICIT NONE
+
+       INTEGER(iwp)    ::  i               !< 
+       INTEGER(iwp)    ::  ii(1)           !< 
+       INTEGER(iwp)    ::  iii             !< 
+       INTEGER(iwp)    ::  sender          !< 
+       REAL(wp)       ::  average_cputime  !< 
+       REAL(wp), SAVE ::  norm = 1.0_wp    !< 
+       REAL(wp), DIMENSION(:),   ALLOCATABLE ::  pe_max        !< 
+       REAL(wp), DIMENSION(:),   ALLOCATABLE ::  pe_min        !< 
+       REAL(wp), DIMENSION(:),   ALLOCATABLE ::  pe_rms        !< 
+       REAL(wp), DIMENSION(:),   ALLOCATABLE ::  sum           !< 
+       REAL(wp), DIMENSION(:,:), ALLOCATABLE ::  pe_log_points !< 
+
+
+       CALL location_message( 'calculating cpu statistics', .FALSE. )
+
+!
+!--    Compute cpu-times in seconds
+       log_point%mtime  = log_point%mtime  / norm
+       log_point%sum    = log_point%sum    / norm
+       log_point%vector = log_point%vector / norm
+       WHERE ( log_point%counts /= 0 )
+          log_point%mean = log_point%sum / log_point%counts
+       END WHERE
+
+
+!
+!--    Collect cpu-times from all PEs and calculate statistics
+       IF ( myid == 0 )  THEN
+!
+!--       Allocate and initialize temporary arrays needed for statistics
+          ALLOCATE( pe_max( SIZE( log_point ) ), pe_min( SIZE( log_point ) ),  &
+                    pe_rms( SIZE( log_point ) ),                               &
+                    pe_log_points( SIZE( log_point ), 0:numprocs-1 ) )
+          pe_min = log_point%sum
+          pe_max = log_point%sum    ! need to be set in case of 1 PE
+          pe_rms = 0.0_wp
+
+#if defined( __parallel )
+!
+!--       Receive data from all PEs
+          DO  i = 1, numprocs-1
+             CALL MPI_RECV( pe_max(1), SIZE( log_point ), MPI_REAL,            &
+                            i, i, comm2d, status, ierr )
+             sender = status(MPI_SOURCE)
+             pe_log_points(:,sender) = pe_max
+          ENDDO
+          pe_log_points(:,0) = log_point%sum   ! Results from PE0
+!
+!--       Calculate mean of all PEs, store it on log_point%sum
+!--       and find minimum and maximum
+          DO  iii = 1, SIZE( log_point )
+             DO  i = 1, numprocs-1
+                log_point(iii)%sum = log_point(iii)%sum + pe_log_points(iii,i)
+                pe_min(iii) = MIN( pe_min(iii), pe_log_points(iii,i) )
+                pe_max(iii) = MAX( pe_max(iii), pe_log_points(iii,i) )
+             ENDDO
+             log_point(iii)%sum = log_point(iii)%sum / numprocs
+!
+!--          Calculate rms
+             DO  i = 0, numprocs-1
+                pe_rms(iii) = pe_rms(iii) + (                                  &
+                                    pe_log_points(iii,i) - log_point(iii)%sum  &
+                                            )**2
+             ENDDO
+             pe_rms(iii) = SQRT( pe_rms(iii) / numprocs )
+          ENDDO
+       ELSE
+!
+!--       Send data to PE0 (pe_max is used as temporary storage to send
+!--       the data in order to avoid sending the data type log)
+          ALLOCATE( pe_max( SIZE( log_point ) ) )
+          pe_max = log_point%sum
+          CALL MPI_SEND( pe_max(1), SIZE( log_point ), MPI_REAL, 0, myid, comm2d, &
+                         ierr )
+#endif
+
+       ENDIF
+
+!
+!--    Write cpu-times
+       IF ( myid == 0 )  THEN
+!
+!--       Re-store sums
+          ALLOCATE( sum( SIZE( log_point ) ) )
+          WHERE ( log_point%counts /= 0 )
+             sum = log_point%sum
+          ELSEWHERE
+             sum = -1.0_wp
+          ENDWHERE
+
+!
+!--       Get total time in order to calculate CPU-time per gridpoint and timestep
+          IF ( nr_timesteps_this_run /= 0 )  THEN
+             average_cputime = log_point(1)%sum / REAL( (nx+1) * (ny+1) * nz, KIND=wp ) / &
+                               REAL( nr_timesteps_this_run, KIND=wp ) * 1E6_wp  ! in micro-sec
+          ELSE
+             average_cputime = -1.0_wp
+          ENDIF
+
+!
+!--       Write cpu-times sorted by size
+          CALL check_open( 18 )
+#if defined( __parallel )
+          WRITE ( 18, 100 )  TRIM( run_description_header ),                          &
+                             numprocs * threads_per_task, pdims(1), pdims(2),         &
+                             threads_per_task, nx+1, ny+1, nz, nr_timesteps_this_run, &
+                             average_cputime
+
+          IF ( num_acc_per_node /= 0 )  WRITE ( 18, 108 )  num_acc_per_node
+          WRITE ( 18, 110 )
+#else
+          WRITE ( 18, 100 )  TRIM( run_description_header ),                          &
+                             numprocs * threads_per_task, 1, 1,                       &
+                             threads_per_task, nx+1, ny+1, nz, nr_timesteps_this_run, &
+                             average_cputime
+
+          IF ( num_acc_per_node /= 0 )  WRITE ( 18, 109 )  num_acc_per_node
+          WRITE ( 18, 110 )
+#endif
+          DO
+             ii = MAXLOC( sum )
+             i = ii(1)
+             IF ( sum(i) /= -1.0_wp )  THEN
+                WRITE ( 18, 102 ) &
+              log_point(i)%place, log_point(i)%sum,                            &
+                   log_point(i)%sum / log_point(1)%sum * 100.0_wp,             &
+                   log_point(i)%counts, pe_min(i), pe_max(i), pe_rms(i)
+                sum(i) = -1.0_wp
+             ELSE
+                EXIT
+             ENDIF
+          ENDDO
+       ENDIF
+
+
+!
+!--    The same procedure again for the individual measurements.
+!
+!--    Compute cpu-times in seconds
+       log_point_s%mtime  = log_point_s%mtime  / norm
+       log_point_s%sum    = log_point_s%sum    / norm
+       log_point_s%vector = log_point_s%vector / norm
+       WHERE ( log_point_s%counts /= 0 )
+          log_point_s%mean = log_point_s%sum / log_point_s%counts
+       END WHERE
+
+!
+!--    Collect cpu-times from all PEs and calculate statistics
+#if defined( __parallel )
+!
+!--    Set barrier in order to avoid that PE0 receives log_point_s-data
+!--    while still busy with receiving log_point-data (see above)
+       CALL MPI_BARRIER( comm2d, ierr )
+#endif
+       IF ( myid == 0 )  THEN
+!
+!--       Initialize temporary arrays needed for statistics
+          pe_min = log_point_s%sum
+          pe_max = log_point_s%sum    ! need to be set in case of 1 PE
+          pe_rms = 0.0_wp
+
+#if defined( __parallel )
+!
+!--       Receive data from all PEs
+          DO  i = 1, numprocs-1
+             CALL MPI_RECV( pe_max(1), SIZE( log_point ), MPI_REAL, &
+                            MPI_ANY_SOURCE, MPI_ANY_TAG, comm2d, status, ierr )
+             sender = status(MPI_SOURCE)
+             pe_log_points(:,sender) = pe_max
+          ENDDO
+          pe_log_points(:,0) = log_point_s%sum   ! Results from PE0
+!
+!--       Calculate mean of all PEs, store it on log_point_s%sum
+!--       and find minimum and maximum
+          DO  iii = 1, SIZE( log_point )
+             DO  i = 1, numprocs-1
+                log_point_s(iii)%sum = log_point_s(iii)%sum + pe_log_points(iii,i)
+                pe_min(iii) = MIN( pe_min(iii), pe_log_points(iii,i) )
+                pe_max(iii) = MAX( pe_max(iii), pe_log_points(iii,i) )
+             ENDDO
+             log_point_s(iii)%sum = log_point_s(iii)%sum / numprocs
+!
+!--          Calculate rms
+             DO  i = 0, numprocs-1
+                pe_rms(iii) = pe_rms(iii) + (                                  &
+                                    pe_log_points(iii,i) - log_point_s(iii)%sum &
+                                            )**2
+             ENDDO
+             pe_rms(iii) = SQRT( pe_rms(iii) / numprocs )
+          ENDDO
+       ELSE
+!
+!--       Send data to PE0 (pe_max is used as temporary storage to send
+!--       the data in order to avoid sending the data type log)
+          pe_max = log_point_s%sum
+          CALL MPI_SEND( pe_max(1), SIZE( log_point ), MPI_REAL, 0, 0, comm2d, &
+                         ierr )
+#endif
+
+       ENDIF
+
+!
+!--    Write cpu-times
+       IF ( myid == 0 )  THEN
+!
+!--       Re-store sums
+          WHERE ( log_point_s%counts /= 0 )
+             sum = log_point_s%sum
+          ELSEWHERE
+             sum = -1.0_wp
+          ENDWHERE
+
+!
+!--       Write cpu-times sorted by size
+          WRITE ( 18, 101 )
+          DO
+             ii = MAXLOC( sum )
+             i = ii(1)
+             IF ( sum(i) /= -1.0_wp )  THEN
+                WRITE ( 18, 102 )                                              &
+                   log_point_s(i)%place, log_point_s(i)%sum,                   &
+                   log_point_s(i)%sum / log_point(1)%sum * 100.0_wp,           &
+                   log_point_s(i)%counts, pe_min(i), pe_max(i), pe_rms(i)
+                sum(i) = -1.0_wp
+             ELSE
+                EXIT
+             ENDIF
+          ENDDO
+
+!
+!--       Output of handling of MPI operations
+          IF ( collective_wait )  THEN
+             WRITE ( 18, 103 )
+          ELSE
+             WRITE ( 18, 104 )
+          ENDIF
+          IF ( cpu_log_barrierwait )  WRITE ( 18, 111 )
+          IF ( synchronous_exchange )  THEN
+             WRITE ( 18, 105 )
+          ELSE
+             WRITE ( 18, 106 )
+          ENDIF
+
+!
+!--       Empty lines in order to create a gap to the results of the model
+!--       continuation runs
+          WRITE ( 18, 107 )
+
+!
+!--       Unit 18 is not needed anymore
+          CALL close_file( 18 )
+
+       ENDIF
+
+       CALL location_message( 'finished', .TRUE. )
+
+   100 FORMAT (A/11('-')//'CPU measures for ',I5,' PEs (',I5,'(x) * ',I5,'(y', &
+               &') tasks *',I5,' threads):'//                                  &
+               'gridpoints (x/y/z): ',20X,I5,' * ',I5,' * ',I5/                &
+               'nr of timesteps: ',22X,I6/                                     &
+               'cpu time per grid point and timestep: ',5X,F8.5,' * 10**-6 s')
+
+   101 FORMAT (/'special measures:'/ &
+               &'-----------------------------------------------------------', &
+               &'--------------------')
+
+   102 FORMAT (A20,2X,F9.3,2X,F7.2,1X,I7,3(1X,F9.3))
+   103 FORMAT (/'Barriers are set in front of collective operations')
+   104 FORMAT (/'No barriers are set in front of collective operations')
+   105 FORMAT (/'Exchange of ghostpoints via MPI_SENDRCV')
+   106 FORMAT (/'Exchange of ghostpoints via MPI_ISEND/MPI_IRECV')
+   107 FORMAT (//)
+   108 FORMAT ('Accelerator boards per node: ',14X,I2)
+   109 FORMAT ('Accelerator boards: ',23X,I2)
+   110 FORMAT ('----------------------------------------------------------',   &
+               &'------------'//&
+               &'place:                        mean        counts      min  ', &
+               &'     max       rms'/ &
+               &'                           sec.      %                sec. ', &
+               &'     sec.      sec.'/  &
+               &'-----------------------------------------------------------', &
+               &'-------------------')
+   111 FORMAT (/'Barriers are set at beginning (start/continue) of measurements')
+
+    END SUBROUTINE cpu_statistics
+
+ END MODULE cpulog
Index: lm/trunk/SOURCE/cuda_fft_interfaces.f90
===================================================================
--- /palm/trunk/SOURCE/cuda_fft_interfaces.f90	(revision 1849)
+++ 	(revision )
@@ -1,186 +1,0 @@
-!> @file cuda_fft_interfaces.f90
-!--------------------------------------------------------------------------------!
-! This file is part of PALM.
-!
-! PALM is free software: you can redistribute it and/or modify it under the terms
-! of the GNU General Public License as published by the Free Software Foundation,
-! either version 3 of the License, or (at your option) any later version.
-!
-! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
-! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
-! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along with
-! PALM. If not, see <http://www.gnu.org/licenses/>.
-!
-! Copyright 1997-2016 Leibniz Universitaet Hannover
-!--------------------------------------------------------------------------------!
-!
-! Current revisions:
-! -----------------
-! 
-! 
-! Former revisions:
-! -----------------
-! $Id$
-!
-! 1682 2015-10-07 23:56:08Z knoop
-! Code annotations made doxygen readable 
-! 
-! 1374 2014-04-25 12:55:07Z raasch
-! bugfix: missing module kinds added
-!
-! 1320 2014-03-20 08:40:49Z raasch
-! Kind-parameters added to all INTEGER and REAL declaration statements,
-! kinds are defined in new module kinds,
-! old module precision_kind is removed,
-! revision history before 2012 removed,
-! comment fields (!:) to be used for variable explanations added to
-! all variable declaration statements
-!
-! 1224 2013-09-16 07:27:23Z raasch
-! dummy interface added to avoid compiler warnings
-!
-! 1166 2013-05-24 13:55:44Z raasch
-! C_DOUBLE/COMPLEX reset to dpk,
-! DEVICE attribut added to idata/odata arguments
-!
-! 1153 2013-05-10 14:33:08Z raasch
-! code adjustment of data types for CUDA fft required by PGI 12.3 / CUDA 5.0
-!
-! 1111 2013-03-08 23:54:10Z raasch
-! idata and odata changed from 1d- to 3d-arrays
-!
-! 1106 2013-03-04 05:31:38Z raasch
-! Initial revision
-!
-! Description:
-! ------------
-!> FORTRAN interfaces for the CUDA fft
-!> Routines for the fft along x and y (forward/backward) using the CUDA fft
-!--------------------------------------------------------------------------------!
- MODULE cuda_fft_interfaces
- 
-
-#if defined ( __cuda_fft )
-
-    USE kinds
-
-    INTEGER(iwp) ::  CUFFT_FORWARD = -1   !<
-    INTEGER(iwp) ::  CUFFT_INVERSE =  1   !<
-    INTEGER(iwp) ::  CUFFT_R2C = Z'2a'    !< Real to Complex (interleaved)
-    INTEGER(iwp) ::  CUFFT_C2R = Z'2c'    !< Complex (interleaved) to Real
-    INTEGER(iwp) ::  CUFFT_C2C = Z'29'    !< Complex to Complex, interleaved
-    INTEGER(iwp) ::  CUFFT_D2Z = Z'6a'    !< Double to Double-Complex
-    INTEGER(iwp) ::  CUFFT_Z2D = Z'6c'    !< Double-Complex to Double
-    INTEGER(iwp) ::  CUFFT_Z2Z = Z'69'    !< Double-Complex to Double-Complex
-
-    PUBLIC
-
-
-!
-!-- cufftPlan1d( cufftHandle *plan, int nx, cufftType type, int batch )
-    INTERFACE CUFFTPLAN1D
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> @todo Missing subroutine description.
-!------------------------------------------------------------------------------!
-       SUBROUTINE CUFFTPLAN1D( plan, nx, type, batch ) bind( C, name='cufftPlan1d' )
-
-          USE ISO_C_BINDING
-
-          INTEGER(C_INT)        ::  plan   !< 
-          INTEGER(C_INT), value ::  batch  !< 
-          INTEGER(C_INT), value ::  nx     !< 
-          INTEGER(C_INT), value ::  type   !< 
-       END SUBROUTINE CUFFTPLAN1D
-
-    END INTERFACE CUFFTPLAN1D
-
-!
-!-- cufftDestroy( cufftHandle plan )  !!! remove later if not really needed !!!
-    INTERFACE CUFFTDESTROY
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> @todo Missing subroutine description.
-!------------------------------------------------------------------------------!
-       SUBROUTINE CUFFTDESTROY( plan ) bind( C, name='cufftDestroy' )
-
-          USE ISO_C_BINDING
-
-          INTEGER(C_INT), VALUE ::  plan
-
-       END SUBROUTINE CUFFTDESTROY
-
-    END INTERFACE CUFFTDESTROY
-
-
-    INTERFACE CUFFTEXECZ2D
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> @todo Missing subroutine description.
-!------------------------------------------------------------------------------!
-       SUBROUTINE CUFFTEXECZ2D( plan, idata, odata ) bind( C, name='cufftExecZ2D' )
-
-          USE ISO_C_BINDING
-          USE kinds
-
-          INTEGER(C_INT), VALUE ::  plan          !<
-          COMPLEX(dp), DEVICE   ::  idata(:,:,:)  !<
-          REAL(dp), DEVICE      ::  odata(:,:,:)  !<
-
-       END SUBROUTINE CUFFTEXECZ2D
-
-    END INTERFACE CUFFTEXECZ2D
-
-
-    INTERFACE CUFFTEXECD2Z
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> @todo Missing subroutine description.
-!------------------------------------------------------------------------------!
-       SUBROUTINE CUFFTEXECD2Z( plan, idata, odata ) bind( C, name='cufftExecD2Z' )
-
-          USE ISO_C_BINDING
-          
-          USE kinds
-
-          INTEGER(C_INT), VALUE ::  plan          !<
-          REAL(dp), DEVICE      ::  idata(:,:,:)  !<
-          COMPLEX(dp), DEVICE   ::  odata(:,:,:)  !<
-
-       END SUBROUTINE CUFFTEXECD2Z
-
-    END INTERFACE CUFFTEXECD2Z
-
-#else
-
-    INTERFACE CUFFTdummy
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Dummy interface to avoid compiler warnings in case of no bublic objects
-!> declared.
-!------------------------------------------------------------------------------!
-       SUBROUTINE CUFFTdummy( dummy )
-       
-          USE kinds
-
-          REAL(wp) ::  dummy  !<
-
-       END SUBROUTINE CUFFTdummy
-
-    END INTERFACE CUFFTdummy
-
-#endif
-
- END MODULE cuda_fft_interfaces
Index: /palm/trunk/SOURCE/cuda_fft_interfaces_mod.f90
===================================================================
--- /palm/trunk/SOURCE/cuda_fft_interfaces_mod.f90	(revision 1850)
+++ /palm/trunk/SOURCE/cuda_fft_interfaces_mod.f90	(revision 1850)
@@ -0,0 +1,187 @@
+!> @file cuda_fft_interfaces_mod.f90
+!--------------------------------------------------------------------------------!
+! This file is part of PALM.
+!
+! PALM is free software: you can redistribute it and/or modify it under the terms
+! of the GNU General Public License as published by the Free Software Foundation,
+! either version 3 of the License, or (at your option) any later version.
+!
+! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
+! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
+! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along with
+! PALM. If not, see <http://www.gnu.org/licenses/>.
+!
+! Copyright 1997-2016 Leibniz Universitaet Hannover
+!--------------------------------------------------------------------------------!
+!
+! Current revisions:
+! -----------------
+! Module renamed
+! 
+! 
+! Former revisions:
+! -----------------
+! $Id$
+!
+! 1682 2015-10-07 23:56:08Z knoop
+! Code annotations made doxygen readable 
+! 
+! 1374 2014-04-25 12:55:07Z raasch
+! bugfix: missing module kinds added
+!
+! 1320 2014-03-20 08:40:49Z raasch
+! Kind-parameters added to all INTEGER and REAL declaration statements,
+! kinds are defined in new module kinds,
+! old module precision_kind is removed,
+! revision history before 2012 removed,
+! comment fields (!:) to be used for variable explanations added to
+! all variable declaration statements
+!
+! 1224 2013-09-16 07:27:23Z raasch
+! dummy interface added to avoid compiler warnings
+!
+! 1166 2013-05-24 13:55:44Z raasch
+! C_DOUBLE/COMPLEX reset to dpk,
+! DEVICE attribut added to idata/odata arguments
+!
+! 1153 2013-05-10 14:33:08Z raasch
+! code adjustment of data types for CUDA fft required by PGI 12.3 / CUDA 5.0
+!
+! 1111 2013-03-08 23:54:10Z raasch
+! idata and odata changed from 1d- to 3d-arrays
+!
+! 1106 2013-03-04 05:31:38Z raasch
+! Initial revision
+!
+! Description:
+! ------------
+!> FORTRAN interfaces for the CUDA fft
+!> Routines for the fft along x and y (forward/backward) using the CUDA fft
+!--------------------------------------------------------------------------------!
+ MODULE cuda_fft_interfaces
+ 
+
+#if defined ( __cuda_fft )
+
+    USE kinds
+
+    INTEGER(iwp) ::  CUFFT_FORWARD = -1   !<
+    INTEGER(iwp) ::  CUFFT_INVERSE =  1   !<
+    INTEGER(iwp) ::  CUFFT_R2C = Z'2a'    !< Real to Complex (interleaved)
+    INTEGER(iwp) ::  CUFFT_C2R = Z'2c'    !< Complex (interleaved) to Real
+    INTEGER(iwp) ::  CUFFT_C2C = Z'29'    !< Complex to Complex, interleaved
+    INTEGER(iwp) ::  CUFFT_D2Z = Z'6a'    !< Double to Double-Complex
+    INTEGER(iwp) ::  CUFFT_Z2D = Z'6c'    !< Double-Complex to Double
+    INTEGER(iwp) ::  CUFFT_Z2Z = Z'69'    !< Double-Complex to Double-Complex
+
+    PUBLIC
+
+
+!
+!-- cufftPlan1d( cufftHandle *plan, int nx, cufftType type, int batch )
+    INTERFACE CUFFTPLAN1D
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> @todo Missing subroutine description.
+!------------------------------------------------------------------------------!
+       SUBROUTINE CUFFTPLAN1D( plan, nx, type, batch ) bind( C, name='cufftPlan1d' )
+
+          USE ISO_C_BINDING
+
+          INTEGER(C_INT)        ::  plan   !< 
+          INTEGER(C_INT), value ::  batch  !< 
+          INTEGER(C_INT), value ::  nx     !< 
+          INTEGER(C_INT), value ::  type   !< 
+       END SUBROUTINE CUFFTPLAN1D
+
+    END INTERFACE CUFFTPLAN1D
+
+!
+!-- cufftDestroy( cufftHandle plan )  !!! remove later if not really needed !!!
+    INTERFACE CUFFTDESTROY
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> @todo Missing subroutine description.
+!------------------------------------------------------------------------------!
+       SUBROUTINE CUFFTDESTROY( plan ) bind( C, name='cufftDestroy' )
+
+          USE ISO_C_BINDING
+
+          INTEGER(C_INT), VALUE ::  plan
+
+       END SUBROUTINE CUFFTDESTROY
+
+    END INTERFACE CUFFTDESTROY
+
+
+    INTERFACE CUFFTEXECZ2D
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> @todo Missing subroutine description.
+!------------------------------------------------------------------------------!
+       SUBROUTINE CUFFTEXECZ2D( plan, idata, odata ) bind( C, name='cufftExecZ2D' )
+
+          USE ISO_C_BINDING
+          USE kinds
+
+          INTEGER(C_INT), VALUE ::  plan          !<
+          COMPLEX(dp), DEVICE   ::  idata(:,:,:)  !<
+          REAL(dp), DEVICE      ::  odata(:,:,:)  !<
+
+       END SUBROUTINE CUFFTEXECZ2D
+
+    END INTERFACE CUFFTEXECZ2D
+
+
+    INTERFACE CUFFTEXECD2Z
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> @todo Missing subroutine description.
+!------------------------------------------------------------------------------!
+       SUBROUTINE CUFFTEXECD2Z( plan, idata, odata ) bind( C, name='cufftExecD2Z' )
+
+          USE ISO_C_BINDING
+          
+          USE kinds
+
+          INTEGER(C_INT), VALUE ::  plan          !<
+          REAL(dp), DEVICE      ::  idata(:,:,:)  !<
+          COMPLEX(dp), DEVICE   ::  odata(:,:,:)  !<
+
+       END SUBROUTINE CUFFTEXECD2Z
+
+    END INTERFACE CUFFTEXECD2Z
+
+#else
+
+    INTERFACE CUFFTdummy
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Dummy interface to avoid compiler warnings in case of no bublic objects
+!> declared.
+!------------------------------------------------------------------------------!
+       SUBROUTINE CUFFTdummy( dummy )
+       
+          USE kinds
+
+          REAL(wp) ::  dummy  !<
+
+       END SUBROUTINE CUFFTdummy
+
+    END INTERFACE CUFFTdummy
+
+#endif
+
+ END MODULE cuda_fft_interfaces
Index: lm/trunk/SOURCE/data_output_dvrp.f90
===================================================================
--- /palm/trunk/SOURCE/data_output_dvrp.f90	(revision 1849)
+++ 	(revision )
@@ -1,540 +1,0 @@
-!> @file data_output_dvrp.f90
-!--------------------------------------------------------------------------------!
-! This file is part of PALM.
-!
-! PALM is free software: you can redistribute it and/or modify it under the terms
-! of the GNU General Public License as published by the Free Software Foundation,
-! either version 3 of the License, or (at your option) any later version.
-!
-! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
-! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
-! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along with
-! PALM. If not, see <http://www.gnu.org/licenses/>.
-!
-! Copyright 1997-2016 Leibniz Universitaet Hannover
-!--------------------------------------------------------------------------------!
-!
-! Current revisions:
-! -----------------
-!
-! 
-! Former revisions:
-! -----------------
-! $Id$
-!
-! 1822 2016-04-07 07:49:42Z hoffmann
-! Particles and tails removed.
-!
-! 1682 2015-10-07 23:56:08Z knoop
-! Code annotations made doxygen readable 
-! 
-! 1353 2014-04-08 15:21:23Z heinze
-! REAL constants provided with KIND-attribute
-!
-! 1346 2014-03-27 13:18:20Z heinze
-! Bugfix: REAL constants provided with KIND-attribute especially in call of 
-! intrinsic function like MAX, MIN, SIGN
-!
-! 1320 2014-03-20 08:40:49Z raasch
-! ONLY-attribute added to USE-statements,
-! kind-parameters added to all INTEGER and REAL declaration statements,
-! kinds are defined in new module kinds,
-! revision history before 2012 removed,
-! comment fields (!:) to be used for variable explanations added to
-! all variable declaration statements
-!
-! 1318 2014-03-17 13:35:16Z raasch
-! module interfaces removed
-!
-! 1036 2012-10-22 13:43:42Z raasch
-! code put under GPL (PALM 3.9)
-!
-! 828 2012-02-21 12:00:36Z raasch
-! particle feature color renamed class
-!
-! Revision 1.1  2000/04/27 06:27:17  raasch
-! Initial revision
-!
-!
-! Description:
-! ------------
-!> Plot of isosurface and slicers with dvrp-software
-!------------------------------------------------------------------------------!
- MODULE dvrp_color
- 
-
-    USE dvrp_variables
-    
-    USE kinds
-
-    IMPLICIT NONE
-
- CONTAINS
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> @todo Missing subroutine description.
-!------------------------------------------------------------------------------!
-    SUBROUTINE color_dvrp( value, color )
-
-       REAL(wp), INTENT(IN)  ::  value    !< 
-       REAL(wp), INTENT(OUT) ::  color(4) !< 
-
-       REAL(wp)              ::  scale    !< 
-
-       scale = ( value - slicer_range_limits_dvrp(1,islice_dvrp) ) /           &
-               ( slicer_range_limits_dvrp(2,islice_dvrp) -                     &
-                 slicer_range_limits_dvrp(1,islice_dvrp) )
-
-       scale = MODULO( 180.0_wp + 180.0_wp * scale, 360.0_wp )
-
-       color = (/ scale, 0.5_wp, 1.0_wp, 0.0_wp /)
-
-    END SUBROUTINE color_dvrp
-
- END MODULE dvrp_color
-
-
- RECURSIVE SUBROUTINE data_output_dvrp
-
-#if defined( __dvrp_graphics )
-
-    USE arrays_3d,                                                             &
-        ONLY:  p, pt, q, ql, ts, u, us, v, w, zu
-        
-    USE cloud_parameters,                                                      &
-        ONLY:  l_d_cp, pt_d_t
-        
-    USE constants,                                                             &
-        ONLY:  pi
-        
-    USE control_parameters,                                                    &
-        ONLY:  cloud_droplets, cloud_physics, do2d, do3d, humidity, ibc_uv_b,  &
-               message_string, nz_do3d, passive_scalar, simulated_time,        &
-               threshold
-        
-    USE cpulog,                                                                &
-        ONLY:  log_point, log_point_s, cpu_log
-        
-    USE DVRP
-    
-    USE dvrp_color
-        
-    USE dvrp_variables
-        
-    USE grid_variables,                                                        &
-        ONLY:  dx, dy
-        
-    USE indices,                                                               &
-        ONLY:  nxl, nxr, nyn, nys, nzb
-        
-    USE kinds
-
-    USE pegrid
-
-    IMPLICIT NONE
-
-    CHARACTER (LEN=2) ::  section_chr      !< 
-    CHARACTER (LEN=6) ::  output_variable  !< 
-    
-    INTEGER(iwp) ::  c_mode           !<  
-    INTEGER(iwp) ::  c_size_x         !< 
-    INTEGER(iwp) ::  c_size_y         !< 
-    INTEGER(iwp) ::  c_size_z         !< 
-    INTEGER(iwp) ::  dvrp_nop         !< 
-    INTEGER(iwp) ::  dvrp_not         !< 
-    INTEGER(iwp) ::  gradient_normals !< 
-    INTEGER(iwp) ::  i                !< 
-    INTEGER(iwp) ::  ip               !< 
-    INTEGER(iwp) ::  j                !< 
-    INTEGER(iwp) ::  jp               !< 
-    INTEGER(iwp) ::  k                !< 
-    INTEGER(iwp) ::  l                !< 
-    INTEGER(iwp) ::  m                !< 
-    INTEGER(iwp) ::  n                !< 
-    INTEGER(iwp) ::  n_isosurface     !< 
-    INTEGER(iwp) ::  n_slicer         !< 
-    INTEGER(iwp) ::  nn               !< 
-    INTEGER(iwp) ::  section_mode     !< 
-    INTEGER(iwp) ::  vn               !< 
-    INTEGER(iwp), DIMENSION(:), ALLOCATABLE ::  p_c  !< 
-    INTEGER(iwp), DIMENSION(:), ALLOCATABLE ::  p_t  !< 
-
-    LOGICAL, DIMENSION(:), ALLOCATABLE ::  dvrp_mask  !< 
-
-    REAL(sp) ::  slicer_position  !< 
-    REAL(sp) ::  tmp_alpha        !< 
-    REAL(sp) ::  tmp_alpha_w      !< 
-    REAL(sp) ::  tmp_b            !< 
-    REAL(sp) ::  tmp_c_alpha      !< 
-    REAL(sp) ::  tmp_g            !< 
-    REAL(sp) ::  tmp_norm         !< 
-    REAL(sp) ::  tmp_pos          !< 
-    REAL(sp) ::  tmp_r            !< 
-    REAL(sp) ::  tmp_t            !< 
-    REAL(sp) ::  tmp_th           !< 
-    REAL(sp), DIMENSION(:),     ALLOCATABLE   ::  psize  !< 
-    REAL(sp), DIMENSION(:),     ALLOCATABLE   ::  p_x    !< 
-    REAL(sp), DIMENSION(:),     ALLOCATABLE   ::  p_y    !< 
-    REAL(sp), DIMENSION(:),     ALLOCATABLE   ::  p_z    !< 
-    REAL(sp), DIMENSION(:,:,:), ALLOCATABLE   ::  local_pf  !< 
-    REAL(sp), DIMENSION(:,:,:,:), ALLOCATABLE ::  local_pfi !< 
-
-
-    CALL cpu_log( log_point(27), 'data_output_dvrp', 'start' )
-
-!
-!-- Loop over all output modes choosed
-    m            = 1
-    n_isosurface = 0  ! isosurface counter (for threshold values and color)
-    n_slicer     = 0  ! slice plane counter (for range of values)
-    DO WHILE ( mode_dvrp(m) /= ' ' )
-!
-!--    Update of the steering variables
-       IF ( .NOT. lock_steering_update )  THEN
-!
-!--       Set lock to avoid recursive calls of DVRP_STEERING_UPDATE
-          lock_steering_update = .TRUE.
-!          CALL DVRP_STEERING_UPDATE( m-1, data_output_dvrp )
-          lock_steering_update = .FALSE.
-       ENDIF
-
-!
-!--    Determine the variable which shall be plotted (in case of slicers or
-!--    isosurfaces)
-       IF ( mode_dvrp(m)(1:10) == 'isosurface' )  THEN
-          READ ( mode_dvrp(m), '(10X,I2)' )  vn
-          output_variable = do3d(0,vn)
-          n_isosurface = n_isosurface + 1
-       ELSEIF ( mode_dvrp(m)(1:6) == 'slicer' )  THEN
-          READ ( mode_dvrp(m), '(6X,I2)' )  vn
-          output_variable = do2d(0,vn)
-          l = MAX( 2, LEN_TRIM( do2d(0,vn) ) )
-          section_chr = do2d(0,vn)(l-1:l)
-          SELECT CASE ( section_chr )
-             CASE ( 'xy' )
-                section_mode = 2
-                slicer_position = zu(MIN( slicer_position_dvrp(m), nz_do3d ))
-             CASE ( 'xz' )
-                section_mode = 1
-                slicer_position = slicer_position_dvrp(m) * dy
-             CASE ( 'yz' )
-                section_mode = 0
-                slicer_position = slicer_position_dvrp(m) * dx
-          END SELECT
-       ENDIF
-
-!
-!--    Select the plot mode (in case of isosurface or slicer only if user has
-!--    defined a variable which shall be plotted; otherwise do nothing)
-       IF ( ( mode_dvrp(m)(1:10) == 'isosurface'  .OR.                     &
-                  mode_dvrp(m)(1:6)  == 'slicer'           )                   &
-                  .AND.  output_variable /= ' ' )  THEN
-
-!
-!--       Create an intermediate array, properly dimensioned for plot-output 
-          ALLOCATE( local_pf(nxl_dvrp:nxr_dvrp+1,nys_dvrp:nyn_dvrp+1,          &
-                             nzb:nz_do3d) )
-
-!
-!--       Move original array to intermediate array
-          IF ( dvrp_overlap )  THEN
-
-             SELECT CASE ( output_variable )
-
-                CASE ( 'u', 'u_xy', 'u_xz', 'u_yz' )
-                   DO  i = nxl_dvrp, nxr_dvrp+1
-                      DO  j = nys_dvrp, nyn_dvrp+1
-                         DO  k = nzb, nz_do3d
-                            local_pf(i,j,k) = u(k,j,i)
-                         ENDDO
-                      ENDDO
-                   ENDDO
-!
-!--                Replace mirrored values at lower surface by real surface
-!--                values
-                   IF ( output_variable == 'u_xz'  .OR.                        &
-                        output_variable == 'u_yz' )  THEN
-                      IF ( ibc_uv_b == 0 )  local_pf(:,:,nzb) = 0.0_wp
-                   ENDIF
-
-
-                CASE ( 'v', 'v_xy', 'v_xz', 'v_yz' )
-                   DO  i = nxl_dvrp, nxr_dvrp+1
-                      DO  j = nys_dvrp, nyn_dvrp+1
-                         DO  k = nzb, nz_do3d
-                            local_pf(i,j,k) = v(k,j,i)
-                         ENDDO
-                      ENDDO
-                   ENDDO
-!
-!--                Replace mirrored values at lower surface by real surface
-!--                values
-                   IF ( output_variable == 'v_xz'  .OR.                        &
-                        output_variable == 'v_yz' )  THEN
-                      IF ( ibc_uv_b == 0 )  local_pf(:,:,nzb) = 0.0_wp
-                   ENDIF
-
-                CASE ( 'w', 'w_xy', 'w_xz', 'w_yz' )
-                   DO  i = nxl_dvrp, nxr_dvrp+1
-                      DO  j = nys_dvrp, nyn_dvrp+1
-                         DO  k = nzb, nz_do3d
-                            local_pf(i,j,k) = w(k,j,i)
-                         ENDDO
-                      ENDDO
-                   ENDDO
-! Averaging for Langmuir circulation
-!                   DO  k = nzb, nz_do3d
-!                      DO  j = nys_dvrp+1, nyn_dvrp
-!                         DO  i = nxl_dvrp, nxr_dvrp+1
-!                            local_pf(i,j,k) = 0.25 * local_pf(i,j-1,k) + &
-!                                              0.50 * local_pf(i,j,k)   + &
-!                                              0.25 * local_pf(i,j+1,k)
-!                         ENDDO
-!                      ENDDO
-!                   ENDDO
-
-                CASE ( 'p', 'p_xy', 'p_xz', 'p_yz' )
-                   DO  i = nxl_dvrp, nxr_dvrp+1
-                      DO  j = nys_dvrp, nyn_dvrp+1
-                         DO  k = nzb, nz_do3d
-                            local_pf(i,j,k) = p(k,j,i)
-                         ENDDO
-                      ENDDO
-                   ENDDO
-
-                CASE ( 'pt', 'pt_xy', 'pt_xz', 'pt_yz' )
-                   IF ( .NOT. cloud_physics ) THEN
-                      DO  i = nxl_dvrp, nxr_dvrp+1
-                         DO  j = nys_dvrp, nyn_dvrp+1
-                            DO  k = nzb, nz_do3d
-                               local_pf(i,j,k) = pt(k,j,i)
-                            ENDDO
-                         ENDDO
-                      ENDDO
-                   ELSE
-                      DO  i = nxl_dvrp, nxr_dvrp+1
-                         DO  j = nys_dvrp, nyn_dvrp+1
-                            DO  k = nzb, nz_do3d
-                               local_pf(i,j,k) = pt(k,j,i) + l_d_cp *          &
-                                                 pt_d_t(k) * ql(k,j,i)
-                            ENDDO
-                         ENDDO
-                      ENDDO
-                   ENDIF
-
-                CASE ( 'q', 'q_xy', 'q_xz', 'q_yz' )
-                   IF ( humidity  .OR.  passive_scalar )  THEN
-                      DO  i = nxl_dvrp, nxr_dvrp+1
-                         DO  j = nys_dvrp, nyn_dvrp+1
-                            DO  k = nzb, nz_do3d
-                               local_pf(i,j,k) = q(k,j,i)
-                            ENDDO
-                         ENDDO
-                      ENDDO            
-                   ELSE                    
-                      message_string = 'if humidity/passive_scalar = '    //   & 
-                            'FALSE output of ' // TRIM( output_variable ) //   &
-                            'is not provided' 
-                      CALL message( 'data_output_dvrp', 'PA0183',&
-                                                                 0, 0, 0, 6, 0 )
-                   ENDIF
-             
-                CASE ( 'ql', 'ql_xy', 'ql_xz', 'ql_yz' )
-                   IF ( cloud_physics  .OR.  cloud_droplets )  THEN
-                      DO  i = nxl_dvrp, nxr_dvrp+1
-                         DO  j = nys_dvrp, nyn_dvrp+1
-                            DO  k = nzb, nz_do3d
-                               local_pf(i,j,k) = ql(k,j,i)
-                            ENDDO
-                         ENDDO
-                      ENDDO
-                   ELSE                     
-                      message_string = 'if cloud_physics = FALSE '       //    & 
-                                  'output of ' // TRIM( output_variable) //    &
-                                  'is not provided' 
-                      CALL message( 'data_output_dvrp', 'PA0184',&
-                                                                 0, 0, 0, 6, 0 )
-                   ENDIF
-
-                CASE ( 'u*_xy' )
-                   DO  i = nxl_dvrp, nxr_dvrp+1
-                      DO  j = nys_dvrp, nyn_dvrp+1
-                         local_pf(i,j,nzb+1) = us(j,i)
-                      ENDDO
-                   ENDDO
-                   slicer_position = zu(nzb+1)
-
-                CASE ( 't*_xy' )
-                   DO  i = nxl_dvrp, nxr_dvrp+1
-                      DO  j = nys_dvrp, nyn_dvrp+1
-                         local_pf(i,j,nzb+1) = ts(j,i)
-                      ENDDO
-                   ENDDO
-                   slicer_position = zu(nzb+1)
-
-
-                CASE DEFAULT
-!
-!--                The DEFAULT case is reached either if output_variable
-!--                contains unsupported variable or if the user has coded a
-!--                special case in the user interface. There, the subroutine
-!--                user_data_output_dvrp checks which of these two conditions
-!--                applies.
-                   CALL user_data_output_dvrp( output_variable, local_pf )
-
-
-             END SELECT
-
-          ELSE
-!
-!--          No overlap of clipping domain with the current subdomain
-             DO  i = nxl_dvrp, nxr_dvrp+1
-                DO  j = nys_dvrp, nyn_dvrp+1
-                   DO  k = nzb, nz_do3d
-                      local_pf(i,j,k) = 0.0_wp
-                   ENDDO
-                ENDDO
-             ENDDO
-
-          ENDIF
-
-          IF ( mode_dvrp(m)(1:10) == 'isosurface' )  THEN
-
-!
-!--          DVRP-Calls for plotting isosurfaces:
-             CALL cpu_log( log_point_s(26), 'dvrp_isosurface', 'start' )
-
-!
-!--          Definition of isosurface color
-             tmp_r = isosurface_color(1,n_isosurface)
-             tmp_g = isosurface_color(2,n_isosurface)
-             tmp_b = isosurface_color(3,n_isosurface)
-             tmp_t = 0.0_wp
-             CALL DVRP_MATERIAL_RGB( m-1, 1, tmp_r, tmp_g, tmp_b, tmp_t )
-
-!
-!--          Compute and plot isosurface in dvr-format
-             CALL DVRP_DATA( m-1, local_pf, 1, nx_dvrp, ny_dvrp, nz_dvrp,      &
-                             cyclic_dvrp, cyclic_dvrp, cyclic_dvrp )
-
-             c_size_x = vc_size_x;  c_size_y = vc_size_y;  c_size_z = vc_size_z
-             CALL DVRP_CLUSTER_SIZE( m-1, c_size_x, c_size_y, c_size_z )
-
-             c_mode   = vc_mode 
-             CALL DVRP_CLUSTERING_MODE( m-1, c_mode )
-
-             gradient_normals = vc_gradient_normals
-             CALL DVRP_GRADIENTNORMALS( m-1, gradient_normals )
-
-!
-!--          A seperate procedure for setting vc_alpha will be in the next
-!--          version of libDVRP
-             tmp_c_alpha = vc_alpha 
-             CALL DVRP_THRESHOLD( -(m-1)-1, tmp_c_alpha )
-
-             IF ( dvrp_overlap )  THEN
-                tmp_th = threshold(n_isosurface)
-             ELSE
-                tmp_th = 1.0_wp  ! nothing is plotted because array values are 0
-             ENDIF
-
-             CALL DVRP_THRESHOLD( m-1, tmp_th )
-
-             CALL DVRP_VISUALIZE( m-1, 21, dvrp_filecount )
-
-             CALL cpu_log( log_point_s(26), 'dvrp_isosurface', 'stop' )
-
-          ELSEIF ( mode_dvrp(m)(1:6) == 'slicer' )  THEN
-
-!
-!--          DVRP-Calls for plotting slicers:
-             CALL cpu_log( log_point_s(27), 'dvrp_slicer', 'start' )
-
-!
-!--          Material and color definitions
-             tmp_r = 0.0_wp;  tmp_g = 0.0_wp;  tmp_b = 0.0_wp;  tmp_t = 0.0_wp
-             CALL DVRP_MATERIAL_RGB( m-1, 1, tmp_r, tmp_g, tmp_b, tmp_t )
-
-             n_slicer = n_slicer + 1
-
-!
-!--           Using dolorfunction has not been properly tested
-!             islice_dvrp = n_slicer
-!             CALL DVRP_COLORFUNCTION( m-1, DVRP_CM_HLS, 25,                 &
-!                                      slicer_range_limits_dvrp(:,n_slicer), &
-!                                      color_dvrp )
-
-!
-!--          Set interval of values defining the colortable
-             CALL set_slicer_attributes_dvrp( n_slicer )
-
-!
-!--          Create user-defined colortable
-             CALL user_dvrp_coltab( 'slicer', output_variable )
-
-             CALL DVRP_COLORTABLE_HLS( m-1, 1, interval_values_dvrp,           &
-                                       interval_h_dvrp, interval_l_dvrp,       &
-                                       interval_s_dvrp, interval_a_dvrp )
-
-!
-!--          Compute and plot slicer in dvr-format
-             CALL DVRP_DATA( m-1, local_pf, 1, nx_dvrp, ny_dvrp, nz_dvrp,      &
-                             cyclic_dvrp, cyclic_dvrp, cyclic_dvrp )
-             tmp_pos = slicer_position
-             CALL DVRP_SLICER( m-1, section_mode, tmp_pos )
-
-             CALL DVRP_VISUALIZE( m-1, 2, dvrp_filecount )
-
-             CALL cpu_log( log_point_s(27), 'dvrp_slicer', 'stop' )
-
-          ENDIF
-
-          DEALLOCATE( local_pf )
-
-       ELSEIF ( mode_dvrp(m)(1:9) == 'pathlines' ) THEN
-
-          ALLOCATE( local_pfi(4,nxl:nxr+1,nys:nyn+1,nzb:nz_do3d) )
-          DO  i = nxl, nxr+1
-             DO  j = nys, nyn+1
-                DO  k = nzb, nz_do3d
-                   local_pfi(1,i,j,k) = u(k,j,i)
-                   local_pfi(2,i,j,k) = v(k,j,i)
-                   local_pfi(3,i,j,k) = w(k,j,i)
-                   tmp_norm           = SQRT( u(k,j,i) * u(k,j,i) +            &
-                                              v(k,j,i) * v(k,j,i) +            &
-                                              w(k,j,i) * w(k,j,i) )
-                   tmp_alpha          = ACOS( 0.0_wp * u(k,j,i) / tmp_norm +   &
-                                              0.0_wp * v(k,j,i) / tmp_norm -   &
-                                              1.0_wp * w(k,j,i) / tmp_norm )
-                   tmp_alpha_w        = tmp_alpha / pi * 180.0_wp
-                   local_pfi(4,i,j,k) = tmp_alpha_w
-                ENDDO
-             ENDDO
-          ENDDO
-
-          CALL cpu_log( log_point_s(31), 'dvrp_pathlines', 'start' )
-
-          CALL DVRP_DATA( m-1, local_pfi, 4, nx_dvrp, ny_dvrp, nz_dvrp, &
-                          cyclic_dvrp, cyclic_dvrp, cyclic_dvrp )
-          CALL DVRP_VISUALIZE( m-1, 20, dvrp_filecount )
-
-          CALL cpu_log( log_point_s(31), 'dvrp_pathlines', 'stop' )
-
-          DEALLOCATE( local_pfi )
-
-       ENDIF
-
-       m = m + 1
-
-    ENDDO
-
-    dvrp_filecount = dvrp_filecount + 1
-
-    CALL cpu_log( log_point(27), 'data_output_dvrp', 'stop' )
-
-#endif
- END SUBROUTINE data_output_dvrp
Index: /palm/trunk/SOURCE/data_output_dvrp_mod.f90
===================================================================
--- /palm/trunk/SOURCE/data_output_dvrp_mod.f90	(revision 1850)
+++ /palm/trunk/SOURCE/data_output_dvrp_mod.f90	(revision 1850)
@@ -0,0 +1,541 @@
+!> @file data_output_dvrp_mod.f90
+!--------------------------------------------------------------------------------!
+! This file is part of PALM.
+!
+! PALM is free software: you can redistribute it and/or modify it under the terms
+! of the GNU General Public License as published by the Free Software Foundation,
+! either version 3 of the License, or (at your option) any later version.
+!
+! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
+! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
+! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along with
+! PALM. If not, see <http://www.gnu.org/licenses/>.
+!
+! Copyright 1997-2016 Leibniz Universitaet Hannover
+!--------------------------------------------------------------------------------!
+!
+! Current revisions:
+! -----------------
+! Module renamed
+!
+! 
+! Former revisions:
+! -----------------
+! $Id$
+!
+! 1822 2016-04-07 07:49:42Z hoffmann
+! Particles and tails removed.
+!
+! 1682 2015-10-07 23:56:08Z knoop
+! Code annotations made doxygen readable 
+! 
+! 1353 2014-04-08 15:21:23Z heinze
+! REAL constants provided with KIND-attribute
+!
+! 1346 2014-03-27 13:18:20Z heinze
+! Bugfix: REAL constants provided with KIND-attribute especially in call of 
+! intrinsic function like MAX, MIN, SIGN
+!
+! 1320 2014-03-20 08:40:49Z raasch
+! ONLY-attribute added to USE-statements,
+! kind-parameters added to all INTEGER and REAL declaration statements,
+! kinds are defined in new module kinds,
+! revision history before 2012 removed,
+! comment fields (!:) to be used for variable explanations added to
+! all variable declaration statements
+!
+! 1318 2014-03-17 13:35:16Z raasch
+! module interfaces removed
+!
+! 1036 2012-10-22 13:43:42Z raasch
+! code put under GPL (PALM 3.9)
+!
+! 828 2012-02-21 12:00:36Z raasch
+! particle feature color renamed class
+!
+! Revision 1.1  2000/04/27 06:27:17  raasch
+! Initial revision
+!
+!
+! Description:
+! ------------
+!> Plot of isosurface and slicers with dvrp-software
+!------------------------------------------------------------------------------!
+ MODULE dvrp_color
+ 
+
+    USE dvrp_variables
+    
+    USE kinds
+
+    IMPLICIT NONE
+
+ CONTAINS
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> @todo Missing subroutine description.
+!------------------------------------------------------------------------------!
+    SUBROUTINE color_dvrp( value, color )
+
+       REAL(wp), INTENT(IN)  ::  value    !< 
+       REAL(wp), INTENT(OUT) ::  color(4) !< 
+
+       REAL(wp)              ::  scale    !< 
+
+       scale = ( value - slicer_range_limits_dvrp(1,islice_dvrp) ) /           &
+               ( slicer_range_limits_dvrp(2,islice_dvrp) -                     &
+                 slicer_range_limits_dvrp(1,islice_dvrp) )
+
+       scale = MODULO( 180.0_wp + 180.0_wp * scale, 360.0_wp )
+
+       color = (/ scale, 0.5_wp, 1.0_wp, 0.0_wp /)
+
+    END SUBROUTINE color_dvrp
+
+ END MODULE dvrp_color
+
+
+ RECURSIVE SUBROUTINE data_output_dvrp
+
+#if defined( __dvrp_graphics )
+
+    USE arrays_3d,                                                             &
+        ONLY:  p, pt, q, ql, ts, u, us, v, w, zu
+        
+    USE cloud_parameters,                                                      &
+        ONLY:  l_d_cp, pt_d_t
+        
+    USE constants,                                                             &
+        ONLY:  pi
+        
+    USE control_parameters,                                                    &
+        ONLY:  cloud_droplets, cloud_physics, do2d, do3d, humidity, ibc_uv_b,  &
+               message_string, nz_do3d, passive_scalar, simulated_time,        &
+               threshold
+        
+    USE cpulog,                                                                &
+        ONLY:  log_point, log_point_s, cpu_log
+        
+    USE DVRP
+    
+    USE dvrp_color
+        
+    USE dvrp_variables
+        
+    USE grid_variables,                                                        &
+        ONLY:  dx, dy
+        
+    USE indices,                                                               &
+        ONLY:  nxl, nxr, nyn, nys, nzb
+        
+    USE kinds
+
+    USE pegrid
+
+    IMPLICIT NONE
+
+    CHARACTER (LEN=2) ::  section_chr      !< 
+    CHARACTER (LEN=6) ::  output_variable  !< 
+    
+    INTEGER(iwp) ::  c_mode           !<  
+    INTEGER(iwp) ::  c_size_x         !< 
+    INTEGER(iwp) ::  c_size_y         !< 
+    INTEGER(iwp) ::  c_size_z         !< 
+    INTEGER(iwp) ::  dvrp_nop         !< 
+    INTEGER(iwp) ::  dvrp_not         !< 
+    INTEGER(iwp) ::  gradient_normals !< 
+    INTEGER(iwp) ::  i                !< 
+    INTEGER(iwp) ::  ip               !< 
+    INTEGER(iwp) ::  j                !< 
+    INTEGER(iwp) ::  jp               !< 
+    INTEGER(iwp) ::  k                !< 
+    INTEGER(iwp) ::  l                !< 
+    INTEGER(iwp) ::  m                !< 
+    INTEGER(iwp) ::  n                !< 
+    INTEGER(iwp) ::  n_isosurface     !< 
+    INTEGER(iwp) ::  n_slicer         !< 
+    INTEGER(iwp) ::  nn               !< 
+    INTEGER(iwp) ::  section_mode     !< 
+    INTEGER(iwp) ::  vn               !< 
+    INTEGER(iwp), DIMENSION(:), ALLOCATABLE ::  p_c  !< 
+    INTEGER(iwp), DIMENSION(:), ALLOCATABLE ::  p_t  !< 
+
+    LOGICAL, DIMENSION(:), ALLOCATABLE ::  dvrp_mask  !< 
+
+    REAL(sp) ::  slicer_position  !< 
+    REAL(sp) ::  tmp_alpha        !< 
+    REAL(sp) ::  tmp_alpha_w      !< 
+    REAL(sp) ::  tmp_b            !< 
+    REAL(sp) ::  tmp_c_alpha      !< 
+    REAL(sp) ::  tmp_g            !< 
+    REAL(sp) ::  tmp_norm         !< 
+    REAL(sp) ::  tmp_pos          !< 
+    REAL(sp) ::  tmp_r            !< 
+    REAL(sp) ::  tmp_t            !< 
+    REAL(sp) ::  tmp_th           !< 
+    REAL(sp), DIMENSION(:),     ALLOCATABLE   ::  psize  !< 
+    REAL(sp), DIMENSION(:),     ALLOCATABLE   ::  p_x    !< 
+    REAL(sp), DIMENSION(:),     ALLOCATABLE   ::  p_y    !< 
+    REAL(sp), DIMENSION(:),     ALLOCATABLE   ::  p_z    !< 
+    REAL(sp), DIMENSION(:,:,:), ALLOCATABLE   ::  local_pf  !< 
+    REAL(sp), DIMENSION(:,:,:,:), ALLOCATABLE ::  local_pfi !< 
+
+
+    CALL cpu_log( log_point(27), 'data_output_dvrp', 'start' )
+
+!
+!-- Loop over all output modes choosed
+    m            = 1
+    n_isosurface = 0  ! isosurface counter (for threshold values and color)
+    n_slicer     = 0  ! slice plane counter (for range of values)
+    DO WHILE ( mode_dvrp(m) /= ' ' )
+!
+!--    Update of the steering variables
+       IF ( .NOT. lock_steering_update )  THEN
+!
+!--       Set lock to avoid recursive calls of DVRP_STEERING_UPDATE
+          lock_steering_update = .TRUE.
+!          CALL DVRP_STEERING_UPDATE( m-1, data_output_dvrp )
+          lock_steering_update = .FALSE.
+       ENDIF
+
+!
+!--    Determine the variable which shall be plotted (in case of slicers or
+!--    isosurfaces)
+       IF ( mode_dvrp(m)(1:10) == 'isosurface' )  THEN
+          READ ( mode_dvrp(m), '(10X,I2)' )  vn
+          output_variable = do3d(0,vn)
+          n_isosurface = n_isosurface + 1
+       ELSEIF ( mode_dvrp(m)(1:6) == 'slicer' )  THEN
+          READ ( mode_dvrp(m), '(6X,I2)' )  vn
+          output_variable = do2d(0,vn)
+          l = MAX( 2, LEN_TRIM( do2d(0,vn) ) )
+          section_chr = do2d(0,vn)(l-1:l)
+          SELECT CASE ( section_chr )
+             CASE ( 'xy' )
+                section_mode = 2
+                slicer_position = zu(MIN( slicer_position_dvrp(m), nz_do3d ))
+             CASE ( 'xz' )
+                section_mode = 1
+                slicer_position = slicer_position_dvrp(m) * dy
+             CASE ( 'yz' )
+                section_mode = 0
+                slicer_position = slicer_position_dvrp(m) * dx
+          END SELECT
+       ENDIF
+
+!
+!--    Select the plot mode (in case of isosurface or slicer only if user has
+!--    defined a variable which shall be plotted; otherwise do nothing)
+       IF ( ( mode_dvrp(m)(1:10) == 'isosurface'  .OR.                     &
+                  mode_dvrp(m)(1:6)  == 'slicer'           )                   &
+                  .AND.  output_variable /= ' ' )  THEN
+
+!
+!--       Create an intermediate array, properly dimensioned for plot-output 
+          ALLOCATE( local_pf(nxl_dvrp:nxr_dvrp+1,nys_dvrp:nyn_dvrp+1,          &
+                             nzb:nz_do3d) )
+
+!
+!--       Move original array to intermediate array
+          IF ( dvrp_overlap )  THEN
+
+             SELECT CASE ( output_variable )
+
+                CASE ( 'u', 'u_xy', 'u_xz', 'u_yz' )
+                   DO  i = nxl_dvrp, nxr_dvrp+1
+                      DO  j = nys_dvrp, nyn_dvrp+1
+                         DO  k = nzb, nz_do3d
+                            local_pf(i,j,k) = u(k,j,i)
+                         ENDDO
+                      ENDDO
+                   ENDDO
+!
+!--                Replace mirrored values at lower surface by real surface
+!--                values
+                   IF ( output_variable == 'u_xz'  .OR.                        &
+                        output_variable == 'u_yz' )  THEN
+                      IF ( ibc_uv_b == 0 )  local_pf(:,:,nzb) = 0.0_wp
+                   ENDIF
+
+
+                CASE ( 'v', 'v_xy', 'v_xz', 'v_yz' )
+                   DO  i = nxl_dvrp, nxr_dvrp+1
+                      DO  j = nys_dvrp, nyn_dvrp+1
+                         DO  k = nzb, nz_do3d
+                            local_pf(i,j,k) = v(k,j,i)
+                         ENDDO
+                      ENDDO
+                   ENDDO
+!
+!--                Replace mirrored values at lower surface by real surface
+!--                values
+                   IF ( output_variable == 'v_xz'  .OR.                        &
+                        output_variable == 'v_yz' )  THEN
+                      IF ( ibc_uv_b == 0 )  local_pf(:,:,nzb) = 0.0_wp
+                   ENDIF
+
+                CASE ( 'w', 'w_xy', 'w_xz', 'w_yz' )
+                   DO  i = nxl_dvrp, nxr_dvrp+1
+                      DO  j = nys_dvrp, nyn_dvrp+1
+                         DO  k = nzb, nz_do3d
+                            local_pf(i,j,k) = w(k,j,i)
+                         ENDDO
+                      ENDDO
+                   ENDDO
+! Averaging for Langmuir circulation
+!                   DO  k = nzb, nz_do3d
+!                      DO  j = nys_dvrp+1, nyn_dvrp
+!                         DO  i = nxl_dvrp, nxr_dvrp+1
+!                            local_pf(i,j,k) = 0.25 * local_pf(i,j-1,k) + &
+!                                              0.50 * local_pf(i,j,k)   + &
+!                                              0.25 * local_pf(i,j+1,k)
+!                         ENDDO
+!                      ENDDO
+!                   ENDDO
+
+                CASE ( 'p', 'p_xy', 'p_xz', 'p_yz' )
+                   DO  i = nxl_dvrp, nxr_dvrp+1
+                      DO  j = nys_dvrp, nyn_dvrp+1
+                         DO  k = nzb, nz_do3d
+                            local_pf(i,j,k) = p(k,j,i)
+                         ENDDO
+                      ENDDO
+                   ENDDO
+
+                CASE ( 'pt', 'pt_xy', 'pt_xz', 'pt_yz' )
+                   IF ( .NOT. cloud_physics ) THEN
+                      DO  i = nxl_dvrp, nxr_dvrp+1
+                         DO  j = nys_dvrp, nyn_dvrp+1
+                            DO  k = nzb, nz_do3d
+                               local_pf(i,j,k) = pt(k,j,i)
+                            ENDDO
+                         ENDDO
+                      ENDDO
+                   ELSE
+                      DO  i = nxl_dvrp, nxr_dvrp+1
+                         DO  j = nys_dvrp, nyn_dvrp+1
+                            DO  k = nzb, nz_do3d
+                               local_pf(i,j,k) = pt(k,j,i) + l_d_cp *          &
+                                                 pt_d_t(k) * ql(k,j,i)
+                            ENDDO
+                         ENDDO
+                      ENDDO
+                   ENDIF
+
+                CASE ( 'q', 'q_xy', 'q_xz', 'q_yz' )
+                   IF ( humidity  .OR.  passive_scalar )  THEN
+                      DO  i = nxl_dvrp, nxr_dvrp+1
+                         DO  j = nys_dvrp, nyn_dvrp+1
+                            DO  k = nzb, nz_do3d
+                               local_pf(i,j,k) = q(k,j,i)
+                            ENDDO
+                         ENDDO
+                      ENDDO            
+                   ELSE                    
+                      message_string = 'if humidity/passive_scalar = '    //   & 
+                            'FALSE output of ' // TRIM( output_variable ) //   &
+                            'is not provided' 
+                      CALL message( 'data_output_dvrp', 'PA0183',&
+                                                                 0, 0, 0, 6, 0 )
+                   ENDIF
+             
+                CASE ( 'ql', 'ql_xy', 'ql_xz', 'ql_yz' )
+                   IF ( cloud_physics  .OR.  cloud_droplets )  THEN
+                      DO  i = nxl_dvrp, nxr_dvrp+1
+                         DO  j = nys_dvrp, nyn_dvrp+1
+                            DO  k = nzb, nz_do3d
+                               local_pf(i,j,k) = ql(k,j,i)
+                            ENDDO
+                         ENDDO
+                      ENDDO
+                   ELSE                     
+                      message_string = 'if cloud_physics = FALSE '       //    & 
+                                  'output of ' // TRIM( output_variable) //    &
+                                  'is not provided' 
+                      CALL message( 'data_output_dvrp', 'PA0184',&
+                                                                 0, 0, 0, 6, 0 )
+                   ENDIF
+
+                CASE ( 'u*_xy' )
+                   DO  i = nxl_dvrp, nxr_dvrp+1
+                      DO  j = nys_dvrp, nyn_dvrp+1
+                         local_pf(i,j,nzb+1) = us(j,i)
+                      ENDDO
+                   ENDDO
+                   slicer_position = zu(nzb+1)
+
+                CASE ( 't*_xy' )
+                   DO  i = nxl_dvrp, nxr_dvrp+1
+                      DO  j = nys_dvrp, nyn_dvrp+1
+                         local_pf(i,j,nzb+1) = ts(j,i)
+                      ENDDO
+                   ENDDO
+                   slicer_position = zu(nzb+1)
+
+
+                CASE DEFAULT
+!
+!--                The DEFAULT case is reached either if output_variable
+!--                contains unsupported variable or if the user has coded a
+!--                special case in the user interface. There, the subroutine
+!--                user_data_output_dvrp checks which of these two conditions
+!--                applies.
+                   CALL user_data_output_dvrp( output_variable, local_pf )
+
+
+             END SELECT
+
+          ELSE
+!
+!--          No overlap of clipping domain with the current subdomain
+             DO  i = nxl_dvrp, nxr_dvrp+1
+                DO  j = nys_dvrp, nyn_dvrp+1
+                   DO  k = nzb, nz_do3d
+                      local_pf(i,j,k) = 0.0_wp
+                   ENDDO
+                ENDDO
+             ENDDO
+
+          ENDIF
+
+          IF ( mode_dvrp(m)(1:10) == 'isosurface' )  THEN
+
+!
+!--          DVRP-Calls for plotting isosurfaces:
+             CALL cpu_log( log_point_s(26), 'dvrp_isosurface', 'start' )
+
+!
+!--          Definition of isosurface color
+             tmp_r = isosurface_color(1,n_isosurface)
+             tmp_g = isosurface_color(2,n_isosurface)
+             tmp_b = isosurface_color(3,n_isosurface)
+             tmp_t = 0.0_wp
+             CALL DVRP_MATERIAL_RGB( m-1, 1, tmp_r, tmp_g, tmp_b, tmp_t )
+
+!
+!--          Compute and plot isosurface in dvr-format
+             CALL DVRP_DATA( m-1, local_pf, 1, nx_dvrp, ny_dvrp, nz_dvrp,      &
+                             cyclic_dvrp, cyclic_dvrp, cyclic_dvrp )
+
+             c_size_x = vc_size_x;  c_size_y = vc_size_y;  c_size_z = vc_size_z
+             CALL DVRP_CLUSTER_SIZE( m-1, c_size_x, c_size_y, c_size_z )
+
+             c_mode   = vc_mode 
+             CALL DVRP_CLUSTERING_MODE( m-1, c_mode )
+
+             gradient_normals = vc_gradient_normals
+             CALL DVRP_GRADIENTNORMALS( m-1, gradient_normals )
+
+!
+!--          A seperate procedure for setting vc_alpha will be in the next
+!--          version of libDVRP
+             tmp_c_alpha = vc_alpha 
+             CALL DVRP_THRESHOLD( -(m-1)-1, tmp_c_alpha )
+
+             IF ( dvrp_overlap )  THEN
+                tmp_th = threshold(n_isosurface)
+             ELSE
+                tmp_th = 1.0_wp  ! nothing is plotted because array values are 0
+             ENDIF
+
+             CALL DVRP_THRESHOLD( m-1, tmp_th )
+
+             CALL DVRP_VISUALIZE( m-1, 21, dvrp_filecount )
+
+             CALL cpu_log( log_point_s(26), 'dvrp_isosurface', 'stop' )
+
+          ELSEIF ( mode_dvrp(m)(1:6) == 'slicer' )  THEN
+
+!
+!--          DVRP-Calls for plotting slicers:
+             CALL cpu_log( log_point_s(27), 'dvrp_slicer', 'start' )
+
+!
+!--          Material and color definitions
+             tmp_r = 0.0_wp;  tmp_g = 0.0_wp;  tmp_b = 0.0_wp;  tmp_t = 0.0_wp
+             CALL DVRP_MATERIAL_RGB( m-1, 1, tmp_r, tmp_g, tmp_b, tmp_t )
+
+             n_slicer = n_slicer + 1
+
+!
+!--           Using dolorfunction has not been properly tested
+!             islice_dvrp = n_slicer
+!             CALL DVRP_COLORFUNCTION( m-1, DVRP_CM_HLS, 25,                 &
+!                                      slicer_range_limits_dvrp(:,n_slicer), &
+!                                      color_dvrp )
+
+!
+!--          Set interval of values defining the colortable
+             CALL set_slicer_attributes_dvrp( n_slicer )
+
+!
+!--          Create user-defined colortable
+             CALL user_dvrp_coltab( 'slicer', output_variable )
+
+             CALL DVRP_COLORTABLE_HLS( m-1, 1, interval_values_dvrp,           &
+                                       interval_h_dvrp, interval_l_dvrp,       &
+                                       interval_s_dvrp, interval_a_dvrp )
+
+!
+!--          Compute and plot slicer in dvr-format
+             CALL DVRP_DATA( m-1, local_pf, 1, nx_dvrp, ny_dvrp, nz_dvrp,      &
+                             cyclic_dvrp, cyclic_dvrp, cyclic_dvrp )
+             tmp_pos = slicer_position
+             CALL DVRP_SLICER( m-1, section_mode, tmp_pos )
+
+             CALL DVRP_VISUALIZE( m-1, 2, dvrp_filecount )
+
+             CALL cpu_log( log_point_s(27), 'dvrp_slicer', 'stop' )
+
+          ENDIF
+
+          DEALLOCATE( local_pf )
+
+       ELSEIF ( mode_dvrp(m)(1:9) == 'pathlines' ) THEN
+
+          ALLOCATE( local_pfi(4,nxl:nxr+1,nys:nyn+1,nzb:nz_do3d) )
+          DO  i = nxl, nxr+1
+             DO  j = nys, nyn+1
+                DO  k = nzb, nz_do3d
+                   local_pfi(1,i,j,k) = u(k,j,i)
+                   local_pfi(2,i,j,k) = v(k,j,i)
+                   local_pfi(3,i,j,k) = w(k,j,i)
+                   tmp_norm           = SQRT( u(k,j,i) * u(k,j,i) +            &
+                                              v(k,j,i) * v(k,j,i) +            &
+                                              w(k,j,i) * w(k,j,i) )
+                   tmp_alpha          = ACOS( 0.0_wp * u(k,j,i) / tmp_norm +   &
+                                              0.0_wp * v(k,j,i) / tmp_norm -   &
+                                              1.0_wp * w(k,j,i) / tmp_norm )
+                   tmp_alpha_w        = tmp_alpha / pi * 180.0_wp
+                   local_pfi(4,i,j,k) = tmp_alpha_w
+                ENDDO
+             ENDDO
+          ENDDO
+
+          CALL cpu_log( log_point_s(31), 'dvrp_pathlines', 'start' )
+
+          CALL DVRP_DATA( m-1, local_pfi, 4, nx_dvrp, ny_dvrp, nz_dvrp, &
+                          cyclic_dvrp, cyclic_dvrp, cyclic_dvrp )
+          CALL DVRP_VISUALIZE( m-1, 20, dvrp_filecount )
+
+          CALL cpu_log( log_point_s(31), 'dvrp_pathlines', 'stop' )
+
+          DEALLOCATE( local_pfi )
+
+       ENDIF
+
+       m = m + 1
+
+    ENDDO
+
+    dvrp_filecount = dvrp_filecount + 1
+
+    CALL cpu_log( log_point(27), 'data_output_dvrp', 'stop' )
+
+#endif
+ END SUBROUTINE data_output_dvrp
Index: lm/trunk/SOURCE/diffusion_e.f90
===================================================================
--- /palm/trunk/SOURCE/diffusion_e.f90	(revision 1849)
+++ 	(revision )
@@ -1,635 +1,0 @@
-!> @file diffusion_e.f90
-!--------------------------------------------------------------------------------!
-! This file is part of PALM.
-!
-! PALM is free software: you can redistribute it and/or modify it under the terms
-! of the GNU General Public License as published by the Free Software Foundation,
-! either version 3 of the License, or (at your option) any later version.
-!
-! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
-! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
-! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along with
-! PALM. If not, see <http://www.gnu.org/licenses/>.
-!
-! Copyright 1997-2016 Leibniz Universitaet Hannover
-!--------------------------------------------------------------------------------!
-!
-! Current revisions:
-! -----------------
-! Adapted for modularization of microphysics
-! 
-! Former revisions:
-! -----------------
-! $Id$
-!
-! 1831 2016-04-07 13:15:51Z hoffmann 
-! turbulence renamed collision_turbulence
-!
-! 1682 2015-10-07 23:56:08Z knoop
-! Code annotations made doxygen readable 
-! 
-! 1374 2014-04-25 12:55:07Z raasch
-! missing variables added to ONLY list
-! rif removed from acc-present-list
-! 
-! 1340 2014-03-25 19:45:13Z kanani
-! REAL constants defined as wp-kind
-!
-! 1320 2014-03-20 08:40:49Z raasch
-! ONLY-attribute added to USE-statements,
-! kind-parameters added to all INTEGER and REAL declaration statements,
-! kinds are defined in new module kinds,
-! revision history before 2012 removed,
-! comment fields (!:) to be used for variable explanations added to
-! all variable declaration statements
-!
-! 1257 2013-11-08 15:18:40Z raasch
-! openacc loop and loop vector clauses removed
-!
-! 1179 2013-06-14 05:57:58Z raasch
-! use_reference renamed use_single_reference_value
-!
-! 1171 2013-05-30 11:27:45Z raasch
-! use_reference-case activated in accelerator version
-!
-! 1128 2013-04-12 06:19:32Z raasch
-! loop index bounds in accelerator version replaced by i_left, i_right, j_south,
-! j_north
-!
-! 1065 2012-11-22 17:42:36Z hoffmann
-! Enabled the claculation of diss in case of turbulence = .TRUE. (parameterized 
-! effects of turbulence on autoconversion and accretion in two-moments cloud 
-! physics scheme). 
-!
-! 1036 2012-10-22 13:43:42Z raasch
-! code put under GPL (PALM 3.9)
-!
-! 1015 2012-09-27 09:23:24Z raasch
-! accelerator version (*_acc) added,
-! adjustment of mixing length to the Prandtl mixing length at first grid point
-! above ground removed
-!
-! 1010 2012-09-20 07:59:54Z raasch
-! cpp switch __nopointer added for pointer free version
-!
-! 1001 2012-09-13 14:08:46Z raasch
-! most arrays comunicated by module instead of parameter list
-!
-! 825 2012-02-19 03:03:44Z raasch
-! wang_collision_kernel renamed wang_kernel
-!
-! Revision 1.1  1997/09/19 07:40:24  raasch
-! Initial revision
-!
-!
-! Description:
-! ------------
-!> Diffusion- and dissipation terms for the TKE
-!------------------------------------------------------------------------------!
- MODULE diffusion_e_mod
- 
-
-    PRIVATE
-    PUBLIC diffusion_e, diffusion_e_acc
-    
-
-    INTERFACE diffusion_e
-       MODULE PROCEDURE diffusion_e
-       MODULE PROCEDURE diffusion_e_ij
-    END INTERFACE diffusion_e
- 
-    INTERFACE diffusion_e_acc
-       MODULE PROCEDURE diffusion_e_acc
-    END INTERFACE diffusion_e_acc
-
- CONTAINS
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Call for all grid points
-!------------------------------------------------------------------------------!
-    SUBROUTINE diffusion_e( var, var_reference )
-
-       USE arrays_3d,                                                          &
-           ONLY:  dd2zu, ddzu, ddzw, diss, e, km, l_grid, tend, zu, zw
-           
-       USE control_parameters,                                                 &
-           ONLY:  atmos_ocean_sign, g, use_single_reference_value, &
-                  wall_adjustment, wall_adjustment_factor
-
-       USE grid_variables,                                                     &
-           ONLY:  ddx2, ddy2
-           
-       USE indices,                                                            &
-           ONLY:  nxl, nxlg, nxr, nxrg, nyn, nyng, nys, nysg, nzb, nzb_s_inner,&
-                  nzt
-           
-       USE kinds
-
-       USE microphysics_mod,                                                   &
-           ONLY:  collision_turbulence
-
-       USE particle_attributes,                                                &
-           ONLY:  use_sgs_for_particles, wang_kernel
-
-       IMPLICIT NONE
-
-       INTEGER(iwp) ::  i              !< 
-       INTEGER(iwp) ::  j              !< 
-       INTEGER(iwp) ::  k              !< 
-       REAL(wp)     ::  dvar_dz        !< 
-       REAL(wp)     ::  l_stable       !< 
-       REAL(wp)     ::  var_reference  !< 
-
-#if defined( __nopointer )
-       REAL(wp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ::  var  !< 
-#else
-       REAL(wp), DIMENSION(:,:,:), POINTER ::  var  !< 
-#endif
-       REAL(wp), DIMENSION(nzb+1:nzt,nys:nyn) ::  dissipation  !<
-       REAL(wp), DIMENSION(nzb+1:nzt,nys:nyn) ::  l            !<
-       REAL(wp), DIMENSION(nzb+1:nzt,nys:nyn) ::  ll           !< 
- 
-
-!
-!--    This if clause must be outside the k-loop because otherwise
-!--    runtime errors occur with -C hopt on NEC
-       IF ( use_single_reference_value )  THEN
-
-          DO  i = nxl, nxr
-             DO  j = nys, nyn
-                DO  k = nzb_s_inner(j,i)+1, nzt
-!
-!--                Calculate the mixing length (for dissipation)
-                   dvar_dz = atmos_ocean_sign * &
-                             ( var(k+1,j,i) - var(k-1,j,i) ) * dd2zu(k)
-                   IF ( dvar_dz > 0.0_wp ) THEN
-                      l_stable = 0.76_wp * SQRT( e(k,j,i) ) / &
-                                    SQRT( g / var_reference * dvar_dz ) + 1E-5_wp
-                   ELSE
-                      l_stable = l_grid(k)
-                   ENDIF
-!
-!--                Adjustment of the mixing length
-                   IF ( wall_adjustment )  THEN
-                      l(k,j)  = MIN( wall_adjustment_factor *          &
-                                     ( zu(k) - zw(nzb_s_inner(j,i)) ), &
-                                     l_grid(k), l_stable )
-                      ll(k,j) = MIN( wall_adjustment_factor *          &
-                                     ( zu(k) - zw(nzb_s_inner(j,i)) ), &
-                                     l_grid(k) )
-                   ELSE
-                      l(k,j)  = MIN( l_grid(k), l_stable )
-                      ll(k,j) = l_grid(k)
-                   ENDIF
-
-                ENDDO
-             ENDDO
-
-!
-!--          Calculate the tendency terms
-             DO  j = nys, nyn
-                DO  k = nzb_s_inner(j,i)+1, nzt
-
-                    dissipation(k,j) = ( 0.19_wp + 0.74_wp * l(k,j) / ll(k,j) ) * &
-                                       e(k,j,i) * SQRT( e(k,j,i) ) / l(k,j)
-
-                    tend(k,j,i) = tend(k,j,i)                                  &
-                                        + (                                    &
-                          ( km(k,j,i)+km(k,j,i+1) ) * ( e(k,j,i+1)-e(k,j,i) )  &
-                        - ( km(k,j,i)+km(k,j,i-1) ) * ( e(k,j,i)-e(k,j,i-1) )  &
-                                          ) * ddx2                             &
-                                        + (                                    &
-                          ( km(k,j,i)+km(k,j+1,i) ) * ( e(k,j+1,i)-e(k,j,i) )  &
-                        - ( km(k,j,i)+km(k,j-1,i) ) * ( e(k,j,i)-e(k,j-1,i) )  &
-                                          ) * ddy2                             &
-                                        + (                                    &
-               ( km(k,j,i)+km(k+1,j,i) ) * ( e(k+1,j,i)-e(k,j,i) ) * ddzu(k+1) &
-             - ( km(k,j,i)+km(k-1,j,i) ) * ( e(k,j,i)-e(k-1,j,i) ) * ddzu(k)   &
-                                          ) * ddzw(k)                          &
-                             - dissipation(k,j)
-
-                ENDDO
-             ENDDO
-
-!
-!--          Store dissipation if needed for calculating the sgs particle
-!--          velocities
-             IF ( use_sgs_for_particles  .OR.  wang_kernel  .OR.               &
-                  collision_turbulence )  THEN
-                DO  j = nys, nyn
-                   DO  k = nzb_s_inner(j,i)+1, nzt
-                      diss(k,j,i) = dissipation(k,j)
-                   ENDDO
-                ENDDO
-             ENDIF
-
-          ENDDO
-
-       ELSE
-
-          DO  i = nxl, nxr
-             DO  j = nys, nyn
-                DO  k = nzb_s_inner(j,i)+1, nzt
-!
-!--                Calculate the mixing length (for dissipation)
-                   dvar_dz = atmos_ocean_sign * &
-                             ( var(k+1,j,i) - var(k-1,j,i) ) * dd2zu(k)
-                   IF ( dvar_dz > 0.0_wp ) THEN
-                      l_stable = 0.76_wp * SQRT( e(k,j,i) ) / &
-                                           SQRT( g / var(k,j,i) * dvar_dz ) + 1E-5_wp
-                   ELSE
-                      l_stable = l_grid(k)
-                   ENDIF
-!
-!--                Adjustment of the mixing length
-                   IF ( wall_adjustment )  THEN
-                      l(k,j)  = MIN( wall_adjustment_factor *          &
-                                     ( zu(k) - zw(nzb_s_inner(j,i)) ), &
-                                     l_grid(k), l_stable )
-                      ll(k,j) = MIN( wall_adjustment_factor *          &
-                                     ( zu(k) - zw(nzb_s_inner(j,i)) ), &
-                                     l_grid(k) )
-                   ELSE
-                      l(k,j)  = MIN( l_grid(k), l_stable )
-                      ll(k,j) = l_grid(k)
-                   ENDIF
-
-                ENDDO
-             ENDDO
-
-!
-!--          Calculate the tendency terms
-             DO  j = nys, nyn
-                DO  k = nzb_s_inner(j,i)+1, nzt
-
-                    dissipation(k,j) = ( 0.19_wp + 0.74_wp * l(k,j) / ll(k,j) ) * &
-                                             e(k,j,i) * SQRT( e(k,j,i) ) / l(k,j)
-
-                    tend(k,j,i) = tend(k,j,i)                                  &
-                                        + (                                    &
-                          ( km(k,j,i)+km(k,j,i+1) ) * ( e(k,j,i+1)-e(k,j,i) )  &
-                        - ( km(k,j,i)+km(k,j,i-1) ) * ( e(k,j,i)-e(k,j,i-1) )  &
-                                          ) * ddx2                             &
-                                        + (                                    &
-                          ( km(k,j,i)+km(k,j+1,i) ) * ( e(k,j+1,i)-e(k,j,i) )  &
-                        - ( km(k,j,i)+km(k,j-1,i) ) * ( e(k,j,i)-e(k,j-1,i) )  &
-                                          ) * ddy2                             &
-                                        + (                                    &
-               ( km(k,j,i)+km(k+1,j,i) ) * ( e(k+1,j,i)-e(k,j,i) ) * ddzu(k+1) &
-             - ( km(k,j,i)+km(k-1,j,i) ) * ( e(k,j,i)-e(k-1,j,i) ) * ddzu(k)   &
-                                          ) * ddzw(k)                          &
-                             - dissipation(k,j)
-
-                ENDDO
-             ENDDO
-
-!
-!--          Store dissipation if needed for calculating the sgs particle
-!--          velocities
-             IF ( use_sgs_for_particles  .OR.  wang_kernel  .OR.               &
-                  collision_turbulence )  THEN
-                DO  j = nys, nyn
-                   DO  k = nzb_s_inner(j,i)+1, nzt
-                      diss(k,j,i) = dissipation(k,j)
-                   ENDDO
-                ENDDO
-             ENDIF
-
-          ENDDO
-
-       ENDIF
-
-!
-!--    Boundary condition for dissipation
-       IF ( use_sgs_for_particles  .OR.  wang_kernel  .OR.  &
-            collision_turbulence )  THEN
-          DO  i = nxl, nxr
-             DO  j = nys, nyn
-                diss(nzb_s_inner(j,i),j,i) = diss(nzb_s_inner(j,i)+1,j,i)
-             ENDDO
-          ENDDO
-       ENDIF
-
-    END SUBROUTINE diffusion_e
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Call for all grid points - accelerator version
-!------------------------------------------------------------------------------!
-    SUBROUTINE diffusion_e_acc( var, var_reference )
-
-       USE arrays_3d,                                                          &
-           ONLY:  dd2zu, ddzu, ddzw, diss, e, km, l_grid, tend, zu, zw
-          
-       USE control_parameters,                                                 &
-           ONLY:  atmos_ocean_sign, g, use_single_reference_value,             &
-                  wall_adjustment, wall_adjustment_factor
-
-       USE grid_variables,                                                     &
-           ONLY:  ddx2, ddy2
-           
-       USE indices,                                                            &
-           ONLY:  i_left, i_right, j_north, j_south, nxlg, nxrg, nyng, nysg,   &
-                  nzb, nzb_s_inner, nzt
-           
-       USE kinds
-
-       USE microphysics_mod,                                                   &
-           ONLY:  collision_turbulence
-
-       USE particle_attributes,                                                &
-           ONLY:  use_sgs_for_particles, wang_kernel
-
-       IMPLICIT NONE
-
-       INTEGER(iwp) ::  i              !< 
-       INTEGER(iwp) ::  j              !< 
-       INTEGER(iwp) ::  k              !< 
-       REAL(wp)     ::  dissipation    !< 
-       REAL(wp)     ::  dvar_dz        !< 
-       REAL(wp)     ::  l              !< 
-       REAL(wp)     ::  ll             !< 
-       REAL(wp)     ::  l_stable       !< 
-       REAL(wp)     ::  var_reference  !< 
-
-#if defined( __nopointer )
-       REAL(wp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ::  var  !< 
-#else
-       REAL(wp), DIMENSION(:,:,:), POINTER ::  var  !< 
-#endif
-
-
-!
-!--    This if clause must be outside the k-loop because otherwise
-!--    runtime errors occur with -C hopt on NEC
-       IF ( use_single_reference_value )  THEN
-
-          !$acc kernels present( ddzu, ddzw, dd2zu, diss, e, km, l_grid ) &
-          !$acc         present( nzb_s_inner, tend, var, zu, zw )
-          DO  i = i_left, i_right
-             DO  j = j_south, j_north
-                DO  k = 1, nzt
-
-                   IF ( k > nzb_s_inner(j,i) )  THEN
-!
-!--                   Calculate the mixing length (for dissipation)
-                      dvar_dz = atmos_ocean_sign * &
-                                ( var(k+1,j,i) - var(k-1,j,i) ) * dd2zu(k)
-                      IF ( dvar_dz > 0.0_wp ) THEN
-                         l_stable = 0.76_wp * SQRT( e(k,j,i) ) / &
-                                       SQRT( g / var_reference * dvar_dz ) + 1E-5_wp
-                      ELSE
-                         l_stable = l_grid(k)
-                      ENDIF
-!
-!--                   Adjustment of the mixing length
-                      IF ( wall_adjustment )  THEN
-                         l  = MIN( wall_adjustment_factor *          &
-                                   ( zu(k) - zw(nzb_s_inner(j,i)) ), &
-                                   l_grid(k), l_stable )
-                         ll = MIN( wall_adjustment_factor *          &
-                                   ( zu(k) - zw(nzb_s_inner(j,i)) ), &
-                                   l_grid(k) )
-                      ELSE
-                         l  = MIN( l_grid(k), l_stable )
-                         ll = l_grid(k)
-                      ENDIF
-!
-!--                   Calculate the tendency terms
-                      dissipation = ( 0.19_wp + 0.74_wp * l / ll ) * &
-                                          e(k,j,i) * SQRT( e(k,j,i) ) / l
-
-                      tend(k,j,i) = tend(k,j,i)                                  &
-                                        + (                                    &
-                          ( km(k,j,i)+km(k,j,i+1) ) * ( e(k,j,i+1)-e(k,j,i) )  &
-                        - ( km(k,j,i)+km(k,j,i-1) ) * ( e(k,j,i)-e(k,j,i-1) )  &
-                                          ) * ddx2                             &
-                                        + (                                    &
-                          ( km(k,j,i)+km(k,j+1,i) ) * ( e(k,j+1,i)-e(k,j,i) )  &
-                        - ( km(k,j,i)+km(k,j-1,i) ) * ( e(k,j,i)-e(k,j-1,i) )  &
-                                          ) * ddy2                             &
-                                        + (                                    &
-               ( km(k,j,i)+km(k+1,j,i) ) * ( e(k+1,j,i)-e(k,j,i) ) * ddzu(k+1) &
-             - ( km(k,j,i)+km(k-1,j,i) ) * ( e(k,j,i)-e(k-1,j,i) ) * ddzu(k)   &
-                                          ) * ddzw(k)                          &
-                                  - dissipation
-
-!
-!--                   Store dissipation if needed for calculating the sgs particle
-!--                   velocities
-                      IF ( use_sgs_for_particles  .OR.  wang_kernel  .OR.      &
-                           collision_turbulence )  THEN
-                         diss(k,j,i) = dissipation
-                      ENDIF
-
-                   ENDIF
-
-                ENDDO
-             ENDDO
-          ENDDO
-          !$acc end kernels
-
-       ELSE
-
-          !$acc kernels present( ddzu, ddzw, dd2zu, diss, e, km, l_grid ) &
-          !$acc         present( nzb_s_inner, tend, var, zu, zw )
-          DO  i = i_left, i_right
-             DO  j = j_south, j_north
-                DO  k = 1, nzt
-
-                   IF ( k > nzb_s_inner(j,i) )  THEN
-!
-!--                   Calculate the mixing length (for dissipation)
-                      dvar_dz = atmos_ocean_sign * &
-                                ( var(k+1,j,i) - var(k-1,j,i) ) * dd2zu(k)
-                      IF ( dvar_dz > 0.0_wp ) THEN
-                         l_stable = 0.76_wp * SQRT( e(k,j,i) ) / &
-                                              SQRT( g / var(k,j,i) * dvar_dz ) + 1E-5_wp
-                      ELSE
-                         l_stable = l_grid(k)
-                      ENDIF
-!
-!--                   Adjustment of the mixing length
-                      IF ( wall_adjustment )  THEN
-                         l  = MIN( wall_adjustment_factor *          &
-                                   ( zu(k) - zw(nzb_s_inner(j,i)) ), &
-                                     l_grid(k), l_stable )
-                         ll = MIN( wall_adjustment_factor *          &
-                                   ( zu(k) - zw(nzb_s_inner(j,i)) ), &
-                                   l_grid(k) )
-                      ELSE
-                         l  = MIN( l_grid(k), l_stable )
-                         ll = l_grid(k)
-                      ENDIF
-!
-!--                   Calculate the tendency terms
-                      dissipation = ( 0.19_wp + 0.74_wp * l / ll ) * &
-                                          e(k,j,i) * SQRT( e(k,j,i) ) / l
-
-                      tend(k,j,i) = tend(k,j,i)                                &
-                                        + (                                    &
-                          ( km(k,j,i)+km(k,j,i+1) ) * ( e(k,j,i+1)-e(k,j,i) )  &
-                        - ( km(k,j,i)+km(k,j,i-1) ) * ( e(k,j,i)-e(k,j,i-1) )  &
-                                          ) * ddx2                             &
-                                        + (                                    &
-                          ( km(k,j,i)+km(k,j+1,i) ) * ( e(k,j+1,i)-e(k,j,i) )  &
-                        - ( km(k,j,i)+km(k,j-1,i) ) * ( e(k,j,i)-e(k,j-1,i) )  &
-                                          ) * ddy2                             &
-                                        + (                                    &
-               ( km(k,j,i)+km(k+1,j,i) ) * ( e(k+1,j,i)-e(k,j,i) ) * ddzu(k+1) &
-             - ( km(k,j,i)+km(k-1,j,i) ) * ( e(k,j,i)-e(k-1,j,i) ) * ddzu(k)   &
-                                          ) * ddzw(k)                          &
-                                  - dissipation
-
-!
-!--                   Store dissipation if needed for calculating the sgs
-!--                   particle  velocities
-                      IF ( use_sgs_for_particles  .OR.  wang_kernel  .OR.      &
-                           collision_turbulence )  THEN
-                         diss(k,j,i) = dissipation
-                      ENDIF
-
-                   ENDIF
-
-                ENDDO
-             ENDDO
-          ENDDO
-          !$acc end kernels
-
-       ENDIF
-
-!
-!--    Boundary condition for dissipation
-       IF ( use_sgs_for_particles  .OR.  wang_kernel  .OR.                     &
-            collision_turbulence )  THEN
-          !$acc kernels present( diss, nzb_s_inner )
-          DO  i = i_left, i_right
-             DO  j = j_south, j_north
-                diss(nzb_s_inner(j,i),j,i) = diss(nzb_s_inner(j,i)+1,j,i)
-             ENDDO
-          ENDDO
-          !$acc end kernels
-       ENDIF
-
-    END SUBROUTINE diffusion_e_acc
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Call for grid point i,j
-!------------------------------------------------------------------------------!
-    SUBROUTINE diffusion_e_ij( i, j, var, var_reference )
-
-       USE arrays_3d,                                                          &
-           ONLY:  dd2zu, ddzu, ddzw, diss, e, km, l_grid, tend, zu, zw
-          
-       USE control_parameters,                                                 &
-           ONLY:  atmos_ocean_sign, g, use_single_reference_value,             &
-                  wall_adjustment, wall_adjustment_factor
-
-       USE grid_variables,                                                     &
-           ONLY:  ddx2, ddy2
-           
-       USE indices,                                                            &
-           ONLY:  nxlg, nxrg, nyng, nysg, nzb, nzb_s_inner, nzt
-           
-       USE kinds
-
-       USE microphysics_mod,                                                   &
-           ONLY:  collision_turbulence
-
-       USE particle_attributes,                                                &
-           ONLY:  use_sgs_for_particles, wang_kernel
-
-       IMPLICIT NONE
-
-       INTEGER(iwp) ::  i              !< 
-       INTEGER(iwp) ::  j              !< 
-       INTEGER(iwp) ::  k              !< 
-       REAL(wp)     ::  dvar_dz        !< 
-       REAL(wp)     ::  l_stable       !<
-       REAL(wp)     ::  var_reference  !<
-
-#if defined( __nopointer )
-       REAL(wp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ::  var  !<
-#else
-       REAL(wp), DIMENSION(:,:,:), POINTER ::  var     !<
-#endif
-       REAL(wp), DIMENSION(nzb+1:nzt) ::  dissipation  !<
-       REAL(wp), DIMENSION(nzb+1:nzt) ::  l            !<
-       REAL(wp), DIMENSION(nzb+1:nzt) ::  ll           !<
-
-
-!
-!--    Calculate the mixing length (for dissipation)
-       DO  k = nzb_s_inner(j,i)+1, nzt
-          dvar_dz = atmos_ocean_sign * &
-                    ( var(k+1,j,i) - var(k-1,j,i) ) * dd2zu(k)
-          IF ( dvar_dz > 0.0_wp ) THEN
-             IF ( use_single_reference_value )  THEN
-                l_stable = 0.76_wp * SQRT( e(k,j,i) ) / &
-                                     SQRT( g / var_reference * dvar_dz ) + 1E-5_wp
-             ELSE
-                l_stable = 0.76_wp * SQRT( e(k,j,i) ) / &
-                                     SQRT( g / var(k,j,i) * dvar_dz ) + 1E-5_wp
-             ENDIF
-          ELSE
-             l_stable = l_grid(k)
-          ENDIF
-!
-!--       Adjustment of the mixing length
-          IF ( wall_adjustment )  THEN
-             l(k)  = MIN( wall_adjustment_factor *                     &
-                          ( zu(k) - zw(nzb_s_inner(j,i)) ), l_grid(k), &
-                          l_stable )
-             ll(k) = MIN( wall_adjustment_factor *                     &
-                          ( zu(k) - zw(nzb_s_inner(j,i)) ), l_grid(k) )
-          ELSE
-             l(k)  = MIN( l_grid(k), l_stable )
-             ll(k) = l_grid(k)
-          ENDIF
-!
-!--       Calculate the tendency term
-          dissipation(k) = ( 0.19_wp + 0.74_wp * l(k) / ll(k) ) * e(k,j,i) * &
-                                 SQRT( e(k,j,i) ) / l(k)
-
-          tend(k,j,i) = tend(k,j,i)                                           &
-                                       + (                                    &
-                         ( km(k,j,i)+km(k,j,i+1) ) * ( e(k,j,i+1)-e(k,j,i) )  &
-                       - ( km(k,j,i)+km(k,j,i-1) ) * ( e(k,j,i)-e(k,j,i-1) )  &
-                                         ) * ddx2                             &
-                                       + (                                    &
-                         ( km(k,j,i)+km(k,j+1,i) ) * ( e(k,j+1,i)-e(k,j,i) )  &
-                       - ( km(k,j,i)+km(k,j-1,i) ) * ( e(k,j,i)-e(k,j-1,i) )  &
-                                         ) * ddy2                             &
-                                       + (                                    &
-              ( km(k,j,i)+km(k+1,j,i) ) * ( e(k+1,j,i)-e(k,j,i) ) * ddzu(k+1) &
-            - ( km(k,j,i)+km(k-1,j,i) ) * ( e(k,j,i)-e(k-1,j,i) ) * ddzu(k)   &
-                                         ) * ddzw(k)                          &
-                                       - dissipation(k)
-
-       ENDDO
-
-!
-!--    Store dissipation if needed for calculating the sgs particle velocities
-       IF ( use_sgs_for_particles  .OR.  wang_kernel  .OR.                     &
-            collision_turbulence )  THEN
-          DO  k = nzb_s_inner(j,i)+1, nzt
-             diss(k,j,i) = dissipation(k)
-          ENDDO
-!
-!--       Boundary condition for dissipation
-          diss(nzb_s_inner(j,i),j,i) = diss(nzb_s_inner(j,i)+1,j,i)
-       ENDIF
-
-    END SUBROUTINE diffusion_e_ij
-
- END MODULE diffusion_e_mod
Index: /palm/trunk/SOURCE/diffusion_e_mod.f90
===================================================================
--- /palm/trunk/SOURCE/diffusion_e_mod.f90	(revision 1850)
+++ /palm/trunk/SOURCE/diffusion_e_mod.f90	(revision 1850)
@@ -0,0 +1,636 @@
+!> @file diffusion_e_mod.f90
+!--------------------------------------------------------------------------------!
+! This file is part of PALM.
+!
+! PALM is free software: you can redistribute it and/or modify it under the terms
+! of the GNU General Public License as published by the Free Software Foundation,
+! either version 3 of the License, or (at your option) any later version.
+!
+! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
+! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
+! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along with
+! PALM. If not, see <http://www.gnu.org/licenses/>.
+!
+! Copyright 1997-2016 Leibniz Universitaet Hannover
+!--------------------------------------------------------------------------------!
+!
+! Current revisions:
+! -----------------
+! Module renamed
+! Adapted for modularization of microphysics
+! 
+! Former revisions:
+! -----------------
+! $Id$
+!
+! 1831 2016-04-07 13:15:51Z hoffmann 
+! turbulence renamed collision_turbulence
+!
+! 1682 2015-10-07 23:56:08Z knoop
+! Code annotations made doxygen readable 
+! 
+! 1374 2014-04-25 12:55:07Z raasch
+! missing variables added to ONLY list
+! rif removed from acc-present-list
+! 
+! 1340 2014-03-25 19:45:13Z kanani
+! REAL constants defined as wp-kind
+!
+! 1320 2014-03-20 08:40:49Z raasch
+! ONLY-attribute added to USE-statements,
+! kind-parameters added to all INTEGER and REAL declaration statements,
+! kinds are defined in new module kinds,
+! revision history before 2012 removed,
+! comment fields (!:) to be used for variable explanations added to
+! all variable declaration statements
+!
+! 1257 2013-11-08 15:18:40Z raasch
+! openacc loop and loop vector clauses removed
+!
+! 1179 2013-06-14 05:57:58Z raasch
+! use_reference renamed use_single_reference_value
+!
+! 1171 2013-05-30 11:27:45Z raasch
+! use_reference-case activated in accelerator version
+!
+! 1128 2013-04-12 06:19:32Z raasch
+! loop index bounds in accelerator version replaced by i_left, i_right, j_south,
+! j_north
+!
+! 1065 2012-11-22 17:42:36Z hoffmann
+! Enabled the claculation of diss in case of turbulence = .TRUE. (parameterized 
+! effects of turbulence on autoconversion and accretion in two-moments cloud 
+! physics scheme). 
+!
+! 1036 2012-10-22 13:43:42Z raasch
+! code put under GPL (PALM 3.9)
+!
+! 1015 2012-09-27 09:23:24Z raasch
+! accelerator version (*_acc) added,
+! adjustment of mixing length to the Prandtl mixing length at first grid point
+! above ground removed
+!
+! 1010 2012-09-20 07:59:54Z raasch
+! cpp switch __nopointer added for pointer free version
+!
+! 1001 2012-09-13 14:08:46Z raasch
+! most arrays comunicated by module instead of parameter list
+!
+! 825 2012-02-19 03:03:44Z raasch
+! wang_collision_kernel renamed wang_kernel
+!
+! Revision 1.1  1997/09/19 07:40:24  raasch
+! Initial revision
+!
+!
+! Description:
+! ------------
+!> Diffusion- and dissipation terms for the TKE
+!------------------------------------------------------------------------------!
+ MODULE diffusion_e_mod
+ 
+
+    PRIVATE
+    PUBLIC diffusion_e, diffusion_e_acc
+    
+
+    INTERFACE diffusion_e
+       MODULE PROCEDURE diffusion_e
+       MODULE PROCEDURE diffusion_e_ij
+    END INTERFACE diffusion_e
+ 
+    INTERFACE diffusion_e_acc
+       MODULE PROCEDURE diffusion_e_acc
+    END INTERFACE diffusion_e_acc
+
+ CONTAINS
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Call for all grid points
+!------------------------------------------------------------------------------!
+    SUBROUTINE diffusion_e( var, var_reference )
+
+       USE arrays_3d,                                                          &
+           ONLY:  dd2zu, ddzu, ddzw, diss, e, km, l_grid, tend, zu, zw
+           
+       USE control_parameters,                                                 &
+           ONLY:  atmos_ocean_sign, g, use_single_reference_value, &
+                  wall_adjustment, wall_adjustment_factor
+
+       USE grid_variables,                                                     &
+           ONLY:  ddx2, ddy2
+           
+       USE indices,                                                            &
+           ONLY:  nxl, nxlg, nxr, nxrg, nyn, nyng, nys, nysg, nzb, nzb_s_inner,&
+                  nzt
+           
+       USE kinds
+
+       USE microphysics_mod,                                                   &
+           ONLY:  collision_turbulence
+
+       USE particle_attributes,                                                &
+           ONLY:  use_sgs_for_particles, wang_kernel
+
+       IMPLICIT NONE
+
+       INTEGER(iwp) ::  i              !< 
+       INTEGER(iwp) ::  j              !< 
+       INTEGER(iwp) ::  k              !< 
+       REAL(wp)     ::  dvar_dz        !< 
+       REAL(wp)     ::  l_stable       !< 
+       REAL(wp)     ::  var_reference  !< 
+
+#if defined( __nopointer )
+       REAL(wp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ::  var  !< 
+#else
+       REAL(wp), DIMENSION(:,:,:), POINTER ::  var  !< 
+#endif
+       REAL(wp), DIMENSION(nzb+1:nzt,nys:nyn) ::  dissipation  !<
+       REAL(wp), DIMENSION(nzb+1:nzt,nys:nyn) ::  l            !<
+       REAL(wp), DIMENSION(nzb+1:nzt,nys:nyn) ::  ll           !< 
+ 
+
+!
+!--    This if clause must be outside the k-loop because otherwise
+!--    runtime errors occur with -C hopt on NEC
+       IF ( use_single_reference_value )  THEN
+
+          DO  i = nxl, nxr
+             DO  j = nys, nyn
+                DO  k = nzb_s_inner(j,i)+1, nzt
+!
+!--                Calculate the mixing length (for dissipation)
+                   dvar_dz = atmos_ocean_sign * &
+                             ( var(k+1,j,i) - var(k-1,j,i) ) * dd2zu(k)
+                   IF ( dvar_dz > 0.0_wp ) THEN
+                      l_stable = 0.76_wp * SQRT( e(k,j,i) ) / &
+                                    SQRT( g / var_reference * dvar_dz ) + 1E-5_wp
+                   ELSE
+                      l_stable = l_grid(k)
+                   ENDIF
+!
+!--                Adjustment of the mixing length
+                   IF ( wall_adjustment )  THEN
+                      l(k,j)  = MIN( wall_adjustment_factor *          &
+                                     ( zu(k) - zw(nzb_s_inner(j,i)) ), &
+                                     l_grid(k), l_stable )
+                      ll(k,j) = MIN( wall_adjustment_factor *          &
+                                     ( zu(k) - zw(nzb_s_inner(j,i)) ), &
+                                     l_grid(k) )
+                   ELSE
+                      l(k,j)  = MIN( l_grid(k), l_stable )
+                      ll(k,j) = l_grid(k)
+                   ENDIF
+
+                ENDDO
+             ENDDO
+
+!
+!--          Calculate the tendency terms
+             DO  j = nys, nyn
+                DO  k = nzb_s_inner(j,i)+1, nzt
+
+                    dissipation(k,j) = ( 0.19_wp + 0.74_wp * l(k,j) / ll(k,j) ) * &
+                                       e(k,j,i) * SQRT( e(k,j,i) ) / l(k,j)
+
+                    tend(k,j,i) = tend(k,j,i)                                  &
+                                        + (                                    &
+                          ( km(k,j,i)+km(k,j,i+1) ) * ( e(k,j,i+1)-e(k,j,i) )  &
+                        - ( km(k,j,i)+km(k,j,i-1) ) * ( e(k,j,i)-e(k,j,i-1) )  &
+                                          ) * ddx2                             &
+                                        + (                                    &
+                          ( km(k,j,i)+km(k,j+1,i) ) * ( e(k,j+1,i)-e(k,j,i) )  &
+                        - ( km(k,j,i)+km(k,j-1,i) ) * ( e(k,j,i)-e(k,j-1,i) )  &
+                                          ) * ddy2                             &
+                                        + (                                    &
+               ( km(k,j,i)+km(k+1,j,i) ) * ( e(k+1,j,i)-e(k,j,i) ) * ddzu(k+1) &
+             - ( km(k,j,i)+km(k-1,j,i) ) * ( e(k,j,i)-e(k-1,j,i) ) * ddzu(k)   &
+                                          ) * ddzw(k)                          &
+                             - dissipation(k,j)
+
+                ENDDO
+             ENDDO
+
+!
+!--          Store dissipation if needed for calculating the sgs particle
+!--          velocities
+             IF ( use_sgs_for_particles  .OR.  wang_kernel  .OR.               &
+                  collision_turbulence )  THEN
+                DO  j = nys, nyn
+                   DO  k = nzb_s_inner(j,i)+1, nzt
+                      diss(k,j,i) = dissipation(k,j)
+                   ENDDO
+                ENDDO
+             ENDIF
+
+          ENDDO
+
+       ELSE
+
+          DO  i = nxl, nxr
+             DO  j = nys, nyn
+                DO  k = nzb_s_inner(j,i)+1, nzt
+!
+!--                Calculate the mixing length (for dissipation)
+                   dvar_dz = atmos_ocean_sign * &
+                             ( var(k+1,j,i) - var(k-1,j,i) ) * dd2zu(k)
+                   IF ( dvar_dz > 0.0_wp ) THEN
+                      l_stable = 0.76_wp * SQRT( e(k,j,i) ) / &
+                                           SQRT( g / var(k,j,i) * dvar_dz ) + 1E-5_wp
+                   ELSE
+                      l_stable = l_grid(k)
+                   ENDIF
+!
+!--                Adjustment of the mixing length
+                   IF ( wall_adjustment )  THEN
+                      l(k,j)  = MIN( wall_adjustment_factor *          &
+                                     ( zu(k) - zw(nzb_s_inner(j,i)) ), &
+                                     l_grid(k), l_stable )
+                      ll(k,j) = MIN( wall_adjustment_factor *          &
+                                     ( zu(k) - zw(nzb_s_inner(j,i)) ), &
+                                     l_grid(k) )
+                   ELSE
+                      l(k,j)  = MIN( l_grid(k), l_stable )
+                      ll(k,j) = l_grid(k)
+                   ENDIF
+
+                ENDDO
+             ENDDO
+
+!
+!--          Calculate the tendency terms
+             DO  j = nys, nyn
+                DO  k = nzb_s_inner(j,i)+1, nzt
+
+                    dissipation(k,j) = ( 0.19_wp + 0.74_wp * l(k,j) / ll(k,j) ) * &
+                                             e(k,j,i) * SQRT( e(k,j,i) ) / l(k,j)
+
+                    tend(k,j,i) = tend(k,j,i)                                  &
+                                        + (                                    &
+                          ( km(k,j,i)+km(k,j,i+1) ) * ( e(k,j,i+1)-e(k,j,i) )  &
+                        - ( km(k,j,i)+km(k,j,i-1) ) * ( e(k,j,i)-e(k,j,i-1) )  &
+                                          ) * ddx2                             &
+                                        + (                                    &
+                          ( km(k,j,i)+km(k,j+1,i) ) * ( e(k,j+1,i)-e(k,j,i) )  &
+                        - ( km(k,j,i)+km(k,j-1,i) ) * ( e(k,j,i)-e(k,j-1,i) )  &
+                                          ) * ddy2                             &
+                                        + (                                    &
+               ( km(k,j,i)+km(k+1,j,i) ) * ( e(k+1,j,i)-e(k,j,i) ) * ddzu(k+1) &
+             - ( km(k,j,i)+km(k-1,j,i) ) * ( e(k,j,i)-e(k-1,j,i) ) * ddzu(k)   &
+                                          ) * ddzw(k)                          &
+                             - dissipation(k,j)
+
+                ENDDO
+             ENDDO
+
+!
+!--          Store dissipation if needed for calculating the sgs particle
+!--          velocities
+             IF ( use_sgs_for_particles  .OR.  wang_kernel  .OR.               &
+                  collision_turbulence )  THEN
+                DO  j = nys, nyn
+                   DO  k = nzb_s_inner(j,i)+1, nzt
+                      diss(k,j,i) = dissipation(k,j)
+                   ENDDO
+                ENDDO
+             ENDIF
+
+          ENDDO
+
+       ENDIF
+
+!
+!--    Boundary condition for dissipation
+       IF ( use_sgs_for_particles  .OR.  wang_kernel  .OR.  &
+            collision_turbulence )  THEN
+          DO  i = nxl, nxr
+             DO  j = nys, nyn
+                diss(nzb_s_inner(j,i),j,i) = diss(nzb_s_inner(j,i)+1,j,i)
+             ENDDO
+          ENDDO
+       ENDIF
+
+    END SUBROUTINE diffusion_e
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Call for all grid points - accelerator version
+!------------------------------------------------------------------------------!
+    SUBROUTINE diffusion_e_acc( var, var_reference )
+
+       USE arrays_3d,                                                          &
+           ONLY:  dd2zu, ddzu, ddzw, diss, e, km, l_grid, tend, zu, zw
+          
+       USE control_parameters,                                                 &
+           ONLY:  atmos_ocean_sign, g, use_single_reference_value,             &
+                  wall_adjustment, wall_adjustment_factor
+
+       USE grid_variables,                                                     &
+           ONLY:  ddx2, ddy2
+           
+       USE indices,                                                            &
+           ONLY:  i_left, i_right, j_north, j_south, nxlg, nxrg, nyng, nysg,   &
+                  nzb, nzb_s_inner, nzt
+           
+       USE kinds
+
+       USE microphysics_mod,                                                   &
+           ONLY:  collision_turbulence
+
+       USE particle_attributes,                                                &
+           ONLY:  use_sgs_for_particles, wang_kernel
+
+       IMPLICIT NONE
+
+       INTEGER(iwp) ::  i              !< 
+       INTEGER(iwp) ::  j              !< 
+       INTEGER(iwp) ::  k              !< 
+       REAL(wp)     ::  dissipation    !< 
+       REAL(wp)     ::  dvar_dz        !< 
+       REAL(wp)     ::  l              !< 
+       REAL(wp)     ::  ll             !< 
+       REAL(wp)     ::  l_stable       !< 
+       REAL(wp)     ::  var_reference  !< 
+
+#if defined( __nopointer )
+       REAL(wp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ::  var  !< 
+#else
+       REAL(wp), DIMENSION(:,:,:), POINTER ::  var  !< 
+#endif
+
+
+!
+!--    This if clause must be outside the k-loop because otherwise
+!--    runtime errors occur with -C hopt on NEC
+       IF ( use_single_reference_value )  THEN
+
+          !$acc kernels present( ddzu, ddzw, dd2zu, diss, e, km, l_grid ) &
+          !$acc         present( nzb_s_inner, tend, var, zu, zw )
+          DO  i = i_left, i_right
+             DO  j = j_south, j_north
+                DO  k = 1, nzt
+
+                   IF ( k > nzb_s_inner(j,i) )  THEN
+!
+!--                   Calculate the mixing length (for dissipation)
+                      dvar_dz = atmos_ocean_sign * &
+                                ( var(k+1,j,i) - var(k-1,j,i) ) * dd2zu(k)
+                      IF ( dvar_dz > 0.0_wp ) THEN
+                         l_stable = 0.76_wp * SQRT( e(k,j,i) ) / &
+                                       SQRT( g / var_reference * dvar_dz ) + 1E-5_wp
+                      ELSE
+                         l_stable = l_grid(k)
+                      ENDIF
+!
+!--                   Adjustment of the mixing length
+                      IF ( wall_adjustment )  THEN
+                         l  = MIN( wall_adjustment_factor *          &
+                                   ( zu(k) - zw(nzb_s_inner(j,i)) ), &
+                                   l_grid(k), l_stable )
+                         ll = MIN( wall_adjustment_factor *          &
+                                   ( zu(k) - zw(nzb_s_inner(j,i)) ), &
+                                   l_grid(k) )
+                      ELSE
+                         l  = MIN( l_grid(k), l_stable )
+                         ll = l_grid(k)
+                      ENDIF
+!
+!--                   Calculate the tendency terms
+                      dissipation = ( 0.19_wp + 0.74_wp * l / ll ) * &
+                                          e(k,j,i) * SQRT( e(k,j,i) ) / l
+
+                      tend(k,j,i) = tend(k,j,i)                                  &
+                                        + (                                    &
+                          ( km(k,j,i)+km(k,j,i+1) ) * ( e(k,j,i+1)-e(k,j,i) )  &
+                        - ( km(k,j,i)+km(k,j,i-1) ) * ( e(k,j,i)-e(k,j,i-1) )  &
+                                          ) * ddx2                             &
+                                        + (                                    &
+                          ( km(k,j,i)+km(k,j+1,i) ) * ( e(k,j+1,i)-e(k,j,i) )  &
+                        - ( km(k,j,i)+km(k,j-1,i) ) * ( e(k,j,i)-e(k,j-1,i) )  &
+                                          ) * ddy2                             &
+                                        + (                                    &
+               ( km(k,j,i)+km(k+1,j,i) ) * ( e(k+1,j,i)-e(k,j,i) ) * ddzu(k+1) &
+             - ( km(k,j,i)+km(k-1,j,i) ) * ( e(k,j,i)-e(k-1,j,i) ) * ddzu(k)   &
+                                          ) * ddzw(k)                          &
+                                  - dissipation
+
+!
+!--                   Store dissipation if needed for calculating the sgs particle
+!--                   velocities
+                      IF ( use_sgs_for_particles  .OR.  wang_kernel  .OR.      &
+                           collision_turbulence )  THEN
+                         diss(k,j,i) = dissipation
+                      ENDIF
+
+                   ENDIF
+
+                ENDDO
+             ENDDO
+          ENDDO
+          !$acc end kernels
+
+       ELSE
+
+          !$acc kernels present( ddzu, ddzw, dd2zu, diss, e, km, l_grid ) &
+          !$acc         present( nzb_s_inner, tend, var, zu, zw )
+          DO  i = i_left, i_right
+             DO  j = j_south, j_north
+                DO  k = 1, nzt
+
+                   IF ( k > nzb_s_inner(j,i) )  THEN
+!
+!--                   Calculate the mixing length (for dissipation)
+                      dvar_dz = atmos_ocean_sign * &
+                                ( var(k+1,j,i) - var(k-1,j,i) ) * dd2zu(k)
+                      IF ( dvar_dz > 0.0_wp ) THEN
+                         l_stable = 0.76_wp * SQRT( e(k,j,i) ) / &
+                                              SQRT( g / var(k,j,i) * dvar_dz ) + 1E-5_wp
+                      ELSE
+                         l_stable = l_grid(k)
+                      ENDIF
+!
+!--                   Adjustment of the mixing length
+                      IF ( wall_adjustment )  THEN
+                         l  = MIN( wall_adjustment_factor *          &
+                                   ( zu(k) - zw(nzb_s_inner(j,i)) ), &
+                                     l_grid(k), l_stable )
+                         ll = MIN( wall_adjustment_factor *          &
+                                   ( zu(k) - zw(nzb_s_inner(j,i)) ), &
+                                   l_grid(k) )
+                      ELSE
+                         l  = MIN( l_grid(k), l_stable )
+                         ll = l_grid(k)
+                      ENDIF
+!
+!--                   Calculate the tendency terms
+                      dissipation = ( 0.19_wp + 0.74_wp * l / ll ) * &
+                                          e(k,j,i) * SQRT( e(k,j,i) ) / l
+
+                      tend(k,j,i) = tend(k,j,i)                                &
+                                        + (                                    &
+                          ( km(k,j,i)+km(k,j,i+1) ) * ( e(k,j,i+1)-e(k,j,i) )  &
+                        - ( km(k,j,i)+km(k,j,i-1) ) * ( e(k,j,i)-e(k,j,i-1) )  &
+                                          ) * ddx2                             &
+                                        + (                                    &
+                          ( km(k,j,i)+km(k,j+1,i) ) * ( e(k,j+1,i)-e(k,j,i) )  &
+                        - ( km(k,j,i)+km(k,j-1,i) ) * ( e(k,j,i)-e(k,j-1,i) )  &
+                                          ) * ddy2                             &
+                                        + (                                    &
+               ( km(k,j,i)+km(k+1,j,i) ) * ( e(k+1,j,i)-e(k,j,i) ) * ddzu(k+1) &
+             - ( km(k,j,i)+km(k-1,j,i) ) * ( e(k,j,i)-e(k-1,j,i) ) * ddzu(k)   &
+                                          ) * ddzw(k)                          &
+                                  - dissipation
+
+!
+!--                   Store dissipation if needed for calculating the sgs
+!--                   particle  velocities
+                      IF ( use_sgs_for_particles  .OR.  wang_kernel  .OR.      &
+                           collision_turbulence )  THEN
+                         diss(k,j,i) = dissipation
+                      ENDIF
+
+                   ENDIF
+
+                ENDDO
+             ENDDO
+          ENDDO
+          !$acc end kernels
+
+       ENDIF
+
+!
+!--    Boundary condition for dissipation
+       IF ( use_sgs_for_particles  .OR.  wang_kernel  .OR.                     &
+            collision_turbulence )  THEN
+          !$acc kernels present( diss, nzb_s_inner )
+          DO  i = i_left, i_right
+             DO  j = j_south, j_north
+                diss(nzb_s_inner(j,i),j,i) = diss(nzb_s_inner(j,i)+1,j,i)
+             ENDDO
+          ENDDO
+          !$acc end kernels
+       ENDIF
+
+    END SUBROUTINE diffusion_e_acc
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Call for grid point i,j
+!------------------------------------------------------------------------------!
+    SUBROUTINE diffusion_e_ij( i, j, var, var_reference )
+
+       USE arrays_3d,                                                          &
+           ONLY:  dd2zu, ddzu, ddzw, diss, e, km, l_grid, tend, zu, zw
+          
+       USE control_parameters,                                                 &
+           ONLY:  atmos_ocean_sign, g, use_single_reference_value,             &
+                  wall_adjustment, wall_adjustment_factor
+
+       USE grid_variables,                                                     &
+           ONLY:  ddx2, ddy2
+           
+       USE indices,                                                            &
+           ONLY:  nxlg, nxrg, nyng, nysg, nzb, nzb_s_inner, nzt
+           
+       USE kinds
+
+       USE microphysics_mod,                                                   &
+           ONLY:  collision_turbulence
+
+       USE particle_attributes,                                                &
+           ONLY:  use_sgs_for_particles, wang_kernel
+
+       IMPLICIT NONE
+
+       INTEGER(iwp) ::  i              !< 
+       INTEGER(iwp) ::  j              !< 
+       INTEGER(iwp) ::  k              !< 
+       REAL(wp)     ::  dvar_dz        !< 
+       REAL(wp)     ::  l_stable       !<
+       REAL(wp)     ::  var_reference  !<
+
+#if defined( __nopointer )
+       REAL(wp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ::  var  !<
+#else
+       REAL(wp), DIMENSION(:,:,:), POINTER ::  var     !<
+#endif
+       REAL(wp), DIMENSION(nzb+1:nzt) ::  dissipation  !<
+       REAL(wp), DIMENSION(nzb+1:nzt) ::  l            !<
+       REAL(wp), DIMENSION(nzb+1:nzt) ::  ll           !<
+
+
+!
+!--    Calculate the mixing length (for dissipation)
+       DO  k = nzb_s_inner(j,i)+1, nzt
+          dvar_dz = atmos_ocean_sign * &
+                    ( var(k+1,j,i) - var(k-1,j,i) ) * dd2zu(k)
+          IF ( dvar_dz > 0.0_wp ) THEN
+             IF ( use_single_reference_value )  THEN
+                l_stable = 0.76_wp * SQRT( e(k,j,i) ) / &
+                                     SQRT( g / var_reference * dvar_dz ) + 1E-5_wp
+             ELSE
+                l_stable = 0.76_wp * SQRT( e(k,j,i) ) / &
+                                     SQRT( g / var(k,j,i) * dvar_dz ) + 1E-5_wp
+             ENDIF
+          ELSE
+             l_stable = l_grid(k)
+          ENDIF
+!
+!--       Adjustment of the mixing length
+          IF ( wall_adjustment )  THEN
+             l(k)  = MIN( wall_adjustment_factor *                     &
+                          ( zu(k) - zw(nzb_s_inner(j,i)) ), l_grid(k), &
+                          l_stable )
+             ll(k) = MIN( wall_adjustment_factor *                     &
+                          ( zu(k) - zw(nzb_s_inner(j,i)) ), l_grid(k) )
+          ELSE
+             l(k)  = MIN( l_grid(k), l_stable )
+             ll(k) = l_grid(k)
+          ENDIF
+!
+!--       Calculate the tendency term
+          dissipation(k) = ( 0.19_wp + 0.74_wp * l(k) / ll(k) ) * e(k,j,i) * &
+                                 SQRT( e(k,j,i) ) / l(k)
+
+          tend(k,j,i) = tend(k,j,i)                                           &
+                                       + (                                    &
+                         ( km(k,j,i)+km(k,j,i+1) ) * ( e(k,j,i+1)-e(k,j,i) )  &
+                       - ( km(k,j,i)+km(k,j,i-1) ) * ( e(k,j,i)-e(k,j,i-1) )  &
+                                         ) * ddx2                             &
+                                       + (                                    &
+                         ( km(k,j,i)+km(k,j+1,i) ) * ( e(k,j+1,i)-e(k,j,i) )  &
+                       - ( km(k,j,i)+km(k,j-1,i) ) * ( e(k,j,i)-e(k,j-1,i) )  &
+                                         ) * ddy2                             &
+                                       + (                                    &
+              ( km(k,j,i)+km(k+1,j,i) ) * ( e(k+1,j,i)-e(k,j,i) ) * ddzu(k+1) &
+            - ( km(k,j,i)+km(k-1,j,i) ) * ( e(k,j,i)-e(k-1,j,i) ) * ddzu(k)   &
+                                         ) * ddzw(k)                          &
+                                       - dissipation(k)
+
+       ENDDO
+
+!
+!--    Store dissipation if needed for calculating the sgs particle velocities
+       IF ( use_sgs_for_particles  .OR.  wang_kernel  .OR.                     &
+            collision_turbulence )  THEN
+          DO  k = nzb_s_inner(j,i)+1, nzt
+             diss(k,j,i) = dissipation(k)
+          ENDDO
+!
+!--       Boundary condition for dissipation
+          diss(nzb_s_inner(j,i),j,i) = diss(nzb_s_inner(j,i)+1,j,i)
+       ENDIF
+
+    END SUBROUTINE diffusion_e_ij
+
+ END MODULE diffusion_e_mod
Index: lm/trunk/SOURCE/diffusion_s.f90
===================================================================
--- /palm/trunk/SOURCE/diffusion_s.f90	(revision 1849)
+++ 	(revision )
@@ -1,470 +1,0 @@
-!> @file diffusion_s.f90
-!--------------------------------------------------------------------------------!
-! This file is part of PALM.
-!
-! PALM is free software: you can redistribute it and/or modify it under the terms
-! of the GNU General Public License as published by the Free Software Foundation,
-! either version 3 of the License, or (at your option) any later version.
-!
-! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
-! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
-! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along with
-! PALM. If not, see <http://www.gnu.org/licenses/>.
-!
-! Copyright 1997-2016 Leibniz Universitaet Hannover
-!--------------------------------------------------------------------------------!
-!
-! Current revisions:
-! ------------------
-! 
-! 
-! Former revisions:
-! -----------------
-! $Id$
-!
-! 1691 2015-10-26 16:17:44Z maronga
-! Formatting corrections.
-! 
-! 1682 2015-10-07 23:56:08Z knoop
-! Code annotations made doxygen readable 
-! 
-! 1374 2014-04-25 12:55:07Z raasch
-! missing variables added to ONLY list
-! 
-! 1340 2014-03-25 19:45:13Z kanani
-! REAL constants defined as wp-kind
-!
-! 1320 2014-03-20 08:40:49Z raasch
-! ONLY-attribute added to USE-statements,
-! kind-parameters added to all INTEGER and REAL declaration statements,
-! kinds are defined in new module kinds,
-! revision history before 2012 removed,
-! comment fields (!:) to be used for variable explanations added to
-! all variable declaration statements
-! 
-! 1257 2013-11-08 15:18:40Z raasch
-! openacc loop and loop vector clauses removed
-!
-! 1128 2013-04-12 06:19:32Z raasch
-! loop index bounds in accelerator version replaced by i_left, i_right, j_south,
-! j_north
-!
-! 1092 2013-02-02 11:24:22Z raasch
-! unused variables removed
-!
-! 1036 2012-10-22 13:43:42Z raasch
-! code put under GPL (PALM 3.9)
-!
-! 1015 2012-09-27 09:23:24Z raasch
-! accelerator version (*_acc) added
-!
-! 1010 2012-09-20 07:59:54Z raasch
-! cpp switch __nopointer added for pointer free version
-!
-! 1001 2012-09-13 14:08:46Z raasch
-! some arrays comunicated by module instead of parameter list
-!
-! Revision 1.1  2000/04/13 14:54:02  schroeter
-! Initial revision
-!
-!
-! Description:
-! ------------
-!> Diffusion term of scalar quantities (temperature and water content)
-!------------------------------------------------------------------------------!
- MODULE diffusion_s_mod
- 
-
-    PRIVATE
-    PUBLIC diffusion_s, diffusion_s_acc
-
-    INTERFACE diffusion_s
-       MODULE PROCEDURE diffusion_s
-       MODULE PROCEDURE diffusion_s_ij
-    END INTERFACE diffusion_s
-
-    INTERFACE diffusion_s_acc
-       MODULE PROCEDURE diffusion_s_acc
-    END INTERFACE diffusion_s_acc
-
- CONTAINS
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Call for all grid points
-!------------------------------------------------------------------------------!
-    SUBROUTINE diffusion_s( s, s_flux_b, s_flux_t, wall_s_flux )
-
-       USE arrays_3d,                                                          &
-           ONLY:  ddzu, ddzw, kh, tend
-       
-       USE control_parameters,                                                 & 
-           ONLY: use_surface_fluxes, use_top_fluxes
-       
-       USE grid_variables,                                                     &
-           ONLY:  ddx2, ddy2, fwxm, fwxp, fwym, fwyp, wall_w_x, wall_w_y
-       
-       USE indices,                                                            &
-           ONLY:  nxl, nxlg, nxr, nxrg, nyn, nyng, nys, nysg, nzb,             &
-                  nzb_diff_s_inner, nzb_s_inner, nzb_s_outer, nzt, nzt_diff
-       
-       USE kinds
-
-       IMPLICIT NONE
-
-       INTEGER(iwp) ::  i                 !< 
-       INTEGER(iwp) ::  j                 !< 
-       INTEGER(iwp) ::  k                 !< 
-       REAL(wp)     ::  wall_s_flux(0:4)  !< 
-       REAL(wp), DIMENSION(nysg:nyng,nxlg:nxrg) ::  s_flux_b, s_flux_t !<
-#if defined( __nopointer )
-       REAL(wp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ::  s  !< 
-#else
-       REAL(wp), DIMENSION(:,:,:), POINTER ::  s  !< 
-#endif
-
-       DO  i = nxl, nxr
-          DO  j = nys,nyn
-!
-!--          Compute horizontal diffusion
-             DO  k = nzb_s_outer(j,i)+1, nzt
-
-                tend(k,j,i) = tend(k,j,i)                                      &
-                                          + 0.5_wp * (                         &
-                        ( kh(k,j,i) + kh(k,j,i+1) ) * ( s(k,j,i+1)-s(k,j,i) )  &
-                      - ( kh(k,j,i) + kh(k,j,i-1) ) * ( s(k,j,i)-s(k,j,i-1) )  &
-                                                     ) * ddx2                  &
-                                          + 0.5_wp * (                         &
-                        ( kh(k,j,i) + kh(k,j+1,i) ) * ( s(k,j+1,i)-s(k,j,i) )  &
-                      - ( kh(k,j,i) + kh(k,j-1,i) ) * ( s(k,j,i)-s(k,j-1,i) )  &
-                                                     ) * ddy2
-             ENDDO
-
-!
-!--          Apply prescribed horizontal wall heatflux where necessary
-             IF ( ( wall_w_x(j,i) /= 0.0_wp ) .OR. ( wall_w_y(j,i) /= 0.0_wp ) &
-                )  THEN
-                DO  k = nzb_s_inner(j,i)+1, nzb_s_outer(j,i)
-
-                   tend(k,j,i) = tend(k,j,i)                                   &
-                                                + ( fwxp(j,i) * 0.5_wp *       &
-                        ( kh(k,j,i) + kh(k,j,i+1) ) * ( s(k,j,i+1)-s(k,j,i) )  &
-                        + ( 1.0_wp - fwxp(j,i) ) * wall_s_flux(1)              &
-                                                   -fwxm(j,i) * 0.5_wp *       &
-                        ( kh(k,j,i) + kh(k,j,i-1) ) * ( s(k,j,i)-s(k,j,i-1) )  &
-                        + ( 1.0_wp - fwxm(j,i) ) * wall_s_flux(2)              &
-                                                  ) * ddx2                     &
-                                                + ( fwyp(j,i) * 0.5_wp *       &
-                        ( kh(k,j,i) + kh(k,j+1,i) ) * ( s(k,j+1,i)-s(k,j,i) )  &
-                        + ( 1.0_wp - fwyp(j,i) ) * wall_s_flux(3)              &
-                                                   -fwym(j,i) * 0.5_wp *       &
-                        ( kh(k,j,i) + kh(k,j-1,i) ) * ( s(k,j,i)-s(k,j-1,i) )  &
-                        + ( 1.0_wp - fwym(j,i) ) * wall_s_flux(4)              &
-                                                  ) * ddy2
-                ENDDO
-             ENDIF
-
-!
-!--          Compute vertical diffusion. In case that surface fluxes have been
-!--          prescribed or computed at bottom and/or top, index k starts/ends at
-!--          nzb+2 or nzt-1, respectively.
-             DO  k = nzb_diff_s_inner(j,i), nzt_diff
-
-                tend(k,j,i) = tend(k,j,i)                                      &
-                                       + 0.5_wp * (                            &
-            ( kh(k,j,i) + kh(k+1,j,i) ) * ( s(k+1,j,i)-s(k,j,i) ) * ddzu(k+1)  &
-          - ( kh(k,j,i) + kh(k-1,j,i) ) * ( s(k,j,i)-s(k-1,j,i) ) * ddzu(k)    &
-                                                  ) * ddzw(k)
-             ENDDO
-
-!
-!--          Vertical diffusion at the first computational gridpoint along
-!--          z-direction
-             IF ( use_surface_fluxes )  THEN
-
-                k = nzb_s_inner(j,i)+1
-
-                tend(k,j,i) = tend(k,j,i)                                      &
-                                       + ( 0.5_wp * ( kh(k,j,i)+kh(k+1,j,i) )  &
-                                                  * ( s(k+1,j,i)-s(k,j,i) )    &
-                                                  * ddzu(k+1)                  &
-                                           + s_flux_b(j,i)                     &
-                                         ) * ddzw(k)
-
-             ENDIF
-
-!
-!--          Vertical diffusion at the last computational gridpoint along
-!--          z-direction
-             IF ( use_top_fluxes )  THEN
-
-                k = nzt
-
-                tend(k,j,i) = tend(k,j,i)                                      &
-                                       + ( - s_flux_t(j,i)                     &
-                                           - 0.5_wp * ( kh(k-1,j,i)+kh(k,j,i) )&
-                                                    * ( s(k,j,i)-s(k-1,j,i) )  &
-                                                    * ddzu(k)                  &
-                                         ) * ddzw(k)
-
-             ENDIF
-
-          ENDDO
-       ENDDO
-
-    END SUBROUTINE diffusion_s
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Call for all grid points - accelerator version
-!------------------------------------------------------------------------------!
-    SUBROUTINE diffusion_s_acc( s, s_flux_b, s_flux_t, wall_s_flux )
-
-       USE arrays_3d,                                                          &
-           ONLY:  ddzu, ddzw, kh, tend
-           
-       USE control_parameters,                                                 & 
-           ONLY: use_surface_fluxes, use_top_fluxes
-       
-       USE grid_variables,                                                     &
-           ONLY:  ddx2, ddy2, fwxm, fwxp, fwym, fwyp, wall_w_x, wall_w_y
-       
-       USE indices, &
-           ONLY: i_left, i_right, j_north, j_south, nxlg, nxrg, nyng, nysg,    &
-                 nzb, nzb_diff_s_inner, nzb_s_inner, nzb_s_outer, nzt, nzt_diff
-           
-       USE kinds
-
-       IMPLICIT NONE
-
-       INTEGER(iwp) ::  i                 !< 
-       INTEGER(iwp) ::  j                 !< 
-       INTEGER(iwp) ::  k                 !< 
-       REAL(wp)     ::  wall_s_flux(0:4)  !< 
-       REAL(wp), DIMENSION(nysg:nyng,nxlg:nxrg) ::  s_flux_b !< 
-       REAL(wp), DIMENSION(nysg:nyng,nxlg:nxrg) ::  s_flux_t !< 
-#if defined( __nopointer )
-       REAL(wp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ::  s  !<
-#else
-       REAL(wp), DIMENSION(:,:,:), POINTER ::  s  !<
-#endif
-
-       !$acc kernels present( ddzu, ddzw, fwxm, fwxp, fwym, fwyp, kh )        &
-       !$acc         present( nzb_diff_s_inner, nzb_s_inner, nzb_s_outer, s ) &
-       !$acc         present( s_flux_b, s_flux_t, tend, wall_s_flux )         &
-       !$acc         present( wall_w_x, wall_w_y )
-       DO  i = i_left, i_right
-          DO  j = j_south, j_north
-!
-!--          Compute horizontal diffusion
-             DO  k = 1, nzt
-                IF ( k > nzb_s_outer(j,i) )  THEN
-
-                   tend(k,j,i) = tend(k,j,i)                                   &
-                                          + 0.5_wp * (                         &
-                        ( kh(k,j,i) + kh(k,j,i+1) ) * ( s(k,j,i+1)-s(k,j,i) )  &
-                      - ( kh(k,j,i) + kh(k,j,i-1) ) * ( s(k,j,i)-s(k,j,i-1) )  &
-                                                     ) * ddx2                  &
-                                          + 0.5_wp * (                         &
-                        ( kh(k,j,i) + kh(k,j+1,i) ) * ( s(k,j+1,i)-s(k,j,i) )  &
-                      - ( kh(k,j,i) + kh(k,j-1,i) ) * ( s(k,j,i)-s(k,j-1,i) )  &
-                                                     ) * ddy2
-                ENDIF
-             ENDDO
-
-!
-!--          Apply prescribed horizontal wall heatflux where necessary
-             DO  k = 1, nzt
-                IF ( k > nzb_s_inner(j,i)  .AND.  k <= nzb_s_outer(j,i)  .AND. &
-                     ( wall_w_x(j,i) /= 0.0_wp  .OR.  wall_w_y(j,i) /= 0.0_wp ) )    &
-                THEN
-                   tend(k,j,i) = tend(k,j,i)                                   &
-                                                + ( fwxp(j,i) * 0.5_wp *       &
-                        ( kh(k,j,i) + kh(k,j,i+1) ) * ( s(k,j,i+1)-s(k,j,i) )  &
-                        + ( 1.0_wp - fwxp(j,i) ) * wall_s_flux(1)              &
-                                                   -fwxm(j,i) * 0.5_wp *       &
-                        ( kh(k,j,i) + kh(k,j,i-1) ) * ( s(k,j,i)-s(k,j,i-1) )  &
-                        + ( 1.0_wp - fwxm(j,i) ) * wall_s_flux(2)              &
-                                                  ) * ddx2                     &
-                                                + ( fwyp(j,i) * 0.5_wp *       &
-                        ( kh(k,j,i) + kh(k,j+1,i) ) * ( s(k,j+1,i)-s(k,j,i) )  &
-                        + ( 1.0_wp - fwyp(j,i) ) * wall_s_flux(3)              &
-                                                   -fwym(j,i) * 0.5_wp *       &
-                        ( kh(k,j,i) + kh(k,j-1,i) ) * ( s(k,j,i)-s(k,j-1,i) )  &
-                        + ( 1.0_wp - fwym(j,i) ) * wall_s_flux(4)              &
-                                                  ) * ddy2
-                ENDIF
-             ENDDO
-
-!
-!--          Compute vertical diffusion. In case that surface fluxes have been
-!--          prescribed or computed at bottom and/or top, index k starts/ends at
-!--          nzb+2 or nzt-1, respectively.
-             DO  k = 1, nzt_diff
-                IF ( k >= nzb_diff_s_inner(j,i) )  THEN
-                   tend(k,j,i) = tend(k,j,i)                                   &
-                                       + 0.5_wp * (                            &
-            ( kh(k,j,i) + kh(k+1,j,i) ) * ( s(k+1,j,i)-s(k,j,i) ) * ddzu(k+1)  &
-          - ( kh(k,j,i) + kh(k-1,j,i) ) * ( s(k,j,i)-s(k-1,j,i) ) * ddzu(k)    &
-                                                  ) * ddzw(k)
-                ENDIF
-             ENDDO
-
-!
-!--          Vertical diffusion at the first computational gridpoint along
-!--          z-direction
-             DO  k = 1, nzt
-                IF ( use_surface_fluxes  .AND.  k == nzb_s_inner(j,i)+1 )  THEN
-                   tend(k,j,i) = tend(k,j,i)                                   &
-                                          + ( 0.5_wp * ( kh(k,j,i)+kh(k+1,j,i) )&
-                                                     * ( s(k+1,j,i)-s(k,j,i) ) &
-                                                     * ddzu(k+1)               &
-                                              + s_flux_b(j,i)                  &
-                                            ) * ddzw(k)
-                ENDIF
-
-!
-!--             Vertical diffusion at the last computational gridpoint along
-!--             z-direction
-                IF ( use_top_fluxes  .AND.  k == nzt )  THEN
-                   tend(k,j,i) = tend(k,j,i)                                   &
-                                          + ( - s_flux_t(j,i)                  &
-                                              - 0.5_wp * ( kh(k-1,j,i)+kh(k,j,i) )&
-                                                       * ( s(k,j,i)-s(k-1,j,i) )  &
-                                                       * ddzu(k)                  &
-                                            ) * ddzw(k)
-                ENDIF
-             ENDDO
-
-          ENDDO
-       ENDDO
-       !$acc end kernels
-
-    END SUBROUTINE diffusion_s_acc
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Call for grid point i,j
-!------------------------------------------------------------------------------!
-    SUBROUTINE diffusion_s_ij( i, j, s, s_flux_b, s_flux_t, wall_s_flux )
-
-       USE arrays_3d,                                                          &
-           ONLY:  ddzu, ddzw, kh, tend
-           
-       USE control_parameters,                                                 & 
-           ONLY: use_surface_fluxes, use_top_fluxes
-       
-       USE grid_variables,                                                     &
-           ONLY:  ddx2, ddy2, fwxm, fwxp, fwym, fwyp, wall_w_x, wall_w_y
-       
-       USE indices,                                                            &
-           ONLY:  nxlg, nxrg, nyng, nysg, nzb, nzb_diff_s_inner, nzb_s_inner,  &
-                  nzb_s_outer, nzt, nzt_diff
-       
-       USE kinds
-
-       IMPLICIT NONE
-
-       INTEGER(iwp) ::  i                 !< 
-       INTEGER(iwp) ::  j                 !< 
-       INTEGER(iwp) ::  k                 !< 
-       REAL(wp)     ::  wall_s_flux(0:4)  !< 
-       REAL(wp), DIMENSION(nysg:nyng,nxlg:nxrg) ::  s_flux_b  !< 
-       REAL(wp), DIMENSION(nysg:nyng,nxlg:nxrg) ::  s_flux_t  !< 
-#if defined( __nopointer )
-       REAL(wp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ::  s !< 
-#else
-       REAL(wp), DIMENSION(:,:,:), POINTER ::  s  !< 
-#endif
-
-!
-!--    Compute horizontal diffusion
-       DO  k = nzb_s_outer(j,i)+1, nzt
-
-          tend(k,j,i) = tend(k,j,i)                                            &
-                                          + 0.5_wp * (                         &
-                        ( kh(k,j,i) + kh(k,j,i+1) ) * ( s(k,j,i+1)-s(k,j,i) )  &
-                      - ( kh(k,j,i) + kh(k,j,i-1) ) * ( s(k,j,i)-s(k,j,i-1) )  &
-                                                     ) * ddx2                  &
-                                          + 0.5_wp * (                         &
-                        ( kh(k,j,i) + kh(k,j+1,i) ) * ( s(k,j+1,i)-s(k,j,i) )  &
-                      - ( kh(k,j,i) + kh(k,j-1,i) ) * ( s(k,j,i)-s(k,j-1,i) )  &
-                                                     ) * ddy2
-       ENDDO
-
-!
-!--    Apply prescribed horizontal wall heatflux where necessary
-       IF ( ( wall_w_x(j,i) /= 0.0_wp ) .OR. ( wall_w_y(j,i) /= 0.0_wp ) )     &
-       THEN
-          DO  k = nzb_s_inner(j,i)+1, nzb_s_outer(j,i)
-
-             tend(k,j,i) = tend(k,j,i)                                         &
-                                                + ( fwxp(j,i) * 0.5_wp *       &
-                        ( kh(k,j,i) + kh(k,j,i+1) ) * ( s(k,j,i+1)-s(k,j,i) )  &
-                        + ( 1.0_wp - fwxp(j,i) ) * wall_s_flux(1)              &
-                                                   -fwxm(j,i) * 0.5_wp *       &
-                        ( kh(k,j,i) + kh(k,j,i-1) ) * ( s(k,j,i)-s(k,j,i-1) )  &
-                        + ( 1.0_wp - fwxm(j,i) ) * wall_s_flux(2)              &
-                                                  ) * ddx2                     &
-                                                + ( fwyp(j,i) * 0.5_wp *       &
-                        ( kh(k,j,i) + kh(k,j+1,i) ) * ( s(k,j+1,i)-s(k,j,i) )  &
-                        + ( 1.0_wp - fwyp(j,i) ) * wall_s_flux(3)              &
-                                                   -fwym(j,i) * 0.5_wp *       &
-                        ( kh(k,j,i) + kh(k,j-1,i) ) * ( s(k,j,i)-s(k,j-1,i) )  &
-                        + ( 1.0_wp - fwym(j,i) ) * wall_s_flux(4)              &
-                                                  ) * ddy2
-          ENDDO
-       ENDIF
-
-!
-!--    Compute vertical diffusion. In case that surface fluxes have been
-!--    prescribed or computed at bottom and/or top, index k starts/ends at
-!--    nzb+2 or nzt-1, respectively.
-       DO  k = nzb_diff_s_inner(j,i), nzt_diff
-
-          tend(k,j,i) = tend(k,j,i)                                            &
-                                       + 0.5_wp * (                            &
-            ( kh(k,j,i) + kh(k+1,j,i) ) * ( s(k+1,j,i)-s(k,j,i) ) * ddzu(k+1)  &
-          - ( kh(k,j,i) + kh(k-1,j,i) ) * ( s(k,j,i)-s(k-1,j,i) ) * ddzu(k)    &
-                                                  ) * ddzw(k)
-       ENDDO
-
-!
-!--    Vertical diffusion at the first computational gridpoint along z-direction
-       IF ( use_surface_fluxes )  THEN
-
-          k = nzb_s_inner(j,i)+1
-
-          tend(k,j,i) = tend(k,j,i) + ( 0.5_wp * ( kh(k,j,i)+kh(k+1,j,i) )     &
-                                               * ( s(k+1,j,i)-s(k,j,i) )       &
-                                               * ddzu(k+1)                     &
-                                        + s_flux_b(j,i)                        &
-                                      ) * ddzw(k)
-
-       ENDIF
-
-!
-!--    Vertical diffusion at the last computational gridpoint along z-direction
-       IF ( use_top_fluxes )  THEN
-
-          k = nzt
-
-          tend(k,j,i) = tend(k,j,i) + ( - s_flux_t(j,i)                        &
-                                      - 0.5_wp * ( kh(k-1,j,i)+kh(k,j,i) )     &
-                                               * ( s(k,j,i)-s(k-1,j,i) )       &
-                                               * ddzu(k)                       &
-                                      ) * ddzw(k)
-
-       ENDIF
-
-    END SUBROUTINE diffusion_s_ij
-
- END MODULE diffusion_s_mod
Index: /palm/trunk/SOURCE/diffusion_s_mod.f90
===================================================================
--- /palm/trunk/SOURCE/diffusion_s_mod.f90	(revision 1850)
+++ /palm/trunk/SOURCE/diffusion_s_mod.f90	(revision 1850)
@@ -0,0 +1,471 @@
+!> @file diffusion_s_mod.f90
+!--------------------------------------------------------------------------------!
+! This file is part of PALM.
+!
+! PALM is free software: you can redistribute it and/or modify it under the terms
+! of the GNU General Public License as published by the Free Software Foundation,
+! either version 3 of the License, or (at your option) any later version.
+!
+! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
+! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
+! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along with
+! PALM. If not, see <http://www.gnu.org/licenses/>.
+!
+! Copyright 1997-2016 Leibniz Universitaet Hannover
+!--------------------------------------------------------------------------------!
+!
+! Current revisions:
+! ------------------
+! Module renamed
+! 
+! 
+! Former revisions:
+! -----------------
+! $Id$
+!
+! 1691 2015-10-26 16:17:44Z maronga
+! Formatting corrections.
+! 
+! 1682 2015-10-07 23:56:08Z knoop
+! Code annotations made doxygen readable 
+! 
+! 1374 2014-04-25 12:55:07Z raasch
+! missing variables added to ONLY list
+! 
+! 1340 2014-03-25 19:45:13Z kanani
+! REAL constants defined as wp-kind
+!
+! 1320 2014-03-20 08:40:49Z raasch
+! ONLY-attribute added to USE-statements,
+! kind-parameters added to all INTEGER and REAL declaration statements,
+! kinds are defined in new module kinds,
+! revision history before 2012 removed,
+! comment fields (!:) to be used for variable explanations added to
+! all variable declaration statements
+! 
+! 1257 2013-11-08 15:18:40Z raasch
+! openacc loop and loop vector clauses removed
+!
+! 1128 2013-04-12 06:19:32Z raasch
+! loop index bounds in accelerator version replaced by i_left, i_right, j_south,
+! j_north
+!
+! 1092 2013-02-02 11:24:22Z raasch
+! unused variables removed
+!
+! 1036 2012-10-22 13:43:42Z raasch
+! code put under GPL (PALM 3.9)
+!
+! 1015 2012-09-27 09:23:24Z raasch
+! accelerator version (*_acc) added
+!
+! 1010 2012-09-20 07:59:54Z raasch
+! cpp switch __nopointer added for pointer free version
+!
+! 1001 2012-09-13 14:08:46Z raasch
+! some arrays comunicated by module instead of parameter list
+!
+! Revision 1.1  2000/04/13 14:54:02  schroeter
+! Initial revision
+!
+!
+! Description:
+! ------------
+!> Diffusion term of scalar quantities (temperature and water content)
+!------------------------------------------------------------------------------!
+ MODULE diffusion_s_mod
+ 
+
+    PRIVATE
+    PUBLIC diffusion_s, diffusion_s_acc
+
+    INTERFACE diffusion_s
+       MODULE PROCEDURE diffusion_s
+       MODULE PROCEDURE diffusion_s_ij
+    END INTERFACE diffusion_s
+
+    INTERFACE diffusion_s_acc
+       MODULE PROCEDURE diffusion_s_acc
+    END INTERFACE diffusion_s_acc
+
+ CONTAINS
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Call for all grid points
+!------------------------------------------------------------------------------!
+    SUBROUTINE diffusion_s( s, s_flux_b, s_flux_t, wall_s_flux )
+
+       USE arrays_3d,                                                          &
+           ONLY:  ddzu, ddzw, kh, tend
+       
+       USE control_parameters,                                                 & 
+           ONLY: use_surface_fluxes, use_top_fluxes
+       
+       USE grid_variables,                                                     &
+           ONLY:  ddx2, ddy2, fwxm, fwxp, fwym, fwyp, wall_w_x, wall_w_y
+       
+       USE indices,                                                            &
+           ONLY:  nxl, nxlg, nxr, nxrg, nyn, nyng, nys, nysg, nzb,             &
+                  nzb_diff_s_inner, nzb_s_inner, nzb_s_outer, nzt, nzt_diff
+       
+       USE kinds
+
+       IMPLICIT NONE
+
+       INTEGER(iwp) ::  i                 !< 
+       INTEGER(iwp) ::  j                 !< 
+       INTEGER(iwp) ::  k                 !< 
+       REAL(wp)     ::  wall_s_flux(0:4)  !< 
+       REAL(wp), DIMENSION(nysg:nyng,nxlg:nxrg) ::  s_flux_b, s_flux_t !<
+#if defined( __nopointer )
+       REAL(wp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ::  s  !< 
+#else
+       REAL(wp), DIMENSION(:,:,:), POINTER ::  s  !< 
+#endif
+
+       DO  i = nxl, nxr
+          DO  j = nys,nyn
+!
+!--          Compute horizontal diffusion
+             DO  k = nzb_s_outer(j,i)+1, nzt
+
+                tend(k,j,i) = tend(k,j,i)                                      &
+                                          + 0.5_wp * (                         &
+                        ( kh(k,j,i) + kh(k,j,i+1) ) * ( s(k,j,i+1)-s(k,j,i) )  &
+                      - ( kh(k,j,i) + kh(k,j,i-1) ) * ( s(k,j,i)-s(k,j,i-1) )  &
+                                                     ) * ddx2                  &
+                                          + 0.5_wp * (                         &
+                        ( kh(k,j,i) + kh(k,j+1,i) ) * ( s(k,j+1,i)-s(k,j,i) )  &
+                      - ( kh(k,j,i) + kh(k,j-1,i) ) * ( s(k,j,i)-s(k,j-1,i) )  &
+                                                     ) * ddy2
+             ENDDO
+
+!
+!--          Apply prescribed horizontal wall heatflux where necessary
+             IF ( ( wall_w_x(j,i) /= 0.0_wp ) .OR. ( wall_w_y(j,i) /= 0.0_wp ) &
+                )  THEN
+                DO  k = nzb_s_inner(j,i)+1, nzb_s_outer(j,i)
+
+                   tend(k,j,i) = tend(k,j,i)                                   &
+                                                + ( fwxp(j,i) * 0.5_wp *       &
+                        ( kh(k,j,i) + kh(k,j,i+1) ) * ( s(k,j,i+1)-s(k,j,i) )  &
+                        + ( 1.0_wp - fwxp(j,i) ) * wall_s_flux(1)              &
+                                                   -fwxm(j,i) * 0.5_wp *       &
+                        ( kh(k,j,i) + kh(k,j,i-1) ) * ( s(k,j,i)-s(k,j,i-1) )  &
+                        + ( 1.0_wp - fwxm(j,i) ) * wall_s_flux(2)              &
+                                                  ) * ddx2                     &
+                                                + ( fwyp(j,i) * 0.5_wp *       &
+                        ( kh(k,j,i) + kh(k,j+1,i) ) * ( s(k,j+1,i)-s(k,j,i) )  &
+                        + ( 1.0_wp - fwyp(j,i) ) * wall_s_flux(3)              &
+                                                   -fwym(j,i) * 0.5_wp *       &
+                        ( kh(k,j,i) + kh(k,j-1,i) ) * ( s(k,j,i)-s(k,j-1,i) )  &
+                        + ( 1.0_wp - fwym(j,i) ) * wall_s_flux(4)              &
+                                                  ) * ddy2
+                ENDDO
+             ENDIF
+
+!
+!--          Compute vertical diffusion. In case that surface fluxes have been
+!--          prescribed or computed at bottom and/or top, index k starts/ends at
+!--          nzb+2 or nzt-1, respectively.
+             DO  k = nzb_diff_s_inner(j,i), nzt_diff
+
+                tend(k,j,i) = tend(k,j,i)                                      &
+                                       + 0.5_wp * (                            &
+            ( kh(k,j,i) + kh(k+1,j,i) ) * ( s(k+1,j,i)-s(k,j,i) ) * ddzu(k+1)  &
+          - ( kh(k,j,i) + kh(k-1,j,i) ) * ( s(k,j,i)-s(k-1,j,i) ) * ddzu(k)    &
+                                                  ) * ddzw(k)
+             ENDDO
+
+!
+!--          Vertical diffusion at the first computational gridpoint along
+!--          z-direction
+             IF ( use_surface_fluxes )  THEN
+
+                k = nzb_s_inner(j,i)+1
+
+                tend(k,j,i) = tend(k,j,i)                                      &
+                                       + ( 0.5_wp * ( kh(k,j,i)+kh(k+1,j,i) )  &
+                                                  * ( s(k+1,j,i)-s(k,j,i) )    &
+                                                  * ddzu(k+1)                  &
+                                           + s_flux_b(j,i)                     &
+                                         ) * ddzw(k)
+
+             ENDIF
+
+!
+!--          Vertical diffusion at the last computational gridpoint along
+!--          z-direction
+             IF ( use_top_fluxes )  THEN
+
+                k = nzt
+
+                tend(k,j,i) = tend(k,j,i)                                      &
+                                       + ( - s_flux_t(j,i)                     &
+                                           - 0.5_wp * ( kh(k-1,j,i)+kh(k,j,i) )&
+                                                    * ( s(k,j,i)-s(k-1,j,i) )  &
+                                                    * ddzu(k)                  &
+                                         ) * ddzw(k)
+
+             ENDIF
+
+          ENDDO
+       ENDDO
+
+    END SUBROUTINE diffusion_s
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Call for all grid points - accelerator version
+!------------------------------------------------------------------------------!
+    SUBROUTINE diffusion_s_acc( s, s_flux_b, s_flux_t, wall_s_flux )
+
+       USE arrays_3d,                                                          &
+           ONLY:  ddzu, ddzw, kh, tend
+           
+       USE control_parameters,                                                 & 
+           ONLY: use_surface_fluxes, use_top_fluxes
+       
+       USE grid_variables,                                                     &
+           ONLY:  ddx2, ddy2, fwxm, fwxp, fwym, fwyp, wall_w_x, wall_w_y
+       
+       USE indices, &
+           ONLY: i_left, i_right, j_north, j_south, nxlg, nxrg, nyng, nysg,    &
+                 nzb, nzb_diff_s_inner, nzb_s_inner, nzb_s_outer, nzt, nzt_diff
+           
+       USE kinds
+
+       IMPLICIT NONE
+
+       INTEGER(iwp) ::  i                 !< 
+       INTEGER(iwp) ::  j                 !< 
+       INTEGER(iwp) ::  k                 !< 
+       REAL(wp)     ::  wall_s_flux(0:4)  !< 
+       REAL(wp), DIMENSION(nysg:nyng,nxlg:nxrg) ::  s_flux_b !< 
+       REAL(wp), DIMENSION(nysg:nyng,nxlg:nxrg) ::  s_flux_t !< 
+#if defined( __nopointer )
+       REAL(wp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ::  s  !<
+#else
+       REAL(wp), DIMENSION(:,:,:), POINTER ::  s  !<
+#endif
+
+       !$acc kernels present( ddzu, ddzw, fwxm, fwxp, fwym, fwyp, kh )        &
+       !$acc         present( nzb_diff_s_inner, nzb_s_inner, nzb_s_outer, s ) &
+       !$acc         present( s_flux_b, s_flux_t, tend, wall_s_flux )         &
+       !$acc         present( wall_w_x, wall_w_y )
+       DO  i = i_left, i_right
+          DO  j = j_south, j_north
+!
+!--          Compute horizontal diffusion
+             DO  k = 1, nzt
+                IF ( k > nzb_s_outer(j,i) )  THEN
+
+                   tend(k,j,i) = tend(k,j,i)                                   &
+                                          + 0.5_wp * (                         &
+                        ( kh(k,j,i) + kh(k,j,i+1) ) * ( s(k,j,i+1)-s(k,j,i) )  &
+                      - ( kh(k,j,i) + kh(k,j,i-1) ) * ( s(k,j,i)-s(k,j,i-1) )  &
+                                                     ) * ddx2                  &
+                                          + 0.5_wp * (                         &
+                        ( kh(k,j,i) + kh(k,j+1,i) ) * ( s(k,j+1,i)-s(k,j,i) )  &
+                      - ( kh(k,j,i) + kh(k,j-1,i) ) * ( s(k,j,i)-s(k,j-1,i) )  &
+                                                     ) * ddy2
+                ENDIF
+             ENDDO
+
+!
+!--          Apply prescribed horizontal wall heatflux where necessary
+             DO  k = 1, nzt
+                IF ( k > nzb_s_inner(j,i)  .AND.  k <= nzb_s_outer(j,i)  .AND. &
+                     ( wall_w_x(j,i) /= 0.0_wp  .OR.  wall_w_y(j,i) /= 0.0_wp ) )    &
+                THEN
+                   tend(k,j,i) = tend(k,j,i)                                   &
+                                                + ( fwxp(j,i) * 0.5_wp *       &
+                        ( kh(k,j,i) + kh(k,j,i+1) ) * ( s(k,j,i+1)-s(k,j,i) )  &
+                        + ( 1.0_wp - fwxp(j,i) ) * wall_s_flux(1)              &
+                                                   -fwxm(j,i) * 0.5_wp *       &
+                        ( kh(k,j,i) + kh(k,j,i-1) ) * ( s(k,j,i)-s(k,j,i-1) )  &
+                        + ( 1.0_wp - fwxm(j,i) ) * wall_s_flux(2)              &
+                                                  ) * ddx2                     &
+                                                + ( fwyp(j,i) * 0.5_wp *       &
+                        ( kh(k,j,i) + kh(k,j+1,i) ) * ( s(k,j+1,i)-s(k,j,i) )  &
+                        + ( 1.0_wp - fwyp(j,i) ) * wall_s_flux(3)              &
+                                                   -fwym(j,i) * 0.5_wp *       &
+                        ( kh(k,j,i) + kh(k,j-1,i) ) * ( s(k,j,i)-s(k,j-1,i) )  &
+                        + ( 1.0_wp - fwym(j,i) ) * wall_s_flux(4)              &
+                                                  ) * ddy2
+                ENDIF
+             ENDDO
+
+!
+!--          Compute vertical diffusion. In case that surface fluxes have been
+!--          prescribed or computed at bottom and/or top, index k starts/ends at
+!--          nzb+2 or nzt-1, respectively.
+             DO  k = 1, nzt_diff
+                IF ( k >= nzb_diff_s_inner(j,i) )  THEN
+                   tend(k,j,i) = tend(k,j,i)                                   &
+                                       + 0.5_wp * (                            &
+            ( kh(k,j,i) + kh(k+1,j,i) ) * ( s(k+1,j,i)-s(k,j,i) ) * ddzu(k+1)  &
+          - ( kh(k,j,i) + kh(k-1,j,i) ) * ( s(k,j,i)-s(k-1,j,i) ) * ddzu(k)    &
+                                                  ) * ddzw(k)
+                ENDIF
+             ENDDO
+
+!
+!--          Vertical diffusion at the first computational gridpoint along
+!--          z-direction
+             DO  k = 1, nzt
+                IF ( use_surface_fluxes  .AND.  k == nzb_s_inner(j,i)+1 )  THEN
+                   tend(k,j,i) = tend(k,j,i)                                   &
+                                          + ( 0.5_wp * ( kh(k,j,i)+kh(k+1,j,i) )&
+                                                     * ( s(k+1,j,i)-s(k,j,i) ) &
+                                                     * ddzu(k+1)               &
+                                              + s_flux_b(j,i)                  &
+                                            ) * ddzw(k)
+                ENDIF
+
+!
+!--             Vertical diffusion at the last computational gridpoint along
+!--             z-direction
+                IF ( use_top_fluxes  .AND.  k == nzt )  THEN
+                   tend(k,j,i) = tend(k,j,i)                                   &
+                                          + ( - s_flux_t(j,i)                  &
+                                              - 0.5_wp * ( kh(k-1,j,i)+kh(k,j,i) )&
+                                                       * ( s(k,j,i)-s(k-1,j,i) )  &
+                                                       * ddzu(k)                  &
+                                            ) * ddzw(k)
+                ENDIF
+             ENDDO
+
+          ENDDO
+       ENDDO
+       !$acc end kernels
+
+    END SUBROUTINE diffusion_s_acc
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Call for grid point i,j
+!------------------------------------------------------------------------------!
+    SUBROUTINE diffusion_s_ij( i, j, s, s_flux_b, s_flux_t, wall_s_flux )
+
+       USE arrays_3d,                                                          &
+           ONLY:  ddzu, ddzw, kh, tend
+           
+       USE control_parameters,                                                 & 
+           ONLY: use_surface_fluxes, use_top_fluxes
+       
+       USE grid_variables,                                                     &
+           ONLY:  ddx2, ddy2, fwxm, fwxp, fwym, fwyp, wall_w_x, wall_w_y
+       
+       USE indices,                                                            &
+           ONLY:  nxlg, nxrg, nyng, nysg, nzb, nzb_diff_s_inner, nzb_s_inner,  &
+                  nzb_s_outer, nzt, nzt_diff
+       
+       USE kinds
+
+       IMPLICIT NONE
+
+       INTEGER(iwp) ::  i                 !< 
+       INTEGER(iwp) ::  j                 !< 
+       INTEGER(iwp) ::  k                 !< 
+       REAL(wp)     ::  wall_s_flux(0:4)  !< 
+       REAL(wp), DIMENSION(nysg:nyng,nxlg:nxrg) ::  s_flux_b  !< 
+       REAL(wp), DIMENSION(nysg:nyng,nxlg:nxrg) ::  s_flux_t  !< 
+#if defined( __nopointer )
+       REAL(wp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ::  s !< 
+#else
+       REAL(wp), DIMENSION(:,:,:), POINTER ::  s  !< 
+#endif
+
+!
+!--    Compute horizontal diffusion
+       DO  k = nzb_s_outer(j,i)+1, nzt
+
+          tend(k,j,i) = tend(k,j,i)                                            &
+                                          + 0.5_wp * (                         &
+                        ( kh(k,j,i) + kh(k,j,i+1) ) * ( s(k,j,i+1)-s(k,j,i) )  &
+                      - ( kh(k,j,i) + kh(k,j,i-1) ) * ( s(k,j,i)-s(k,j,i-1) )  &
+                                                     ) * ddx2                  &
+                                          + 0.5_wp * (                         &
+                        ( kh(k,j,i) + kh(k,j+1,i) ) * ( s(k,j+1,i)-s(k,j,i) )  &
+                      - ( kh(k,j,i) + kh(k,j-1,i) ) * ( s(k,j,i)-s(k,j-1,i) )  &
+                                                     ) * ddy2
+       ENDDO
+
+!
+!--    Apply prescribed horizontal wall heatflux where necessary
+       IF ( ( wall_w_x(j,i) /= 0.0_wp ) .OR. ( wall_w_y(j,i) /= 0.0_wp ) )     &
+       THEN
+          DO  k = nzb_s_inner(j,i)+1, nzb_s_outer(j,i)
+
+             tend(k,j,i) = tend(k,j,i)                                         &
+                                                + ( fwxp(j,i) * 0.5_wp *       &
+                        ( kh(k,j,i) + kh(k,j,i+1) ) * ( s(k,j,i+1)-s(k,j,i) )  &
+                        + ( 1.0_wp - fwxp(j,i) ) * wall_s_flux(1)              &
+                                                   -fwxm(j,i) * 0.5_wp *       &
+                        ( kh(k,j,i) + kh(k,j,i-1) ) * ( s(k,j,i)-s(k,j,i-1) )  &
+                        + ( 1.0_wp - fwxm(j,i) ) * wall_s_flux(2)              &
+                                                  ) * ddx2                     &
+                                                + ( fwyp(j,i) * 0.5_wp *       &
+                        ( kh(k,j,i) + kh(k,j+1,i) ) * ( s(k,j+1,i)-s(k,j,i) )  &
+                        + ( 1.0_wp - fwyp(j,i) ) * wall_s_flux(3)              &
+                                                   -fwym(j,i) * 0.5_wp *       &
+                        ( kh(k,j,i) + kh(k,j-1,i) ) * ( s(k,j,i)-s(k,j-1,i) )  &
+                        + ( 1.0_wp - fwym(j,i) ) * wall_s_flux(4)              &
+                                                  ) * ddy2
+          ENDDO
+       ENDIF
+
+!
+!--    Compute vertical diffusion. In case that surface fluxes have been
+!--    prescribed or computed at bottom and/or top, index k starts/ends at
+!--    nzb+2 or nzt-1, respectively.
+       DO  k = nzb_diff_s_inner(j,i), nzt_diff
+
+          tend(k,j,i) = tend(k,j,i)                                            &
+                                       + 0.5_wp * (                            &
+            ( kh(k,j,i) + kh(k+1,j,i) ) * ( s(k+1,j,i)-s(k,j,i) ) * ddzu(k+1)  &
+          - ( kh(k,j,i) + kh(k-1,j,i) ) * ( s(k,j,i)-s(k-1,j,i) ) * ddzu(k)    &
+                                                  ) * ddzw(k)
+       ENDDO
+
+!
+!--    Vertical diffusion at the first computational gridpoint along z-direction
+       IF ( use_surface_fluxes )  THEN
+
+          k = nzb_s_inner(j,i)+1
+
+          tend(k,j,i) = tend(k,j,i) + ( 0.5_wp * ( kh(k,j,i)+kh(k+1,j,i) )     &
+                                               * ( s(k+1,j,i)-s(k,j,i) )       &
+                                               * ddzu(k+1)                     &
+                                        + s_flux_b(j,i)                        &
+                                      ) * ddzw(k)
+
+       ENDIF
+
+!
+!--    Vertical diffusion at the last computational gridpoint along z-direction
+       IF ( use_top_fluxes )  THEN
+
+          k = nzt
+
+          tend(k,j,i) = tend(k,j,i) + ( - s_flux_t(j,i)                        &
+                                      - 0.5_wp * ( kh(k-1,j,i)+kh(k,j,i) )     &
+                                               * ( s(k,j,i)-s(k-1,j,i) )       &
+                                               * ddzu(k)                       &
+                                      ) * ddzw(k)
+
+       ENDIF
+
+    END SUBROUTINE diffusion_s_ij
+
+ END MODULE diffusion_s_mod
Index: lm/trunk/SOURCE/diffusion_u.f90
===================================================================
--- /palm/trunk/SOURCE/diffusion_u.f90	(revision 1849)
+++ 	(revision )
@@ -1,600 +1,0 @@
-!> @file diffusion_u.f90
-!--------------------------------------------------------------------------------!
-! This file is part of PALM.
-!
-! PALM is free software: you can redistribute it and/or modify it under the terms
-! of the GNU General Public License as published by the Free Software Foundation,
-! either version 3 of the License, or (at your option) any later version.
-!
-! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
-! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
-! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along with
-! PALM. If not, see <http://www.gnu.org/licenses/>.
-!
-! Copyright 1997-2016 Leibniz Universitaet Hannover
-!--------------------------------------------------------------------------------!
-!
-! Current revisions:
-! -----------------
-! 
-!
-! Former revisions:
-! -----------------
-! $Id$
-!
-! 1740 2016-01-13 08:19:40Z raasch
-! unnecessary calculations of kmzm and kmzp in wall bounded parts removed
-!
-! 1691 2015-10-26 16:17:44Z maronga
-! Formatting corrections.
-! 
-! 1682 2015-10-07 23:56:08Z knoop
-! Code annotations made doxygen readable 
-! 
-! 1340 2014-03-25 19:45:13Z kanani
-! REAL constants defined as wp-kind
-!
-! 1320 2014-03-20 08:40:49Z raasch
-! ONLY-attribute added to USE-statements,
-! kind-parameters added to all INTEGER and REAL declaration statements,
-! kinds are defined in new module kinds,
-! revision history before 2012 removed,
-! comment fields (!:) to be used for variable explanations added to
-! all variable declaration statements
-! 
-! 1257 2013-11-08 15:18:40Z raasch
-! openacc loop and loop vector clauses removed, declare create moved after
-! the FORTRAN declaration statement
-!
-! 1128 2013-04-12 06:19:32Z raasch
-! loop index bounds in accelerator version replaced by i_left, i_right, j_south,
-! j_north
-!
-! 1036 2012-10-22 13:43:42Z raasch
-! code put under GPL (PALM 3.9)
-!
-! 1015 2012-09-27 09:23:24Z raasch
-! accelerator version (*_acc) added
-!
-! 1001 2012-09-13 14:08:46Z raasch
-! arrays comunicated by module instead of parameter list
-!
-! 978 2012-08-09 08:28:32Z fricke
-! outflow damping layer removed
-! kmym_x/_y and kmyp_x/_y change to kmym and kmyp
-!
-! Revision 1.1  1997/09/12 06:23:51  raasch
-! Initial revision
-!
-!
-! Description:
-! ------------
-!> Diffusion term of the u-component
-!> @todo additional damping (needed for non-cyclic bc) causes bad vectorization
-!>       and slows down the speed on NEC about 5-10%
-!------------------------------------------------------------------------------!
- MODULE diffusion_u_mod
- 
-
-    USE wall_fluxes_mod
-
-    PRIVATE
-    PUBLIC diffusion_u, diffusion_u_acc
-
-    INTERFACE diffusion_u
-       MODULE PROCEDURE diffusion_u
-       MODULE PROCEDURE diffusion_u_ij
-    END INTERFACE diffusion_u
-
-    INTERFACE diffusion_u_acc
-       MODULE PROCEDURE diffusion_u_acc
-    END INTERFACE diffusion_u_acc
-
- CONTAINS
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Call for all grid points
-!------------------------------------------------------------------------------!
-    SUBROUTINE diffusion_u
-
-       USE arrays_3d,                                                          &
-           ONLY:  ddzu, ddzw, km, tend, u, usws, uswst, v, w
-       
-       USE control_parameters,                                                 &
-           ONLY:  constant_top_momentumflux, topography, use_surface_fluxes,   &
-                  use_top_fluxes
-       
-       USE grid_variables,                                                     &
-           ONLY:  ddx, ddx2, ddy, fym, fyp, wall_u
-       
-       USE indices,                                                            &
-           ONLY:  nxl, nxlu, nxr, nyn, nys, nzb, nzb_diff_u, nzb_u_inner,      &
-                  nzb_u_outer, nzt, nzt_diff
-       
-       USE kinds
-
-       IMPLICIT NONE
-
-       INTEGER(iwp) ::  i     !< 
-       INTEGER(iwp) ::  j     !< 
-       INTEGER(iwp) ::  k     !< 
-       REAL(wp)     ::  kmym  !<
-       REAL(wp)     ::  kmyp  !<
-       REAL(wp)     ::  kmzm  !<
-       REAL(wp)     ::  kmzp  !<
-
-       REAL(wp), DIMENSION(nzb:nzt+1,nys:nyn,nxl:nxr) ::  usvs  !< 
-
-!
-!--    First calculate horizontal momentum flux u'v' at vertical walls,
-!--    if neccessary
-       IF ( topography /= 'flat' )  THEN
-          CALL wall_fluxes( usvs, 1.0_wp, 0.0_wp, 0.0_wp, 0.0_wp, nzb_u_inner, &
-                            nzb_u_outer, wall_u )
-       ENDIF
-
-       DO  i = nxlu, nxr
-          DO  j = nys, nyn
-!
-!--          Compute horizontal diffusion
-             DO  k = nzb_u_outer(j,i)+1, nzt
-!
-!--             Interpolate eddy diffusivities on staggered gridpoints
-                kmyp = 0.25_wp *                                               &
-                       ( km(k,j,i)+km(k,j+1,i)+km(k,j,i-1)+km(k,j+1,i-1) )
-                kmym = 0.25_wp *                                               &
-                       ( km(k,j,i)+km(k,j-1,i)+km(k,j,i-1)+km(k,j-1,i-1) )
-
-                tend(k,j,i) = tend(k,j,i)                                      &
-                      & + 2.0_wp * (                                           &
-                      &           km(k,j,i)   * ( u(k,j,i+1) - u(k,j,i)   )    &
-                      &         - km(k,j,i-1) * ( u(k,j,i)   - u(k,j,i-1) )    &
-                      &            ) * ddx2                                    &
-                      & + ( kmyp * ( u(k,j+1,i) - u(k,j,i)     ) * ddy         &
-                      &   + kmyp * ( v(k,j+1,i) - v(k,j+1,i-1) ) * ddx         &
-                      &   - kmym * ( u(k,j,i) - u(k,j-1,i) ) * ddy             &
-                      &   - kmym * ( v(k,j,i) - v(k,j,i-1) ) * ddx             &
-                      &   ) * ddy
-             ENDDO
-
-!
-!--          Wall functions at the north and south walls, respectively
-             IF ( wall_u(j,i) /= 0.0_wp )  THEN
-
-                DO  k = nzb_u_inner(j,i)+1, nzb_u_outer(j,i)
-                   kmyp = 0.25_wp *                                            &
-                          ( km(k,j,i)+km(k,j+1,i)+km(k,j,i-1)+km(k,j+1,i-1) )
-                   kmym = 0.25_wp *                                            &
-                          ( km(k,j,i)+km(k,j-1,i)+km(k,j,i-1)+km(k,j-1,i-1) )
-
-                   tend(k,j,i) = tend(k,j,i)                                   &
-                                 + 2.0_wp * (                                  &
-                                       km(k,j,i)   * ( u(k,j,i+1) - u(k,j,i) ) &
-                                     - km(k,j,i-1) * ( u(k,j,i) - u(k,j,i-1) ) &
-                                            ) * ddx2                           &
-                                 + (   fyp(j,i) * (                            &
-                                  kmyp * ( u(k,j+1,i) - u(k,j,i)     ) * ddy   &
-                                + kmyp * ( v(k,j+1,i) - v(k,j+1,i-1) ) * ddx   &
-                                                  )                            &
-                                     - fym(j,i) * (                            &
-                                  kmym * ( u(k,j,i) - u(k,j-1,i) ) * ddy       &
-                                + kmym * ( v(k,j,i) - v(k,j,i-1) ) * ddx       &
-                                                  )                            &
-                                     + wall_u(j,i) * usvs(k,j,i)               &
-                                   ) * ddy
-                ENDDO
-             ENDIF
-
-!
-!--          Compute vertical diffusion. In case of simulating a Prandtl layer,
-!--          index k starts at nzb_u_inner+2.
-             DO  k = nzb_diff_u(j,i), nzt_diff
-!
-!--             Interpolate eddy diffusivities on staggered gridpoints
-                kmzp = 0.25_wp *                                               &
-                       ( km(k,j,i)+km(k+1,j,i)+km(k,j,i-1)+km(k+1,j,i-1) )
-                kmzm = 0.25_wp *                                               &
-                       ( km(k,j,i)+km(k-1,j,i)+km(k,j,i-1)+km(k-1,j,i-1) )
-
-                tend(k,j,i) = tend(k,j,i)                                      &
-                      & + ( kmzp * ( ( u(k+1,j,i) - u(k,j,i)   ) * ddzu(k+1)   &
-                      &            + ( w(k,j,i)   - w(k,j,i-1) ) * ddx         &
-                      &            )                                           &
-                      &   - kmzm * ( ( u(k,j,i)   - u(k-1,j,i)   ) * ddzu(k)   &
-                      &            + ( w(k-1,j,i) - w(k-1,j,i-1) ) * ddx       &
-                      &            )                                           &
-                      &   ) * ddzw(k)
-             ENDDO
-
-!
-!--          Vertical diffusion at the first grid point above the surface,
-!--          if the momentum flux at the bottom is given by the Prandtl law or
-!--          if it is prescribed by the user.
-!--          Difference quotient of the momentum flux is not formed over half
-!--          of the grid spacing (2.0*ddzw(k)) any more, since the comparison
-!--          with other (LES) models showed that the values of the momentum
-!--          flux becomes too large in this case.
-!--          The term containing w(k-1,..) (see above equation) is removed here
-!--          because the vertical velocity is assumed to be zero at the surface.
-             IF ( use_surface_fluxes )  THEN
-                k = nzb_u_inner(j,i)+1
-!
-!--             Interpolate eddy diffusivities on staggered gridpoints
-                kmzp = 0.25_wp *                                               &
-                      ( km(k,j,i)+km(k+1,j,i)+km(k,j,i-1)+km(k+1,j,i-1) )
-
-                tend(k,j,i) = tend(k,j,i)                                      &
-                      & + ( kmzp * ( w(k,j,i)   - w(k,j,i-1)   ) * ddx         &
-                      &   ) * ddzw(k)                                          &
-                      & + ( kmzp * ( u(k+1,j,i) - u(k,j,i)     ) * ddzu(k+1)   &
-                      &   + usws(j,i)                                          &
-                      &   ) * ddzw(k)
-             ENDIF
-
-!
-!--          Vertical diffusion at the first gridpoint below the top boundary,
-!--          if the momentum flux at the top is prescribed by the user
-             IF ( use_top_fluxes  .AND.  constant_top_momentumflux )  THEN
-                k = nzt
-!
-!--             Interpolate eddy diffusivities on staggered gridpoints
-                kmzm = 0.25_wp *                                               &
-                       ( km(k,j,i)+km(k-1,j,i)+km(k,j,i-1)+km(k-1,j,i-1) )
-
-                tend(k,j,i) = tend(k,j,i)                                      &
-                      & - ( kmzm * ( w(k-1,j,i) - w(k-1,j,i-1) ) * ddx         &
-                      &   ) * ddzw(k)                                          &
-                      & + ( -uswst(j,i)                                        &
-                      &   - kmzm * ( u(k,j,i)   - u(k-1,j,i)   ) * ddzu(k)     &
-                      &   ) * ddzw(k)
-             ENDIF
-
-          ENDDO
-       ENDDO
-
-    END SUBROUTINE diffusion_u
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Call for all grid points - accelerator version
-!------------------------------------------------------------------------------!
-    SUBROUTINE diffusion_u_acc
-
-       USE arrays_3d,                                                          &
-           ONLY:  ddzu, ddzw, km, tend, u, usws, uswst, v, w
-       
-       USE control_parameters,                                                 &
-           ONLY:  constant_top_momentumflux, topography, use_surface_fluxes,   &
-                  use_top_fluxes
-       
-       USE grid_variables,                                                     &
-           ONLY:  ddx, ddx2, ddy, fym, fyp, wall_u
-       
-       USE indices,                                                            &
-           ONLY:  i_left, i_right, j_north, j_south, nxl, nxr, nyn, nys, nzb,  &
-                  nzb_diff_u, nzb_u_inner, nzb_u_outer, nzt, nzt_diff
-       
-       USE kinds
-
-       IMPLICIT NONE
-
-       INTEGER(iwp) ::  i     !< 
-       INTEGER(iwp) ::  j     !< 
-       INTEGER(iwp) ::  k     !< 
-       REAL(wp)     ::  kmym  !<
-       REAL(wp)     ::  kmyp  !<
-       REAL(wp)     ::  kmzm  !<
-       REAL(wp)     ::  kmzp  !<
-
-       REAL(wp), DIMENSION(nzb:nzt+1,nys:nyn,nxl:nxr) ::  usvs  !< 
-       !$acc declare create ( usvs )
-
-!
-!--    First calculate horizontal momentum flux u'v' at vertical walls,
-!--    if neccessary
-       IF ( topography /= 'flat' )  THEN
-          CALL wall_fluxes_acc( usvs, 1.0_wp, 0.0_wp, 0.0_wp, 0.0_wp,          &
-                                nzb_u_inner, nzb_u_outer, wall_u )
-       ENDIF
-
-       !$acc kernels present ( u, v, w, km, tend, usws, uswst )                &
-       !$acc         present ( ddzu, ddzw, fym, fyp, wall_u )                  &
-       !$acc         present ( nzb_u_inner, nzb_u_outer, nzb_diff_u )
-       DO  i = i_left, i_right
-          DO  j = j_south, j_north
-!
-!--          Compute horizontal diffusion
-             DO  k = 1, nzt
-                IF ( k > nzb_u_outer(j,i) )  THEN
-!
-!--                Interpolate eddy diffusivities on staggered gridpoints
-                   kmyp = 0.25_wp *                                            &
-                          ( km(k,j,i)+km(k,j+1,i)+km(k,j,i-1)+km(k,j+1,i-1) )
-                   kmym = 0.25_wp *                                            &
-                          ( km(k,j,i)+km(k,j-1,i)+km(k,j,i-1)+km(k,j-1,i-1) )
-
-                   tend(k,j,i) = tend(k,j,i)                                   &
-                         & + 2.0_wp * (                                        &
-                         &           km(k,j,i)   * ( u(k,j,i+1) - u(k,j,i)   ) &
-                         &         - km(k,j,i-1) * ( u(k,j,i)   - u(k,j,i-1) ) &
-                         &            ) * ddx2                                 &
-                         & + ( kmyp * ( u(k,j+1,i) - u(k,j,i)     ) * ddy      &
-                         &   + kmyp * ( v(k,j+1,i) - v(k,j+1,i-1) ) * ddx      &
-                         &   - kmym * ( u(k,j,i) - u(k,j-1,i) ) * ddy          &
-                         &   - kmym * ( v(k,j,i) - v(k,j,i-1) ) * ddx          &
-                         &   ) * ddy
-                ENDIF
-             ENDDO
-
-!
-!--          Wall functions at the north and south walls, respectively
-             DO  k = 1, nzt
-                IF( k > nzb_u_inner(j,i)  .AND.  k <= nzb_u_outer(j,i)  .AND.  &
-                    wall_u(j,i) /= 0.0_wp )  THEN
-
-                   kmyp = 0.25_wp *                                            &
-                          ( km(k,j,i)+km(k,j+1,i)+km(k,j,i-1)+km(k,j+1,i-1) )
-                   kmym = 0.25_wp *                                            &
-                          ( km(k,j,i)+km(k,j-1,i)+km(k,j,i-1)+km(k,j-1,i-1) )
-
-                   tend(k,j,i) = tend(k,j,i)                                   &
-                                 + 2.0_wp * (                                  &
-                                       km(k,j,i)   * ( u(k,j,i+1) - u(k,j,i) ) &
-                                     - km(k,j,i-1) * ( u(k,j,i) - u(k,j,i-1) ) &
-                                            ) * ddx2                           &
-                                 + (   fyp(j,i) * (                            &
-                                  kmyp * ( u(k,j+1,i) - u(k,j,i)     ) * ddy   &
-                                + kmyp * ( v(k,j+1,i) - v(k,j+1,i-1) ) * ddx   &
-                                                  )                            &
-                                     - fym(j,i) * (                            &
-                                  kmym * ( u(k,j,i) - u(k,j-1,i) ) * ddy       &
-                                + kmym * ( v(k,j,i) - v(k,j,i-1) ) * ddx       &
-                                                  )                            &
-                                     + wall_u(j,i) * usvs(k,j,i)               &
-                                   ) * ddy
-                ENDIF
-             ENDDO
-
-!
-!--          Compute vertical diffusion. In case of simulating a Prandtl layer,
-!--          index k starts at nzb_u_inner+2.
-             DO  k = 1, nzt_diff
-                IF ( k >= nzb_diff_u(j,i) )  THEN
-!
-!--                Interpolate eddy diffusivities on staggered gridpoints
-                   kmzp = 0.25_wp *                                            &
-                          ( km(k,j,i)+km(k+1,j,i)+km(k,j,i-1)+km(k+1,j,i-1) )
-                   kmzm = 0.25_wp *                                            &
-                          ( km(k,j,i)+km(k-1,j,i)+km(k,j,i-1)+km(k-1,j,i-1) )
-
-                   tend(k,j,i) = tend(k,j,i)                                   &
-                         & + ( kmzp * ( ( u(k+1,j,i) - u(k,j,i)   ) * ddzu(k+1)&
-                         &            + ( w(k,j,i)   - w(k,j,i-1) ) * ddx      &
-                         &            )                                        &
-                         &   - kmzm * ( ( u(k,j,i)   - u(k-1,j,i)   ) * ddzu(k)&
-                         &            + ( w(k-1,j,i) - w(k-1,j,i-1) ) * ddx    &
-                         &            )                                        &
-                         &   ) * ddzw(k)
-                ENDIF
-             ENDDO
-
-          ENDDO
-       ENDDO
-
-!
-!--    Vertical diffusion at the first grid point above the surface,
-!--    if the momentum flux at the bottom is given by the Prandtl law or
-!--    if it is prescribed by the user.
-!--    Difference quotient of the momentum flux is not formed over half
-!--    of the grid spacing (2.0*ddzw(k)) any more, since the comparison
-!--    with other (LES) models showed that the values of the momentum
-!--    flux becomes too large in this case.
-!--    The term containing w(k-1,..) (see above equation) is removed here
-!--    because the vertical velocity is assumed to be zero at the surface.
-       IF ( use_surface_fluxes )  THEN
-
-          DO  i = i_left, i_right
-             DO  j = j_south, j_north
-          
-                k = nzb_u_inner(j,i)+1
-!
-!--             Interpolate eddy diffusivities on staggered gridpoints
-                kmzp = 0.25_wp *                                               &
-                      ( km(k,j,i)+km(k+1,j,i)+km(k,j,i-1)+km(k+1,j,i-1) )
-
-                tend(k,j,i) = tend(k,j,i)                                      &
-                      & + ( kmzp * ( w(k,j,i)   - w(k,j,i-1)   ) * ddx         &
-                      &   ) * ddzw(k)                                          &
-                      & + ( kmzp * ( u(k+1,j,i) - u(k,j,i)     ) * ddzu(k+1)   &
-                      &   + usws(j,i)                                          &
-                      &   ) * ddzw(k)
-             ENDDO
-          ENDDO
-
-       ENDIF
-
-!
-!--    Vertical diffusion at the first gridpoint below the top boundary,
-!--    if the momentum flux at the top is prescribed by the user
-       IF ( use_top_fluxes  .AND.  constant_top_momentumflux )  THEN
-
-          k = nzt
-
-          DO  i = i_left, i_right
-             DO  j = j_south, j_north
-
-!
-!--             Interpolate eddy diffusivities on staggered gridpoints
-                kmzm = 0.25_wp *                                               &
-                       ( km(k,j,i)+km(k-1,j,i)+km(k,j,i-1)+km(k-1,j,i-1) )
-
-                tend(k,j,i) = tend(k,j,i)                                      &
-                      & - ( kmzm * ( w(k-1,j,i) - w(k-1,j,i-1) ) * ddx         &
-                      &   ) * ddzw(k)                                          &
-                      & + ( -uswst(j,i)                                        &
-                      &   - kmzm * ( u(k,j,i)   - u(k-1,j,i)   ) * ddzu(k)     &
-                      &   ) * ddzw(k)
-             ENDDO
-          ENDDO
-
-       ENDIF
-       !$acc end kernels
-
-    END SUBROUTINE diffusion_u_acc
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Call for grid point i,j
-!------------------------------------------------------------------------------!
-    SUBROUTINE diffusion_u_ij( i, j )
-
-       USE arrays_3d,                                                          &
-           ONLY:  ddzu, ddzw, km, tend, u, usws, uswst, v, w
-       
-       USE control_parameters,                                                 &
-           ONLY:  constant_top_momentumflux, use_surface_fluxes, use_top_fluxes
-       
-       USE grid_variables,                                                     &
-           ONLY:  ddx, ddx2, ddy, fym, fyp, wall_u
-       
-       USE indices,                                                            &
-           ONLY:  nzb, nzb_diff_u, nzb_u_inner, nzb_u_outer, nzt, nzt_diff
-       
-       USE kinds
-
-       IMPLICIT NONE
-
-       INTEGER(iwp) ::  i     !< 
-       INTEGER(iwp) ::  j     !< 
-       INTEGER(iwp) ::  k     !< 
-       REAL(wp)     ::  kmym  !<
-       REAL(wp)     ::  kmyp  !<
-       REAL(wp)     ::  kmzm  !<
-       REAL(wp)     ::  kmzp  !<
-
-       REAL(wp), DIMENSION(nzb:nzt+1) ::  usvs  !< 
-
-!
-!--    Compute horizontal diffusion
-       DO  k = nzb_u_outer(j,i)+1, nzt
-!
-!--       Interpolate eddy diffusivities on staggered gridpoints
-          kmyp = 0.25_wp * ( km(k,j,i)+km(k,j+1,i)+km(k,j,i-1)+km(k,j+1,i-1) )
-          kmym = 0.25_wp * ( km(k,j,i)+km(k,j-1,i)+km(k,j,i-1)+km(k,j-1,i-1) )
-
-          tend(k,j,i) = tend(k,j,i)                                            &
-                      & + 2.0_wp * (                                           &
-                      &           km(k,j,i)   * ( u(k,j,i+1) - u(k,j,i)   )    &
-                      &         - km(k,j,i-1) * ( u(k,j,i)   - u(k,j,i-1) )    &
-                      &            ) * ddx2                                    &
-                      & + ( kmyp * ( u(k,j+1,i) - u(k,j,i)     ) * ddy         &
-                      &   + kmyp * ( v(k,j+1,i) - v(k,j+1,i-1) ) * ddx         &
-                      &   - kmym * ( u(k,j,i) - u(k,j-1,i) ) * ddy             &
-                      &   - kmym * ( v(k,j,i) - v(k,j,i-1) ) * ddx             &
-                      &   ) * ddy
-       ENDDO
-
-!
-!--    Wall functions at the north and south walls, respectively
-       IF ( wall_u(j,i) /= 0.0_wp )  THEN
-
-!
-!--       Calculate the horizontal momentum flux u'v'
-          CALL wall_fluxes( i, j, nzb_u_inner(j,i)+1, nzb_u_outer(j,i),        &
-                            usvs, 1.0_wp, 0.0_wp, 0.0_wp, 0.0_wp )
-
-          DO  k = nzb_u_inner(j,i)+1, nzb_u_outer(j,i)
-             kmyp = 0.25_wp * ( km(k,j,i)+km(k,j+1,i)+km(k,j,i-1)+km(k,j+1,i-1) )
-             kmym = 0.25_wp * ( km(k,j,i)+km(k,j-1,i)+km(k,j,i-1)+km(k,j-1,i-1) )
-
-             tend(k,j,i) = tend(k,j,i)                                         &
-                                 + 2.0_wp * (                                  &
-                                       km(k,j,i)   * ( u(k,j,i+1) - u(k,j,i) ) &
-                                     - km(k,j,i-1) * ( u(k,j,i) - u(k,j,i-1) ) &
-                                            ) * ddx2                           &
-                                 + (   fyp(j,i) * (                            &
-                                  kmyp * ( u(k,j+1,i) - u(k,j,i)     ) * ddy   &
-                                + kmyp * ( v(k,j+1,i) - v(k,j+1,i-1) ) * ddx   &
-                                                  )                            &
-                                     - fym(j,i) * (                            &
-                                  kmym * ( u(k,j,i) - u(k,j-1,i) ) * ddy       &
-                                + kmym * ( v(k,j,i) - v(k,j,i-1) ) * ddx       &
-                                                  )                            &
-                                     + wall_u(j,i) * usvs(k)                   &
-                                   ) * ddy
-          ENDDO
-       ENDIF
-
-!
-!--    Compute vertical diffusion. In case of simulating a Prandtl layer,
-!--    index k starts at nzb_u_inner+2.
-       DO  k = nzb_diff_u(j,i), nzt_diff
-!
-!--       Interpolate eddy diffusivities on staggered gridpoints
-          kmzp = 0.25_wp * ( km(k,j,i)+km(k+1,j,i)+km(k,j,i-1)+km(k+1,j,i-1) )
-          kmzm = 0.25_wp * ( km(k,j,i)+km(k-1,j,i)+km(k,j,i-1)+km(k-1,j,i-1) )
-
-          tend(k,j,i) = tend(k,j,i)                                            &
-                      & + ( kmzp * ( ( u(k+1,j,i) - u(k,j,i)   ) * ddzu(k+1)   &
-                      &            + ( w(k,j,i)   - w(k,j,i-1) ) * ddx         &
-                      &            )                                           &
-                      &   - kmzm * ( ( u(k,j,i)   - u(k-1,j,i)   ) * ddzu(k)   &
-                      &            + ( w(k-1,j,i) - w(k-1,j,i-1) ) * ddx       &
-                      &            )                                           &
-                      &   ) * ddzw(k)
-       ENDDO
-
-!
-!--    Vertical diffusion at the first grid point above the surface, if the
-!--    momentum flux at the bottom is given by the Prandtl law or if it is
-!--    prescribed by the user.
-!--    Difference quotient of the momentum flux is not formed over half of
-!--    the grid spacing (2.0*ddzw(k)) any more, since the comparison with 
-!--    other (LES) models showed that the values of the momentum flux becomes
-!--    too large in this case.
-!--    The term containing w(k-1,..) (see above equation) is removed here
-!--    because the vertical velocity is assumed to be zero at the surface.
-       IF ( use_surface_fluxes )  THEN
-          k = nzb_u_inner(j,i)+1
-!
-!--       Interpolate eddy diffusivities on staggered gridpoints
-          kmzp = 0.25_wp * ( km(k,j,i)+km(k+1,j,i)+km(k,j,i-1)+km(k+1,j,i-1) )
-
-          tend(k,j,i) = tend(k,j,i)                                            &
-                      & + ( kmzp * ( w(k,j,i)   - w(k,j,i-1)   ) * ddx         &
-                      &   ) * ddzw(k)                                          &
-                      & + ( kmzp * ( u(k+1,j,i) - u(k,j,i)     ) * ddzu(k+1)   &
-                      &   + usws(j,i)                                          &
-                      &   ) * ddzw(k)
-       ENDIF
-
-!
-!--    Vertical diffusion at the first gridpoint below the top boundary,
-!--    if the momentum flux at the top is prescribed by the user
-       IF ( use_top_fluxes  .AND.  constant_top_momentumflux )  THEN
-          k = nzt
-!
-!--       Interpolate eddy diffusivities on staggered gridpoints
-          kmzm = 0.25_wp *                                                     &
-                 ( km(k,j,i)+km(k-1,j,i)+km(k,j,i-1)+km(k-1,j,i-1) )
-
-          tend(k,j,i) = tend(k,j,i)                                            &
-                      & - ( kmzm * ( w(k-1,j,i) - w(k-1,j,i-1) ) * ddx         &
-                      &   ) * ddzw(k)                                          &
-                      & + ( -uswst(j,i)                                        &
-                      &   - kmzm * ( u(k,j,i)   - u(k-1,j,i)   ) * ddzu(k)     &
-                      &   ) * ddzw(k)
-       ENDIF
-
-    END SUBROUTINE diffusion_u_ij
-
- END MODULE diffusion_u_mod
Index: /palm/trunk/SOURCE/diffusion_u_mod.f90
===================================================================
--- /palm/trunk/SOURCE/diffusion_u_mod.f90	(revision 1850)
+++ /palm/trunk/SOURCE/diffusion_u_mod.f90	(revision 1850)
@@ -0,0 +1,601 @@
+!> @file diffusion_u_mod.f90
+!--------------------------------------------------------------------------------!
+! This file is part of PALM.
+!
+! PALM is free software: you can redistribute it and/or modify it under the terms
+! of the GNU General Public License as published by the Free Software Foundation,
+! either version 3 of the License, or (at your option) any later version.
+!
+! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
+! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
+! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along with
+! PALM. If not, see <http://www.gnu.org/licenses/>.
+!
+! Copyright 1997-2016 Leibniz Universitaet Hannover
+!--------------------------------------------------------------------------------!
+!
+! Current revisions:
+! -----------------
+! Module renamed
+! 
+!
+! Former revisions:
+! -----------------
+! $Id$
+!
+! 1740 2016-01-13 08:19:40Z raasch
+! unnecessary calculations of kmzm and kmzp in wall bounded parts removed
+!
+! 1691 2015-10-26 16:17:44Z maronga
+! Formatting corrections.
+! 
+! 1682 2015-10-07 23:56:08Z knoop
+! Code annotations made doxygen readable 
+! 
+! 1340 2014-03-25 19:45:13Z kanani
+! REAL constants defined as wp-kind
+!
+! 1320 2014-03-20 08:40:49Z raasch
+! ONLY-attribute added to USE-statements,
+! kind-parameters added to all INTEGER and REAL declaration statements,
+! kinds are defined in new module kinds,
+! revision history before 2012 removed,
+! comment fields (!:) to be used for variable explanations added to
+! all variable declaration statements
+! 
+! 1257 2013-11-08 15:18:40Z raasch
+! openacc loop and loop vector clauses removed, declare create moved after
+! the FORTRAN declaration statement
+!
+! 1128 2013-04-12 06:19:32Z raasch
+! loop index bounds in accelerator version replaced by i_left, i_right, j_south,
+! j_north
+!
+! 1036 2012-10-22 13:43:42Z raasch
+! code put under GPL (PALM 3.9)
+!
+! 1015 2012-09-27 09:23:24Z raasch
+! accelerator version (*_acc) added
+!
+! 1001 2012-09-13 14:08:46Z raasch
+! arrays comunicated by module instead of parameter list
+!
+! 978 2012-08-09 08:28:32Z fricke
+! outflow damping layer removed
+! kmym_x/_y and kmyp_x/_y change to kmym and kmyp
+!
+! Revision 1.1  1997/09/12 06:23:51  raasch
+! Initial revision
+!
+!
+! Description:
+! ------------
+!> Diffusion term of the u-component
+!> @todo additional damping (needed for non-cyclic bc) causes bad vectorization
+!>       and slows down the speed on NEC about 5-10%
+!------------------------------------------------------------------------------!
+ MODULE diffusion_u_mod
+ 
+
+    USE wall_fluxes_mod
+
+    PRIVATE
+    PUBLIC diffusion_u, diffusion_u_acc
+
+    INTERFACE diffusion_u
+       MODULE PROCEDURE diffusion_u
+       MODULE PROCEDURE diffusion_u_ij
+    END INTERFACE diffusion_u
+
+    INTERFACE diffusion_u_acc
+       MODULE PROCEDURE diffusion_u_acc
+    END INTERFACE diffusion_u_acc
+
+ CONTAINS
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Call for all grid points
+!------------------------------------------------------------------------------!
+    SUBROUTINE diffusion_u
+
+       USE arrays_3d,                                                          &
+           ONLY:  ddzu, ddzw, km, tend, u, usws, uswst, v, w
+       
+       USE control_parameters,                                                 &
+           ONLY:  constant_top_momentumflux, topography, use_surface_fluxes,   &
+                  use_top_fluxes
+       
+       USE grid_variables,                                                     &
+           ONLY:  ddx, ddx2, ddy, fym, fyp, wall_u
+       
+       USE indices,                                                            &
+           ONLY:  nxl, nxlu, nxr, nyn, nys, nzb, nzb_diff_u, nzb_u_inner,      &
+                  nzb_u_outer, nzt, nzt_diff
+       
+       USE kinds
+
+       IMPLICIT NONE
+
+       INTEGER(iwp) ::  i     !< 
+       INTEGER(iwp) ::  j     !< 
+       INTEGER(iwp) ::  k     !< 
+       REAL(wp)     ::  kmym  !<
+       REAL(wp)     ::  kmyp  !<
+       REAL(wp)     ::  kmzm  !<
+       REAL(wp)     ::  kmzp  !<
+
+       REAL(wp), DIMENSION(nzb:nzt+1,nys:nyn,nxl:nxr) ::  usvs  !< 
+
+!
+!--    First calculate horizontal momentum flux u'v' at vertical walls,
+!--    if neccessary
+       IF ( topography /= 'flat' )  THEN
+          CALL wall_fluxes( usvs, 1.0_wp, 0.0_wp, 0.0_wp, 0.0_wp, nzb_u_inner, &
+                            nzb_u_outer, wall_u )
+       ENDIF
+
+       DO  i = nxlu, nxr
+          DO  j = nys, nyn
+!
+!--          Compute horizontal diffusion
+             DO  k = nzb_u_outer(j,i)+1, nzt
+!
+!--             Interpolate eddy diffusivities on staggered gridpoints
+                kmyp = 0.25_wp *                                               &
+                       ( km(k,j,i)+km(k,j+1,i)+km(k,j,i-1)+km(k,j+1,i-1) )
+                kmym = 0.25_wp *                                               &
+                       ( km(k,j,i)+km(k,j-1,i)+km(k,j,i-1)+km(k,j-1,i-1) )
+
+                tend(k,j,i) = tend(k,j,i)                                      &
+                      & + 2.0_wp * (                                           &
+                      &           km(k,j,i)   * ( u(k,j,i+1) - u(k,j,i)   )    &
+                      &         - km(k,j,i-1) * ( u(k,j,i)   - u(k,j,i-1) )    &
+                      &            ) * ddx2                                    &
+                      & + ( kmyp * ( u(k,j+1,i) - u(k,j,i)     ) * ddy         &
+                      &   + kmyp * ( v(k,j+1,i) - v(k,j+1,i-1) ) * ddx         &
+                      &   - kmym * ( u(k,j,i) - u(k,j-1,i) ) * ddy             &
+                      &   - kmym * ( v(k,j,i) - v(k,j,i-1) ) * ddx             &
+                      &   ) * ddy
+             ENDDO
+
+!
+!--          Wall functions at the north and south walls, respectively
+             IF ( wall_u(j,i) /= 0.0_wp )  THEN
+
+                DO  k = nzb_u_inner(j,i)+1, nzb_u_outer(j,i)
+                   kmyp = 0.25_wp *                                            &
+                          ( km(k,j,i)+km(k,j+1,i)+km(k,j,i-1)+km(k,j+1,i-1) )
+                   kmym = 0.25_wp *                                            &
+                          ( km(k,j,i)+km(k,j-1,i)+km(k,j,i-1)+km(k,j-1,i-1) )
+
+                   tend(k,j,i) = tend(k,j,i)                                   &
+                                 + 2.0_wp * (                                  &
+                                       km(k,j,i)   * ( u(k,j,i+1) - u(k,j,i) ) &
+                                     - km(k,j,i-1) * ( u(k,j,i) - u(k,j,i-1) ) &
+                                            ) * ddx2                           &
+                                 + (   fyp(j,i) * (                            &
+                                  kmyp * ( u(k,j+1,i) - u(k,j,i)     ) * ddy   &
+                                + kmyp * ( v(k,j+1,i) - v(k,j+1,i-1) ) * ddx   &
+                                                  )                            &
+                                     - fym(j,i) * (                            &
+                                  kmym * ( u(k,j,i) - u(k,j-1,i) ) * ddy       &
+                                + kmym * ( v(k,j,i) - v(k,j,i-1) ) * ddx       &
+                                                  )                            &
+                                     + wall_u(j,i) * usvs(k,j,i)               &
+                                   ) * ddy
+                ENDDO
+             ENDIF
+
+!
+!--          Compute vertical diffusion. In case of simulating a Prandtl layer,
+!--          index k starts at nzb_u_inner+2.
+             DO  k = nzb_diff_u(j,i), nzt_diff
+!
+!--             Interpolate eddy diffusivities on staggered gridpoints
+                kmzp = 0.25_wp *                                               &
+                       ( km(k,j,i)+km(k+1,j,i)+km(k,j,i-1)+km(k+1,j,i-1) )
+                kmzm = 0.25_wp *                                               &
+                       ( km(k,j,i)+km(k-1,j,i)+km(k,j,i-1)+km(k-1,j,i-1) )
+
+                tend(k,j,i) = tend(k,j,i)                                      &
+                      & + ( kmzp * ( ( u(k+1,j,i) - u(k,j,i)   ) * ddzu(k+1)   &
+                      &            + ( w(k,j,i)   - w(k,j,i-1) ) * ddx         &
+                      &            )                                           &
+                      &   - kmzm * ( ( u(k,j,i)   - u(k-1,j,i)   ) * ddzu(k)   &
+                      &            + ( w(k-1,j,i) - w(k-1,j,i-1) ) * ddx       &
+                      &            )                                           &
+                      &   ) * ddzw(k)
+             ENDDO
+
+!
+!--          Vertical diffusion at the first grid point above the surface,
+!--          if the momentum flux at the bottom is given by the Prandtl law or
+!--          if it is prescribed by the user.
+!--          Difference quotient of the momentum flux is not formed over half
+!--          of the grid spacing (2.0*ddzw(k)) any more, since the comparison
+!--          with other (LES) models showed that the values of the momentum
+!--          flux becomes too large in this case.
+!--          The term containing w(k-1,..) (see above equation) is removed here
+!--          because the vertical velocity is assumed to be zero at the surface.
+             IF ( use_surface_fluxes )  THEN
+                k = nzb_u_inner(j,i)+1
+!
+!--             Interpolate eddy diffusivities on staggered gridpoints
+                kmzp = 0.25_wp *                                               &
+                      ( km(k,j,i)+km(k+1,j,i)+km(k,j,i-1)+km(k+1,j,i-1) )
+
+                tend(k,j,i) = tend(k,j,i)                                      &
+                      & + ( kmzp * ( w(k,j,i)   - w(k,j,i-1)   ) * ddx         &
+                      &   ) * ddzw(k)                                          &
+                      & + ( kmzp * ( u(k+1,j,i) - u(k,j,i)     ) * ddzu(k+1)   &
+                      &   + usws(j,i)                                          &
+                      &   ) * ddzw(k)
+             ENDIF
+
+!
+!--          Vertical diffusion at the first gridpoint below the top boundary,
+!--          if the momentum flux at the top is prescribed by the user
+             IF ( use_top_fluxes  .AND.  constant_top_momentumflux )  THEN
+                k = nzt
+!
+!--             Interpolate eddy diffusivities on staggered gridpoints
+                kmzm = 0.25_wp *                                               &
+                       ( km(k,j,i)+km(k-1,j,i)+km(k,j,i-1)+km(k-1,j,i-1) )
+
+                tend(k,j,i) = tend(k,j,i)                                      &
+                      & - ( kmzm * ( w(k-1,j,i) - w(k-1,j,i-1) ) * ddx         &
+                      &   ) * ddzw(k)                                          &
+                      & + ( -uswst(j,i)                                        &
+                      &   - kmzm * ( u(k,j,i)   - u(k-1,j,i)   ) * ddzu(k)     &
+                      &   ) * ddzw(k)
+             ENDIF
+
+          ENDDO
+       ENDDO
+
+    END SUBROUTINE diffusion_u
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Call for all grid points - accelerator version
+!------------------------------------------------------------------------------!
+    SUBROUTINE diffusion_u_acc
+
+       USE arrays_3d,                                                          &
+           ONLY:  ddzu, ddzw, km, tend, u, usws, uswst, v, w
+       
+       USE control_parameters,                                                 &
+           ONLY:  constant_top_momentumflux, topography, use_surface_fluxes,   &
+                  use_top_fluxes
+       
+       USE grid_variables,                                                     &
+           ONLY:  ddx, ddx2, ddy, fym, fyp, wall_u
+       
+       USE indices,                                                            &
+           ONLY:  i_left, i_right, j_north, j_south, nxl, nxr, nyn, nys, nzb,  &
+                  nzb_diff_u, nzb_u_inner, nzb_u_outer, nzt, nzt_diff
+       
+       USE kinds
+
+       IMPLICIT NONE
+
+       INTEGER(iwp) ::  i     !< 
+       INTEGER(iwp) ::  j     !< 
+       INTEGER(iwp) ::  k     !< 
+       REAL(wp)     ::  kmym  !<
+       REAL(wp)     ::  kmyp  !<
+       REAL(wp)     ::  kmzm  !<
+       REAL(wp)     ::  kmzp  !<
+
+       REAL(wp), DIMENSION(nzb:nzt+1,nys:nyn,nxl:nxr) ::  usvs  !< 
+       !$acc declare create ( usvs )
+
+!
+!--    First calculate horizontal momentum flux u'v' at vertical walls,
+!--    if neccessary
+       IF ( topography /= 'flat' )  THEN
+          CALL wall_fluxes_acc( usvs, 1.0_wp, 0.0_wp, 0.0_wp, 0.0_wp,          &
+                                nzb_u_inner, nzb_u_outer, wall_u )
+       ENDIF
+
+       !$acc kernels present ( u, v, w, km, tend, usws, uswst )                &
+       !$acc         present ( ddzu, ddzw, fym, fyp, wall_u )                  &
+       !$acc         present ( nzb_u_inner, nzb_u_outer, nzb_diff_u )
+       DO  i = i_left, i_right
+          DO  j = j_south, j_north
+!
+!--          Compute horizontal diffusion
+             DO  k = 1, nzt
+                IF ( k > nzb_u_outer(j,i) )  THEN
+!
+!--                Interpolate eddy diffusivities on staggered gridpoints
+                   kmyp = 0.25_wp *                                            &
+                          ( km(k,j,i)+km(k,j+1,i)+km(k,j,i-1)+km(k,j+1,i-1) )
+                   kmym = 0.25_wp *                                            &
+                          ( km(k,j,i)+km(k,j-1,i)+km(k,j,i-1)+km(k,j-1,i-1) )
+
+                   tend(k,j,i) = tend(k,j,i)                                   &
+                         & + 2.0_wp * (                                        &
+                         &           km(k,j,i)   * ( u(k,j,i+1) - u(k,j,i)   ) &
+                         &         - km(k,j,i-1) * ( u(k,j,i)   - u(k,j,i-1) ) &
+                         &            ) * ddx2                                 &
+                         & + ( kmyp * ( u(k,j+1,i) - u(k,j,i)     ) * ddy      &
+                         &   + kmyp * ( v(k,j+1,i) - v(k,j+1,i-1) ) * ddx      &
+                         &   - kmym * ( u(k,j,i) - u(k,j-1,i) ) * ddy          &
+                         &   - kmym * ( v(k,j,i) - v(k,j,i-1) ) * ddx          &
+                         &   ) * ddy
+                ENDIF
+             ENDDO
+
+!
+!--          Wall functions at the north and south walls, respectively
+             DO  k = 1, nzt
+                IF( k > nzb_u_inner(j,i)  .AND.  k <= nzb_u_outer(j,i)  .AND.  &
+                    wall_u(j,i) /= 0.0_wp )  THEN
+
+                   kmyp = 0.25_wp *                                            &
+                          ( km(k,j,i)+km(k,j+1,i)+km(k,j,i-1)+km(k,j+1,i-1) )
+                   kmym = 0.25_wp *                                            &
+                          ( km(k,j,i)+km(k,j-1,i)+km(k,j,i-1)+km(k,j-1,i-1) )
+
+                   tend(k,j,i) = tend(k,j,i)                                   &
+                                 + 2.0_wp * (                                  &
+                                       km(k,j,i)   * ( u(k,j,i+1) - u(k,j,i) ) &
+                                     - km(k,j,i-1) * ( u(k,j,i) - u(k,j,i-1) ) &
+                                            ) * ddx2                           &
+                                 + (   fyp(j,i) * (                            &
+                                  kmyp * ( u(k,j+1,i) - u(k,j,i)     ) * ddy   &
+                                + kmyp * ( v(k,j+1,i) - v(k,j+1,i-1) ) * ddx   &
+                                                  )                            &
+                                     - fym(j,i) * (                            &
+                                  kmym * ( u(k,j,i) - u(k,j-1,i) ) * ddy       &
+                                + kmym * ( v(k,j,i) - v(k,j,i-1) ) * ddx       &
+                                                  )                            &
+                                     + wall_u(j,i) * usvs(k,j,i)               &
+                                   ) * ddy
+                ENDIF
+             ENDDO
+
+!
+!--          Compute vertical diffusion. In case of simulating a Prandtl layer,
+!--          index k starts at nzb_u_inner+2.
+             DO  k = 1, nzt_diff
+                IF ( k >= nzb_diff_u(j,i) )  THEN
+!
+!--                Interpolate eddy diffusivities on staggered gridpoints
+                   kmzp = 0.25_wp *                                            &
+                          ( km(k,j,i)+km(k+1,j,i)+km(k,j,i-1)+km(k+1,j,i-1) )
+                   kmzm = 0.25_wp *                                            &
+                          ( km(k,j,i)+km(k-1,j,i)+km(k,j,i-1)+km(k-1,j,i-1) )
+
+                   tend(k,j,i) = tend(k,j,i)                                   &
+                         & + ( kmzp * ( ( u(k+1,j,i) - u(k,j,i)   ) * ddzu(k+1)&
+                         &            + ( w(k,j,i)   - w(k,j,i-1) ) * ddx      &
+                         &            )                                        &
+                         &   - kmzm * ( ( u(k,j,i)   - u(k-1,j,i)   ) * ddzu(k)&
+                         &            + ( w(k-1,j,i) - w(k-1,j,i-1) ) * ddx    &
+                         &            )                                        &
+                         &   ) * ddzw(k)
+                ENDIF
+             ENDDO
+
+          ENDDO
+       ENDDO
+
+!
+!--    Vertical diffusion at the first grid point above the surface,
+!--    if the momentum flux at the bottom is given by the Prandtl law or
+!--    if it is prescribed by the user.
+!--    Difference quotient of the momentum flux is not formed over half
+!--    of the grid spacing (2.0*ddzw(k)) any more, since the comparison
+!--    with other (LES) models showed that the values of the momentum
+!--    flux becomes too large in this case.
+!--    The term containing w(k-1,..) (see above equation) is removed here
+!--    because the vertical velocity is assumed to be zero at the surface.
+       IF ( use_surface_fluxes )  THEN
+
+          DO  i = i_left, i_right
+             DO  j = j_south, j_north
+          
+                k = nzb_u_inner(j,i)+1
+!
+!--             Interpolate eddy diffusivities on staggered gridpoints
+                kmzp = 0.25_wp *                                               &
+                      ( km(k,j,i)+km(k+1,j,i)+km(k,j,i-1)+km(k+1,j,i-1) )
+
+                tend(k,j,i) = tend(k,j,i)                                      &
+                      & + ( kmzp * ( w(k,j,i)   - w(k,j,i-1)   ) * ddx         &
+                      &   ) * ddzw(k)                                          &
+                      & + ( kmzp * ( u(k+1,j,i) - u(k,j,i)     ) * ddzu(k+1)   &
+                      &   + usws(j,i)                                          &
+                      &   ) * ddzw(k)
+             ENDDO
+          ENDDO
+
+       ENDIF
+
+!
+!--    Vertical diffusion at the first gridpoint below the top boundary,
+!--    if the momentum flux at the top is prescribed by the user
+       IF ( use_top_fluxes  .AND.  constant_top_momentumflux )  THEN
+
+          k = nzt
+
+          DO  i = i_left, i_right
+             DO  j = j_south, j_north
+
+!
+!--             Interpolate eddy diffusivities on staggered gridpoints
+                kmzm = 0.25_wp *                                               &
+                       ( km(k,j,i)+km(k-1,j,i)+km(k,j,i-1)+km(k-1,j,i-1) )
+
+                tend(k,j,i) = tend(k,j,i)                                      &
+                      & - ( kmzm * ( w(k-1,j,i) - w(k-1,j,i-1) ) * ddx         &
+                      &   ) * ddzw(k)                                          &
+                      & + ( -uswst(j,i)                                        &
+                      &   - kmzm * ( u(k,j,i)   - u(k-1,j,i)   ) * ddzu(k)     &
+                      &   ) * ddzw(k)
+             ENDDO
+          ENDDO
+
+       ENDIF
+       !$acc end kernels
+
+    END SUBROUTINE diffusion_u_acc
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Call for grid point i,j
+!------------------------------------------------------------------------------!
+    SUBROUTINE diffusion_u_ij( i, j )
+
+       USE arrays_3d,                                                          &
+           ONLY:  ddzu, ddzw, km, tend, u, usws, uswst, v, w
+       
+       USE control_parameters,                                                 &
+           ONLY:  constant_top_momentumflux, use_surface_fluxes, use_top_fluxes
+       
+       USE grid_variables,                                                     &
+           ONLY:  ddx, ddx2, ddy, fym, fyp, wall_u
+       
+       USE indices,                                                            &
+           ONLY:  nzb, nzb_diff_u, nzb_u_inner, nzb_u_outer, nzt, nzt_diff
+       
+       USE kinds
+
+       IMPLICIT NONE
+
+       INTEGER(iwp) ::  i     !< 
+       INTEGER(iwp) ::  j     !< 
+       INTEGER(iwp) ::  k     !< 
+       REAL(wp)     ::  kmym  !<
+       REAL(wp)     ::  kmyp  !<
+       REAL(wp)     ::  kmzm  !<
+       REAL(wp)     ::  kmzp  !<
+
+       REAL(wp), DIMENSION(nzb:nzt+1) ::  usvs  !< 
+
+!
+!--    Compute horizontal diffusion
+       DO  k = nzb_u_outer(j,i)+1, nzt
+!
+!--       Interpolate eddy diffusivities on staggered gridpoints
+          kmyp = 0.25_wp * ( km(k,j,i)+km(k,j+1,i)+km(k,j,i-1)+km(k,j+1,i-1) )
+          kmym = 0.25_wp * ( km(k,j,i)+km(k,j-1,i)+km(k,j,i-1)+km(k,j-1,i-1) )
+
+          tend(k,j,i) = tend(k,j,i)                                            &
+                      & + 2.0_wp * (                                           &
+                      &           km(k,j,i)   * ( u(k,j,i+1) - u(k,j,i)   )    &
+                      &         - km(k,j,i-1) * ( u(k,j,i)   - u(k,j,i-1) )    &
+                      &            ) * ddx2                                    &
+                      & + ( kmyp * ( u(k,j+1,i) - u(k,j,i)     ) * ddy         &
+                      &   + kmyp * ( v(k,j+1,i) - v(k,j+1,i-1) ) * ddx         &
+                      &   - kmym * ( u(k,j,i) - u(k,j-1,i) ) * ddy             &
+                      &   - kmym * ( v(k,j,i) - v(k,j,i-1) ) * ddx             &
+                      &   ) * ddy
+       ENDDO
+
+!
+!--    Wall functions at the north and south walls, respectively
+       IF ( wall_u(j,i) /= 0.0_wp )  THEN
+
+!
+!--       Calculate the horizontal momentum flux u'v'
+          CALL wall_fluxes( i, j, nzb_u_inner(j,i)+1, nzb_u_outer(j,i),        &
+                            usvs, 1.0_wp, 0.0_wp, 0.0_wp, 0.0_wp )
+
+          DO  k = nzb_u_inner(j,i)+1, nzb_u_outer(j,i)
+             kmyp = 0.25_wp * ( km(k,j,i)+km(k,j+1,i)+km(k,j,i-1)+km(k,j+1,i-1) )
+             kmym = 0.25_wp * ( km(k,j,i)+km(k,j-1,i)+km(k,j,i-1)+km(k,j-1,i-1) )
+
+             tend(k,j,i) = tend(k,j,i)                                         &
+                                 + 2.0_wp * (                                  &
+                                       km(k,j,i)   * ( u(k,j,i+1) - u(k,j,i) ) &
+                                     - km(k,j,i-1) * ( u(k,j,i) - u(k,j,i-1) ) &
+                                            ) * ddx2                           &
+                                 + (   fyp(j,i) * (                            &
+                                  kmyp * ( u(k,j+1,i) - u(k,j,i)     ) * ddy   &
+                                + kmyp * ( v(k,j+1,i) - v(k,j+1,i-1) ) * ddx   &
+                                                  )                            &
+                                     - fym(j,i) * (                            &
+                                  kmym * ( u(k,j,i) - u(k,j-1,i) ) * ddy       &
+                                + kmym * ( v(k,j,i) - v(k,j,i-1) ) * ddx       &
+                                                  )                            &
+                                     + wall_u(j,i) * usvs(k)                   &
+                                   ) * ddy
+          ENDDO
+       ENDIF
+
+!
+!--    Compute vertical diffusion. In case of simulating a Prandtl layer,
+!--    index k starts at nzb_u_inner+2.
+       DO  k = nzb_diff_u(j,i), nzt_diff
+!
+!--       Interpolate eddy diffusivities on staggered gridpoints
+          kmzp = 0.25_wp * ( km(k,j,i)+km(k+1,j,i)+km(k,j,i-1)+km(k+1,j,i-1) )
+          kmzm = 0.25_wp * ( km(k,j,i)+km(k-1,j,i)+km(k,j,i-1)+km(k-1,j,i-1) )
+
+          tend(k,j,i) = tend(k,j,i)                                            &
+                      & + ( kmzp * ( ( u(k+1,j,i) - u(k,j,i)   ) * ddzu(k+1)   &
+                      &            + ( w(k,j,i)   - w(k,j,i-1) ) * ddx         &
+                      &            )                                           &
+                      &   - kmzm * ( ( u(k,j,i)   - u(k-1,j,i)   ) * ddzu(k)   &
+                      &            + ( w(k-1,j,i) - w(k-1,j,i-1) ) * ddx       &
+                      &            )                                           &
+                      &   ) * ddzw(k)
+       ENDDO
+
+!
+!--    Vertical diffusion at the first grid point above the surface, if the
+!--    momentum flux at the bottom is given by the Prandtl law or if it is
+!--    prescribed by the user.
+!--    Difference quotient of the momentum flux is not formed over half of
+!--    the grid spacing (2.0*ddzw(k)) any more, since the comparison with 
+!--    other (LES) models showed that the values of the momentum flux becomes
+!--    too large in this case.
+!--    The term containing w(k-1,..) (see above equation) is removed here
+!--    because the vertical velocity is assumed to be zero at the surface.
+       IF ( use_surface_fluxes )  THEN
+          k = nzb_u_inner(j,i)+1
+!
+!--       Interpolate eddy diffusivities on staggered gridpoints
+          kmzp = 0.25_wp * ( km(k,j,i)+km(k+1,j,i)+km(k,j,i-1)+km(k+1,j,i-1) )
+
+          tend(k,j,i) = tend(k,j,i)                                            &
+                      & + ( kmzp * ( w(k,j,i)   - w(k,j,i-1)   ) * ddx         &
+                      &   ) * ddzw(k)                                          &
+                      & + ( kmzp * ( u(k+1,j,i) - u(k,j,i)     ) * ddzu(k+1)   &
+                      &   + usws(j,i)                                          &
+                      &   ) * ddzw(k)
+       ENDIF
+
+!
+!--    Vertical diffusion at the first gridpoint below the top boundary,
+!--    if the momentum flux at the top is prescribed by the user
+       IF ( use_top_fluxes  .AND.  constant_top_momentumflux )  THEN
+          k = nzt
+!
+!--       Interpolate eddy diffusivities on staggered gridpoints
+          kmzm = 0.25_wp *                                                     &
+                 ( km(k,j,i)+km(k-1,j,i)+km(k,j,i-1)+km(k-1,j,i-1) )
+
+          tend(k,j,i) = tend(k,j,i)                                            &
+                      & - ( kmzm * ( w(k-1,j,i) - w(k-1,j,i-1) ) * ddx         &
+                      &   ) * ddzw(k)                                          &
+                      & + ( -uswst(j,i)                                        &
+                      &   - kmzm * ( u(k,j,i)   - u(k-1,j,i)   ) * ddzu(k)     &
+                      &   ) * ddzw(k)
+       ENDIF
+
+    END SUBROUTINE diffusion_u_ij
+
+ END MODULE diffusion_u_mod
Index: lm/trunk/SOURCE/diffusion_v.f90
===================================================================
--- /palm/trunk/SOURCE/diffusion_v.f90	(revision 1849)
+++ 	(revision )
@@ -1,597 +1,0 @@
-!> @file diffusion_v.f90
-!--------------------------------------------------------------------------------!
-! This file is part of PALM.
-!
-! PALM is free software: you can redistribute it and/or modify it under the terms
-! of the GNU General Public License as published by the Free Software Foundation,
-! either version 3 of the License, or (at your option) any later version.
-!
-! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
-! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
-! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along with
-! PALM. If not, see <http://www.gnu.org/licenses/>.
-!
-! Copyright 1997-2016 Leibniz Universitaet Hannover
-!--------------------------------------------------------------------------------!
-!
-! Current revisions:
-! -----------------
-! 
-!
-! Former revisions:
-! -----------------
-! $Id$
-!
-! 1740 2016-01-13 08:19:40Z raasch
-! unnecessary calculations of kmzm and kmzp in wall bounded parts removed
-!
-! 1682 2015-10-07 23:56:08Z knoop
-! Code annotations made doxygen readable 
-! 
-! 1340 2014-03-25 19:45:13Z kanani
-! REAL constants defined as wp-kind
-!
-! 1320 2014-03-20 08:40:49Z raasch
-! ONLY-attribute added to USE-statements,
-! kind-parameters added to all INTEGER and REAL declaration statements,
-! kinds are defined in new module kinds,
-! revision history before 2012 removed,
-! comment fields (!:) to be used for variable explanations added to
-! all variable declaration statements
-! 
-! 1257 2013-11-08 15:18:40Z raasch
-! openacc loop and loop vector clauses removed, declare create moved after
-! the FORTRAN declaration statement
-!
-! 1128 2013-04-12 06:19:32Z raasch
-! loop index bounds in accelerator version replaced by i_left, i_right, j_south,
-! j_north
-!
-! 1036 2012-10-22 13:43:42Z raasch
-! code put under GPL (PALM 3.9)
-!
-! 1015 2012-09-27 09:23:24Z raasch
-! accelerator version (*_acc) added
-!
-! 1001 2012-09-13 14:08:46Z raasch
-! arrays comunicated by module instead of parameter list
-!
-! 978 2012-08-09 08:28:32Z fricke
-! outflow damping layer removed
-! kmxm_x/_y and kmxp_x/_y change to kmxm and kmxp
-!
-! Revision 1.1  1997/09/12 06:24:01  raasch
-! Initial revision
-!
-!
-! Description:
-! ------------
-!> Diffusion term of the v-component
-!------------------------------------------------------------------------------!
- MODULE diffusion_v_mod
- 
-
-    USE wall_fluxes_mod
-
-    PRIVATE
-    PUBLIC diffusion_v, diffusion_v_acc
-
-    INTERFACE diffusion_v
-       MODULE PROCEDURE diffusion_v
-       MODULE PROCEDURE diffusion_v_ij
-    END INTERFACE diffusion_v
-
-    INTERFACE diffusion_v_acc
-       MODULE PROCEDURE diffusion_v_acc
-    END INTERFACE diffusion_v_acc
-
- CONTAINS
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Call for all grid points
-!------------------------------------------------------------------------------!
-    SUBROUTINE diffusion_v
-
-       USE arrays_3d,                                                          &
-           ONLY:  ddzu, ddzw, km, tend, u, v, vsws, vswst, w
-       
-       USE control_parameters,                                                 &
-           ONLY:  constant_top_momentumflux, topography, use_surface_fluxes,   &
-                  use_top_fluxes
-       
-       USE grid_variables,                                                     &
-           ONLY:  ddx, ddy, ddy2, fxm, fxp, wall_v
-       
-       USE indices,                                                            &
-           ONLY:  nxl, nxr, nyn, nys, nysv, nzb, nzb_diff_v, nzb_v_inner,      &
-                  nzb_v_outer, nzt, nzt_diff
-       
-       USE kinds
-
-       IMPLICIT NONE
-
-       INTEGER(iwp) ::  i     !< 
-       INTEGER(iwp) ::  j     !< 
-       INTEGER(iwp) ::  k     !< 
-       REAL(wp)     ::  kmxm  !< 
-       REAL(wp)     ::  kmxp  !< 
-       REAL(wp)     ::  kmzm  !< 
-       REAL(wp)     ::  kmzp  !< 
-
-       REAL(wp), DIMENSION(nzb:nzt+1,nys:nyn,nxl:nxr) ::  vsus  !< 
-
-!
-!--    First calculate horizontal momentum flux v'u' at vertical walls,
-!--    if neccessary
-       IF ( topography /= 'flat' )  THEN
-          CALL wall_fluxes( vsus, 0.0_wp, 1.0_wp, 0.0_wp, 0.0_wp, nzb_v_inner, &
-                            nzb_v_outer, wall_v )
-       ENDIF
-
-       DO  i = nxl, nxr
-          DO  j = nysv, nyn
-!
-!--          Compute horizontal diffusion
-             DO  k = nzb_v_outer(j,i)+1, nzt
-!
-!--             Interpolate eddy diffusivities on staggered gridpoints
-                kmxp = 0.25_wp * &
-                       ( km(k,j,i)+km(k,j,i+1)+km(k,j-1,i)+km(k,j-1,i+1) )
-                kmxm = 0.25_wp * &
-                       ( km(k,j,i)+km(k,j,i-1)+km(k,j-1,i)+km(k,j-1,i-1) )
-
-                tend(k,j,i) = tend(k,j,i)                                      &
-                      & + ( kmxp * ( v(k,j,i+1) - v(k,j,i)     ) * ddx         &
-                      &   + kmxp * ( u(k,j,i+1) - u(k,j-1,i+1) ) * ddy         &
-                      &   - kmxm * ( v(k,j,i) - v(k,j,i-1) ) * ddx             &
-                      &   - kmxm * ( u(k,j,i) - u(k,j-1,i) ) * ddy             &
-                      &   ) * ddx                                              &
-                      & + 2.0_wp * (                                           &
-                      &           km(k,j,i)   * ( v(k,j+1,i) - v(k,j,i) )      &
-                      &         - km(k,j-1,i) * ( v(k,j,i) - v(k,j-1,i) )      &
-                      &            ) * ddy2
-             ENDDO
-
-!
-!--          Wall functions at the left and right walls, respectively
-             IF ( wall_v(j,i) /= 0.0_wp )  THEN
-
-                DO  k = nzb_v_inner(j,i)+1, nzb_v_outer(j,i)
-                   kmxp = 0.25_wp *                                            &
-                          ( km(k,j,i)+km(k,j,i+1)+km(k,j-1,i)+km(k,j-1,i+1) )
-                   kmxm = 0.25_wp *                                            &
-                          ( km(k,j,i)+km(k,j,i-1)+km(k,j-1,i)+km(k,j-1,i-1) )
-                   
-                   tend(k,j,i) = tend(k,j,i)                                   &
-                                 + 2.0_wp * (                                  &
-                                       km(k,j,i)   * ( v(k,j+1,i) - v(k,j,i) ) &
-                                     - km(k,j-1,i) * ( v(k,j,i) - v(k,j-1,i) ) &
-                                            ) * ddy2                           &
-                                 + (   fxp(j,i) * (                            &
-                                  kmxp * ( v(k,j,i+1) - v(k,j,i)     ) * ddx   &
-                                + kmxp * ( u(k,j,i+1) - u(k,j-1,i+1) ) * ddy   &
-                                                  )                            &
-                                     - fxm(j,i) * (                            &
-                                  kmxm * ( v(k,j,i) - v(k,j,i-1) ) * ddx       &
-                                + kmxm * ( u(k,j,i) - u(k,j-1,i) ) * ddy       &
-                                                  )                            &
-                                     + wall_v(j,i) * vsus(k,j,i)               &
-                                   ) * ddx
-                ENDDO
-             ENDIF
-
-!
-!--          Compute vertical diffusion. In case of simulating a Prandtl
-!--          layer, index k starts at nzb_v_inner+2.
-             DO  k = nzb_diff_v(j,i), nzt_diff
-!
-!--             Interpolate eddy diffusivities on staggered gridpoints
-                kmzp = 0.25_wp * &
-                       ( km(k,j,i)+km(k+1,j,i)+km(k,j-1,i)+km(k+1,j-1,i) )
-                kmzm = 0.25_wp * &
-                       ( km(k,j,i)+km(k-1,j,i)+km(k,j-1,i)+km(k-1,j-1,i) )
-
-                tend(k,j,i) = tend(k,j,i)                                      &
-                      & + ( kmzp * ( ( v(k+1,j,i) - v(k,j,i) ) * ddzu(k+1)     &
-                      &            + ( w(k,j,i) - w(k,j-1,i) ) * ddy           &
-                      &            )                                           &
-                      &   - kmzm * ( ( v(k,j,i)   - v(k-1,j,i)   ) * ddzu(k)   &
-                      &            + ( w(k-1,j,i) - w(k-1,j-1,i) ) * ddy       &
-                      &            )                                           &
-                      &   ) * ddzw(k)
-             ENDDO
-
-!
-!--          Vertical diffusion at the first grid point above the surface,
-!--          if the momentum flux at the bottom is given by the Prandtl law
-!--          or if it is prescribed by the user.
-!--          Difference quotient of the momentum flux is not formed over
-!--          half of the grid spacing (2.0*ddzw(k)) any more, since the
-!--          comparison with other (LES) models showed that the values of
-!--          the momentum flux becomes too large in this case.
-!--          The term containing w(k-1,..) (see above equation) is removed here
-!--          because the vertical velocity is assumed to be zero at the surface.
-             IF ( use_surface_fluxes )  THEN
-                k = nzb_v_inner(j,i)+1
-!
-!--             Interpolate eddy diffusivities on staggered gridpoints
-                kmzp = 0.25_wp *                                               &
-                       ( km(k,j,i)+km(k+1,j,i)+km(k,j-1,i)+km(k+1,j-1,i) )
-
-                tend(k,j,i) = tend(k,j,i)                                      &
-                      & + ( kmzp * ( w(k,j,i) - w(k,j-1,i)     ) * ddy         &
-                      &   ) * ddzw(k)                                          &
-                      & + ( kmzp * ( v(k+1,j,i) - v(k,j,i)     ) * ddzu(k+1)   &
-                      &   + vsws(j,i)                                          &
-                      &   ) * ddzw(k)
-             ENDIF
-
-!
-!--          Vertical diffusion at the first gridpoint below the top boundary,
-!--          if the momentum flux at the top is prescribed by the user
-             IF ( use_top_fluxes  .AND.  constant_top_momentumflux )  THEN
-                k = nzt
-!
-!--             Interpolate eddy diffusivities on staggered gridpoints
-                kmzm = 0.25_wp *                                               &
-                       ( km(k,j,i)+km(k-1,j,i)+km(k,j-1,i)+km(k-1,j-1,i) )
-
-                tend(k,j,i) = tend(k,j,i)                                      &
-                      & - ( kmzm *  ( w(k-1,j,i) - w(k-1,j-1,i) ) * ddy        &
-                      &   ) * ddzw(k)                                          &
-                      & + ( -vswst(j,i)                                        &
-                      &   - kmzm * ( v(k,j,i)   - v(k-1,j,i)    ) * ddzu(k)    &
-                      &   ) * ddzw(k)
-             ENDIF
-
-          ENDDO
-       ENDDO
-
-    END SUBROUTINE diffusion_v
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Call for all grid points - accelerator version
-!------------------------------------------------------------------------------!
-    SUBROUTINE diffusion_v_acc
-
-       USE arrays_3d,                                                          &
-           ONLY:  ddzu, ddzw, km, tend, u, v, vsws, vswst, w
-       
-       USE control_parameters,                                                 &
-           ONLY:  constant_top_momentumflux, topography, use_surface_fluxes,   &
-                  use_top_fluxes
-       
-       USE grid_variables,                                                     &
-           ONLY:  ddx, ddy, ddy2, fxm, fxp, wall_v
-       
-       USE indices,                                                            &
-           ONLY:  i_left, i_right, j_north, j_south, nxl, nxr, nyn, nys, nzb,  &
-                  nzb_diff_v, nzb_v_inner, nzb_v_outer, nzt, nzt_diff
-       
-       USE kinds
-
-       IMPLICIT NONE
-
-       INTEGER(iwp) ::  i     !< 
-       INTEGER(iwp) ::  j     !< 
-       INTEGER(iwp) ::  k     !< 
-       REAL(wp)     ::  kmxm  !< 
-       REAL(wp)     ::  kmxp  !< 
-       REAL(wp)     ::  kmzm  !< 
-       REAL(wp)     ::  kmzp  !< 
-
-       REAL(wp), DIMENSION(nzb:nzt+1,nys:nyn,nxl:nxr) ::  vsus  !< 
-       !$acc declare create ( vsus )
-
-!
-!--    First calculate horizontal momentum flux v'u' at vertical walls,
-!--    if neccessary
-       IF ( topography /= 'flat' )  THEN
-          CALL wall_fluxes_acc( vsus, 0.0_wp, 1.0_wp, 0.0_wp, 0.0_wp,          &
-                                nzb_v_inner, nzb_v_outer, wall_v )
-       ENDIF
-
-       !$acc kernels present ( u, v, w, km, tend, vsws, vswst )                &
-       !$acc         present ( ddzu, ddzw, fxm, fxp, wall_v )                  &
-       !$acc         present ( nzb_v_inner, nzb_v_outer, nzb_diff_v )
-       DO  i = i_left, i_right
-          DO  j = j_south, j_north
-!
-!--          Compute horizontal diffusion
-             DO  k = 1, nzt
-                IF ( k > nzb_v_outer(j,i) )  THEN
-!
-!--                Interpolate eddy diffusivities on staggered gridpoints
-                   kmxp = 0.25_wp *                                            &
-                          ( km(k,j,i)+km(k,j,i+1)+km(k,j-1,i)+km(k,j-1,i+1) )
-                   kmxm = 0.25_wp *                                            &
-                          ( km(k,j,i)+km(k,j,i-1)+km(k,j-1,i)+km(k,j-1,i-1) )
-
-                   tend(k,j,i) = tend(k,j,i)                                   &
-                         & + ( kmxp * ( v(k,j,i+1) - v(k,j,i)     ) * ddx      &
-                         &   + kmxp * ( u(k,j,i+1) - u(k,j-1,i+1) ) * ddy      &
-                         &   - kmxm * ( v(k,j,i) - v(k,j,i-1) ) * ddx          &
-                         &   - kmxm * ( u(k,j,i) - u(k,j-1,i) ) * ddy          &
-                         &   ) * ddx                                           &
-                         & + 2.0_wp * (                                        &
-                         &           km(k,j,i)   * ( v(k,j+1,i) - v(k,j,i) )   &
-                         &         - km(k,j-1,i) * ( v(k,j,i) - v(k,j-1,i) )   &
-                         &            ) * ddy2
-                ENDIF
-             ENDDO
-
-!
-!--          Wall functions at the left and right walls, respectively
-             DO  k = 1, nzt
-                IF( k > nzb_v_inner(j,i)  .AND.  k <= nzb_v_outer(j,i)  .AND.  &
-                    wall_v(j,i) /= 0.0_wp )  THEN
-
-                   kmxp = 0.25_wp *                                            &
-                          ( km(k,j,i)+km(k,j,i+1)+km(k,j-1,i)+km(k,j-1,i+1) )
-                   kmxm = 0.25_wp *                                            &
-                          ( km(k,j,i)+km(k,j,i-1)+km(k,j-1,i)+km(k,j-1,i-1) )
-                   
-                   tend(k,j,i) = tend(k,j,i)                                   &
-                                 + 2.0_wp * (                                  &
-                                       km(k,j,i)   * ( v(k,j+1,i) - v(k,j,i) ) &
-                                     - km(k,j-1,i) * ( v(k,j,i) - v(k,j-1,i) ) &
-                                            ) * ddy2                           &
-                                 + (   fxp(j,i) * (                            &
-                                  kmxp * ( v(k,j,i+1) - v(k,j,i)     ) * ddx   &
-                                + kmxp * ( u(k,j,i+1) - u(k,j-1,i+1) ) * ddy   &
-                                                  )                            &
-                                     - fxm(j,i) * (                            &
-                                  kmxm * ( v(k,j,i) - v(k,j,i-1) ) * ddx       &
-                                + kmxm * ( u(k,j,i) - u(k,j-1,i) ) * ddy       &
-                                                  )                            &
-                                     + wall_v(j,i) * vsus(k,j,i)               &
-                                   ) * ddx
-                ENDIF
-             ENDDO
-
-!
-!--          Compute vertical diffusion. In case of simulating a Prandtl
-!--          layer, index k starts at nzb_v_inner+2.
-             DO  k = 1, nzt_diff
-                IF ( k >= nzb_diff_v(j,i) )  THEN
-!
-!--                Interpolate eddy diffusivities on staggered gridpoints
-                   kmzp = 0.25_wp *                                            &
-                          ( km(k,j,i)+km(k+1,j,i)+km(k,j-1,i)+km(k+1,j-1,i) )
-                   kmzm = 0.25_wp *                                            &
-                          ( km(k,j,i)+km(k-1,j,i)+km(k,j-1,i)+km(k-1,j-1,i) )
-
-                   tend(k,j,i) = tend(k,j,i)                                   &
-                         & + ( kmzp * ( ( v(k+1,j,i) - v(k,j,i)   ) * ddzu(k+1)&
-                         &            + ( w(k,j,i)   - w(k,j-1,i) ) * ddy      &
-                         &            )                                        &
-                         &   - kmzm * ( ( v(k,j,i)   - v(k-1,j,i)   ) * ddzu(k)&
-                         &            + ( w(k-1,j,i) - w(k-1,j-1,i) ) * ddy    &
-                         &            )                                        &
-                         &   ) * ddzw(k)
-                ENDIF
-             ENDDO
-
-          ENDDO
-       ENDDO
-
-!
-!--    Vertical diffusion at the first grid point above the surface,
-!--    if the momentum flux at the bottom is given by the Prandtl law
-!--    or if it is prescribed by the user.
-!--    Difference quotient of the momentum flux is not formed over
-!--    half of the grid spacing (2.0*ddzw(k)) any more, since the
-!--    comparison with other (LES) models showed that the values of
-!--    the momentum flux becomes too large in this case.
-!--    The term containing w(k-1,..) (see above equation) is removed here
-!--    because the vertical velocity is assumed to be zero at the surface.
-       IF ( use_surface_fluxes )  THEN
-
-          DO  i = i_left, i_right
-             DO  j = j_south, j_north
-          
-                k = nzb_v_inner(j,i)+1
-!
-!--             Interpolate eddy diffusivities on staggered gridpoints
-                kmzp = 0.25_wp *                                               &
-                       ( km(k,j,i)+km(k+1,j,i)+km(k,j-1,i)+km(k+1,j-1,i) )
-
-                tend(k,j,i) = tend(k,j,i)                                      &
-                      & + ( kmzp * ( w(k,j,i) - w(k,j-1,i)     ) * ddy         &
-                      &   ) * ddzw(k)                                          &
-                      & + ( kmzp * ( v(k+1,j,i) - v(k,j,i)     ) * ddzu(k+1)   &
-                      &   + vsws(j,i)                                          &
-                      &   ) * ddzw(k)
-             ENDDO
-          ENDDO
-
-       ENDIF
-
-!
-!--    Vertical diffusion at the first gridpoint below the top boundary,
-!--    if the momentum flux at the top is prescribed by the user
-       IF ( use_top_fluxes  .AND.  constant_top_momentumflux )  THEN
-
-          k = nzt
-
-          DO  i = i_left, i_right
-             DO  j = j_south, j_north
-
-!
-!--             Interpolate eddy diffusivities on staggered gridpoints
-                kmzm = 0.25_wp *                                               &
-                       ( km(k,j,i)+km(k-1,j,i)+km(k,j-1,i)+km(k-1,j-1,i) )
-
-                tend(k,j,i) = tend(k,j,i)                                      &
-                      & - ( kmzm *  ( w(k-1,j,i) - w(k-1,j-1,i) ) * ddy        &
-                      &   ) * ddzw(k)                                          &
-                      & + ( -vswst(j,i)                                        &
-                      &   - kmzm * ( v(k,j,i)   - v(k-1,j,i)    ) * ddzu(k)    &
-                      &   ) * ddzw(k)
-             ENDDO
-          ENDDO
-
-       ENDIF
-       !$acc end kernels
-
-    END SUBROUTINE diffusion_v_acc
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Call for grid point i,j
-!------------------------------------------------------------------------------!
-    SUBROUTINE diffusion_v_ij( i, j )
-
-       USE arrays_3d,                                                          &
-           ONLY:  ddzu, ddzw, km, tend, u, v, vsws, vswst, w
-       
-       USE control_parameters,                                                 &
-           ONLY:  constant_top_momentumflux, use_surface_fluxes, use_top_fluxes
-       
-       USE grid_variables,                                                     &
-           ONLY:  ddx, ddy, ddy2, fxm, fxp, wall_v
-       
-       USE indices,                                                            &
-           ONLY:  nzb, nzb_diff_v, nzb_v_inner, nzb_v_outer, nzt, nzt_diff
-       
-       USE kinds
-
-       IMPLICIT NONE
-
-       INTEGER(iwp) ::  i     !< 
-       INTEGER(iwp) ::  j     !< 
-       INTEGER(iwp) ::  k     !< 
-       REAL(wp)     ::  kmxm  !< 
-       REAL(wp)     ::  kmxp  !< 
-       REAL(wp)     ::  kmzm  !< 
-       REAL(wp)     ::  kmzp  !< 
-
-       REAL(wp), DIMENSION(nzb:nzt+1) ::  vsus  !< 
-
-!
-!--    Compute horizontal diffusion
-       DO  k = nzb_v_outer(j,i)+1, nzt
-!
-!--       Interpolate eddy diffusivities on staggered gridpoints
-          kmxp = 0.25_wp * ( km(k,j,i)+km(k,j,i+1)+km(k,j-1,i)+km(k,j-1,i+1) )
-          kmxm = 0.25_wp * ( km(k,j,i)+km(k,j,i-1)+km(k,j-1,i)+km(k,j-1,i-1) )
-
-          tend(k,j,i) = tend(k,j,i)                                            &
-                      & + ( kmxp * ( v(k,j,i+1) - v(k,j,i)     ) * ddx         &
-                      &   + kmxp * ( u(k,j,i+1) - u(k,j-1,i+1) ) * ddy         &
-                      &   - kmxm * ( v(k,j,i) - v(k,j,i-1) ) * ddx             &
-                      &   - kmxm * ( u(k,j,i) - u(k,j-1,i) ) * ddy             &
-                      &   ) * ddx                                              &
-                      & + 2.0_wp * (                                           &
-                      &           km(k,j,i)   * ( v(k,j+1,i) - v(k,j,i) )      &
-                      &         - km(k,j-1,i) * ( v(k,j,i) - v(k,j-1,i) )      &
-                      &            ) * ddy2
-       ENDDO
-
-!
-!--    Wall functions at the left and right walls, respectively
-       IF ( wall_v(j,i) /= 0.0_wp )  THEN
-
-!
-!--       Calculate the horizontal momentum flux v'u'
-          CALL wall_fluxes( i, j, nzb_v_inner(j,i)+1, nzb_v_outer(j,i),        &
-                            vsus, 0.0_wp, 1.0_wp, 0.0_wp, 0.0_wp )
-
-          DO  k = nzb_v_inner(j,i)+1, nzb_v_outer(j,i)
-             kmxp = 0.25_wp *                                                  &
-                    ( km(k,j,i)+km(k,j,i+1)+km(k,j-1,i)+km(k,j-1,i+1) )
-             kmxm = 0.25_wp *                                                  &
-                    ( km(k,j,i)+km(k,j,i-1)+km(k,j-1,i)+km(k,j-1,i-1) )
-
-             tend(k,j,i) = tend(k,j,i)                                         &
-                                 + 2.0_wp * (                                  &
-                                       km(k,j,i)   * ( v(k,j+1,i) - v(k,j,i) ) &
-                                     - km(k,j-1,i) * ( v(k,j,i) - v(k,j-1,i) ) &
-                                            ) * ddy2                           &
-                                 + (   fxp(j,i) * (                            &
-                                  kmxp * ( v(k,j,i+1) - v(k,j,i)     ) * ddx   &
-                                + kmxp * ( u(k,j,i+1) - u(k,j-1,i+1) ) * ddy   &
-                                                  )                            &
-                                     - fxm(j,i) * (                            &
-                                  kmxm * ( v(k,j,i) - v(k,j,i-1) ) * ddx       &
-                                + kmxm * ( u(k,j,i) - u(k,j-1,i) ) * ddy       &
-                                                  )                            &
-                                     + wall_v(j,i) * vsus(k)                   &
-                                   ) * ddx
-          ENDDO
-       ENDIF
-
-!
-!--    Compute vertical diffusion. In case of simulating a Prandtl layer,
-!--    index k starts at nzb_v_inner+2.
-       DO  k = nzb_diff_v(j,i), nzt_diff
-!
-!--       Interpolate eddy diffusivities on staggered gridpoints
-          kmzp = 0.25_wp * ( km(k,j,i)+km(k+1,j,i)+km(k,j-1,i)+km(k+1,j-1,i) )
-          kmzm = 0.25_wp * ( km(k,j,i)+km(k-1,j,i)+km(k,j-1,i)+km(k-1,j-1,i) )
-
-          tend(k,j,i) = tend(k,j,i)                                            &
-                      & + ( kmzp * ( ( v(k+1,j,i) - v(k,j,i) ) * ddzu(k+1)     &
-                      &            + ( w(k,j,i) - w(k,j-1,i) ) * ddy           &
-                      &            )                                           &
-                      &   - kmzm * ( ( v(k,j,i)   - v(k-1,j,i)   ) * ddzu(k)   &
-                      &            + ( w(k-1,j,i) - w(k-1,j-1,i) ) * ddy       &
-                      &            )                                           &
-                      &   ) * ddzw(k)
-       ENDDO
-
-!
-!--    Vertical diffusion at the first grid point above the surface, if the
-!--    momentum flux at the bottom is given by the Prandtl law or if it is
-!--    prescribed by the user.
-!--    Difference quotient of the momentum flux is not formed over half of
-!--    the grid spacing (2.0*ddzw(k)) any more, since the comparison with 
-!--    other (LES) models showed that the values of the momentum flux becomes
-!--    too large in this case.
-!--    The term containing w(k-1,..) (see above equation) is removed here
-!--    because the vertical velocity is assumed to be zero at the surface.
-       IF ( use_surface_fluxes )  THEN
-          k = nzb_v_inner(j,i)+1
-!
-!--       Interpolate eddy diffusivities on staggered gridpoints
-          kmzp = 0.25_wp * ( km(k,j,i)+km(k+1,j,i)+km(k,j-1,i)+km(k+1,j-1,i) )
-
-          tend(k,j,i) = tend(k,j,i)                                            &
-                      & + ( kmzp * ( w(k,j,i) - w(k,j-1,i)     ) * ddy         &
-                      &   ) * ddzw(k)                                          &
-                      & + ( kmzp * ( v(k+1,j,i) - v(k,j,i)     ) * ddzu(k+1)   &
-                      &   + vsws(j,i)                                          &
-                      &   ) * ddzw(k)
-       ENDIF
-
-!
-!--    Vertical diffusion at the first gridpoint below the top boundary,
-!--    if the momentum flux at the top is prescribed by the user
-       IF ( use_top_fluxes  .AND.  constant_top_momentumflux )  THEN
-          k = nzt
-!
-!--       Interpolate eddy diffusivities on staggered gridpoints
-          kmzm = 0.25_wp * &
-                 ( km(k,j,i)+km(k-1,j,i)+km(k,j-1,i)+km(k-1,j-1,i) )
-
-          tend(k,j,i) = tend(k,j,i)                                            &
-                      & - ( kmzm *  ( w(k-1,j,i) - w(k-1,j-1,i) ) * ddy        &
-                      &   ) * ddzw(k)                                          &
-                      & + ( -vswst(j,i)                                        &
-                      &   - kmzm * ( v(k,j,i)   - v(k-1,j,i)    ) * ddzu(k)    &
-                      &   ) * ddzw(k)
-       ENDIF
-
-    END SUBROUTINE diffusion_v_ij
-
- END MODULE diffusion_v_mod
Index: /palm/trunk/SOURCE/diffusion_v_mod.f90
===================================================================
--- /palm/trunk/SOURCE/diffusion_v_mod.f90	(revision 1850)
+++ /palm/trunk/SOURCE/diffusion_v_mod.f90	(revision 1850)
@@ -0,0 +1,598 @@
+!> @file diffusion_v_mod.f90
+!--------------------------------------------------------------------------------!
+! This file is part of PALM.
+!
+! PALM is free software: you can redistribute it and/or modify it under the terms
+! of the GNU General Public License as published by the Free Software Foundation,
+! either version 3 of the License, or (at your option) any later version.
+!
+! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
+! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
+! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along with
+! PALM. If not, see <http://www.gnu.org/licenses/>.
+!
+! Copyright 1997-2016 Leibniz Universitaet Hannover
+!--------------------------------------------------------------------------------!
+!
+! Current revisions:
+! -----------------
+! Module renamed
+! 
+!
+! Former revisions:
+! -----------------
+! $Id$
+!
+! 1740 2016-01-13 08:19:40Z raasch
+! unnecessary calculations of kmzm and kmzp in wall bounded parts removed
+!
+! 1682 2015-10-07 23:56:08Z knoop
+! Code annotations made doxygen readable 
+! 
+! 1340 2014-03-25 19:45:13Z kanani
+! REAL constants defined as wp-kind
+!
+! 1320 2014-03-20 08:40:49Z raasch
+! ONLY-attribute added to USE-statements,
+! kind-parameters added to all INTEGER and REAL declaration statements,
+! kinds are defined in new module kinds,
+! revision history before 2012 removed,
+! comment fields (!:) to be used for variable explanations added to
+! all variable declaration statements
+! 
+! 1257 2013-11-08 15:18:40Z raasch
+! openacc loop and loop vector clauses removed, declare create moved after
+! the FORTRAN declaration statement
+!
+! 1128 2013-04-12 06:19:32Z raasch
+! loop index bounds in accelerator version replaced by i_left, i_right, j_south,
+! j_north
+!
+! 1036 2012-10-22 13:43:42Z raasch
+! code put under GPL (PALM 3.9)
+!
+! 1015 2012-09-27 09:23:24Z raasch
+! accelerator version (*_acc) added
+!
+! 1001 2012-09-13 14:08:46Z raasch
+! arrays comunicated by module instead of parameter list
+!
+! 978 2012-08-09 08:28:32Z fricke
+! outflow damping layer removed
+! kmxm_x/_y and kmxp_x/_y change to kmxm and kmxp
+!
+! Revision 1.1  1997/09/12 06:24:01  raasch
+! Initial revision
+!
+!
+! Description:
+! ------------
+!> Diffusion term of the v-component
+!------------------------------------------------------------------------------!
+ MODULE diffusion_v_mod
+ 
+
+    USE wall_fluxes_mod
+
+    PRIVATE
+    PUBLIC diffusion_v, diffusion_v_acc
+
+    INTERFACE diffusion_v
+       MODULE PROCEDURE diffusion_v
+       MODULE PROCEDURE diffusion_v_ij
+    END INTERFACE diffusion_v
+
+    INTERFACE diffusion_v_acc
+       MODULE PROCEDURE diffusion_v_acc
+    END INTERFACE diffusion_v_acc
+
+ CONTAINS
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Call for all grid points
+!------------------------------------------------------------------------------!
+    SUBROUTINE diffusion_v
+
+       USE arrays_3d,                                                          &
+           ONLY:  ddzu, ddzw, km, tend, u, v, vsws, vswst, w
+       
+       USE control_parameters,                                                 &
+           ONLY:  constant_top_momentumflux, topography, use_surface_fluxes,   &
+                  use_top_fluxes
+       
+       USE grid_variables,                                                     &
+           ONLY:  ddx, ddy, ddy2, fxm, fxp, wall_v
+       
+       USE indices,                                                            &
+           ONLY:  nxl, nxr, nyn, nys, nysv, nzb, nzb_diff_v, nzb_v_inner,      &
+                  nzb_v_outer, nzt, nzt_diff
+       
+       USE kinds
+
+       IMPLICIT NONE
+
+       INTEGER(iwp) ::  i     !< 
+       INTEGER(iwp) ::  j     !< 
+       INTEGER(iwp) ::  k     !< 
+       REAL(wp)     ::  kmxm  !< 
+       REAL(wp)     ::  kmxp  !< 
+       REAL(wp)     ::  kmzm  !< 
+       REAL(wp)     ::  kmzp  !< 
+
+       REAL(wp), DIMENSION(nzb:nzt+1,nys:nyn,nxl:nxr) ::  vsus  !< 
+
+!
+!--    First calculate horizontal momentum flux v'u' at vertical walls,
+!--    if neccessary
+       IF ( topography /= 'flat' )  THEN
+          CALL wall_fluxes( vsus, 0.0_wp, 1.0_wp, 0.0_wp, 0.0_wp, nzb_v_inner, &
+                            nzb_v_outer, wall_v )
+       ENDIF
+
+       DO  i = nxl, nxr
+          DO  j = nysv, nyn
+!
+!--          Compute horizontal diffusion
+             DO  k = nzb_v_outer(j,i)+1, nzt
+!
+!--             Interpolate eddy diffusivities on staggered gridpoints
+                kmxp = 0.25_wp * &
+                       ( km(k,j,i)+km(k,j,i+1)+km(k,j-1,i)+km(k,j-1,i+1) )
+                kmxm = 0.25_wp * &
+                       ( km(k,j,i)+km(k,j,i-1)+km(k,j-1,i)+km(k,j-1,i-1) )
+
+                tend(k,j,i) = tend(k,j,i)                                      &
+                      & + ( kmxp * ( v(k,j,i+1) - v(k,j,i)     ) * ddx         &
+                      &   + kmxp * ( u(k,j,i+1) - u(k,j-1,i+1) ) * ddy         &
+                      &   - kmxm * ( v(k,j,i) - v(k,j,i-1) ) * ddx             &
+                      &   - kmxm * ( u(k,j,i) - u(k,j-1,i) ) * ddy             &
+                      &   ) * ddx                                              &
+                      & + 2.0_wp * (                                           &
+                      &           km(k,j,i)   * ( v(k,j+1,i) - v(k,j,i) )      &
+                      &         - km(k,j-1,i) * ( v(k,j,i) - v(k,j-1,i) )      &
+                      &            ) * ddy2
+             ENDDO
+
+!
+!--          Wall functions at the left and right walls, respectively
+             IF ( wall_v(j,i) /= 0.0_wp )  THEN
+
+                DO  k = nzb_v_inner(j,i)+1, nzb_v_outer(j,i)
+                   kmxp = 0.25_wp *                                            &
+                          ( km(k,j,i)+km(k,j,i+1)+km(k,j-1,i)+km(k,j-1,i+1) )
+                   kmxm = 0.25_wp *                                            &
+                          ( km(k,j,i)+km(k,j,i-1)+km(k,j-1,i)+km(k,j-1,i-1) )
+                   
+                   tend(k,j,i) = tend(k,j,i)                                   &
+                                 + 2.0_wp * (                                  &
+                                       km(k,j,i)   * ( v(k,j+1,i) - v(k,j,i) ) &
+                                     - km(k,j-1,i) * ( v(k,j,i) - v(k,j-1,i) ) &
+                                            ) * ddy2                           &
+                                 + (   fxp(j,i) * (                            &
+                                  kmxp * ( v(k,j,i+1) - v(k,j,i)     ) * ddx   &
+                                + kmxp * ( u(k,j,i+1) - u(k,j-1,i+1) ) * ddy   &
+                                                  )                            &
+                                     - fxm(j,i) * (                            &
+                                  kmxm * ( v(k,j,i) - v(k,j,i-1) ) * ddx       &
+                                + kmxm * ( u(k,j,i) - u(k,j-1,i) ) * ddy       &
+                                                  )                            &
+                                     + wall_v(j,i) * vsus(k,j,i)               &
+                                   ) * ddx
+                ENDDO
+             ENDIF
+
+!
+!--          Compute vertical diffusion. In case of simulating a Prandtl
+!--          layer, index k starts at nzb_v_inner+2.
+             DO  k = nzb_diff_v(j,i), nzt_diff
+!
+!--             Interpolate eddy diffusivities on staggered gridpoints
+                kmzp = 0.25_wp * &
+                       ( km(k,j,i)+km(k+1,j,i)+km(k,j-1,i)+km(k+1,j-1,i) )
+                kmzm = 0.25_wp * &
+                       ( km(k,j,i)+km(k-1,j,i)+km(k,j-1,i)+km(k-1,j-1,i) )
+
+                tend(k,j,i) = tend(k,j,i)                                      &
+                      & + ( kmzp * ( ( v(k+1,j,i) - v(k,j,i) ) * ddzu(k+1)     &
+                      &            + ( w(k,j,i) - w(k,j-1,i) ) * ddy           &
+                      &            )                                           &
+                      &   - kmzm * ( ( v(k,j,i)   - v(k-1,j,i)   ) * ddzu(k)   &
+                      &            + ( w(k-1,j,i) - w(k-1,j-1,i) ) * ddy       &
+                      &            )                                           &
+                      &   ) * ddzw(k)
+             ENDDO
+
+!
+!--          Vertical diffusion at the first grid point above the surface,
+!--          if the momentum flux at the bottom is given by the Prandtl law
+!--          or if it is prescribed by the user.
+!--          Difference quotient of the momentum flux is not formed over
+!--          half of the grid spacing (2.0*ddzw(k)) any more, since the
+!--          comparison with other (LES) models showed that the values of
+!--          the momentum flux becomes too large in this case.
+!--          The term containing w(k-1,..) (see above equation) is removed here
+!--          because the vertical velocity is assumed to be zero at the surface.
+             IF ( use_surface_fluxes )  THEN
+                k = nzb_v_inner(j,i)+1
+!
+!--             Interpolate eddy diffusivities on staggered gridpoints
+                kmzp = 0.25_wp *                                               &
+                       ( km(k,j,i)+km(k+1,j,i)+km(k,j-1,i)+km(k+1,j-1,i) )
+
+                tend(k,j,i) = tend(k,j,i)                                      &
+                      & + ( kmzp * ( w(k,j,i) - w(k,j-1,i)     ) * ddy         &
+                      &   ) * ddzw(k)                                          &
+                      & + ( kmzp * ( v(k+1,j,i) - v(k,j,i)     ) * ddzu(k+1)   &
+                      &   + vsws(j,i)                                          &
+                      &   ) * ddzw(k)
+             ENDIF
+
+!
+!--          Vertical diffusion at the first gridpoint below the top boundary,
+!--          if the momentum flux at the top is prescribed by the user
+             IF ( use_top_fluxes  .AND.  constant_top_momentumflux )  THEN
+                k = nzt
+!
+!--             Interpolate eddy diffusivities on staggered gridpoints
+                kmzm = 0.25_wp *                                               &
+                       ( km(k,j,i)+km(k-1,j,i)+km(k,j-1,i)+km(k-1,j-1,i) )
+
+                tend(k,j,i) = tend(k,j,i)                                      &
+                      & - ( kmzm *  ( w(k-1,j,i) - w(k-1,j-1,i) ) * ddy        &
+                      &   ) * ddzw(k)                                          &
+                      & + ( -vswst(j,i)                                        &
+                      &   - kmzm * ( v(k,j,i)   - v(k-1,j,i)    ) * ddzu(k)    &
+                      &   ) * ddzw(k)
+             ENDIF
+
+          ENDDO
+       ENDDO
+
+    END SUBROUTINE diffusion_v
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Call for all grid points - accelerator version
+!------------------------------------------------------------------------------!
+    SUBROUTINE diffusion_v_acc
+
+       USE arrays_3d,                                                          &
+           ONLY:  ddzu, ddzw, km, tend, u, v, vsws, vswst, w
+       
+       USE control_parameters,                                                 &
+           ONLY:  constant_top_momentumflux, topography, use_surface_fluxes,   &
+                  use_top_fluxes
+       
+       USE grid_variables,                                                     &
+           ONLY:  ddx, ddy, ddy2, fxm, fxp, wall_v
+       
+       USE indices,                                                            &
+           ONLY:  i_left, i_right, j_north, j_south, nxl, nxr, nyn, nys, nzb,  &
+                  nzb_diff_v, nzb_v_inner, nzb_v_outer, nzt, nzt_diff
+       
+       USE kinds
+
+       IMPLICIT NONE
+
+       INTEGER(iwp) ::  i     !< 
+       INTEGER(iwp) ::  j     !< 
+       INTEGER(iwp) ::  k     !< 
+       REAL(wp)     ::  kmxm  !< 
+       REAL(wp)     ::  kmxp  !< 
+       REAL(wp)     ::  kmzm  !< 
+       REAL(wp)     ::  kmzp  !< 
+
+       REAL(wp), DIMENSION(nzb:nzt+1,nys:nyn,nxl:nxr) ::  vsus  !< 
+       !$acc declare create ( vsus )
+
+!
+!--    First calculate horizontal momentum flux v'u' at vertical walls,
+!--    if neccessary
+       IF ( topography /= 'flat' )  THEN
+          CALL wall_fluxes_acc( vsus, 0.0_wp, 1.0_wp, 0.0_wp, 0.0_wp,          &
+                                nzb_v_inner, nzb_v_outer, wall_v )
+       ENDIF
+
+       !$acc kernels present ( u, v, w, km, tend, vsws, vswst )                &
+       !$acc         present ( ddzu, ddzw, fxm, fxp, wall_v )                  &
+       !$acc         present ( nzb_v_inner, nzb_v_outer, nzb_diff_v )
+       DO  i = i_left, i_right
+          DO  j = j_south, j_north
+!
+!--          Compute horizontal diffusion
+             DO  k = 1, nzt
+                IF ( k > nzb_v_outer(j,i) )  THEN
+!
+!--                Interpolate eddy diffusivities on staggered gridpoints
+                   kmxp = 0.25_wp *                                            &
+                          ( km(k,j,i)+km(k,j,i+1)+km(k,j-1,i)+km(k,j-1,i+1) )
+                   kmxm = 0.25_wp *                                            &
+                          ( km(k,j,i)+km(k,j,i-1)+km(k,j-1,i)+km(k,j-1,i-1) )
+
+                   tend(k,j,i) = tend(k,j,i)                                   &
+                         & + ( kmxp * ( v(k,j,i+1) - v(k,j,i)     ) * ddx      &
+                         &   + kmxp * ( u(k,j,i+1) - u(k,j-1,i+1) ) * ddy      &
+                         &   - kmxm * ( v(k,j,i) - v(k,j,i-1) ) * ddx          &
+                         &   - kmxm * ( u(k,j,i) - u(k,j-1,i) ) * ddy          &
+                         &   ) * ddx                                           &
+                         & + 2.0_wp * (                                        &
+                         &           km(k,j,i)   * ( v(k,j+1,i) - v(k,j,i) )   &
+                         &         - km(k,j-1,i) * ( v(k,j,i) - v(k,j-1,i) )   &
+                         &            ) * ddy2
+                ENDIF
+             ENDDO
+
+!
+!--          Wall functions at the left and right walls, respectively
+             DO  k = 1, nzt
+                IF( k > nzb_v_inner(j,i)  .AND.  k <= nzb_v_outer(j,i)  .AND.  &
+                    wall_v(j,i) /= 0.0_wp )  THEN
+
+                   kmxp = 0.25_wp *                                            &
+                          ( km(k,j,i)+km(k,j,i+1)+km(k,j-1,i)+km(k,j-1,i+1) )
+                   kmxm = 0.25_wp *                                            &
+                          ( km(k,j,i)+km(k,j,i-1)+km(k,j-1,i)+km(k,j-1,i-1) )
+                   
+                   tend(k,j,i) = tend(k,j,i)                                   &
+                                 + 2.0_wp * (                                  &
+                                       km(k,j,i)   * ( v(k,j+1,i) - v(k,j,i) ) &
+                                     - km(k,j-1,i) * ( v(k,j,i) - v(k,j-1,i) ) &
+                                            ) * ddy2                           &
+                                 + (   fxp(j,i) * (                            &
+                                  kmxp * ( v(k,j,i+1) - v(k,j,i)     ) * ddx   &
+                                + kmxp * ( u(k,j,i+1) - u(k,j-1,i+1) ) * ddy   &
+                                                  )                            &
+                                     - fxm(j,i) * (                            &
+                                  kmxm * ( v(k,j,i) - v(k,j,i-1) ) * ddx       &
+                                + kmxm * ( u(k,j,i) - u(k,j-1,i) ) * ddy       &
+                                                  )                            &
+                                     + wall_v(j,i) * vsus(k,j,i)               &
+                                   ) * ddx
+                ENDIF
+             ENDDO
+
+!
+!--          Compute vertical diffusion. In case of simulating a Prandtl
+!--          layer, index k starts at nzb_v_inner+2.
+             DO  k = 1, nzt_diff
+                IF ( k >= nzb_diff_v(j,i) )  THEN
+!
+!--                Interpolate eddy diffusivities on staggered gridpoints
+                   kmzp = 0.25_wp *                                            &
+                          ( km(k,j,i)+km(k+1,j,i)+km(k,j-1,i)+km(k+1,j-1,i) )
+                   kmzm = 0.25_wp *                                            &
+                          ( km(k,j,i)+km(k-1,j,i)+km(k,j-1,i)+km(k-1,j-1,i) )
+
+                   tend(k,j,i) = tend(k,j,i)                                   &
+                         & + ( kmzp * ( ( v(k+1,j,i) - v(k,j,i)   ) * ddzu(k+1)&
+                         &            + ( w(k,j,i)   - w(k,j-1,i) ) * ddy      &
+                         &            )                                        &
+                         &   - kmzm * ( ( v(k,j,i)   - v(k-1,j,i)   ) * ddzu(k)&
+                         &            + ( w(k-1,j,i) - w(k-1,j-1,i) ) * ddy    &
+                         &            )                                        &
+                         &   ) * ddzw(k)
+                ENDIF
+             ENDDO
+
+          ENDDO
+       ENDDO
+
+!
+!--    Vertical diffusion at the first grid point above the surface,
+!--    if the momentum flux at the bottom is given by the Prandtl law
+!--    or if it is prescribed by the user.
+!--    Difference quotient of the momentum flux is not formed over
+!--    half of the grid spacing (2.0*ddzw(k)) any more, since the
+!--    comparison with other (LES) models showed that the values of
+!--    the momentum flux becomes too large in this case.
+!--    The term containing w(k-1,..) (see above equation) is removed here
+!--    because the vertical velocity is assumed to be zero at the surface.
+       IF ( use_surface_fluxes )  THEN
+
+          DO  i = i_left, i_right
+             DO  j = j_south, j_north
+          
+                k = nzb_v_inner(j,i)+1
+!
+!--             Interpolate eddy diffusivities on staggered gridpoints
+                kmzp = 0.25_wp *                                               &
+                       ( km(k,j,i)+km(k+1,j,i)+km(k,j-1,i)+km(k+1,j-1,i) )
+
+                tend(k,j,i) = tend(k,j,i)                                      &
+                      & + ( kmzp * ( w(k,j,i) - w(k,j-1,i)     ) * ddy         &
+                      &   ) * ddzw(k)                                          &
+                      & + ( kmzp * ( v(k+1,j,i) - v(k,j,i)     ) * ddzu(k+1)   &
+                      &   + vsws(j,i)                                          &
+                      &   ) * ddzw(k)
+             ENDDO
+          ENDDO
+
+       ENDIF
+
+!
+!--    Vertical diffusion at the first gridpoint below the top boundary,
+!--    if the momentum flux at the top is prescribed by the user
+       IF ( use_top_fluxes  .AND.  constant_top_momentumflux )  THEN
+
+          k = nzt
+
+          DO  i = i_left, i_right
+             DO  j = j_south, j_north
+
+!
+!--             Interpolate eddy diffusivities on staggered gridpoints
+                kmzm = 0.25_wp *                                               &
+                       ( km(k,j,i)+km(k-1,j,i)+km(k,j-1,i)+km(k-1,j-1,i) )
+
+                tend(k,j,i) = tend(k,j,i)                                      &
+                      & - ( kmzm *  ( w(k-1,j,i) - w(k-1,j-1,i) ) * ddy        &
+                      &   ) * ddzw(k)                                          &
+                      & + ( -vswst(j,i)                                        &
+                      &   - kmzm * ( v(k,j,i)   - v(k-1,j,i)    ) * ddzu(k)    &
+                      &   ) * ddzw(k)
+             ENDDO
+          ENDDO
+
+       ENDIF
+       !$acc end kernels
+
+    END SUBROUTINE diffusion_v_acc
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Call for grid point i,j
+!------------------------------------------------------------------------------!
+    SUBROUTINE diffusion_v_ij( i, j )
+
+       USE arrays_3d,                                                          &
+           ONLY:  ddzu, ddzw, km, tend, u, v, vsws, vswst, w
+       
+       USE control_parameters,                                                 &
+           ONLY:  constant_top_momentumflux, use_surface_fluxes, use_top_fluxes
+       
+       USE grid_variables,                                                     &
+           ONLY:  ddx, ddy, ddy2, fxm, fxp, wall_v
+       
+       USE indices,                                                            &
+           ONLY:  nzb, nzb_diff_v, nzb_v_inner, nzb_v_outer, nzt, nzt_diff
+       
+       USE kinds
+
+       IMPLICIT NONE
+
+       INTEGER(iwp) ::  i     !< 
+       INTEGER(iwp) ::  j     !< 
+       INTEGER(iwp) ::  k     !< 
+       REAL(wp)     ::  kmxm  !< 
+       REAL(wp)     ::  kmxp  !< 
+       REAL(wp)     ::  kmzm  !< 
+       REAL(wp)     ::  kmzp  !< 
+
+       REAL(wp), DIMENSION(nzb:nzt+1) ::  vsus  !< 
+
+!
+!--    Compute horizontal diffusion
+       DO  k = nzb_v_outer(j,i)+1, nzt
+!
+!--       Interpolate eddy diffusivities on staggered gridpoints
+          kmxp = 0.25_wp * ( km(k,j,i)+km(k,j,i+1)+km(k,j-1,i)+km(k,j-1,i+1) )
+          kmxm = 0.25_wp * ( km(k,j,i)+km(k,j,i-1)+km(k,j-1,i)+km(k,j-1,i-1) )
+
+          tend(k,j,i) = tend(k,j,i)                                            &
+                      & + ( kmxp * ( v(k,j,i+1) - v(k,j,i)     ) * ddx         &
+                      &   + kmxp * ( u(k,j,i+1) - u(k,j-1,i+1) ) * ddy         &
+                      &   - kmxm * ( v(k,j,i) - v(k,j,i-1) ) * ddx             &
+                      &   - kmxm * ( u(k,j,i) - u(k,j-1,i) ) * ddy             &
+                      &   ) * ddx                                              &
+                      & + 2.0_wp * (                                           &
+                      &           km(k,j,i)   * ( v(k,j+1,i) - v(k,j,i) )      &
+                      &         - km(k,j-1,i) * ( v(k,j,i) - v(k,j-1,i) )      &
+                      &            ) * ddy2
+       ENDDO
+
+!
+!--    Wall functions at the left and right walls, respectively
+       IF ( wall_v(j,i) /= 0.0_wp )  THEN
+
+!
+!--       Calculate the horizontal momentum flux v'u'
+          CALL wall_fluxes( i, j, nzb_v_inner(j,i)+1, nzb_v_outer(j,i),        &
+                            vsus, 0.0_wp, 1.0_wp, 0.0_wp, 0.0_wp )
+
+          DO  k = nzb_v_inner(j,i)+1, nzb_v_outer(j,i)
+             kmxp = 0.25_wp *                                                  &
+                    ( km(k,j,i)+km(k,j,i+1)+km(k,j-1,i)+km(k,j-1,i+1) )
+             kmxm = 0.25_wp *                                                  &
+                    ( km(k,j,i)+km(k,j,i-1)+km(k,j-1,i)+km(k,j-1,i-1) )
+
+             tend(k,j,i) = tend(k,j,i)                                         &
+                                 + 2.0_wp * (                                  &
+                                       km(k,j,i)   * ( v(k,j+1,i) - v(k,j,i) ) &
+                                     - km(k,j-1,i) * ( v(k,j,i) - v(k,j-1,i) ) &
+                                            ) * ddy2                           &
+                                 + (   fxp(j,i) * (                            &
+                                  kmxp * ( v(k,j,i+1) - v(k,j,i)     ) * ddx   &
+                                + kmxp * ( u(k,j,i+1) - u(k,j-1,i+1) ) * ddy   &
+                                                  )                            &
+                                     - fxm(j,i) * (                            &
+                                  kmxm * ( v(k,j,i) - v(k,j,i-1) ) * ddx       &
+                                + kmxm * ( u(k,j,i) - u(k,j-1,i) ) * ddy       &
+                                                  )                            &
+                                     + wall_v(j,i) * vsus(k)                   &
+                                   ) * ddx
+          ENDDO
+       ENDIF
+
+!
+!--    Compute vertical diffusion. In case of simulating a Prandtl layer,
+!--    index k starts at nzb_v_inner+2.
+       DO  k = nzb_diff_v(j,i), nzt_diff
+!
+!--       Interpolate eddy diffusivities on staggered gridpoints
+          kmzp = 0.25_wp * ( km(k,j,i)+km(k+1,j,i)+km(k,j-1,i)+km(k+1,j-1,i) )
+          kmzm = 0.25_wp * ( km(k,j,i)+km(k-1,j,i)+km(k,j-1,i)+km(k-1,j-1,i) )
+
+          tend(k,j,i) = tend(k,j,i)                                            &
+                      & + ( kmzp * ( ( v(k+1,j,i) - v(k,j,i) ) * ddzu(k+1)     &
+                      &            + ( w(k,j,i) - w(k,j-1,i) ) * ddy           &
+                      &            )                                           &
+                      &   - kmzm * ( ( v(k,j,i)   - v(k-1,j,i)   ) * ddzu(k)   &
+                      &            + ( w(k-1,j,i) - w(k-1,j-1,i) ) * ddy       &
+                      &            )                                           &
+                      &   ) * ddzw(k)
+       ENDDO
+
+!
+!--    Vertical diffusion at the first grid point above the surface, if the
+!--    momentum flux at the bottom is given by the Prandtl law or if it is
+!--    prescribed by the user.
+!--    Difference quotient of the momentum flux is not formed over half of
+!--    the grid spacing (2.0*ddzw(k)) any more, since the comparison with 
+!--    other (LES) models showed that the values of the momentum flux becomes
+!--    too large in this case.
+!--    The term containing w(k-1,..) (see above equation) is removed here
+!--    because the vertical velocity is assumed to be zero at the surface.
+       IF ( use_surface_fluxes )  THEN
+          k = nzb_v_inner(j,i)+1
+!
+!--       Interpolate eddy diffusivities on staggered gridpoints
+          kmzp = 0.25_wp * ( km(k,j,i)+km(k+1,j,i)+km(k,j-1,i)+km(k+1,j-1,i) )
+
+          tend(k,j,i) = tend(k,j,i)                                            &
+                      & + ( kmzp * ( w(k,j,i) - w(k,j-1,i)     ) * ddy         &
+                      &   ) * ddzw(k)                                          &
+                      & + ( kmzp * ( v(k+1,j,i) - v(k,j,i)     ) * ddzu(k+1)   &
+                      &   + vsws(j,i)                                          &
+                      &   ) * ddzw(k)
+       ENDIF
+
+!
+!--    Vertical diffusion at the first gridpoint below the top boundary,
+!--    if the momentum flux at the top is prescribed by the user
+       IF ( use_top_fluxes  .AND.  constant_top_momentumflux )  THEN
+          k = nzt
+!
+!--       Interpolate eddy diffusivities on staggered gridpoints
+          kmzm = 0.25_wp * &
+                 ( km(k,j,i)+km(k-1,j,i)+km(k,j-1,i)+km(k-1,j-1,i) )
+
+          tend(k,j,i) = tend(k,j,i)                                            &
+                      & - ( kmzm *  ( w(k-1,j,i) - w(k-1,j-1,i) ) * ddy        &
+                      &   ) * ddzw(k)                                          &
+                      & + ( -vswst(j,i)                                        &
+                      &   - kmzm * ( v(k,j,i)   - v(k-1,j,i)    ) * ddzu(k)    &
+                      &   ) * ddzw(k)
+       ENDIF
+
+    END SUBROUTINE diffusion_v_ij
+
+ END MODULE diffusion_v_mod
Index: lm/trunk/SOURCE/diffusion_w.f90
===================================================================
--- /palm/trunk/SOURCE/diffusion_w.f90	(revision 1849)
+++ 	(revision )
@@ -1,482 +1,0 @@
-!> @file diffusion_w.f90
-!--------------------------------------------------------------------------------!
-! This file is part of PALM.
-!
-! PALM is free software: you can redistribute it and/or modify it under the terms
-! of the GNU General Public License as published by the Free Software Foundation,
-! either version 3 of the License, or (at your option) any later version.
-!
-! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
-! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
-! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along with
-! PALM. If not, see <http://www.gnu.org/licenses/>.
-!
-! Copyright 1997-2016 Leibniz Universitaet Hannover
-!--------------------------------------------------------------------------------!
-!
-! Current revisions:
-! -----------------
-! 
-! 
-! Former revisions:
-! -----------------
-! $Id$
-!
-! 1682 2015-10-07 23:56:08Z knoop
-! Code annotations made doxygen readable 
-! 
-! 1374 2014-04-25 12:55:07Z raasch
-! vsws + vswst removed from acc-present-list
-! 
-! 1353 2014-04-08 15:21:23Z heinze
-! REAL constants provided with KIND-attribute 
-! 
-! 1340 2014-03-25 19:45:13Z kanani
-! REAL constants defined as wp-kind
-!
-! 1322 2014-03-20 16:38:49Z raasch
-! REAL constants defined as wp-kind
-!
-! 1320 2014-03-20 08:40:49Z raasch
-! ONLY-attribute added to USE-statements,
-! kind-parameters added to all INTEGER and REAL declaration statements, 
-! kinds are defined in new module kinds, 
-! revision history before 2012 removed,
-! comment fields (!:) to be used for variable explanations added to
-! all variable declaration statements 
-!
-! 1257 2013-11-08 15:18:40Z raasch
-! openacc loop and loop vector clauses removed, declare create moved after
-! the FORTRAN declaration statement
-!
-! 1128 2013-04-12 06:19:32Z raasch
-! loop index bounds in accelerator version replaced by i_left, i_right, j_south,
-! j_north
-!
-! 1036 2012-10-22 13:43:42Z raasch
-! code put under GPL (PALM 3.9)
-!
-! 1015 2012-09-27 09:23:24Z raasch
-! accelerator version (*_acc) added
-!
-! 1001 2012-09-13 14:08:46Z raasch
-! arrays comunicated by module instead of parameter list
-!
-! 978 2012-08-09 08:28:32Z fricke
-! outflow damping layer removed
-! kmxm_x/_z and kmxp_x/_z change to kmxm and kmxp
-! kmym_y/_z and kmyp_y/_z change to kmym and kmyp
-!
-! Revision 1.1  1997/09/12 06:24:11  raasch
-! Initial revision
-!
-!
-! Description:
-! ------------
-!> Diffusion term of the w-component
-!------------------------------------------------------------------------------!
- MODULE diffusion_w_mod
- 
-
-    USE wall_fluxes_mod,                                                       &
-        ONLY :  wall_fluxes, wall_fluxes_acc
-
-    PRIVATE
-    PUBLIC diffusion_w, diffusion_w_acc
-
-    INTERFACE diffusion_w
-       MODULE PROCEDURE diffusion_w
-       MODULE PROCEDURE diffusion_w_ij
-    END INTERFACE diffusion_w
-
-    INTERFACE diffusion_w_acc
-       MODULE PROCEDURE diffusion_w_acc
-    END INTERFACE diffusion_w_acc
-
- CONTAINS
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Call for all grid points
-!------------------------------------------------------------------------------!
-    SUBROUTINE diffusion_w
-
-       USE arrays_3d,                                                          &          
-           ONLY :  ddzu, ddzw, km, tend, u, v, w
-           
-       USE control_parameters,                                                 & 
-           ONLY :  topography
-           
-       USE grid_variables,                                                     &     
-           ONLY :  ddx, ddy, fwxm, fwxp, fwym, fwyp, wall_w_x, wall_w_y
-           
-       USE indices,                                                            &            
-           ONLY :  nxl, nxr, nyn, nys, nzb, nzb_w_inner, nzb_w_outer, nzt
-           
-       USE kinds
-
-       IMPLICIT NONE
-
-       INTEGER(iwp) ::  i     !<
-       INTEGER(iwp) ::  j     !<
-       INTEGER(iwp) ::  k     !<
-       
-       REAL(wp) ::  kmxm  !<
-       REAL(wp) ::  kmxp  !<
-       REAL(wp) ::  kmym  !<
-       REAL(wp) ::  kmyp  !< 
-
-       REAL(wp), DIMENSION(nzb:nzt+1,nys:nyn,nxl:nxr) ::  wsus  !<
-       REAL(wp), DIMENSION(nzb:nzt+1,nys:nyn,nxl:nxr) ::  wsvs  !<
-
-
-!
-!--    First calculate horizontal momentum flux w'u' and/or w'v' at vertical
-!--    walls, if neccessary
-       IF ( topography /= 'flat' )  THEN
-          CALL wall_fluxes( wsus, 0.0_wp, 0.0_wp, 0.0_wp, 1.0_wp, nzb_w_inner,             &
-                            nzb_w_outer, wall_w_x )
-          CALL wall_fluxes( wsvs, 0.0_wp, 0.0_wp, 1.0_wp, 0.0_wp, nzb_w_inner,             &
-                            nzb_w_outer, wall_w_y )
-       ENDIF
-
-       DO  i = nxl, nxr
-          DO  j = nys, nyn
-             DO  k = nzb_w_outer(j,i)+1, nzt-1
-!
-!--             Interpolate eddy diffusivities on staggered gridpoints
-                kmxp = 0.25_wp *                                               &
-                       ( km(k,j,i)+km(k,j,i+1)+km(k+1,j,i)+km(k+1,j,i+1) )
-                kmxm = 0.25_wp *                                               &
-                       ( km(k,j,i)+km(k,j,i-1)+km(k+1,j,i)+km(k+1,j,i-1) )
-                kmyp = 0.25_wp *                                               &
-                       ( km(k,j,i)+km(k+1,j,i)+km(k,j+1,i)+km(k+1,j+1,i) )
-                kmym = 0.25_wp *                                               &
-                       ( km(k,j,i)+km(k+1,j,i)+km(k,j-1,i)+km(k+1,j-1,i) )
-
-                tend(k,j,i) = tend(k,j,i)                                      &
-                      & + ( kmxp * ( w(k,j,i+1)   - w(k,j,i)   ) * ddx         &
-                      &   + kmxp * ( u(k+1,j,i+1) - u(k,j,i+1) ) * ddzu(k+1)   &
-                      &   - kmxm * ( w(k,j,i)   - w(k,j,i-1) ) * ddx           &
-                      &   - kmxm * ( u(k+1,j,i) - u(k,j,i)   ) * ddzu(k+1)     &
-                      &   ) * ddx                                              &
-                      & + ( kmyp * ( w(k,j+1,i)   - w(k,j,i)   ) * ddy         &
-                      &   + kmyp * ( v(k+1,j+1,i) - v(k,j+1,i) ) * ddzu(k+1)   &
-                      &   - kmym * ( w(k,j,i)   - w(k,j-1,i) ) * ddy           &
-                      &   - kmym * ( v(k+1,j,i) - v(k,j,i)   ) * ddzu(k+1)     &
-                      &   ) * ddy                                              &
-                      & + 2.0_wp * (                                           &
-                      &   km(k+1,j,i) * ( w(k+1,j,i) - w(k,j,i) ) * ddzw(k+1)  &
-                      & - km(k,j,i)   * ( w(k,j,i)   - w(k-1,j,i) ) * ddzw(k)  &
-                      &            ) * ddzu(k+1)
-             ENDDO
-
-!
-!--          Wall functions at all vertical walls, where necessary
-             IF ( wall_w_x(j,i) /= 0.0_wp  .OR.  wall_w_y(j,i) /= 0.0_wp )  THEN
-
-                DO  k = nzb_w_inner(j,i)+1, nzb_w_outer(j,i)
-!
-!--                Interpolate eddy diffusivities on staggered gridpoints
-                   kmxp = 0.25_wp *                                            &
-                          ( km(k,j,i)+km(k,j,i+1)+km(k+1,j,i)+km(k+1,j,i+1) )
-                   kmxm = 0.25_wp *                                            &
-                          ( km(k,j,i)+km(k,j,i-1)+km(k+1,j,i)+km(k+1,j,i-1) )
-                   kmyp = 0.25_wp *                                            &
-                          ( km(k,j,i)+km(k+1,j,i)+km(k,j+1,i)+km(k+1,j+1,i) )
-                   kmym = 0.25_wp *                                            &
-                          ( km(k,j,i)+km(k+1,j,i)+km(k,j-1,i)+km(k+1,j-1,i) )
-
-                   tend(k,j,i) = tend(k,j,i)                                   &
-                                 + (   fwxp(j,i) * (                           &
-                            kmxp * ( w(k,j,i+1)   - w(k,j,i)   ) * ddx         &
-                          + kmxp * ( u(k+1,j,i+1) - u(k,j,i+1) ) * ddzu(k+1)   &
-                                                   )                           &
-                                     - fwxm(j,i) * (                           &
-                            kmxm * ( w(k,j,i)     - w(k,j,i-1) ) * ddx         &
-                          + kmxm * ( u(k+1,j,i)   - u(k,j,i)   ) * ddzu(k+1)   &
-                                                   )                           &
-                                     + wall_w_x(j,i) * wsus(k,j,i)             &
-                                   ) * ddx                                     &
-                                 + (   fwyp(j,i) * (                           &
-                            kmyp * ( w(k,j+1,i)   - w(k,j,i)   ) * ddy         &
-                          + kmyp * ( v(k+1,j+1,i) - v(k,j+1,i) ) * ddzu(k+1)   &
-                                                   )                           &
-                                     - fwym(j,i) * (                           &
-                            kmym * ( w(k,j,i)     - w(k,j-1,i) ) * ddy         &
-                          + kmym * ( v(k+1,j,i)   - v(k,j,i)   ) * ddzu(k+1)   &
-                                                   )                           &
-                                     + wall_w_y(j,i) * wsvs(k,j,i)             &
-                                   ) * ddy                                     &
-                                 + 2.0_wp * (                                  &
-                           km(k+1,j,i) * ( w(k+1,j,i) - w(k,j,i) ) * ddzw(k+1) &
-                         - km(k,j,i)   * ( w(k,j,i)   - w(k-1,j,i) ) * ddzw(k) &
-                                            ) * ddzu(k+1)
-                ENDDO
-             ENDIF
-
-          ENDDO
-       ENDDO
-
-    END SUBROUTINE diffusion_w
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Call for all grid points - accelerator version
-!------------------------------------------------------------------------------!
-    SUBROUTINE diffusion_w_acc
-
-       USE arrays_3d,                                                          &
-           ONLY :  ddzu, ddzw, km, tend, u, v, w
-           
-       USE control_parameters,                                                 &
-           ONLY :  topography
-           
-       USE grid_variables,                                                     &
-           ONLY : ddx, ddy, fwxm, fwxp, fwym, fwyp, wall_w_x, wall_w_y
-           
-       USE indices,                                                            &
-           ONLY :  i_left, i_right, j_north, j_south, nxl, nxr, nyn, nys, nzb, &
-                   nzb_w_inner, nzb_w_outer, nzt
-                   
-       USE kinds
-
-       IMPLICIT NONE
-
-       INTEGER(iwp) ::  i     !<
-       INTEGER(iwp) ::  j     !<
-       INTEGER(iwp) ::  k     !<
-       
-       REAL(wp) ::  kmxm  !<
-       REAL(wp) ::  kmxp  !<
-       REAL(wp) ::  kmym  !<
-       REAL(wp) ::  kmyp  !< 
-
-       REAL(wp), DIMENSION(nzb:nzt+1,nys:nyn,nxl:nxr) ::  wsus  !<
-       REAL(wp), DIMENSION(nzb:nzt+1,nys:nyn,nxl:nxr) ::  wsvs  !<
-       !$acc declare create ( wsus, wsvs )
-
-!
-!--    First calculate horizontal momentum flux w'u' and/or w'v' at vertical
-!--    walls, if neccessary
-       IF ( topography /= 'flat' )  THEN
-          CALL wall_fluxes_acc( wsus, 0.0_wp, 0.0_wp, 0.0_wp, 1.0_wp,          &
-                                nzb_w_inner, nzb_w_outer, wall_w_x )
-          CALL wall_fluxes_acc( wsvs, 0.0_wp, 0.0_wp, 0.0_wp, 1.0_wp,          &
-                                nzb_w_inner, nzb_w_outer, wall_w_y )
-       ENDIF
-
-       !$acc kernels present ( u, v, w, km, tend )                             &
-       !$acc         present ( ddzu, ddzw, fwxm, fwxp, fwym, fwyp, wall_w_x, wall_w_y )           &
-       !$acc         present ( nzb_w_inner, nzb_w_outer )
-       DO  i = i_left, i_right
-          DO  j = j_south, j_north
-             DO  k = 1, nzt
-                IF ( k > nzb_w_outer(j,i) )  THEN
-!
-!--                Interpolate eddy diffusivities on staggered gridpoints
-                   kmxp = 0.25_wp *                                            &
-                          ( km(k,j,i)+km(k,j,i+1)+km(k+1,j,i)+km(k+1,j,i+1) )
-                   kmxm = 0.25_wp *                                            &
-                          ( km(k,j,i)+km(k,j,i-1)+km(k+1,j,i)+km(k+1,j,i-1) )
-                   kmyp = 0.25_wp *                                            &
-                          ( km(k,j,i)+km(k+1,j,i)+km(k,j+1,i)+km(k+1,j+1,i) )
-                   kmym = 0.25_wp *                                            &
-                          ( km(k,j,i)+km(k+1,j,i)+km(k,j-1,i)+km(k+1,j-1,i) )
-
-                   tend(k,j,i) = tend(k,j,i)                                     &
-                         & + ( kmxp * ( w(k,j,i+1)   - w(k,j,i)   ) * ddx        &
-                         &   + kmxp * ( u(k+1,j,i+1) - u(k,j,i+1) ) * ddzu(k+1)  &
-                         &   - kmxm * ( w(k,j,i)   - w(k,j,i-1) ) * ddx          &
-                         &   - kmxm * ( u(k+1,j,i) - u(k,j,i)   ) * ddzu(k+1)    &
-                         &   ) * ddx                                             &
-                         & + ( kmyp * ( w(k,j+1,i)   - w(k,j,i)   ) * ddy        &
-                         &   + kmyp * ( v(k+1,j+1,i) - v(k,j+1,i) ) * ddzu(k+1)  &
-                         &   - kmym * ( w(k,j,i)   - w(k,j-1,i) ) * ddy          &
-                         &   - kmym * ( v(k+1,j,i) - v(k,j,i)   ) * ddzu(k+1)    &
-                         &   ) * ddy                                             &
-                         & + 2.0_wp * (                                          &
-                         &   km(k+1,j,i) * ( w(k+1,j,i) - w(k,j,i) ) * ddzw(k+1) &
-                         & - km(k,j,i)   * ( w(k,j,i)   - w(k-1,j,i) ) * ddzw(k) &
-                         &            ) * ddzu(k+1)
-                ENDIF
-             ENDDO
-
-!
-!--          Wall functions at all vertical walls, where necessary
-             DO  k = 1,nzt
-
-                IF ( k > nzb_w_inner(j,i)  .AND.  k <= nzb_w_outer(j,i)  .AND. &
-                     wall_w_x(j,i) /= 0.0_wp  .AND.  wall_w_y(j,i) /= 0.0_wp )  THEN
-!
-!--                Interpolate eddy diffusivities on staggered gridpoints
-                   kmxp = 0.25_wp *                                            &
-                          ( km(k,j,i)+km(k,j,i+1)+km(k+1,j,i)+km(k+1,j,i+1) )
-                   kmxm = 0.25_wp *                                            &
-                          ( km(k,j,i)+km(k,j,i-1)+km(k+1,j,i)+km(k+1,j,i-1) )
-                   kmyp = 0.25_wp *                                            &
-                          ( km(k,j,i)+km(k+1,j,i)+km(k,j+1,i)+km(k+1,j+1,i) )
-                   kmym = 0.25_wp *                                            &
-                          ( km(k,j,i)+km(k+1,j,i)+km(k,j-1,i)+km(k+1,j-1,i) )
-
-                   tend(k,j,i) = tend(k,j,i)                                   &
-                                 + (   fwxp(j,i) * (                           &
-                            kmxp * ( w(k,j,i+1)   - w(k,j,i)   ) * ddx         &
-                          + kmxp * ( u(k+1,j,i+1) - u(k,j,i+1) ) * ddzu(k+1)   &
-                                                   )                           &
-                                     - fwxm(j,i) * (                           &
-                            kmxm * ( w(k,j,i)     - w(k,j,i-1) ) * ddx         &
-                          + kmxm * ( u(k+1,j,i)   - u(k,j,i)   ) * ddzu(k+1)   &
-                                                   )                           &
-                                     + wall_w_x(j,i) * wsus(k,j,i)             &
-                                   ) * ddx                                     &
-                                 + (   fwyp(j,i) * (                           &
-                            kmyp * ( w(k,j+1,i)   - w(k,j,i)   ) * ddy         &
-                          + kmyp * ( v(k+1,j+1,i) - v(k,j+1,i) ) * ddzu(k+1)   &
-                                                   )                           &
-                                     - fwym(j,i) * (                           &
-                            kmym * ( w(k,j,i)     - w(k,j-1,i) ) * ddy         &
-                          + kmym * ( v(k+1,j,i)   - v(k,j,i)   ) * ddzu(k+1)   &
-                                                   )                           &
-                                     + wall_w_y(j,i) * wsvs(k,j,i)             &
-                                   ) * ddy                                     &
-                                 + 2.0_wp * (                                  &
-                           km(k+1,j,i) * ( w(k+1,j,i) - w(k,j,i) ) * ddzw(k+1) &
-                         - km(k,j,i)   * ( w(k,j,i)   - w(k-1,j,i) ) * ddzw(k) &
-                                            ) * ddzu(k+1)
-                ENDIF
-             ENDDO
-
-          ENDDO
-       ENDDO
-       !$acc end kernels
-
-    END SUBROUTINE diffusion_w_acc
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Call for grid point i,j
-!------------------------------------------------------------------------------!
-    SUBROUTINE diffusion_w_ij( i, j )
-
-       USE arrays_3d,                                                          &          
-           ONLY :  ddzu, ddzw, km, tend, u, v, w
-           
-       USE control_parameters,                                                 & 
-           ONLY :  topography
-           
-       USE grid_variables,                                                     &     
-           ONLY :  ddx, ddy, fwxm, fwxp, fwym, fwyp, wall_w_x, wall_w_y
-           
-       USE indices,                                                            &            
-           ONLY :  nxl, nxr, nyn, nys, nzb, nzb_w_inner, nzb_w_outer, nzt
-           
-       USE kinds
-
-       IMPLICIT NONE
-
-       INTEGER(iwp) ::  i     !<
-       INTEGER(iwp) ::  j     !<
-       INTEGER(iwp) ::  k     !<
-       
-       REAL(wp) ::  kmxm  !<
-       REAL(wp) ::  kmxp  !<
-       REAL(wp) ::  kmym  !<
-       REAL(wp) ::  kmyp  !< 
-
-       REAL(wp), DIMENSION(nzb:nzt+1) ::  wsus
-       REAL(wp), DIMENSION(nzb:nzt+1) ::  wsvs
-
-
-       DO  k = nzb_w_outer(j,i)+1, nzt-1
-!
-!--       Interpolate eddy diffusivities on staggered gridpoints
-          kmxp = 0.25_wp * ( km(k,j,i)+km(k,j,i+1)+km(k+1,j,i)+km(k+1,j,i+1) )
-          kmxm = 0.25_wp * ( km(k,j,i)+km(k,j,i-1)+km(k+1,j,i)+km(k+1,j,i-1) )
-          kmyp = 0.25_wp * ( km(k,j,i)+km(k+1,j,i)+km(k,j+1,i)+km(k+1,j+1,i) )
-          kmym = 0.25_wp * ( km(k,j,i)+km(k+1,j,i)+km(k,j-1,i)+km(k+1,j-1,i) )
-
-          tend(k,j,i) = tend(k,j,i)                                            &
-                      & + ( kmxp * ( w(k,j,i+1)   - w(k,j,i)   ) * ddx         &
-                      &   + kmxp * ( u(k+1,j,i+1) - u(k,j,i+1) ) * ddzu(k+1)   &
-                      &   - kmxm * ( w(k,j,i)   - w(k,j,i-1) ) * ddx           &
-                      &   - kmxm * ( u(k+1,j,i) - u(k,j,i)   ) * ddzu(k+1)     &
-                      &   ) * ddx                                              &
-                      & + ( kmyp * ( w(k,j+1,i)   - w(k,j,i)   ) * ddy         &
-                      &   + kmyp * ( v(k+1,j+1,i) - v(k,j+1,i) ) * ddzu(k+1)   &
-                      &   - kmym * ( w(k,j,i)   - w(k,j-1,i) ) * ddy           &
-                      &   - kmym * ( v(k+1,j,i) - v(k,j,i)   ) * ddzu(k+1)     &
-                      &   ) * ddy                                              &
-                      & + 2.0_wp * (                                           &
-                      &   km(k+1,j,i) * ( w(k+1,j,i) - w(k,j,i) ) * ddzw(k+1)  &
-                      & - km(k,j,i)   * ( w(k,j,i)   - w(k-1,j,i) ) * ddzw(k)  &
-                      &            ) * ddzu(k+1)
-       ENDDO
-
-!
-!--    Wall functions at all vertical walls, where necessary
-       IF ( wall_w_x(j,i) /= 0.0_wp  .OR.  wall_w_y(j,i) /= 0.0_wp )  THEN
-
-!
-!--       Calculate the horizontal momentum fluxes w'u' and/or w'v'
-          IF ( wall_w_x(j,i) /= 0.0_wp )  THEN
-             CALL wall_fluxes( i, j, nzb_w_inner(j,i)+1, nzb_w_outer(j,i),     &
-                               wsus, 0.0_wp, 0.0_wp, 0.0_wp, 1.0_wp )
-          ELSE
-             wsus = 0.0_wp
-          ENDIF
-
-          IF ( wall_w_y(j,i) /= 0.0_wp )  THEN
-             CALL wall_fluxes( i, j, nzb_w_inner(j,i)+1, nzb_w_outer(j,i),     &
-                               wsvs, 0.0_wp, 0.0_wp, 1.0_wp, 0.0_wp )
-          ELSE
-             wsvs = 0.0_wp
-          ENDIF
-
-          DO  k = nzb_w_inner(j,i)+1, nzb_w_outer(j,i)
-!
-!--          Interpolate eddy diffusivities on staggered gridpoints
-             kmxp = 0.25_wp * ( km(k,j,i)+km(k,j,i+1)+km(k+1,j,i)+km(k+1,j,i+1) )
-             kmxm = 0.25_wp * ( km(k,j,i)+km(k,j,i-1)+km(k+1,j,i)+km(k+1,j,i-1) )
-             kmyp = 0.25_wp * ( km(k,j,i)+km(k+1,j,i)+km(k,j+1,i)+km(k+1,j+1,i) )
-             kmym = 0.25_wp * ( km(k,j,i)+km(k+1,j,i)+km(k,j-1,i)+km(k+1,j-1,i) )
-
-             tend(k,j,i) = tend(k,j,i)                                         &
-                                 + (   fwxp(j,i) * (                           &
-                            kmxp * ( w(k,j,i+1)   - w(k,j,i)   ) * ddx         &
-                          + kmxp * ( u(k+1,j,i+1) - u(k,j,i+1) ) * ddzu(k+1)   &
-                                                   )                           &
-                                     - fwxm(j,i) * (                           &
-                            kmxm * ( w(k,j,i)     - w(k,j,i-1) ) * ddx         &
-                          + kmxm * ( u(k+1,j,i)   - u(k,j,i)   ) * ddzu(k+1)   &
-                                                   )                           &
-                                     + wall_w_x(j,i) * wsus(k)                 &
-                                   ) * ddx                                     &
-                                 + (   fwyp(j,i) * (                           &
-                            kmyp * ( w(k,j+1,i)   - w(k,j,i)   ) * ddy         &
-                          + kmyp * ( v(k+1,j+1,i) - v(k,j+1,i) ) * ddzu(k+1)   &
-                                                   )                           &
-                                     - fwym(j,i) * (                           &
-                            kmym * ( w(k,j,i)     - w(k,j-1,i) ) * ddy         &
-                          + kmym * ( v(k+1,j,i)   - v(k,j,i)   ) * ddzu(k+1)   &
-                                                   )                           &
-                                     + wall_w_y(j,i) * wsvs(k)                 &
-                                   ) * ddy                                     &
-                                 + 2.0_wp * (                                  &
-                           km(k+1,j,i) * ( w(k+1,j,i) - w(k,j,i) ) * ddzw(k+1) &
-                         - km(k,j,i)   * ( w(k,j,i)   - w(k-1,j,i) ) * ddzw(k) &
-                                            ) * ddzu(k+1)
-          ENDDO
-       ENDIF
-
-    END SUBROUTINE diffusion_w_ij
-
- END MODULE diffusion_w_mod
Index: /palm/trunk/SOURCE/diffusion_w_mod.f90
===================================================================
--- /palm/trunk/SOURCE/diffusion_w_mod.f90	(revision 1850)
+++ /palm/trunk/SOURCE/diffusion_w_mod.f90	(revision 1850)
@@ -0,0 +1,483 @@
+!> @file diffusion_w_mod.f90
+!--------------------------------------------------------------------------------!
+! This file is part of PALM.
+!
+! PALM is free software: you can redistribute it and/or modify it under the terms
+! of the GNU General Public License as published by the Free Software Foundation,
+! either version 3 of the License, or (at your option) any later version.
+!
+! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
+! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
+! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along with
+! PALM. If not, see <http://www.gnu.org/licenses/>.
+!
+! Copyright 1997-2016 Leibniz Universitaet Hannover
+!--------------------------------------------------------------------------------!
+!
+! Current revisions:
+! -----------------
+! Module renamed
+! 
+! 
+! Former revisions:
+! -----------------
+! $Id$
+!
+! 1682 2015-10-07 23:56:08Z knoop
+! Code annotations made doxygen readable 
+! 
+! 1374 2014-04-25 12:55:07Z raasch
+! vsws + vswst removed from acc-present-list
+! 
+! 1353 2014-04-08 15:21:23Z heinze
+! REAL constants provided with KIND-attribute 
+! 
+! 1340 2014-03-25 19:45:13Z kanani
+! REAL constants defined as wp-kind
+!
+! 1322 2014-03-20 16:38:49Z raasch
+! REAL constants defined as wp-kind
+!
+! 1320 2014-03-20 08:40:49Z raasch
+! ONLY-attribute added to USE-statements,
+! kind-parameters added to all INTEGER and REAL declaration statements, 
+! kinds are defined in new module kinds, 
+! revision history before 2012 removed,
+! comment fields (!:) to be used for variable explanations added to
+! all variable declaration statements 
+!
+! 1257 2013-11-08 15:18:40Z raasch
+! openacc loop and loop vector clauses removed, declare create moved after
+! the FORTRAN declaration statement
+!
+! 1128 2013-04-12 06:19:32Z raasch
+! loop index bounds in accelerator version replaced by i_left, i_right, j_south,
+! j_north
+!
+! 1036 2012-10-22 13:43:42Z raasch
+! code put under GPL (PALM 3.9)
+!
+! 1015 2012-09-27 09:23:24Z raasch
+! accelerator version (*_acc) added
+!
+! 1001 2012-09-13 14:08:46Z raasch
+! arrays comunicated by module instead of parameter list
+!
+! 978 2012-08-09 08:28:32Z fricke
+! outflow damping layer removed
+! kmxm_x/_z and kmxp_x/_z change to kmxm and kmxp
+! kmym_y/_z and kmyp_y/_z change to kmym and kmyp
+!
+! Revision 1.1  1997/09/12 06:24:11  raasch
+! Initial revision
+!
+!
+! Description:
+! ------------
+!> Diffusion term of the w-component
+!------------------------------------------------------------------------------!
+ MODULE diffusion_w_mod
+ 
+
+    USE wall_fluxes_mod,                                                       &
+        ONLY :  wall_fluxes, wall_fluxes_acc
+
+    PRIVATE
+    PUBLIC diffusion_w, diffusion_w_acc
+
+    INTERFACE diffusion_w
+       MODULE PROCEDURE diffusion_w
+       MODULE PROCEDURE diffusion_w_ij
+    END INTERFACE diffusion_w
+
+    INTERFACE diffusion_w_acc
+       MODULE PROCEDURE diffusion_w_acc
+    END INTERFACE diffusion_w_acc
+
+ CONTAINS
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Call for all grid points
+!------------------------------------------------------------------------------!
+    SUBROUTINE diffusion_w
+
+       USE arrays_3d,                                                          &          
+           ONLY :  ddzu, ddzw, km, tend, u, v, w
+           
+       USE control_parameters,                                                 & 
+           ONLY :  topography
+           
+       USE grid_variables,                                                     &     
+           ONLY :  ddx, ddy, fwxm, fwxp, fwym, fwyp, wall_w_x, wall_w_y
+           
+       USE indices,                                                            &            
+           ONLY :  nxl, nxr, nyn, nys, nzb, nzb_w_inner, nzb_w_outer, nzt
+           
+       USE kinds
+
+       IMPLICIT NONE
+
+       INTEGER(iwp) ::  i     !<
+       INTEGER(iwp) ::  j     !<
+       INTEGER(iwp) ::  k     !<
+       
+       REAL(wp) ::  kmxm  !<
+       REAL(wp) ::  kmxp  !<
+       REAL(wp) ::  kmym  !<
+       REAL(wp) ::  kmyp  !< 
+
+       REAL(wp), DIMENSION(nzb:nzt+1,nys:nyn,nxl:nxr) ::  wsus  !<
+       REAL(wp), DIMENSION(nzb:nzt+1,nys:nyn,nxl:nxr) ::  wsvs  !<
+
+
+!
+!--    First calculate horizontal momentum flux w'u' and/or w'v' at vertical
+!--    walls, if neccessary
+       IF ( topography /= 'flat' )  THEN
+          CALL wall_fluxes( wsus, 0.0_wp, 0.0_wp, 0.0_wp, 1.0_wp, nzb_w_inner,             &
+                            nzb_w_outer, wall_w_x )
+          CALL wall_fluxes( wsvs, 0.0_wp, 0.0_wp, 1.0_wp, 0.0_wp, nzb_w_inner,             &
+                            nzb_w_outer, wall_w_y )
+       ENDIF
+
+       DO  i = nxl, nxr
+          DO  j = nys, nyn
+             DO  k = nzb_w_outer(j,i)+1, nzt-1
+!
+!--             Interpolate eddy diffusivities on staggered gridpoints
+                kmxp = 0.25_wp *                                               &
+                       ( km(k,j,i)+km(k,j,i+1)+km(k+1,j,i)+km(k+1,j,i+1) )
+                kmxm = 0.25_wp *                                               &
+                       ( km(k,j,i)+km(k,j,i-1)+km(k+1,j,i)+km(k+1,j,i-1) )
+                kmyp = 0.25_wp *                                               &
+                       ( km(k,j,i)+km(k+1,j,i)+km(k,j+1,i)+km(k+1,j+1,i) )
+                kmym = 0.25_wp *                                               &
+                       ( km(k,j,i)+km(k+1,j,i)+km(k,j-1,i)+km(k+1,j-1,i) )
+
+                tend(k,j,i) = tend(k,j,i)                                      &
+                      & + ( kmxp * ( w(k,j,i+1)   - w(k,j,i)   ) * ddx         &
+                      &   + kmxp * ( u(k+1,j,i+1) - u(k,j,i+1) ) * ddzu(k+1)   &
+                      &   - kmxm * ( w(k,j,i)   - w(k,j,i-1) ) * ddx           &
+                      &   - kmxm * ( u(k+1,j,i) - u(k,j,i)   ) * ddzu(k+1)     &
+                      &   ) * ddx                                              &
+                      & + ( kmyp * ( w(k,j+1,i)   - w(k,j,i)   ) * ddy         &
+                      &   + kmyp * ( v(k+1,j+1,i) - v(k,j+1,i) ) * ddzu(k+1)   &
+                      &   - kmym * ( w(k,j,i)   - w(k,j-1,i) ) * ddy           &
+                      &   - kmym * ( v(k+1,j,i) - v(k,j,i)   ) * ddzu(k+1)     &
+                      &   ) * ddy                                              &
+                      & + 2.0_wp * (                                           &
+                      &   km(k+1,j,i) * ( w(k+1,j,i) - w(k,j,i) ) * ddzw(k+1)  &
+                      & - km(k,j,i)   * ( w(k,j,i)   - w(k-1,j,i) ) * ddzw(k)  &
+                      &            ) * ddzu(k+1)
+             ENDDO
+
+!
+!--          Wall functions at all vertical walls, where necessary
+             IF ( wall_w_x(j,i) /= 0.0_wp  .OR.  wall_w_y(j,i) /= 0.0_wp )  THEN
+
+                DO  k = nzb_w_inner(j,i)+1, nzb_w_outer(j,i)
+!
+!--                Interpolate eddy diffusivities on staggered gridpoints
+                   kmxp = 0.25_wp *                                            &
+                          ( km(k,j,i)+km(k,j,i+1)+km(k+1,j,i)+km(k+1,j,i+1) )
+                   kmxm = 0.25_wp *                                            &
+                          ( km(k,j,i)+km(k,j,i-1)+km(k+1,j,i)+km(k+1,j,i-1) )
+                   kmyp = 0.25_wp *                                            &
+                          ( km(k,j,i)+km(k+1,j,i)+km(k,j+1,i)+km(k+1,j+1,i) )
+                   kmym = 0.25_wp *                                            &
+                          ( km(k,j,i)+km(k+1,j,i)+km(k,j-1,i)+km(k+1,j-1,i) )
+
+                   tend(k,j,i) = tend(k,j,i)                                   &
+                                 + (   fwxp(j,i) * (                           &
+                            kmxp * ( w(k,j,i+1)   - w(k,j,i)   ) * ddx         &
+                          + kmxp * ( u(k+1,j,i+1) - u(k,j,i+1) ) * ddzu(k+1)   &
+                                                   )                           &
+                                     - fwxm(j,i) * (                           &
+                            kmxm * ( w(k,j,i)     - w(k,j,i-1) ) * ddx         &
+                          + kmxm * ( u(k+1,j,i)   - u(k,j,i)   ) * ddzu(k+1)   &
+                                                   )                           &
+                                     + wall_w_x(j,i) * wsus(k,j,i)             &
+                                   ) * ddx                                     &
+                                 + (   fwyp(j,i) * (                           &
+                            kmyp * ( w(k,j+1,i)   - w(k,j,i)   ) * ddy         &
+                          + kmyp * ( v(k+1,j+1,i) - v(k,j+1,i) ) * ddzu(k+1)   &
+                                                   )                           &
+                                     - fwym(j,i) * (                           &
+                            kmym * ( w(k,j,i)     - w(k,j-1,i) ) * ddy         &
+                          + kmym * ( v(k+1,j,i)   - v(k,j,i)   ) * ddzu(k+1)   &
+                                                   )                           &
+                                     + wall_w_y(j,i) * wsvs(k,j,i)             &
+                                   ) * ddy                                     &
+                                 + 2.0_wp * (                                  &
+                           km(k+1,j,i) * ( w(k+1,j,i) - w(k,j,i) ) * ddzw(k+1) &
+                         - km(k,j,i)   * ( w(k,j,i)   - w(k-1,j,i) ) * ddzw(k) &
+                                            ) * ddzu(k+1)
+                ENDDO
+             ENDIF
+
+          ENDDO
+       ENDDO
+
+    END SUBROUTINE diffusion_w
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Call for all grid points - accelerator version
+!------------------------------------------------------------------------------!
+    SUBROUTINE diffusion_w_acc
+
+       USE arrays_3d,                                                          &
+           ONLY :  ddzu, ddzw, km, tend, u, v, w
+           
+       USE control_parameters,                                                 &
+           ONLY :  topography
+           
+       USE grid_variables,                                                     &
+           ONLY : ddx, ddy, fwxm, fwxp, fwym, fwyp, wall_w_x, wall_w_y
+           
+       USE indices,                                                            &
+           ONLY :  i_left, i_right, j_north, j_south, nxl, nxr, nyn, nys, nzb, &
+                   nzb_w_inner, nzb_w_outer, nzt
+                   
+       USE kinds
+
+       IMPLICIT NONE
+
+       INTEGER(iwp) ::  i     !<
+       INTEGER(iwp) ::  j     !<
+       INTEGER(iwp) ::  k     !<
+       
+       REAL(wp) ::  kmxm  !<
+       REAL(wp) ::  kmxp  !<
+       REAL(wp) ::  kmym  !<
+       REAL(wp) ::  kmyp  !< 
+
+       REAL(wp), DIMENSION(nzb:nzt+1,nys:nyn,nxl:nxr) ::  wsus  !<
+       REAL(wp), DIMENSION(nzb:nzt+1,nys:nyn,nxl:nxr) ::  wsvs  !<
+       !$acc declare create ( wsus, wsvs )
+
+!
+!--    First calculate horizontal momentum flux w'u' and/or w'v' at vertical
+!--    walls, if neccessary
+       IF ( topography /= 'flat' )  THEN
+          CALL wall_fluxes_acc( wsus, 0.0_wp, 0.0_wp, 0.0_wp, 1.0_wp,          &
+                                nzb_w_inner, nzb_w_outer, wall_w_x )
+          CALL wall_fluxes_acc( wsvs, 0.0_wp, 0.0_wp, 0.0_wp, 1.0_wp,          &
+                                nzb_w_inner, nzb_w_outer, wall_w_y )
+       ENDIF
+
+       !$acc kernels present ( u, v, w, km, tend )                             &
+       !$acc         present ( ddzu, ddzw, fwxm, fwxp, fwym, fwyp, wall_w_x, wall_w_y )           &
+       !$acc         present ( nzb_w_inner, nzb_w_outer )
+       DO  i = i_left, i_right
+          DO  j = j_south, j_north
+             DO  k = 1, nzt
+                IF ( k > nzb_w_outer(j,i) )  THEN
+!
+!--                Interpolate eddy diffusivities on staggered gridpoints
+                   kmxp = 0.25_wp *                                            &
+                          ( km(k,j,i)+km(k,j,i+1)+km(k+1,j,i)+km(k+1,j,i+1) )
+                   kmxm = 0.25_wp *                                            &
+                          ( km(k,j,i)+km(k,j,i-1)+km(k+1,j,i)+km(k+1,j,i-1) )
+                   kmyp = 0.25_wp *                                            &
+                          ( km(k,j,i)+km(k+1,j,i)+km(k,j+1,i)+km(k+1,j+1,i) )
+                   kmym = 0.25_wp *                                            &
+                          ( km(k,j,i)+km(k+1,j,i)+km(k,j-1,i)+km(k+1,j-1,i) )
+
+                   tend(k,j,i) = tend(k,j,i)                                     &
+                         & + ( kmxp * ( w(k,j,i+1)   - w(k,j,i)   ) * ddx        &
+                         &   + kmxp * ( u(k+1,j,i+1) - u(k,j,i+1) ) * ddzu(k+1)  &
+                         &   - kmxm * ( w(k,j,i)   - w(k,j,i-1) ) * ddx          &
+                         &   - kmxm * ( u(k+1,j,i) - u(k,j,i)   ) * ddzu(k+1)    &
+                         &   ) * ddx                                             &
+                         & + ( kmyp * ( w(k,j+1,i)   - w(k,j,i)   ) * ddy        &
+                         &   + kmyp * ( v(k+1,j+1,i) - v(k,j+1,i) ) * ddzu(k+1)  &
+                         &   - kmym * ( w(k,j,i)   - w(k,j-1,i) ) * ddy          &
+                         &   - kmym * ( v(k+1,j,i) - v(k,j,i)   ) * ddzu(k+1)    &
+                         &   ) * ddy                                             &
+                         & + 2.0_wp * (                                          &
+                         &   km(k+1,j,i) * ( w(k+1,j,i) - w(k,j,i) ) * ddzw(k+1) &
+                         & - km(k,j,i)   * ( w(k,j,i)   - w(k-1,j,i) ) * ddzw(k) &
+                         &            ) * ddzu(k+1)
+                ENDIF
+             ENDDO
+
+!
+!--          Wall functions at all vertical walls, where necessary
+             DO  k = 1,nzt
+
+                IF ( k > nzb_w_inner(j,i)  .AND.  k <= nzb_w_outer(j,i)  .AND. &
+                     wall_w_x(j,i) /= 0.0_wp  .AND.  wall_w_y(j,i) /= 0.0_wp )  THEN
+!
+!--                Interpolate eddy diffusivities on staggered gridpoints
+                   kmxp = 0.25_wp *                                            &
+                          ( km(k,j,i)+km(k,j,i+1)+km(k+1,j,i)+km(k+1,j,i+1) )
+                   kmxm = 0.25_wp *                                            &
+                          ( km(k,j,i)+km(k,j,i-1)+km(k+1,j,i)+km(k+1,j,i-1) )
+                   kmyp = 0.25_wp *                                            &
+                          ( km(k,j,i)+km(k+1,j,i)+km(k,j+1,i)+km(k+1,j+1,i) )
+                   kmym = 0.25_wp *                                            &
+                          ( km(k,j,i)+km(k+1,j,i)+km(k,j-1,i)+km(k+1,j-1,i) )
+
+                   tend(k,j,i) = tend(k,j,i)                                   &
+                                 + (   fwxp(j,i) * (                           &
+                            kmxp * ( w(k,j,i+1)   - w(k,j,i)   ) * ddx         &
+                          + kmxp * ( u(k+1,j,i+1) - u(k,j,i+1) ) * ddzu(k+1)   &
+                                                   )                           &
+                                     - fwxm(j,i) * (                           &
+                            kmxm * ( w(k,j,i)     - w(k,j,i-1) ) * ddx         &
+                          + kmxm * ( u(k+1,j,i)   - u(k,j,i)   ) * ddzu(k+1)   &
+                                                   )                           &
+                                     + wall_w_x(j,i) * wsus(k,j,i)             &
+                                   ) * ddx                                     &
+                                 + (   fwyp(j,i) * (                           &
+                            kmyp * ( w(k,j+1,i)   - w(k,j,i)   ) * ddy         &
+                          + kmyp * ( v(k+1,j+1,i) - v(k,j+1,i) ) * ddzu(k+1)   &
+                                                   )                           &
+                                     - fwym(j,i) * (                           &
+                            kmym * ( w(k,j,i)     - w(k,j-1,i) ) * ddy         &
+                          + kmym * ( v(k+1,j,i)   - v(k,j,i)   ) * ddzu(k+1)   &
+                                                   )                           &
+                                     + wall_w_y(j,i) * wsvs(k,j,i)             &
+                                   ) * ddy                                     &
+                                 + 2.0_wp * (                                  &
+                           km(k+1,j,i) * ( w(k+1,j,i) - w(k,j,i) ) * ddzw(k+1) &
+                         - km(k,j,i)   * ( w(k,j,i)   - w(k-1,j,i) ) * ddzw(k) &
+                                            ) * ddzu(k+1)
+                ENDIF
+             ENDDO
+
+          ENDDO
+       ENDDO
+       !$acc end kernels
+
+    END SUBROUTINE diffusion_w_acc
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Call for grid point i,j
+!------------------------------------------------------------------------------!
+    SUBROUTINE diffusion_w_ij( i, j )
+
+       USE arrays_3d,                                                          &          
+           ONLY :  ddzu, ddzw, km, tend, u, v, w
+           
+       USE control_parameters,                                                 & 
+           ONLY :  topography
+           
+       USE grid_variables,                                                     &     
+           ONLY :  ddx, ddy, fwxm, fwxp, fwym, fwyp, wall_w_x, wall_w_y
+           
+       USE indices,                                                            &            
+           ONLY :  nxl, nxr, nyn, nys, nzb, nzb_w_inner, nzb_w_outer, nzt
+           
+       USE kinds
+
+       IMPLICIT NONE
+
+       INTEGER(iwp) ::  i     !<
+       INTEGER(iwp) ::  j     !<
+       INTEGER(iwp) ::  k     !<
+       
+       REAL(wp) ::  kmxm  !<
+       REAL(wp) ::  kmxp  !<
+       REAL(wp) ::  kmym  !<
+       REAL(wp) ::  kmyp  !< 
+
+       REAL(wp), DIMENSION(nzb:nzt+1) ::  wsus
+       REAL(wp), DIMENSION(nzb:nzt+1) ::  wsvs
+
+
+       DO  k = nzb_w_outer(j,i)+1, nzt-1
+!
+!--       Interpolate eddy diffusivities on staggered gridpoints
+          kmxp = 0.25_wp * ( km(k,j,i)+km(k,j,i+1)+km(k+1,j,i)+km(k+1,j,i+1) )
+          kmxm = 0.25_wp * ( km(k,j,i)+km(k,j,i-1)+km(k+1,j,i)+km(k+1,j,i-1) )
+          kmyp = 0.25_wp * ( km(k,j,i)+km(k+1,j,i)+km(k,j+1,i)+km(k+1,j+1,i) )
+          kmym = 0.25_wp * ( km(k,j,i)+km(k+1,j,i)+km(k,j-1,i)+km(k+1,j-1,i) )
+
+          tend(k,j,i) = tend(k,j,i)                                            &
+                      & + ( kmxp * ( w(k,j,i+1)   - w(k,j,i)   ) * ddx         &
+                      &   + kmxp * ( u(k+1,j,i+1) - u(k,j,i+1) ) * ddzu(k+1)   &
+                      &   - kmxm * ( w(k,j,i)   - w(k,j,i-1) ) * ddx           &
+                      &   - kmxm * ( u(k+1,j,i) - u(k,j,i)   ) * ddzu(k+1)     &
+                      &   ) * ddx                                              &
+                      & + ( kmyp * ( w(k,j+1,i)   - w(k,j,i)   ) * ddy         &
+                      &   + kmyp * ( v(k+1,j+1,i) - v(k,j+1,i) ) * ddzu(k+1)   &
+                      &   - kmym * ( w(k,j,i)   - w(k,j-1,i) ) * ddy           &
+                      &   - kmym * ( v(k+1,j,i) - v(k,j,i)   ) * ddzu(k+1)     &
+                      &   ) * ddy                                              &
+                      & + 2.0_wp * (                                           &
+                      &   km(k+1,j,i) * ( w(k+1,j,i) - w(k,j,i) ) * ddzw(k+1)  &
+                      & - km(k,j,i)   * ( w(k,j,i)   - w(k-1,j,i) ) * ddzw(k)  &
+                      &            ) * ddzu(k+1)
+       ENDDO
+
+!
+!--    Wall functions at all vertical walls, where necessary
+       IF ( wall_w_x(j,i) /= 0.0_wp  .OR.  wall_w_y(j,i) /= 0.0_wp )  THEN
+
+!
+!--       Calculate the horizontal momentum fluxes w'u' and/or w'v'
+          IF ( wall_w_x(j,i) /= 0.0_wp )  THEN
+             CALL wall_fluxes( i, j, nzb_w_inner(j,i)+1, nzb_w_outer(j,i),     &
+                               wsus, 0.0_wp, 0.0_wp, 0.0_wp, 1.0_wp )
+          ELSE
+             wsus = 0.0_wp
+          ENDIF
+
+          IF ( wall_w_y(j,i) /= 0.0_wp )  THEN
+             CALL wall_fluxes( i, j, nzb_w_inner(j,i)+1, nzb_w_outer(j,i),     &
+                               wsvs, 0.0_wp, 0.0_wp, 1.0_wp, 0.0_wp )
+          ELSE
+             wsvs = 0.0_wp
+          ENDIF
+
+          DO  k = nzb_w_inner(j,i)+1, nzb_w_outer(j,i)
+!
+!--          Interpolate eddy diffusivities on staggered gridpoints
+             kmxp = 0.25_wp * ( km(k,j,i)+km(k,j,i+1)+km(k+1,j,i)+km(k+1,j,i+1) )
+             kmxm = 0.25_wp * ( km(k,j,i)+km(k,j,i-1)+km(k+1,j,i)+km(k+1,j,i-1) )
+             kmyp = 0.25_wp * ( km(k,j,i)+km(k+1,j,i)+km(k,j+1,i)+km(k+1,j+1,i) )
+             kmym = 0.25_wp * ( km(k,j,i)+km(k+1,j,i)+km(k,j-1,i)+km(k+1,j-1,i) )
+
+             tend(k,j,i) = tend(k,j,i)                                         &
+                                 + (   fwxp(j,i) * (                           &
+                            kmxp * ( w(k,j,i+1)   - w(k,j,i)   ) * ddx         &
+                          + kmxp * ( u(k+1,j,i+1) - u(k,j,i+1) ) * ddzu(k+1)   &
+                                                   )                           &
+                                     - fwxm(j,i) * (                           &
+                            kmxm * ( w(k,j,i)     - w(k,j,i-1) ) * ddx         &
+                          + kmxm * ( u(k+1,j,i)   - u(k,j,i)   ) * ddzu(k+1)   &
+                                                   )                           &
+                                     + wall_w_x(j,i) * wsus(k)                 &
+                                   ) * ddx                                     &
+                                 + (   fwyp(j,i) * (                           &
+                            kmyp * ( w(k,j+1,i)   - w(k,j,i)   ) * ddy         &
+                          + kmyp * ( v(k+1,j+1,i) - v(k,j+1,i) ) * ddzu(k+1)   &
+                                                   )                           &
+                                     - fwym(j,i) * (                           &
+                            kmym * ( w(k,j,i)     - w(k,j-1,i) ) * ddy         &
+                          + kmym * ( v(k+1,j,i)   - v(k,j,i)   ) * ddzu(k+1)   &
+                                                   )                           &
+                                     + wall_w_y(j,i) * wsvs(k)                 &
+                                   ) * ddy                                     &
+                                 + 2.0_wp * (                                  &
+                           km(k+1,j,i) * ( w(k+1,j,i) - w(k,j,i) ) * ddzw(k+1) &
+                         - km(k,j,i)   * ( w(k,j,i)   - w(k-1,j,i) ) * ddzw(k) &
+                                            ) * ddzu(k+1)
+          ENDDO
+       ENDIF
+
+    END SUBROUTINE diffusion_w_ij
+
+ END MODULE diffusion_w_mod
Index: lm/trunk/SOURCE/eqn_state_seawater.f90
===================================================================
--- /palm/trunk/SOURCE/eqn_state_seawater.f90	(revision 1849)
+++ 	(revision )
@@ -1,313 +1,0 @@
-!> @file eqn_state_seawater.f90
-!------------------------------------------------------------------------------!
-! This file is part of PALM.
-!
-! PALM is free software: you can redistribute it and/or modify it under the terms
-! of the GNU General Public License as published by the Free Software Foundation,
-! either version 3 of the License, or (at your option) any later version.
-!
-! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
-! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
-! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along with
-! PALM. If not, see <http://www.gnu.org/licenses/>.
-!
-! Copyright 1997-2016 Leibniz Universitaet Hannover
-!------------------------------------------------------------------------------!
-!
-! Current revisions:
-! -----------------
-! 
-! 
-! Former revisions:
-! -----------------
-! $Id$
-!
-! 1682 2015-10-07 23:56:08Z knoop
-! Code annotations made doxygen readable 
-! 
-! 1353 2014-04-08 15:21:23Z heinze
-! REAL constants provided with KIND-attribute 
-!
-! 1320 2014-03-20 08:40:49Z raasch
-! ONLY-attribute added to USE-statements,
-! kind-parameters added to all INTEGER and REAL declaration statements, 
-! kinds are defined in new module kinds, 
-! revision history before 2012 removed,
-! comment fields (!:) to be used for variable explanations added to
-! all variable declaration statements 
-!
-! 1036 2012-10-22 13:43:42Z raasch
-! code put under GPL (PALM 3.9)
-!
-! 97 2007-06-21 08:23:15Z raasch
-! Initial revision
-!
-!
-! Description:
-! ------------
-!> Equation of state for seawater as a function of potential temperature,
-!> salinity, and pressure.
-!> For coefficients see Jackett et al., 2006: J. Atm. Ocean Tech.
-!> eqn_state_seawater calculates the potential density referred at hyp(0).
-!> eqn_state_seawater_func calculates density.
-!------------------------------------------------------------------------------!
- MODULE eqn_state_seawater_mod
- 
-    
-    USE kinds
-
-    IMPLICIT NONE
-
-    PRIVATE
-    PUBLIC eqn_state_seawater, eqn_state_seawater_func
-
-    REAL(wp), DIMENSION(12), PARAMETER ::  nom =                               &
-                          (/ 9.9984085444849347D2,   7.3471625860981584D0,     &
-                            -5.3211231792841769D-2,  3.6492439109814549D-4,    &
-                             2.5880571023991390D0,  -6.7168282786692354D-3,    &
-                             1.9203202055760151D-3,  1.1798263740430364D-2,    &
-                             9.8920219266399117D-8,  4.6996642771754730D-6,    &
-                            -2.5862187075154352D-8, -3.2921414007960662D-12 /)
-                          !<
-
-    REAL(wp), DIMENSION(13), PARAMETER ::  den =                               &
-                          (/ 1.0D0,                  7.2815210113327091D-3,    &
-                            -4.4787265461983921D-5,  3.3851002965802430D-7,    &
-                             1.3651202389758572D-10, 1.7632126669040377D-3,    &
-                            -8.8066583251206474D-6, -1.8832689434804897D-10,   &
-                             5.7463776745432097D-6,  1.4716275472242334D-9,    &
-                             6.7103246285651894D-6, -2.4461698007024582D-17,   &
-                            -9.1534417604289062D-18 /)
-                          !<
-
-    INTERFACE eqn_state_seawater
-       MODULE PROCEDURE eqn_state_seawater
-       MODULE PROCEDURE eqn_state_seawater_ij
-    END INTERFACE eqn_state_seawater
- 
-    INTERFACE eqn_state_seawater_func
-       MODULE PROCEDURE eqn_state_seawater_func
-    END INTERFACE eqn_state_seawater_func
- 
- CONTAINS
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Call for all grid points
-!------------------------------------------------------------------------------!
-    SUBROUTINE eqn_state_seawater
-
-       USE arrays_3d,                                                          &
-           ONLY:  hyp, prho, pt_p, rho, sa_p
-       USE indices,                                                            &
-           ONLY:  nxl, nxr, nyn, nys, nzb_s_inner, nzt
-
-       IMPLICIT NONE
-
-       INTEGER(iwp) ::  i  !<
-       INTEGER(iwp) ::  j  !<
-       INTEGER(iwp) ::  k  !<
-
-       REAL(wp) ::  pden  !<
-       REAL(wp) ::  pnom  !<
-       REAL(wp) ::  p1    !<
-       REAL(wp) ::  p2    !<
-       REAL(wp) ::  p3    !<
-       REAL(wp) ::  pt1   !<
-       REAL(wp) ::  pt2   !<
-       REAL(wp) ::  pt3   !<
-       REAL(wp) ::  pt4   !<
-       REAL(wp) ::  sa1   !<
-       REAL(wp) ::  sa15  !<
-       REAL(wp) ::  sa2   !<
-       
-                       
-
-       DO  i = nxl, nxr
-          DO  j = nys, nyn
-             DO  k = nzb_s_inner(j,i)+1, nzt
-!
-!--             Pressure is needed in dbar
-                p1 = hyp(k) * 1E-4_wp
-                p2 = p1 * p1
-                p3 = p2 * p1
-
-!
-!--             Temperature needed in degree Celsius
-                pt1 = pt_p(k,j,i) - 273.15_wp
-                pt2 = pt1 * pt1
-                pt3 = pt1 * pt2
-                pt4 = pt2 * pt2
-
-                sa1  = sa_p(k,j,i)
-                sa15 = sa1 * SQRT( sa1 )
-                sa2  = sa1 * sa1
-
-                pnom = nom(1)           + nom(2)*pt1     + nom(3)*pt2     +    &
-                       nom(4)*pt3       + nom(5)*sa1     + nom(6)*sa1*pt1 +    &
-                       nom(7)*sa2
-
-                pden = den(1)           + den(2)*pt1     + den(3)*pt2     +    &
-                       den(4)*pt3       + den(5)*pt4     + den(6)*sa1     +    &
-                       den(7)*sa1*pt1   + den(8)*sa1*pt3 + den(9)*sa15    +    &
-                       den(10)*sa15*pt2
-
-!
-!--             Potential density (without pressure terms)
-                prho(k,j,i) = pnom / pden
-
-                pnom = pnom +             nom(8)*p1      + nom(9)*p1*pt2  +    &
-                       nom(10)*p1*sa1   + nom(11)*p2     + nom(12)*p2*pt2
-
-                pden = pden +             den(11)*p1     + den(12)*p2*pt3 +    &
-                       den(13)*p3*pt1
-
-!
-!--             In-situ density
-                rho(k,j,i) = pnom / pden
-
-             ENDDO
-!
-!--          Neumann conditions are assumed at bottom and top boundary
-             prho(nzt+1,j,i)            = prho(nzt,j,i)
-             prho(nzb_s_inner(j,i),j,i) = prho(nzb_s_inner(j,i)+1,j,i)
-             rho(nzt+1,j,i)             = rho(nzt,j,i)
-             rho(nzb_s_inner(j,i),j,i)  = rho(nzb_s_inner(j,i)+1,j,i)
-
-          ENDDO
-       ENDDO
-
-    END SUBROUTINE eqn_state_seawater
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Call for grid point i,j
-!------------------------------------------------------------------------------!
-    SUBROUTINE eqn_state_seawater_ij( i, j )
-
-       USE arrays_3d,                                                          &
-           ONLY:  hyp, prho, pt_p, rho, sa_p
-           
-       USE indices,                                                            &
-           ONLY:  nzb_s_inner, nzt
-
-       IMPLICIT NONE
-
-       INTEGER(iwp) ::  i, j, k
-
-       REAL(wp)     ::  pden, pnom, p1, p2, p3, pt1, pt2, pt3, pt4, sa1, sa15, &
-                        sa2
-
-       DO  k = nzb_s_inner(j,i)+1, nzt
-!
-!--       Pressure is needed in dbar
-          p1 = hyp(k) * 1E-4_wp
-          p2 = p1 * p1
-          p3 = p2 * p1
-
-!
-!--       Temperature needed in degree Celsius
-          pt1 = pt_p(k,j,i) - 273.15_wp
-          pt2 = pt1 * pt1
-          pt3 = pt1 * pt2
-          pt4 = pt2 * pt2
-
-          sa1  = sa_p(k,j,i)
-          sa15 = sa1 * SQRT( sa1 )
-          sa2  = sa1 * sa1
-
-          pnom = nom(1)           + nom(2)*pt1     + nom(3)*pt2     +          &
-                 nom(4)*pt3       + nom(5)*sa1     + nom(6)*sa1*pt1 +          &
-                 nom(7)*sa2
-
-          pden = den(1)           + den(2)*pt1     + den(3)*pt2     +          &
-                 den(4)*pt3       + den(5)*pt4     + den(6)*sa1     +          &
-                 den(7)*sa1*pt1   + den(8)*sa1*pt3 + den(9)*sa15    +          &
-                 den(10)*sa15*pt2
-
-!
-!--       Potential density (without pressure terms)
-          prho(k,j,i) = pnom / pden
-
-          pnom = pnom +             nom(8)*p1      + nom(9)*p1*pt2  +          &
-                 nom(10)*p1*sa1   + nom(11)*p2     + nom(12)*p2*pt2
-          pden = pden +             den(11)*p1     + den(12)*p2*pt3 +          &
-                 den(13)*p3*pt1
-
-!
-!--       In-situ density
-          rho(k,j,i) = pnom / pden
-
-
-       ENDDO
-
-!
-!--    Neumann conditions are assumed at bottom and top boundary
-       prho(nzt+1,j,i)            = prho(nzt,j,i)
-       prho(nzb_s_inner(j,i),j,i) = prho(nzb_s_inner(j,i)+1,j,i)
-       rho(nzt+1,j,i)             = rho(nzt,j,i)
-       rho(nzb_s_inner(j,i),j,i)  = rho(nzb_s_inner(j,i)+1,j,i)
-
-    END SUBROUTINE eqn_state_seawater_ij
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Equation of state as a function
-!------------------------------------------------------------------------------!
-    REAL(wp) FUNCTION eqn_state_seawater_func( p, pt, sa )
-
-       IMPLICIT NONE
-
-       REAL(wp) ::  p      !<
-       REAL(wp) ::  p1     !<
-       REAL(wp) ::  p2     !<
-       REAL(wp) ::  p3     !<
-       REAL(wp) ::  pt     !<
-       REAL(wp) ::  pt1    !<
-       REAL(wp) ::  pt2    !<
-       REAL(wp) ::  pt3    !<
-       REAL(wp) ::  pt4    !<
-       REAL(wp) ::  sa     !<
-       REAL(wp) ::  sa15   !<
-       REAL(wp) ::  sa2    !<
-
-!
-!--    Pressure is needed in dbar
-       p1 = p  * 1E-4_wp
-       p2 = p1 * p1
-       p3 = p2 * p1
-
-!
-!--    Temperature needed in degree Celsius
-       pt1 = pt - 273.15_wp
-       pt2 = pt1 * pt1
-       pt3 = pt1 * pt2
-       pt4 = pt2 * pt2
-
-       sa15 = sa * SQRT( sa )
-       sa2  = sa * sa
-
-
-       eqn_state_seawater_func =                                               &
-         ( nom(1)        + nom(2)*pt1       + nom(3)*pt2    + nom(4)*pt3     + &
-           nom(5)*sa     + nom(6)*sa*pt1    + nom(7)*sa2    + nom(8)*p1      + &
-           nom(9)*p1*pt2 + nom(10)*p1*sa    + nom(11)*p2    + nom(12)*p2*pt2   &
-         ) /                                                                   &
-         ( den(1)        + den(2)*pt1       + den(3)*pt2    + den(4)*pt3     + &
-           den(5)*pt4    + den(6)*sa        + den(7)*sa*pt1 + den(8)*sa*pt3  + &
-           den(9)*sa15   + den(10)*sa15*pt2 + den(11)*p1    + den(12)*p2*pt3 + &
-           den(13)*p3*pt1                                                      &
-         )
-
-
-    END FUNCTION eqn_state_seawater_func
-
- END MODULE eqn_state_seawater_mod
Index: /palm/trunk/SOURCE/eqn_state_seawater_mod.f90
===================================================================
--- /palm/trunk/SOURCE/eqn_state_seawater_mod.f90	(revision 1850)
+++ /palm/trunk/SOURCE/eqn_state_seawater_mod.f90	(revision 1850)
@@ -0,0 +1,314 @@
+!> @file eqn_state_seawater_mod.f90
+!------------------------------------------------------------------------------!
+! This file is part of PALM.
+!
+! PALM is free software: you can redistribute it and/or modify it under the terms
+! of the GNU General Public License as published by the Free Software Foundation,
+! either version 3 of the License, or (at your option) any later version.
+!
+! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
+! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
+! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along with
+! PALM. If not, see <http://www.gnu.org/licenses/>.
+!
+! Copyright 1997-2016 Leibniz Universitaet Hannover
+!------------------------------------------------------------------------------!
+!
+! Current revisions:
+! -----------------
+! Module renamed
+! 
+! 
+! Former revisions:
+! -----------------
+! $Id$
+!
+! 1682 2015-10-07 23:56:08Z knoop
+! Code annotations made doxygen readable 
+! 
+! 1353 2014-04-08 15:21:23Z heinze
+! REAL constants provided with KIND-attribute 
+!
+! 1320 2014-03-20 08:40:49Z raasch
+! ONLY-attribute added to USE-statements,
+! kind-parameters added to all INTEGER and REAL declaration statements, 
+! kinds are defined in new module kinds, 
+! revision history before 2012 removed,
+! comment fields (!:) to be used for variable explanations added to
+! all variable declaration statements 
+!
+! 1036 2012-10-22 13:43:42Z raasch
+! code put under GPL (PALM 3.9)
+!
+! 97 2007-06-21 08:23:15Z raasch
+! Initial revision
+!
+!
+! Description:
+! ------------
+!> Equation of state for seawater as a function of potential temperature,
+!> salinity, and pressure.
+!> For coefficients see Jackett et al., 2006: J. Atm. Ocean Tech.
+!> eqn_state_seawater calculates the potential density referred at hyp(0).
+!> eqn_state_seawater_func calculates density.
+!------------------------------------------------------------------------------!
+ MODULE eqn_state_seawater_mod
+ 
+    
+    USE kinds
+
+    IMPLICIT NONE
+
+    PRIVATE
+    PUBLIC eqn_state_seawater, eqn_state_seawater_func
+
+    REAL(wp), DIMENSION(12), PARAMETER ::  nom =                               &
+                          (/ 9.9984085444849347D2,   7.3471625860981584D0,     &
+                            -5.3211231792841769D-2,  3.6492439109814549D-4,    &
+                             2.5880571023991390D0,  -6.7168282786692354D-3,    &
+                             1.9203202055760151D-3,  1.1798263740430364D-2,    &
+                             9.8920219266399117D-8,  4.6996642771754730D-6,    &
+                            -2.5862187075154352D-8, -3.2921414007960662D-12 /)
+                          !<
+
+    REAL(wp), DIMENSION(13), PARAMETER ::  den =                               &
+                          (/ 1.0D0,                  7.2815210113327091D-3,    &
+                            -4.4787265461983921D-5,  3.3851002965802430D-7,    &
+                             1.3651202389758572D-10, 1.7632126669040377D-3,    &
+                            -8.8066583251206474D-6, -1.8832689434804897D-10,   &
+                             5.7463776745432097D-6,  1.4716275472242334D-9,    &
+                             6.7103246285651894D-6, -2.4461698007024582D-17,   &
+                            -9.1534417604289062D-18 /)
+                          !<
+
+    INTERFACE eqn_state_seawater
+       MODULE PROCEDURE eqn_state_seawater
+       MODULE PROCEDURE eqn_state_seawater_ij
+    END INTERFACE eqn_state_seawater
+ 
+    INTERFACE eqn_state_seawater_func
+       MODULE PROCEDURE eqn_state_seawater_func
+    END INTERFACE eqn_state_seawater_func
+ 
+ CONTAINS
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Call for all grid points
+!------------------------------------------------------------------------------!
+    SUBROUTINE eqn_state_seawater
+
+       USE arrays_3d,                                                          &
+           ONLY:  hyp, prho, pt_p, rho, sa_p
+       USE indices,                                                            &
+           ONLY:  nxl, nxr, nyn, nys, nzb_s_inner, nzt
+
+       IMPLICIT NONE
+
+       INTEGER(iwp) ::  i  !<
+       INTEGER(iwp) ::  j  !<
+       INTEGER(iwp) ::  k  !<
+
+       REAL(wp) ::  pden  !<
+       REAL(wp) ::  pnom  !<
+       REAL(wp) ::  p1    !<
+       REAL(wp) ::  p2    !<
+       REAL(wp) ::  p3    !<
+       REAL(wp) ::  pt1   !<
+       REAL(wp) ::  pt2   !<
+       REAL(wp) ::  pt3   !<
+       REAL(wp) ::  pt4   !<
+       REAL(wp) ::  sa1   !<
+       REAL(wp) ::  sa15  !<
+       REAL(wp) ::  sa2   !<
+       
+                       
+
+       DO  i = nxl, nxr
+          DO  j = nys, nyn
+             DO  k = nzb_s_inner(j,i)+1, nzt
+!
+!--             Pressure is needed in dbar
+                p1 = hyp(k) * 1E-4_wp
+                p2 = p1 * p1
+                p3 = p2 * p1
+
+!
+!--             Temperature needed in degree Celsius
+                pt1 = pt_p(k,j,i) - 273.15_wp
+                pt2 = pt1 * pt1
+                pt3 = pt1 * pt2
+                pt4 = pt2 * pt2
+
+                sa1  = sa_p(k,j,i)
+                sa15 = sa1 * SQRT( sa1 )
+                sa2  = sa1 * sa1
+
+                pnom = nom(1)           + nom(2)*pt1     + nom(3)*pt2     +    &
+                       nom(4)*pt3       + nom(5)*sa1     + nom(6)*sa1*pt1 +    &
+                       nom(7)*sa2
+
+                pden = den(1)           + den(2)*pt1     + den(3)*pt2     +    &
+                       den(4)*pt3       + den(5)*pt4     + den(6)*sa1     +    &
+                       den(7)*sa1*pt1   + den(8)*sa1*pt3 + den(9)*sa15    +    &
+                       den(10)*sa15*pt2
+
+!
+!--             Potential density (without pressure terms)
+                prho(k,j,i) = pnom / pden
+
+                pnom = pnom +             nom(8)*p1      + nom(9)*p1*pt2  +    &
+                       nom(10)*p1*sa1   + nom(11)*p2     + nom(12)*p2*pt2
+
+                pden = pden +             den(11)*p1     + den(12)*p2*pt3 +    &
+                       den(13)*p3*pt1
+
+!
+!--             In-situ density
+                rho(k,j,i) = pnom / pden
+
+             ENDDO
+!
+!--          Neumann conditions are assumed at bottom and top boundary
+             prho(nzt+1,j,i)            = prho(nzt,j,i)
+             prho(nzb_s_inner(j,i),j,i) = prho(nzb_s_inner(j,i)+1,j,i)
+             rho(nzt+1,j,i)             = rho(nzt,j,i)
+             rho(nzb_s_inner(j,i),j,i)  = rho(nzb_s_inner(j,i)+1,j,i)
+
+          ENDDO
+       ENDDO
+
+    END SUBROUTINE eqn_state_seawater
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Call for grid point i,j
+!------------------------------------------------------------------------------!
+    SUBROUTINE eqn_state_seawater_ij( i, j )
+
+       USE arrays_3d,                                                          &
+           ONLY:  hyp, prho, pt_p, rho, sa_p
+           
+       USE indices,                                                            &
+           ONLY:  nzb_s_inner, nzt
+
+       IMPLICIT NONE
+
+       INTEGER(iwp) ::  i, j, k
+
+       REAL(wp)     ::  pden, pnom, p1, p2, p3, pt1, pt2, pt3, pt4, sa1, sa15, &
+                        sa2
+
+       DO  k = nzb_s_inner(j,i)+1, nzt
+!
+!--       Pressure is needed in dbar
+          p1 = hyp(k) * 1E-4_wp
+          p2 = p1 * p1
+          p3 = p2 * p1
+
+!
+!--       Temperature needed in degree Celsius
+          pt1 = pt_p(k,j,i) - 273.15_wp
+          pt2 = pt1 * pt1
+          pt3 = pt1 * pt2
+          pt4 = pt2 * pt2
+
+          sa1  = sa_p(k,j,i)
+          sa15 = sa1 * SQRT( sa1 )
+          sa2  = sa1 * sa1
+
+          pnom = nom(1)           + nom(2)*pt1     + nom(3)*pt2     +          &
+                 nom(4)*pt3       + nom(5)*sa1     + nom(6)*sa1*pt1 +          &
+                 nom(7)*sa2
+
+          pden = den(1)           + den(2)*pt1     + den(3)*pt2     +          &
+                 den(4)*pt3       + den(5)*pt4     + den(6)*sa1     +          &
+                 den(7)*sa1*pt1   + den(8)*sa1*pt3 + den(9)*sa15    +          &
+                 den(10)*sa15*pt2
+
+!
+!--       Potential density (without pressure terms)
+          prho(k,j,i) = pnom / pden
+
+          pnom = pnom +             nom(8)*p1      + nom(9)*p1*pt2  +          &
+                 nom(10)*p1*sa1   + nom(11)*p2     + nom(12)*p2*pt2
+          pden = pden +             den(11)*p1     + den(12)*p2*pt3 +          &
+                 den(13)*p3*pt1
+
+!
+!--       In-situ density
+          rho(k,j,i) = pnom / pden
+
+
+       ENDDO
+
+!
+!--    Neumann conditions are assumed at bottom and top boundary
+       prho(nzt+1,j,i)            = prho(nzt,j,i)
+       prho(nzb_s_inner(j,i),j,i) = prho(nzb_s_inner(j,i)+1,j,i)
+       rho(nzt+1,j,i)             = rho(nzt,j,i)
+       rho(nzb_s_inner(j,i),j,i)  = rho(nzb_s_inner(j,i)+1,j,i)
+
+    END SUBROUTINE eqn_state_seawater_ij
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Equation of state as a function
+!------------------------------------------------------------------------------!
+    REAL(wp) FUNCTION eqn_state_seawater_func( p, pt, sa )
+
+       IMPLICIT NONE
+
+       REAL(wp) ::  p      !<
+       REAL(wp) ::  p1     !<
+       REAL(wp) ::  p2     !<
+       REAL(wp) ::  p3     !<
+       REAL(wp) ::  pt     !<
+       REAL(wp) ::  pt1    !<
+       REAL(wp) ::  pt2    !<
+       REAL(wp) ::  pt3    !<
+       REAL(wp) ::  pt4    !<
+       REAL(wp) ::  sa     !<
+       REAL(wp) ::  sa15   !<
+       REAL(wp) ::  sa2    !<
+
+!
+!--    Pressure is needed in dbar
+       p1 = p  * 1E-4_wp
+       p2 = p1 * p1
+       p3 = p2 * p1
+
+!
+!--    Temperature needed in degree Celsius
+       pt1 = pt - 273.15_wp
+       pt2 = pt1 * pt1
+       pt3 = pt1 * pt2
+       pt4 = pt2 * pt2
+
+       sa15 = sa * SQRT( sa )
+       sa2  = sa * sa
+
+
+       eqn_state_seawater_func =                                               &
+         ( nom(1)        + nom(2)*pt1       + nom(3)*pt2    + nom(4)*pt3     + &
+           nom(5)*sa     + nom(6)*sa*pt1    + nom(7)*sa2    + nom(8)*p1      + &
+           nom(9)*p1*pt2 + nom(10)*p1*sa    + nom(11)*p2    + nom(12)*p2*pt2   &
+         ) /                                                                   &
+         ( den(1)        + den(2)*pt1       + den(3)*pt2    + den(4)*pt3     + &
+           den(5)*pt4    + den(6)*sa        + den(7)*sa*pt1 + den(8)*sa*pt3  + &
+           den(9)*sa15   + den(10)*sa15*pt2 + den(11)*p1    + den(12)*p2*pt3 + &
+           den(13)*p3*pt1                                                      &
+         )
+
+
+    END FUNCTION eqn_state_seawater_func
+
+ END MODULE eqn_state_seawater_mod
Index: lm/trunk/SOURCE/fft_xy.f90
===================================================================
--- /palm/trunk/SOURCE/fft_xy.f90	(revision 1849)
+++ 	(revision )
@@ -1,1933 +1,0 @@
-!> @file fft_xy.f90
-!--------------------------------------------------------------------------------!
-! This file is part of PALM.
-!
-! PALM is free software: you can redistribute it and/or modify it under the terms
-! of the GNU General Public License as published by the Free Software Foundation,
-! either version 3 of the License, or (at your option) any later version.
-!
-! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
-! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
-! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along with
-! PALM. If not, see <http://www.gnu.org/licenses/>.
-!
-! Copyright 1997-2016 Leibniz Universitaet Hannover
-!------------------------------------------------------------------------------!
-!
-! Current revisions:
-! -----------------
-! 
-! 
-! Former revisions:
-! -----------------
-! $Id$
-!
-! 1815 2016-04-06 13:49:59Z raasch
-! cpp-directives for ibmy removed
-!
-! 1749 2016-02-09 12:19:56Z raasch
-! small OpenACC bugfix
-!
-! 1682 2015-10-07 23:56:08Z knoop
-! Code annotations made doxygen readable
-!
-! 1600 2015-06-11 15:50:12Z raasch
-! bugfix: openMP threadprivate statement moved after variable declaration
-!
-! 1482 2014-10-18 12:34:45Z raasch
-! cudafft workaround for data declaration of ar_tmp because of PGI 14.1 bug
-!
-! 1402 2014-05-09 14:25:13Z raasch
-! fortran bugfix for r1392
-! 
-! 1398 2014-05-07 11:15:00Z heinze
-! bugfix: typo removed for KIND in CMPLX function
-!
-! 1392 2014-05-06 09:10:05Z raasch
-! bugfix: KIND attribute added to CMPLX functions
-!
-! 1374 2014-04-25 12:55:07Z raasch
-! bugfixes: missing variables added to ONLY list, dpk renamed dp
-!
-! 1372 2014-04-24 06:29:32Z raasch
-! openMP-bugfix for fftw: some arrays defined as threadprivate
-!
-! 1353 2014-04-08 15:21:23Z heinze
-! REAL constants provided with KIND-attribute 
-! 
-! 1342 2014-03-26 17:04:47Z kanani
-! REAL constants defined as wp-kind
-!
-! 1322 2014-03-20 16:38:49Z raasch
-! REAL functions provided with KIND-attribute
-!
-! 1320 2014-03-20 08:40:49Z raasch
-! ONLY-attribute added to USE-statements,
-! kind-parameters added to all INTEGER and REAL declaration statements, 
-! kinds are defined in new module kinds, 
-! old module precision_kind is removed,
-! revision history before 2012 removed,
-! comment fields (!:) to be used for variable explanations added to
-! all variable declaration statements 
-!
-! 1304 2014-03-12 10:29:42Z raasch
-! openmp bugfix: work1 used in Temperton algorithm must be private
-!
-! 1257 2013-11-08 15:18:40Z raasch
-! openacc loop and loop vector clauses removed, declare create moved after
-! the FORTRAN declaration statement
-!
-! 1219 2013-08-30 09:33:18Z heinze
-! bugfix: use own branch for fftw
-!
-! 1216 2013-08-26 09:31:42Z raasch
-! fft_x and fft_y modified for parallel / ovverlapping execution of fft and
-! transpositions,
-! fftw implemented for 1d-decomposition (fft_x_1d, fft_y_1d)
-!
-! 1210 2013-08-14 10:58:20Z raasch
-! fftw added
-!
-! 1166 2013-05-24 13:55:44Z raasch
-! C_DOUBLE/COMPLEX reset to dpk
-!
-! 1153 2013-05-10 14:33:08Z raasch
-! code adjustment of data types for CUDA fft required by PGI 12.3 / CUDA 5.0
-!
-! 1111 2013-03-08 23:54:10Z raasch
-! further openACC statements added, CUDA branch completely runs on GPU
-! bugfix: CUDA fft plans adjusted for domain decomposition (before they always
-! used total domain)
-!
-! 1106 2013-03-04 05:31:38Z raasch
-! CUDA fft added
-! array_kind renamed precision_kind, 3D- instead of 1D-loops in fft_x and fft_y
-! old fft_x, fft_y become fft_x_1d, fft_y_1d and are used for 1D-decomposition
-!
-! 1092 2013-02-02 11:24:22Z raasch
-! variable sizw declared for NEC case only
-!
-! 1036 2012-10-22 13:43:42Z raasch
-! code put under GPL (PALM 3.9)
-!
-! Revision 1.1  2002/06/11 13:00:49  raasch
-! Initial revision
-!
-!
-! Description:
-! ------------
-!> Fast Fourier transformation along x and y for 1d domain decomposition along x.
-!> Original version: Klaus Ketelsen (May 2002)
-!------------------------------------------------------------------------------!
- MODULE fft_xy
- 
-
-    USE control_parameters,                                                    &
-        ONLY:  fft_method, message_string
-        
-    USE indices,                                                               &
-        ONLY:  nx, ny, nz
-        
-#if defined( __cuda_fft )
-    USE ISO_C_BINDING
-#elif defined( __fftw )
-    USE, INTRINSIC ::  ISO_C_BINDING
-#endif
-
-    USE kinds
-    
-    USE singleton,                                                             &
-        ONLY: fftn
-    
-    USE temperton_fft
-    
-    USE transpose_indices,                                                     &
-        ONLY:  nxl_y, nxr_y, nyn_x, nys_x, nzb_x, nzb_y, nzt_x, nzt_y
-
-    IMPLICIT NONE
-
-    PRIVATE
-    PUBLIC fft_x, fft_x_1d, fft_y, fft_y_1d, fft_init, fft_x_m, fft_y_m
-
-    INTEGER(iwp), DIMENSION(:), ALLOCATABLE, SAVE ::  ifax_x  !<
-    INTEGER(iwp), DIMENSION(:), ALLOCATABLE, SAVE ::  ifax_y  !<
-
-    LOGICAL, SAVE ::  init_fft = .FALSE.  !<
-
-    REAL(wp), SAVE ::  dnx      !<
-    REAL(wp), SAVE ::  dny      !<
-    REAL(wp), SAVE ::  sqr_dnx  !<
-    REAL(wp), SAVE ::  sqr_dny  !<
-    
-    REAL(wp), DIMENSION(:), ALLOCATABLE, SAVE ::  trigs_x  !< 
-    REAL(wp), DIMENSION(:), ALLOCATABLE, SAVE ::  trigs_y  !<
-
-#if defined( __ibm )
-    INTEGER(iwp), PARAMETER ::  nau1 = 20000  !< 
-    INTEGER(iwp), PARAMETER ::  nau2 = 22000  !<
-!
-!-- The following working arrays contain tables and have to be "save" and
-!-- shared in OpenMP sense
-    REAL(wp), DIMENSION(nau1), SAVE ::  aux1  !< 
-    REAL(wp), DIMENSION(nau1), SAVE ::  auy1  !<
-    REAL(wp), DIMENSION(nau1), SAVE ::  aux3  !< 
-    REAL(wp), DIMENSION(nau1), SAVE ::  auy3  !<
-    
-#elif defined( __nec )
-    INTEGER(iwp), SAVE ::  nz1  !<
-    
-    REAL(wp), DIMENSION(:), ALLOCATABLE, SAVE ::  trig_xb  !<
-    REAL(wp), DIMENSION(:), ALLOCATABLE, SAVE ::  trig_xf  !< 
-    REAL(wp), DIMENSION(:), ALLOCATABLE, SAVE ::  trig_yb  !<
-    REAL(wp), DIMENSION(:), ALLOCATABLE, SAVE ::  trig_yf  !<
-    
-#elif defined( __cuda_fft )
-    INTEGER(C_INT), SAVE ::  plan_xf  !<
-    INTEGER(C_INT), SAVE ::  plan_xi  !<
-    INTEGER(C_INT), SAVE ::  plan_yf  !<
-    INTEGER(C_INT), SAVE ::  plan_yi  !<
-    
-    INTEGER(iwp), SAVE   ::  total_points_x_transpo  !<
-    INTEGER(iwp), SAVE   ::  total_points_y_transpo  !<
-#endif
-
-#if defined( __fftw )
-    INCLUDE  'fftw3.f03'
-    INTEGER(KIND=C_INT) ::  nx_c  !<
-    INTEGER(KIND=C_INT) ::  ny_c  !<
-    
-    COMPLEX(KIND=C_DOUBLE_COMPLEX), DIMENSION(:), ALLOCATABLE, SAVE ::  x_out  !<
-    COMPLEX(KIND=C_DOUBLE_COMPLEX), DIMENSION(:), ALLOCATABLE, SAVE ::         &
-       y_out  !<
-    
-    REAL(KIND=C_DOUBLE), DIMENSION(:), ALLOCATABLE, SAVE ::                    &
-       x_in   !<
-    REAL(KIND=C_DOUBLE), DIMENSION(:), ALLOCATABLE, SAVE ::                    &
-       y_in   !<
-    !$OMP THREADPRIVATE( x_out, y_out, x_in, y_in )
-    
-    
-    TYPE(C_PTR), SAVE ::  plan_xf, plan_xi, plan_yf, plan_yi
-#endif
-
-!
-!-- Public interfaces
-    INTERFACE fft_init
-       MODULE PROCEDURE fft_init
-    END INTERFACE fft_init
-
-    INTERFACE fft_x
-       MODULE PROCEDURE fft_x
-    END INTERFACE fft_x
-
-    INTERFACE fft_x_1d
-       MODULE PROCEDURE fft_x_1d
-    END INTERFACE fft_x_1d
-
-    INTERFACE fft_y
-       MODULE PROCEDURE fft_y
-    END INTERFACE fft_y
-
-    INTERFACE fft_y_1d
-       MODULE PROCEDURE fft_y_1d
-    END INTERFACE fft_y_1d
-
-    INTERFACE fft_x_m
-       MODULE PROCEDURE fft_x_m
-    END INTERFACE fft_x_m
-
-    INTERFACE fft_y_m
-       MODULE PROCEDURE fft_y_m
-    END INTERFACE fft_y_m
-
- CONTAINS
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> @todo Missing subroutine description.
-!------------------------------------------------------------------------------!
-    SUBROUTINE fft_init
-
-       USE cuda_fft_interfaces
-
-       IMPLICIT NONE
-
-!
-!--    The following temporary working arrays have to be on stack or private
-!--    in OpenMP sense
-#if defined( __ibm )
-       REAL(wp), DIMENSION(0:nx+2) ::  workx  !<
-       REAL(wp), DIMENSION(0:ny+2) ::  worky  !<
-       REAL(wp), DIMENSION(nau2)   ::  aux2   !< 
-       REAL(wp), DIMENSION(nau2)   ::  auy2   !< 
-       REAL(wp), DIMENSION(nau2)   ::  aux4   !< 
-       REAL(wp), DIMENSION(nau2)   ::  auy4   !<
-#elif defined( __nec )
-       REAL(wp), DIMENSION(0:nx+3,nz+1)   ::  work_x  !<
-       REAL(wp), DIMENSION(0:ny+3,nz+1)   ::  work_y  !<
-       REAL(wp), DIMENSION(6*(nx+3),nz+1) ::  workx   !<
-       REAL(wp), DIMENSION(6*(ny+3),nz+1) ::  worky   !<
-#endif 
-
-!
-!--    Return, if already called
-       IF ( init_fft )  THEN
-          RETURN
-       ELSE
-          init_fft = .TRUE.
-       ENDIF
-
-       IF ( fft_method == 'system-specific' )  THEN
-
-          dnx = 1.0_wp / ( nx + 1.0_wp )
-          dny = 1.0_wp / ( ny + 1.0_wp )
-          sqr_dnx = SQRT( dnx )
-          sqr_dny = SQRT( dny )
-#if defined( __ibm )
-!
-!--       Initialize tables for fft along x
-          CALL DRCFT( 1, workx, 1, workx, 1, nx+1, 1,  1, sqr_dnx, aux1, nau1, &
-                      aux2, nau2 )
-          CALL DCRFT( 1, workx, 1, workx, 1, nx+1, 1, -1, sqr_dnx, aux3, nau1, &
-                      aux4, nau2 )
-!
-!--       Initialize tables for fft along y
-          CALL DRCFT( 1, worky, 1, worky, 1, ny+1, 1,  1, sqr_dny, auy1, nau1, &
-                      auy2, nau2 )
-          CALL DCRFT( 1, worky, 1, worky, 1, ny+1, 1, -1, sqr_dny, auy3, nau1, &
-                      auy4, nau2 )
-#elif defined( __nec )
-          message_string = 'fft method "' // TRIM( fft_method) // &
-                           '" currently does not work on NEC'
-          CALL message( 'fft_init', 'PA0187', 1, 2, 0, 6, 0 )
-
-          ALLOCATE( trig_xb(2*(nx+1)), trig_xf(2*(nx+1)),                      &
-                    trig_yb(2*(ny+1)), trig_yf(2*(ny+1)) )
-
-          work_x = 0.0_wp
-          work_y = 0.0_wp
-          nz1  = nz + MOD( nz+1, 2 )  ! odd nz slows down fft significantly
-                                      ! when using the NEC ffts
-
-!
-!--       Initialize tables for fft along x (non-vector and vector case (M))
-          CALL DZFFT( 0, nx+1, sqr_dnx, work_x, work_x, trig_xf, workx, 0 )
-          CALL ZDFFT( 0, nx+1, sqr_dnx, work_x, work_x, trig_xb, workx, 0 )
-          CALL DZFFTM( 0, nx+1, nz1, sqr_dnx, work_x, nx+4, work_x, nx+4,      &
-                       trig_xf, workx, 0 )
-          CALL ZDFFTM( 0, nx+1, nz1, sqr_dnx, work_x, nx+4, work_x, nx+4,      &
-                       trig_xb, workx, 0 )
-!
-!--       Initialize tables for fft along y (non-vector and vector case (M))
-          CALL DZFFT( 0, ny+1, sqr_dny, work_y, work_y, trig_yf, worky, 0 )
-          CALL ZDFFT( 0, ny+1, sqr_dny, work_y, work_y, trig_yb, worky, 0 )
-          CALL DZFFTM( 0, ny+1, nz1, sqr_dny, work_y, ny+4, work_y, ny+4,      &
-                       trig_yf, worky, 0 )
-          CALL ZDFFTM( 0, ny+1, nz1, sqr_dny, work_y, ny+4, work_y, ny+4,      &
-                       trig_yb, worky, 0 )
-#elif defined( __cuda_fft )
-          total_points_x_transpo = (nx+1) * (nyn_x-nys_x+1) * (nzt_x-nzb_x+1)
-          total_points_y_transpo = (ny+1) * (nxr_y-nxl_y+1) * (nzt_y-nzb_y+1)
-          CALL CUFFTPLAN1D( plan_xf, nx+1, CUFFT_D2Z, (nyn_x-nys_x+1) * (nzt_x-nzb_x+1) )
-          CALL CUFFTPLAN1D( plan_xi, nx+1, CUFFT_Z2D, (nyn_x-nys_x+1) * (nzt_x-nzb_x+1) )
-          CALL CUFFTPLAN1D( plan_yf, ny+1, CUFFT_D2Z, (nxr_y-nxl_y+1) * (nzt_y-nzb_y+1) )
-          CALL CUFFTPLAN1D( plan_yi, ny+1, CUFFT_Z2D, (nxr_y-nxl_y+1) * (nzt_y-nzb_y+1) )
-#else
-          message_string = 'no system-specific fft-call available'
-          CALL message( 'fft_init', 'PA0188', 1, 2, 0, 6, 0 )
-#endif
-       ELSEIF ( fft_method == 'temperton-algorithm' )  THEN
-!
-!--       Temperton-algorithm
-!--       Initialize tables for fft along x and y
-          ALLOCATE( ifax_x(nx+1), ifax_y(ny+1), trigs_x(nx+1), trigs_y(ny+1) )
-
-          CALL set99( trigs_x, ifax_x, nx+1 )
-          CALL set99( trigs_y, ifax_y, ny+1 )
-
-       ELSEIF ( fft_method == 'fftw' )  THEN
-!
-!--       FFTW
-#if defined( __fftw )
-          nx_c = nx+1
-          ny_c = ny+1
-          !$OMP PARALLEL
-          ALLOCATE( x_in(0:nx+2), y_in(0:ny+2), x_out(0:(nx+1)/2),             &
-                    y_out(0:(ny+1)/2) )
-          !$OMP END PARALLEL
-          plan_xf = FFTW_PLAN_DFT_R2C_1D( nx_c, x_in, x_out, FFTW_ESTIMATE )
-          plan_xi = FFTW_PLAN_DFT_C2R_1D( nx_c, x_out, x_in, FFTW_ESTIMATE )
-          plan_yf = FFTW_PLAN_DFT_R2C_1D( ny_c, y_in, y_out, FFTW_ESTIMATE )
-          plan_yi = FFTW_PLAN_DFT_C2R_1D( ny_c, y_out, y_in, FFTW_ESTIMATE )
-#else
-          message_string = 'preprocessor switch for fftw is missing'
-          CALL message( 'fft_init', 'PA0080', 1, 2, 0, 6, 0 )
-#endif
-
-       ELSEIF ( fft_method == 'singleton-algorithm' )  THEN
-
-          CONTINUE
-
-       ELSE
-
-          message_string = 'fft method "' // TRIM( fft_method) // &
-                           '" not available'
-          CALL message( 'fft_init', 'PA0189', 1, 2, 0, 6, 0 )
-       ENDIF
-
-    END SUBROUTINE fft_init
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Fourier-transformation along x-direction.                 
-!> Version for 2D-decomposition.
-!> It uses internal algorithms (Singleton or Temperton) or      
-!> system-specific routines, if they are available           
-!------------------------------------------------------------------------------!
- 
-    SUBROUTINE fft_x( ar, direction, ar_2d )
-
-
-       USE cuda_fft_interfaces
-#if defined( __cuda_fft )
-       USE ISO_C_BINDING
-#endif
-
-       IMPLICIT NONE
-
-       CHARACTER (LEN=*) ::  direction  !<
-       
-       COMPLEX(wp), DIMENSION(:), ALLOCATABLE ::  cwork  !<
-
-       INTEGER(iwp) ::  i          !< 
-       INTEGER(iwp) ::  ishape(1)  !<
-       INTEGER(iwp) ::  j          !<
-       INTEGER(iwp) ::  k          !<
-
-       LOGICAL ::  forward_fft !<
-       
-       REAL(wp), DIMENSION(0:nx+2) ::  work   !<
-       REAL(wp), DIMENSION(nx+2)   ::  work1  !<
-       
-#if defined( __ibm )
-       REAL(wp), DIMENSION(nau2) ::  aux2  !< 
-       REAL(wp), DIMENSION(nau2) ::  aux4  !<
-#elif defined( __nec )
-       REAL(wp), DIMENSION(6*(nx+1)) ::  work2  !<
-#elif defined( __cuda_fft )
-       COMPLEX(dp), DIMENSION(0:(nx+1)/2,nys_x:nyn_x,nzb_x:nzt_x) ::           &
-          ar_tmp  !<
-       ! following does not work for PGI 14.1 -> to be removed later
-       ! !$acc declare create( ar_tmp )
-#endif
-
-       REAL(wp), DIMENSION(0:nx,nys_x:nyn_x), OPTIONAL   ::                    &
-          ar_2d   !<
-       REAL(wp), DIMENSION(0:nx,nys_x:nyn_x,nzb_x:nzt_x) ::                    &
-          ar      !<
-
-       IF ( direction == 'forward' )  THEN
-          forward_fft = .TRUE.
-       ELSE
-          forward_fft = .FALSE.
-       ENDIF
-
-       IF ( fft_method == 'singleton-algorithm' )  THEN
-
-!
-!--       Performing the fft with singleton's software works on every system,
-!--       since it is part of the model
-          ALLOCATE( cwork(0:nx) )
-      
-          IF ( forward_fft )   then
-
-             !$OMP PARALLEL PRIVATE ( cwork, i, ishape, j, k )
-             !$OMP DO
-             DO  k = nzb_x, nzt_x
-                DO  j = nys_x, nyn_x
-
-                   DO  i = 0, nx
-                      cwork(i) = CMPLX( ar(i,j,k), KIND=wp )
-                   ENDDO
-
-                   ishape = SHAPE( cwork )
-                   CALL FFTN( cwork, ishape )
-
-                   DO  i = 0, (nx+1)/2
-                      ar(i,j,k) = REAL( cwork(i), KIND=wp )
-                   ENDDO
-                   DO  i = 1, (nx+1)/2 - 1
-                      ar(nx+1-i,j,k) = -AIMAG( cwork(i) )
-                   ENDDO
-
-                ENDDO
-             ENDDO
-             !$OMP END PARALLEL
-
-          ELSE
-
-             !$OMP PARALLEL PRIVATE ( cwork, i, ishape, j, k )
-             !$OMP DO
-             DO  k = nzb_x, nzt_x
-                DO  j = nys_x, nyn_x
-
-                   cwork(0) = CMPLX( ar(0,j,k), 0.0_wp, KIND=wp )
-                   DO  i = 1, (nx+1)/2 - 1
-                      cwork(i)      = CMPLX( ar(i,j,k), -ar(nx+1-i,j,k),       &
-                                             KIND=wp )
-                      cwork(nx+1-i) = CMPLX( ar(i,j,k),  ar(nx+1-i,j,k),       &
-                                             KIND=wp )
-                   ENDDO
-                   cwork((nx+1)/2) = CMPLX( ar((nx+1)/2,j,k), 0.0_wp, KIND=wp )
-
-                   ishape = SHAPE( cwork )
-                   CALL FFTN( cwork, ishape, inv = .TRUE. )
-
-                   DO  i = 0, nx
-                      ar(i,j,k) = REAL( cwork(i), KIND=wp )
-                   ENDDO
-
-                ENDDO
-             ENDDO
-             !$OMP END PARALLEL
-
-          ENDIF
-
-          DEALLOCATE( cwork )
-
-       ELSEIF ( fft_method == 'temperton-algorithm' )  THEN
-
-!
-!--       Performing the fft with Temperton's software works on every system,
-!--       since it is part of the model
-          IF ( forward_fft )  THEN
-
-             !$OMP PARALLEL PRIVATE ( work, work1, i, j, k )
-             !$OMP DO
-             DO  k = nzb_x, nzt_x
-                DO  j = nys_x, nyn_x
-
-                   work(0:nx) = ar(0:nx,j,k)
-                   CALL fft991cy( work, work1, trigs_x, ifax_x, 1, nx+1, nx+1, 1, -1 )
-
-                   DO  i = 0, (nx+1)/2
-                      ar(i,j,k) = work(2*i)
-                   ENDDO
-                   DO  i = 1, (nx+1)/2 - 1
-                      ar(nx+1-i,j,k) = work(2*i+1)
-                   ENDDO
-
-                ENDDO
-             ENDDO
-             !$OMP END PARALLEL
-
-          ELSE
-
-             !$OMP PARALLEL PRIVATE ( work, work1, i, j, k )
-             !$OMP DO
-             DO  k = nzb_x, nzt_x
-                DO  j = nys_x, nyn_x
-
-                   DO  i = 0, (nx+1)/2
-                      work(2*i) = ar(i,j,k)
-                   ENDDO
-                   DO  i = 1, (nx+1)/2 - 1
-                      work(2*i+1) = ar(nx+1-i,j,k)
-                   ENDDO
-                   work(1)    = 0.0_wp
-                   work(nx+2) = 0.0_wp
-
-                   CALL fft991cy( work, work1, trigs_x, ifax_x, 1, nx+1, nx+1, 1, 1 )
-                   ar(0:nx,j,k) = work(0:nx)
-
-                ENDDO
-             ENDDO
-             !$OMP END PARALLEL
-
-          ENDIF
-
-       ELSEIF ( fft_method == 'fftw' )  THEN
-
-#if defined( __fftw )
-          IF ( forward_fft )  THEN
-
-             !$OMP PARALLEL PRIVATE ( work, i, j, k )
-             !$OMP DO
-             DO  k = nzb_x, nzt_x
-                DO  j = nys_x, nyn_x
-
-                   x_in(0:nx) = ar(0:nx,j,k)
-                   CALL FFTW_EXECUTE_DFT_R2C( plan_xf, x_in, x_out )
-
-                   IF ( PRESENT( ar_2d ) )  THEN
-
-                      DO  i = 0, (nx+1)/2
-                         ar_2d(i,j) = REAL( x_out(i), KIND=wp ) / ( nx+1 )
-                      ENDDO
-                      DO  i = 1, (nx+1)/2 - 1
-                         ar_2d(nx+1-i,j) = AIMAG( x_out(i) ) / ( nx+1 )
-                      ENDDO
-
-                   ELSE
-
-                      DO  i = 0, (nx+1)/2
-                         ar(i,j,k) = REAL( x_out(i), KIND=wp ) / ( nx+1 )
-                      ENDDO
-                      DO  i = 1, (nx+1)/2 - 1
-                         ar(nx+1-i,j,k) = AIMAG( x_out(i) ) / ( nx+1 )
-                      ENDDO
-
-                   ENDIF
-
-                ENDDO
-             ENDDO
-             !$OMP END PARALLEL
-
-          ELSE
-             !$OMP PARALLEL PRIVATE ( work, i, j, k )
-             !$OMP DO
-             DO  k = nzb_x, nzt_x
-                DO  j = nys_x, nyn_x
-
-                   IF ( PRESENT( ar_2d ) )  THEN
-
-                      x_out(0) = CMPLX( ar_2d(0,j), 0.0_wp, KIND=wp )
-                      DO  i = 1, (nx+1)/2 - 1
-                         x_out(i) = CMPLX( ar_2d(i,j), ar_2d(nx+1-i,j),        &
-                                           KIND=wp )
-                      ENDDO
-                      x_out((nx+1)/2) = CMPLX( ar_2d((nx+1)/2,j), 0.0_wp,      &
-                                               KIND=wp )
-
-                   ELSE
-
-                      x_out(0) = CMPLX( ar(0,j,k), 0.0_wp, KIND=wp )
-                      DO  i = 1, (nx+1)/2 - 1
-                         x_out(i) = CMPLX( ar(i,j,k), ar(nx+1-i,j,k), KIND=wp )
-                      ENDDO
-                      x_out((nx+1)/2) = CMPLX( ar((nx+1)/2,j,k), 0.0_wp,       &
-                                               KIND=wp )
-
-                   ENDIF
-
-                   CALL FFTW_EXECUTE_DFT_C2R( plan_xi, x_out, x_in)
-                   ar(0:nx,j,k) = x_in(0:nx)
-
-                ENDDO
-             ENDDO
-             !$OMP END PARALLEL
-
-          ENDIF
-#endif
-
-       ELSEIF ( fft_method == 'system-specific' )  THEN
-
-#if defined( __ibm )
-          IF ( forward_fft )  THEN
-
-             !$OMP PARALLEL PRIVATE ( work, i, j, k )
-             !$OMP DO
-             DO  k = nzb_x, nzt_x
-                DO  j = nys_x, nyn_x
-
-                   CALL DRCFT( 0, ar, 1, work, 1, nx+1, 1, 1, sqr_dnx, aux1,   &
-                               nau1, aux2, nau2 )
-
-                   DO  i = 0, (nx+1)/2
-                      ar(i,j,k) = work(2*i)
-                   ENDDO
-                   DO  i = 1, (nx+1)/2 - 1
-                      ar(nx+1-i,j,k) = work(2*i+1)
-                   ENDDO
-
-                ENDDO
-             ENDDO
-             !$OMP END PARALLEL
-
-          ELSE
-
-             !$OMP PARALLEL PRIVATE ( work, i, j, k )
-             !$OMP DO
-             DO  k = nzb_x, nzt_x
-                DO  j = nys_x, nyn_x
-
-                   DO  i = 0, (nx+1)/2
-                      work(2*i) = ar(i,j,k)
-                   ENDDO
-                   DO  i = 1, (nx+1)/2 - 1
-                      work(2*i+1) = ar(nx+1-i,j,k)
-                   ENDDO
-                   work(1) = 0.0_wp
-                   work(nx+2) = 0.0_wp
-
-                   CALL DCRFT( 0, work, 1, work, 1, nx+1, 1, -1, sqr_dnx,      & 
-                               aux3, nau1, aux4, nau2 )
-
-                   DO  i = 0, nx
-                      ar(i,j,k) = work(i)
-                   ENDDO
-
-                ENDDO
-             ENDDO
-             !$OMP END PARALLEL
-
-          ENDIF
-
-#elif defined( __nec )
-
-          IF ( forward_fft )  THEN
-
-             !$OMP PARALLEL PRIVATE ( work, i, j, k )
-             !$OMP DO
-             DO  k = nzb_x, nzt_x
-                DO  j = nys_x, nyn_x
-
-                   work(0:nx) = ar(0:nx,j,k)
-
-                   CALL DZFFT( 1, nx+1, sqr_dnx, work, work, trig_xf, work2, 0 )
-      
-                   DO  i = 0, (nx+1)/2
-                      ar(i,j,k) = work(2*i)
-                   ENDDO
-                   DO  i = 1, (nx+1)/2 - 1
-                      ar(nx+1-i,j,k) = work(2*i+1)
-                   ENDDO
-
-                ENDDO
-             ENDDO
-             !$END OMP PARALLEL
-
-          ELSE
-
-             !$OMP PARALLEL PRIVATE ( work, i, j, k )
-             !$OMP DO
-             DO  k = nzb_x, nzt_x
-                DO  j = nys_x, nyn_x
-
-                   DO  i = 0, (nx+1)/2
-                      work(2*i) = ar(i,j,k)
-                   ENDDO
-                   DO  i = 1, (nx+1)/2 - 1
-                      work(2*i+1) = ar(nx+1-i,j,k)
-                   ENDDO
-                   work(1) = 0.0_wp
-                   work(nx+2) = 0.0_wp
-
-                   CALL ZDFFT( -1, nx+1, sqr_dnx, work, work, trig_xb, work2, 0 )
-
-                   ar(0:nx,j,k) = work(0:nx)
-
-                ENDDO
-             ENDDO
-             !$OMP END PARALLEL
-
-          ENDIF
-
-#elif defined( __cuda_fft )
-
-          !$acc data create( ar_tmp )
-          IF ( forward_fft )  THEN
-
-             !$acc data present( ar )
-             CALL CUFFTEXECD2Z( plan_xf, ar, ar_tmp )
-
-             !$acc kernels
-             DO  k = nzb_x, nzt_x
-                DO  j = nys_x, nyn_x
-
-                   DO  i = 0, (nx+1)/2
-                      ar(i,j,k)      = REAL( ar_tmp(i,j,k), KIND=wp )  * dnx
-                   ENDDO
-
-                   DO  i = 1, (nx+1)/2 - 1
-                      ar(nx+1-i,j,k) = AIMAG( ar_tmp(i,j,k) ) * dnx
-                   ENDDO
-
-                ENDDO
-             ENDDO
-             !$acc end kernels
-             !$acc end data
-
-          ELSE
-
-             !$acc data present( ar )
-             !$acc kernels
-             DO  k = nzb_x, nzt_x
-                DO  j = nys_x, nyn_x
-
-                   ar_tmp(0,j,k) = CMPLX( ar(0,j,k), 0.0_wp, KIND=wp )
-
-                   DO  i = 1, (nx+1)/2 - 1
-                      ar_tmp(i,j,k) = CMPLX( ar(i,j,k), ar(nx+1-i,j,k),        &
-                                             KIND=wp )
-                   ENDDO
-                   ar_tmp((nx+1)/2,j,k) = CMPLX( ar((nx+1)/2,j,k), 0.0_wp,     &
-                                                 KIND=wp )
-
-                ENDDO
-             ENDDO
-             !$acc end kernels
-
-             CALL CUFFTEXECZ2D( plan_xi, ar_tmp, ar )
-             !$acc end data
-
-          ENDIF
-          !$acc end data
-
-#else
-          message_string = 'no system-specific fft-call available'
-          CALL message( 'fft_x', 'PA0188', 1, 2, 0, 6, 0 )
-#endif
-
-       ELSE
-
-          message_string = 'fft method "' // TRIM( fft_method) // &
-                           '" not available'
-          CALL message( 'fft_x', 'PA0189', 1, 2, 0, 6, 0 )
-
-       ENDIF
-
-    END SUBROUTINE fft_x
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Fourier-transformation along x-direction.
-!> Version for 1D-decomposition.
-!> It uses internal algorithms (Singleton or Temperton) or
-!> system-specific routines, if they are available
-!------------------------------------------------------------------------------!
- 
-    SUBROUTINE fft_x_1d( ar, direction )
-
-
-       IMPLICIT NONE
-
-       CHARACTER (LEN=*) ::  direction  !<
-       
-       INTEGER(iwp) ::  i               !<
-       INTEGER(iwp) ::  ishape(1)       !<
-
-       LOGICAL ::  forward_fft          !<
-
-       REAL(wp), DIMENSION(0:nx)   ::  ar     !<
-       REAL(wp), DIMENSION(0:nx+2) ::  work   !<
-       REAL(wp), DIMENSION(nx+2)   ::  work1  !<
-       
-       COMPLEX(wp), DIMENSION(:), ALLOCATABLE ::  cwork  !<
-       
-#if defined( __ibm )
-       REAL(wp), DIMENSION(nau2) ::  aux2       !<
-       REAL(wp), DIMENSION(nau2) ::  aux4       !<
-#elif defined( __nec )
-       REAL(wp), DIMENSION(6*(nx+1)) ::  work2  !<
-#endif
-
-       IF ( direction == 'forward' )  THEN
-          forward_fft = .TRUE.
-       ELSE
-          forward_fft = .FALSE.
-       ENDIF
-
-       IF ( fft_method == 'singleton-algorithm' )  THEN
-
-!
-!--       Performing the fft with singleton's software works on every system,
-!--       since it is part of the model
-          ALLOCATE( cwork(0:nx) )
-      
-          IF ( forward_fft )   then
-
-             DO  i = 0, nx
-                cwork(i) = CMPLX( ar(i), KIND=wp )
-             ENDDO
-             ishape = SHAPE( cwork )
-             CALL FFTN( cwork, ishape )
-             DO  i = 0, (nx+1)/2
-                ar(i) = REAL( cwork(i), KIND=wp )
-             ENDDO
-             DO  i = 1, (nx+1)/2 - 1
-                ar(nx+1-i) = -AIMAG( cwork(i) )
-             ENDDO
-
-          ELSE
-
-             cwork(0) = CMPLX( ar(0), 0.0_wp, KIND=wp )
-             DO  i = 1, (nx+1)/2 - 1
-                cwork(i)      = CMPLX( ar(i), -ar(nx+1-i), KIND=wp )
-                cwork(nx+1-i) = CMPLX( ar(i),  ar(nx+1-i), KIND=wp )
-             ENDDO
-             cwork((nx+1)/2) = CMPLX( ar((nx+1)/2), 0.0_wp, KIND=wp )
-
-             ishape = SHAPE( cwork )
-             CALL FFTN( cwork, ishape, inv = .TRUE. )
-
-             DO  i = 0, nx
-                ar(i) = REAL( cwork(i), KIND=wp )
-             ENDDO
-
-          ENDIF
-
-          DEALLOCATE( cwork )
-
-       ELSEIF ( fft_method == 'temperton-algorithm' )  THEN
-
-!
-!--       Performing the fft with Temperton's software works on every system,
-!--       since it is part of the model
-          IF ( forward_fft )  THEN
-
-             work(0:nx) = ar
-             CALL fft991cy( work, work1, trigs_x, ifax_x, 1, nx+1, nx+1, 1, -1 )
-
-             DO  i = 0, (nx+1)/2
-                ar(i) = work(2*i)
-             ENDDO
-             DO  i = 1, (nx+1)/2 - 1
-                ar(nx+1-i) = work(2*i+1)
-             ENDDO
-
-          ELSE
-
-             DO  i = 0, (nx+1)/2
-                work(2*i) = ar(i)
-             ENDDO
-             DO  i = 1, (nx+1)/2 - 1
-                work(2*i+1) = ar(nx+1-i)
-             ENDDO
-             work(1)    = 0.0_wp
-             work(nx+2) = 0.0_wp
-
-             CALL fft991cy( work, work1, trigs_x, ifax_x, 1, nx+1, nx+1, 1, 1 )
-             ar = work(0:nx)
-
-          ENDIF
-
-       ELSEIF ( fft_method == 'fftw' )  THEN
-
-#if defined( __fftw )
-          IF ( forward_fft )  THEN
-
-             x_in(0:nx) = ar(0:nx)
-             CALL FFTW_EXECUTE_DFT_R2C( plan_xf, x_in, x_out )
-
-             DO  i = 0, (nx+1)/2
-                ar(i) = REAL( x_out(i), KIND=wp ) / ( nx+1 )
-             ENDDO
-             DO  i = 1, (nx+1)/2 - 1
-                ar(nx+1-i) = AIMAG( x_out(i) ) / ( nx+1 )
-             ENDDO
-
-         ELSE
-
-             x_out(0) = CMPLX( ar(0), 0.0_wp, KIND=wp )
-             DO  i = 1, (nx+1)/2 - 1
-                x_out(i) = CMPLX( ar(i), ar(nx+1-i), KIND=wp )
-             ENDDO
-             x_out((nx+1)/2) = CMPLX( ar((nx+1)/2), 0.0_wp, KIND=wp )
-
-             CALL FFTW_EXECUTE_DFT_C2R( plan_xi, x_out, x_in)
-             ar(0:nx) = x_in(0:nx)
-
-         ENDIF
-#endif
-
-       ELSEIF ( fft_method == 'system-specific' )  THEN
-
-#if defined( __ibm )
-          IF ( forward_fft )  THEN
-
-             CALL DRCFT( 0, ar, 1, work, 1, nx+1, 1, 1, sqr_dnx, aux1, nau1,   &
-                         aux2, nau2 )
-
-             DO  i = 0, (nx+1)/2
-                ar(i) = work(2*i)
-             ENDDO
-             DO  i = 1, (nx+1)/2 - 1
-                ar(nx+1-i) = work(2*i+1)
-             ENDDO
-
-          ELSE
-
-             DO  i = 0, (nx+1)/2
-                work(2*i) = ar(i)
-             ENDDO
-             DO  i = 1, (nx+1)/2 - 1
-                work(2*i+1) = ar(nx+1-i)
-             ENDDO
-             work(1) = 0.0_wp
-             work(nx+2) = 0.0_wp
-
-             CALL DCRFT( 0, work, 1, work, 1, nx+1, 1, -1, sqr_dnx, aux3, nau1, &
-                         aux4, nau2 )
-
-             DO  i = 0, nx
-                ar(i) = work(i)
-             ENDDO
-
-          ENDIF
-#elif defined( __nec )
-          IF ( forward_fft )  THEN
-
-             work(0:nx) = ar(0:nx)
-
-             CALL DZFFT( 1, nx+1, sqr_dnx, work, work, trig_xf, work2, 0 )
-      
-             DO  i = 0, (nx+1)/2
-                ar(i) = work(2*i)
-             ENDDO
-             DO  i = 1, (nx+1)/2 - 1
-                ar(nx+1-i) = work(2*i+1)
-             ENDDO
-
-          ELSE
-
-             DO  i = 0, (nx+1)/2
-                work(2*i) = ar(i)
-             ENDDO
-             DO  i = 1, (nx+1)/2 - 1
-                work(2*i+1) = ar(nx+1-i)
-             ENDDO
-             work(1) = 0.0_wp
-             work(nx+2) = 0.0_wp
-
-             CALL ZDFFT( -1, nx+1, sqr_dnx, work, work, trig_xb, work2, 0 )
-
-             ar(0:nx) = work(0:nx)
-
-          ENDIF
-#else
-          message_string = 'no system-specific fft-call available'
-          CALL message( 'fft_x_1d', 'PA0188', 1, 2, 0, 6, 0 )
-#endif
-       ELSE
-          message_string = 'fft method "' // TRIM( fft_method) // &
-                           '" not available'
-          CALL message( 'fft_x_1d', 'PA0189', 1, 2, 0, 6, 0 )
-
-       ENDIF
-
-    END SUBROUTINE fft_x_1d
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Fourier-transformation along y-direction.
-!> Version for 2D-decomposition.
-!> It uses internal algorithms (Singleton or Temperton) or
-!> system-specific routines, if they are available.
-!> 
-!> direction:  'forward' or 'backward'
-!> ar, ar_tr:  3D data arrays 
-!>             forward:   ar: before  ar_tr: after transformation
-!>             backward:  ar_tr: before  ar: after transfosition
-!> 
-!> In case of non-overlapping transposition/transformation:
-!> nxl_y_bound = nxl_y_l = nxl_y 
-!> nxr_y_bound = nxr_y_l = nxr_y 
-!> 
-!> In case of overlapping transposition/transformation
-!> - nxl_y_bound  and  nxr_y_bound have the original values of
-!>   nxl_y, nxr_y.  ar_tr is dimensioned using these values.
-!> - nxl_y_l = nxr_y_r.  ar is dimensioned with these values, so that
-!>   transformation is carried out for a 2D-plane only.
-!------------------------------------------------------------------------------!
- 
-    SUBROUTINE fft_y( ar, direction, ar_tr, nxl_y_bound, nxr_y_bound, nxl_y_l, &
-                      nxr_y_l )
-
-
-       USE cuda_fft_interfaces
-#if defined( __cuda_fft )
-       USE ISO_C_BINDING
-#endif
-
-       IMPLICIT NONE
-
-       CHARACTER (LEN=*) ::  direction  !<
-       
-       INTEGER(iwp) ::  i            !<
-       INTEGER(iwp) ::  j            !< 
-       INTEGER(iwp) ::  jshape(1)    !<
-       INTEGER(iwp) ::  k            !<
-       INTEGER(iwp) ::  nxl_y_bound  !<
-       INTEGER(iwp) ::  nxl_y_l      !<
-       INTEGER(iwp) ::  nxr_y_bound  !<
-       INTEGER(iwp) ::  nxr_y_l      !<
-
-       LOGICAL ::  forward_fft  !<
-
-       REAL(wp), DIMENSION(0:ny+2) ::  work   !<
-       REAL(wp), DIMENSION(ny+2)   ::  work1  !<
-       
-       COMPLEX(wp), DIMENSION(:), ALLOCATABLE ::  cwork  !<
-       
-#if defined( __ibm )
-       REAL(wp), DIMENSION(nau2) ::  auy2  !<
-       REAL(wp), DIMENSION(nau2) ::  auy4  !<
-#elif defined( __nec )
-       REAL(wp), DIMENSION(6*(ny+1)) ::  work2  !<
-#elif defined( __cuda_fft )
-       COMPLEX(dp), DIMENSION(0:(ny+1)/2,nxl_y:nxr_y,nzb_y:nzt_y) ::           &
-          ar_tmp  !<
-       ! following does not work for PGI 14.1 -> to be removed later
-       ! !$acc declare create( ar_tmp )
-#endif
-
-       REAL(wp), DIMENSION(0:ny,nxl_y_l:nxr_y_l,nzb_y:nzt_y)         ::        &
-          ar     !<
-       REAL(wp), DIMENSION(0:ny,nxl_y_bound:nxr_y_bound,nzb_y:nzt_y) ::        &
-          ar_tr  !<
-
-       IF ( direction == 'forward' )  THEN
-          forward_fft = .TRUE.
-       ELSE
-          forward_fft = .FALSE.
-       ENDIF
-
-       IF ( fft_method == 'singleton-algorithm' )  THEN
-
-!
-!--       Performing the fft with singleton's software works on every system,
-!--       since it is part of the model
-          ALLOCATE( cwork(0:ny) )
-
-          IF ( forward_fft )   then
-
-             !$OMP PARALLEL PRIVATE ( cwork, i, jshape, j, k )
-             !$OMP DO
-             DO  k = nzb_y, nzt_y
-                DO  i = nxl_y_l, nxr_y_l
-
-                   DO  j = 0, ny
-                      cwork(j) = CMPLX( ar(j,i,k), KIND=wp )
-                   ENDDO
-
-                   jshape = SHAPE( cwork )
-                   CALL FFTN( cwork, jshape )
-
-                   DO  j = 0, (ny+1)/2
-                      ar_tr(j,i,k) = REAL( cwork(j), KIND=wp )
-                   ENDDO
-                   DO  j = 1, (ny+1)/2 - 1
-                      ar_tr(ny+1-j,i,k) = -AIMAG( cwork(j) )
-                   ENDDO
-
-                ENDDO
-             ENDDO
-             !$OMP END PARALLEL
-
-          ELSE
-
-             !$OMP PARALLEL PRIVATE ( cwork, i, jshape, j, k )
-             !$OMP DO
-             DO  k = nzb_y, nzt_y
-                DO  i = nxl_y_l, nxr_y_l
-
-                   cwork(0) = CMPLX( ar_tr(0,i,k), 0.0_wp, KIND=wp )
-                   DO  j = 1, (ny+1)/2 - 1
-                      cwork(j)      = CMPLX( ar_tr(j,i,k), -ar_tr(ny+1-j,i,k), &
-                                             KIND=wp )
-                      cwork(ny+1-j) = CMPLX( ar_tr(j,i,k),  ar_tr(ny+1-j,i,k), &
-                                             KIND=wp )
-                   ENDDO
-                   cwork((ny+1)/2) = CMPLX( ar_tr((ny+1)/2,i,k), 0.0_wp,       &
-                                            KIND=wp )
-
-                   jshape = SHAPE( cwork )
-                   CALL FFTN( cwork, jshape, inv = .TRUE. )
-
-                   DO  j = 0, ny
-                      ar(j,i,k) = REAL( cwork(j), KIND=wp )
-                   ENDDO
-
-                ENDDO
-             ENDDO
-             !$OMP END PARALLEL
-
-          ENDIF
-
-          DEALLOCATE( cwork )
-
-       ELSEIF ( fft_method == 'temperton-algorithm' )  THEN
-
-!
-!--       Performing the fft with Temperton's software works on every system,
-!--       since it is part of the model
-          IF ( forward_fft )  THEN
-
-             !$OMP PARALLEL PRIVATE ( work, work1, i, j, k )
-             !$OMP DO
-             DO  k = nzb_y, nzt_y
-                DO  i = nxl_y_l, nxr_y_l
-
-                   work(0:ny) = ar(0:ny,i,k)
-                   CALL fft991cy( work, work1, trigs_y, ifax_y, 1, ny+1, ny+1, 1, -1 )
-
-                   DO  j = 0, (ny+1)/2
-                      ar_tr(j,i,k) = work(2*j)
-                   ENDDO
-                   DO  j = 1, (ny+1)/2 - 1
-                      ar_tr(ny+1-j,i,k) = work(2*j+1)
-                   ENDDO
-
-                ENDDO
-             ENDDO
-             !$OMP END PARALLEL
-
-          ELSE
-
-             !$OMP PARALLEL PRIVATE ( work, work1, i, j, k )
-             !$OMP DO
-             DO  k = nzb_y, nzt_y
-                DO  i = nxl_y_l, nxr_y_l
-
-                   DO  j = 0, (ny+1)/2
-                      work(2*j) = ar_tr(j,i,k)
-                   ENDDO
-                   DO  j = 1, (ny+1)/2 - 1
-                      work(2*j+1) = ar_tr(ny+1-j,i,k)
-                   ENDDO
-                   work(1)    = 0.0_wp
-                   work(ny+2) = 0.0_wp
-
-                   CALL fft991cy( work, work1, trigs_y, ifax_y, 1, ny+1, ny+1, 1, 1 )
-                   ar(0:ny,i,k) = work(0:ny)
-
-                ENDDO
-             ENDDO
-             !$OMP END PARALLEL
-
-          ENDIF
-
-       ELSEIF ( fft_method == 'fftw' )  THEN
-
-#if defined( __fftw )
-          IF ( forward_fft )  THEN
-
-             !$OMP PARALLEL PRIVATE ( work, i, j, k )
-             !$OMP DO
-             DO  k = nzb_y, nzt_y
-                DO  i = nxl_y_l, nxr_y_l
-
-                   y_in(0:ny) = ar(0:ny,i,k)
-                   CALL FFTW_EXECUTE_DFT_R2C( plan_yf, y_in, y_out )
-
-                   DO  j = 0, (ny+1)/2
-                      ar_tr(j,i,k) = REAL( y_out(j), KIND=wp ) / (ny+1)
-                   ENDDO
-                   DO  j = 1, (ny+1)/2 - 1
-                      ar_tr(ny+1-j,i,k) = AIMAG( y_out(j) ) / (ny+1)
-                   ENDDO
-
-                ENDDO
-             ENDDO
-             !$OMP END PARALLEL
-
-          ELSE
-
-             !$OMP PARALLEL PRIVATE ( work, i, j, k )
-             !$OMP DO
-             DO  k = nzb_y, nzt_y
-                DO  i = nxl_y_l, nxr_y_l
-
-                   y_out(0) = CMPLX( ar_tr(0,i,k), 0.0_wp, KIND=wp )
-                   DO  j = 1, (ny+1)/2 - 1
-                      y_out(j) = CMPLX( ar_tr(j,i,k), ar_tr(ny+1-j,i,k),       &
-                                        KIND=wp )
-                   ENDDO
-                   y_out((ny+1)/2) = CMPLX( ar_tr((ny+1)/2,i,k), 0.0_wp,       &
-                                            KIND=wp )
-
-                   CALL FFTW_EXECUTE_DFT_C2R( plan_yi, y_out, y_in )
-                   ar(0:ny,i,k) = y_in(0:ny)
-
-                ENDDO
-             ENDDO
-             !$OMP END PARALLEL
-
-          ENDIF
-#endif
-
-       ELSEIF ( fft_method == 'system-specific' )  THEN
-
-#if defined( __ibm )
-          IF ( forward_fft)  THEN
-
-             !$OMP PARALLEL PRIVATE ( work, i, j, k )
-             !$OMP DO
-             DO  k = nzb_y, nzt_y
-                DO  i = nxl_y_l, nxr_y_l
-
-                   CALL DRCFT( 0, ar, 1, work, 1, ny+1, 1, 1, sqr_dny, auy1,   & 
-                               nau1, auy2, nau2 )
-
-                   DO  j = 0, (ny+1)/2
-                      ar_tr(j,i,k) = work(2*j)
-                   ENDDO
-                   DO  j = 1, (ny+1)/2 - 1
-                      ar_tr(ny+1-j,i,k) = work(2*j+1)
-                   ENDDO
-
-                ENDDO
-             ENDDO
-             !$OMP END PARALLEL
-
-          ELSE
-
-             !$OMP PARALLEL PRIVATE ( work, i, j, k )
-             !$OMP DO
-             DO  k = nzb_y, nzt_y
-                DO  i = nxl_y_l, nxr_y_l
-
-                   DO  j = 0, (ny+1)/2
-                      work(2*j) = ar_tr(j,i,k)
-                   ENDDO
-                   DO  j = 1, (ny+1)/2 - 1
-                      work(2*j+1) = ar_tr(ny+1-j,i,k)
-                   ENDDO
-                   work(1)    = 0.0_wp
-                   work(ny+2) = 0.0_wp
-
-                   CALL DCRFT( 0, work, 1, work, 1, ny+1, 1, -1, sqr_dny,      &
-                               auy3, nau1, auy4, nau2 )
-
-                   DO  j = 0, ny
-                      ar(j,i,k) = work(j)
-                   ENDDO
-
-                ENDDO
-             ENDDO
-             !$OMP END PARALLEL
-
-          ENDIF
-#elif defined( __nec )
-          IF ( forward_fft )  THEN
-
-             !$OMP PARALLEL PRIVATE ( work, i, j, k )
-             !$OMP DO
-             DO  k = nzb_y, nzt_y
-                DO  i = nxl_y_l, nxr_y_l
-
-                   work(0:ny) = ar(0:ny,i,k)
-
-                   CALL DZFFT( 1, ny+1, sqr_dny, work, work, trig_yf, work2, 0 )
-
-                   DO  j = 0, (ny+1)/2
-                      ar_tr(j,i,k) = work(2*j)
-                   ENDDO
-                   DO  j = 1, (ny+1)/2 - 1
-                      ar_tr(ny+1-j,i,k) = work(2*j+1)
-                   ENDDO
-
-                ENDDO
-             ENDDO
-             !$END OMP PARALLEL
-
-          ELSE
-
-             !$OMP PARALLEL PRIVATE ( work, i, j, k )
-             !$OMP DO
-             DO  k = nzb_y, nzt_y
-                DO  i = nxl_y_l, nxr_y_l
-
-                   DO  j = 0, (ny+1)/2
-                      work(2*j) = ar_tr(j,i,k)
-                   ENDDO
-                   DO  j = 1, (ny+1)/2 - 1
-                      work(2*j+1) = ar_tr(ny+1-j,i,k)
-                   ENDDO
-                   work(1) = 0.0_wp
-                   work(ny+2) = 0.0_wp
-
-                   CALL ZDFFT( -1, ny+1, sqr_dny, work, work, trig_yb, work2, 0 )
-
-                   ar(0:ny,i,k) = work(0:ny)
-
-                ENDDO
-             ENDDO
-             !$OMP END PARALLEL
-
-          ENDIF
-#elif defined( __cuda_fft )
-
-          !$acc data create( ar_tmp )
-          IF ( forward_fft )  THEN
-
-             !$acc data present( ar )
-             CALL CUFFTEXECD2Z( plan_yf, ar, ar_tmp )
-
-             !$acc kernels
-             DO  k = nzb_y, nzt_y
-                DO  i = nxl_y, nxr_y
-
-                   DO  j = 0, (ny+1)/2
-                      ar(j,i,k)      = REAL( ar_tmp(j,i,k), KIND=wp )  * dny
-                   ENDDO
-
-                   DO  j = 1, (ny+1)/2 - 1
-                      ar(ny+1-j,i,k) = AIMAG( ar_tmp(j,i,k) ) * dny
-                   ENDDO
-
-                ENDDO
-             ENDDO
-             !$acc end kernels
-             !$acc end data
-
-          ELSE
-
-             !$acc data present( ar )
-             !$acc kernels
-             DO  k = nzb_y, nzt_y
-                DO  i = nxl_y, nxr_y
-
-                   ar_tmp(0,i,k) = CMPLX( ar(0,i,k), 0.0_wp, KIND=wp )
-
-                   DO  j = 1, (ny+1)/2 - 1
-                      ar_tmp(j,i,k) = CMPLX( ar(j,i,k), ar(ny+1-j,i,k),        &
-                                             KIND=wp )
-                   ENDDO
-                   ar_tmp((ny+1)/2,i,k) = CMPLX( ar((ny+1)/2,i,k), 0.0_wp,     &
-                                                 KIND=wp )
-
-                ENDDO
-             ENDDO
-             !$acc end kernels
-
-             CALL CUFFTEXECZ2D( plan_yi, ar_tmp, ar )
-             !$acc end data
-
-          ENDIF
-          !$acc end data
-
-#else
-          message_string = 'no system-specific fft-call available'
-          CALL message( 'fft_y', 'PA0188', 1, 2, 0, 6, 0 ) 
-#endif
-
-       ELSE
-
-          message_string = 'fft method "' // TRIM( fft_method) // &
-                           '" not available'
-          CALL message( 'fft_y', 'PA0189', 1, 2, 0, 6, 0 )
-
-       ENDIF
-
-    END SUBROUTINE fft_y
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Fourier-transformation along y-direction.
-!> Version for 1D-decomposition.
-!> It uses internal algorithms (Singleton or Temperton) or
-!> system-specific routines, if they are available.
-!------------------------------------------------------------------------------!
- 
-    SUBROUTINE fft_y_1d( ar, direction )
-
-
-       IMPLICIT NONE
-
-       CHARACTER (LEN=*) ::  direction
-       
-       INTEGER(iwp) ::  j          !<
-       INTEGER(iwp) ::  jshape(1)  !<
-
-       LOGICAL ::  forward_fft  !<
-
-       REAL(wp), DIMENSION(0:ny)    ::  ar     !<
-       REAL(wp), DIMENSION(0:ny+2)  ::  work   !<
-       REAL(wp), DIMENSION(ny+2)    ::  work1  !<
-       
-       COMPLEX(wp), DIMENSION(:), ALLOCATABLE ::  cwork  !<
-       
-#if defined( __ibm )
-       REAL(wp), DIMENSION(nau2) ::  auy2  !<
-       REAL(wp), DIMENSION(nau2) ::  auy4  !<
-#elif defined( __nec )
-       REAL(wp), DIMENSION(6*(ny+1)) ::  work2  !<
-#endif
-
-       IF ( direction == 'forward' )  THEN
-          forward_fft = .TRUE.
-       ELSE
-          forward_fft = .FALSE.
-       ENDIF
-
-       IF ( fft_method == 'singleton-algorithm' )  THEN
-
-!
-!--       Performing the fft with singleton's software works on every system,
-!--       since it is part of the model
-          ALLOCATE( cwork(0:ny) )
-
-          IF ( forward_fft )  THEN
-
-             DO  j = 0, ny
-                cwork(j) = CMPLX( ar(j), KIND=wp )
-             ENDDO
-
-             jshape = SHAPE( cwork )
-             CALL FFTN( cwork, jshape )
-
-             DO  j = 0, (ny+1)/2
-                ar(j) = REAL( cwork(j), KIND=wp )
-             ENDDO
-             DO  j = 1, (ny+1)/2 - 1
-                ar(ny+1-j) = -AIMAG( cwork(j) )
-             ENDDO
-
-          ELSE
-
-             cwork(0) = CMPLX( ar(0), 0.0_wp, KIND=wp )
-             DO  j = 1, (ny+1)/2 - 1
-                cwork(j)      = CMPLX( ar(j), -ar(ny+1-j), KIND=wp )
-                cwork(ny+1-j) = CMPLX( ar(j),  ar(ny+1-j), KIND=wp )
-             ENDDO
-             cwork((ny+1)/2) = CMPLX( ar((ny+1)/2), 0.0_wp, KIND=wp )
-
-             jshape = SHAPE( cwork )
-             CALL FFTN( cwork, jshape, inv = .TRUE. )
-
-             DO  j = 0, ny
-                ar(j) = REAL( cwork(j), KIND=wp )
-             ENDDO
-
-          ENDIF
-
-          DEALLOCATE( cwork )
-
-       ELSEIF ( fft_method == 'temperton-algorithm' )  THEN
-
-!
-!--       Performing the fft with Temperton's software works on every system,
-!--       since it is part of the model
-          IF ( forward_fft )  THEN
-
-             work(0:ny) = ar
-             CALL fft991cy( work, work1, trigs_y, ifax_y, 1, ny+1, ny+1, 1, -1 )
-
-             DO  j = 0, (ny+1)/2
-                ar(j) = work(2*j)
-             ENDDO
-             DO  j = 1, (ny+1)/2 - 1
-                ar(ny+1-j) = work(2*j+1)
-             ENDDO
-
-          ELSE
-
-             DO  j = 0, (ny+1)/2
-                work(2*j) = ar(j)
-             ENDDO
-             DO  j = 1, (ny+1)/2 - 1
-                work(2*j+1) = ar(ny+1-j)
-             ENDDO
-             work(1)    = 0.0_wp
-             work(ny+2) = 0.0_wp
-
-             CALL fft991cy( work, work1, trigs_y, ifax_y, 1, ny+1, ny+1, 1, 1 )
-             ar = work(0:ny)
-
-          ENDIF
-
-       ELSEIF ( fft_method == 'fftw' )  THEN
-
-#if defined( __fftw )
-          IF ( forward_fft )  THEN
-
-             y_in(0:ny) = ar(0:ny)
-             CALL FFTW_EXECUTE_DFT_R2C( plan_yf, y_in, y_out )
-
-             DO  j = 0, (ny+1)/2
-                ar(j) = REAL( y_out(j), KIND=wp ) / (ny+1)
-             ENDDO
-             DO  j = 1, (ny+1)/2 - 1
-                ar(ny+1-j) = AIMAG( y_out(j) ) / (ny+1)
-             ENDDO
-
-          ELSE
-
-             y_out(0) = CMPLX( ar(0), 0.0_wp, KIND=wp )
-             DO  j = 1, (ny+1)/2 - 1
-                y_out(j) = CMPLX( ar(j), ar(ny+1-j), KIND=wp )
-             ENDDO
-             y_out((ny+1)/2) = CMPLX( ar((ny+1)/2), 0.0_wp, KIND=wp )
-
-             CALL FFTW_EXECUTE_DFT_C2R( plan_yi, y_out, y_in )
-             ar(0:ny) = y_in(0:ny)
-
-          ENDIF
-#endif
-
-       ELSEIF ( fft_method == 'system-specific' )  THEN
-
-#if defined( __ibm )
-          IF ( forward_fft )  THEN
-
-             CALL DRCFT( 0, ar, 1, work, 1, ny+1, 1, 1, sqr_dny, auy1, nau1,   &
-                         auy2, nau2 )
-
-             DO  j = 0, (ny+1)/2
-                ar(j) = work(2*j)
-             ENDDO
-             DO  j = 1, (ny+1)/2 - 1
-                ar(ny+1-j) = work(2*j+1)
-             ENDDO
-
-          ELSE
-
-             DO  j = 0, (ny+1)/2
-                work(2*j) = ar(j)
-             ENDDO
-             DO  j = 1, (ny+1)/2 - 1
-                work(2*j+1) = ar(ny+1-j)
-             ENDDO
-             work(1)    = 0.0_wp
-             work(ny+2) = 0.0_wp
-
-             CALL DCRFT( 0, work, 1, work, 1, ny+1, 1, -1, sqr_dny, auy3,      &
-                         nau1, auy4, nau2 )
-
-             DO  j = 0, ny
-                ar(j) = work(j)
-             ENDDO
-
-          ENDIF
-#elif defined( __nec )
-          IF ( forward_fft )  THEN
-
-             work(0:ny) = ar(0:ny)
-
-             CALL DZFFT( 1, ny+1, sqr_dny, work, work, trig_yf, work2, 0 )
-
-             DO  j = 0, (ny+1)/2
-                ar(j) = work(2*j)
-             ENDDO
-             DO  j = 1, (ny+1)/2 - 1
-                ar(ny+1-j) = work(2*j+1)
-             ENDDO
-
-          ELSE
-
-             DO  j = 0, (ny+1)/2
-                work(2*j) = ar(j)
-             ENDDO
-             DO  j = 1, (ny+1)/2 - 1
-                work(2*j+1) = ar(ny+1-j)
-             ENDDO
-             work(1) = 0.0_wp
-             work(ny+2) = 0.0_wp
-
-             CALL ZDFFT( -1, ny+1, sqr_dny, work, work, trig_yb, work2, 0 )
-
-             ar(0:ny) = work(0:ny)
-
-          ENDIF
-#else
-          message_string = 'no system-specific fft-call available'
-          CALL message( 'fft_y_1d', 'PA0188', 1, 2, 0, 6, 0 ) 
-
-#endif
-
-       ELSE
-
-          message_string = 'fft method "' // TRIM( fft_method) // &
-                           '" not available'
-          CALL message( 'fft_y_1d', 'PA0189', 1, 2, 0, 6, 0 )
-
-       ENDIF
-
-    END SUBROUTINE fft_y_1d
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Fourier-transformation along x-direction.
-!> Version for 1d domain decomposition
-!> using multiple 1D FFT from Math Keisan on NEC or Temperton-algorithm
-!> (no singleton-algorithm on NEC because it does not vectorize)
-!------------------------------------------------------------------------------!
- 
-    SUBROUTINE fft_x_m( ar, direction )
-
-
-       IMPLICIT NONE
-
-       CHARACTER (LEN=*) ::  direction  !<
-       
-       INTEGER(iwp) ::  i     !<
-       INTEGER(iwp) ::  k     !<
-       INTEGER(iwp) ::  siza  !<
-
-       REAL(wp), DIMENSION(0:nx,nz)       ::  ar     !<
-       REAL(wp), DIMENSION(0:nx+3,nz+1)   ::  ai     !<
-       REAL(wp), DIMENSION(6*(nx+4),nz+1) ::  work1  !<
-       
-#if defined( __nec )
-       INTEGER(iwp) ::  sizw  !<
-       
-       COMPLEX(wp), DIMENSION((nx+4)/2+1,nz+1) ::  work  !<
-#endif
-
-       IF ( fft_method == 'temperton-algorithm' )  THEN
-
-          siza = SIZE( ai, 1 )
-
-          IF ( direction == 'forward')  THEN
-
-             ai(0:nx,1:nz) = ar(0:nx,1:nz)
-             ai(nx+1:,:)   = 0.0_wp
-
-             CALL fft991cy( ai, work1, trigs_x, ifax_x, 1, siza, nx+1, nz, -1 )
-
-             DO  k = 1, nz
-                DO  i = 0, (nx+1)/2
-                   ar(i,k) = ai(2*i,k)
-                ENDDO
-                DO  i = 1, (nx+1)/2 - 1
-                   ar(nx+1-i,k) = ai(2*i+1,k)
-                ENDDO
-             ENDDO
-
-          ELSE
-
-             DO  k = 1, nz
-                DO  i = 0, (nx+1)/2
-                   ai(2*i,k) = ar(i,k)
-                ENDDO
-                DO  i = 1, (nx+1)/2 - 1
-                   ai(2*i+1,k) = ar(nx+1-i,k)
-                ENDDO
-                ai(1,k) = 0.0_wp
-                ai(nx+2,k) = 0.0_wp
-             ENDDO
-
-             CALL fft991cy( ai, work1, trigs_x, ifax_x, 1, siza, nx+1, nz, 1 )
-
-             ar(0:nx,1:nz) = ai(0:nx,1:nz)
-
-          ENDIF
-
-       ELSEIF ( fft_method == 'system-specific' )  THEN
-
-#if defined( __nec )
-          siza = SIZE( ai, 1 )
-          sizw = SIZE( work, 1 )
-
-          IF ( direction == 'forward')  THEN
-
-!
-!--          Tables are initialized once more. This call should not be
-!--          necessary, but otherwise program aborts in asymmetric case
-             CALL DZFFTM( 0, nx+1, nz1, sqr_dnx, work, nx+4, work, nx+4,       &
-                          trig_xf, work1, 0 )
-
-             ai(0:nx,1:nz) = ar(0:nx,1:nz)
-             IF ( nz1 > nz )  THEN
-                ai(:,nz1) = 0.0_wp
-             ENDIF
-
-             CALL DZFFTM( 1, nx+1, nz1, sqr_dnx, ai, siza, work, sizw,         &
-                          trig_xf, work1, 0 )
-
-             DO  k = 1, nz
-                DO  i = 0, (nx+1)/2
-                   ar(i,k) = REAL( work(i+1,k), KIND=wp )
-                ENDDO
-                DO  i = 1, (nx+1)/2 - 1
-                   ar(nx+1-i,k) = AIMAG( work(i+1,k) )
-                ENDDO
-             ENDDO
-
-          ELSE
-
-!
-!--          Tables are initialized once more. This call should not be
-!--          necessary, but otherwise program aborts in asymmetric case
-             CALL ZDFFTM( 0, nx+1, nz1, sqr_dnx, work, nx+4, work, nx+4,       &
-                          trig_xb, work1, 0 )
-
-             IF ( nz1 > nz )  THEN
-                work(:,nz1) = 0.0_wp
-             ENDIF
-             DO  k = 1, nz
-                work(1,k) = CMPLX( ar(0,k), 0.0_wp, KIND=wp )
-                DO  i = 1, (nx+1)/2 - 1
-                   work(i+1,k) = CMPLX( ar(i,k), ar(nx+1-i,k), KIND=wp )
-                ENDDO
-                work(((nx+1)/2)+1,k) = CMPLX( ar((nx+1)/2,k), 0.0_wp, KIND=wp )
-             ENDDO
-
-             CALL ZDFFTM( -1, nx+1, nz1, sqr_dnx, work, sizw, ai, siza, &
-                          trig_xb, work1, 0 )
-
-             ar(0:nx,1:nz) = ai(0:nx,1:nz)
-
-          ENDIF
-
-#else
-          message_string = 'no system-specific fft-call available'
-          CALL message( 'fft_x_m', 'PA0188', 1, 2, 0, 6, 0 ) 
-#endif
-
-       ELSE
-
-          message_string = 'fft method "' // TRIM( fft_method) // &
-                           '" not available'
-          CALL message( 'fft_x_m', 'PA0189', 1, 2, 0, 6, 0 )
-
-       ENDIF
-
-    END SUBROUTINE fft_x_m
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Fourier-transformation along y-direction.
-!> Version for 1d domain decomposition
-!> using multiple 1D FFT from Math Keisan on NEC or Temperton-algorithm
-!> (no singleton-algorithm on NEC because it does not vectorize)
-!------------------------------------------------------------------------------!
- 
-    SUBROUTINE fft_y_m( ar, ny1, direction )
-
-
-       IMPLICIT NONE
-
-       CHARACTER (LEN=*) ::  direction  !<
-       
-       INTEGER(iwp) ::  j     !< 
-       INTEGER(iwp) ::  k     !<
-       INTEGER(iwp) ::  ny1   !<
-       INTEGER(iwp) ::  siza  !<
-
-       REAL(wp), DIMENSION(0:ny1,nz)      ::  ar     !<
-       REAL(wp), DIMENSION(0:ny+3,nz+1)   ::  ai     !<
-       REAL(wp), DIMENSION(6*(ny+4),nz+1) ::  work1  !<
-       
-#if defined( __nec )
-       INTEGER(iwp) ::  sizw  !<
-       
-       COMPLEX(wp), DIMENSION((ny+4)/2+1,nz+1) ::  work !<
-#endif
-
-       IF ( fft_method == 'temperton-algorithm' )  THEN
-
-          siza = SIZE( ai, 1 )
-
-          IF ( direction == 'forward')  THEN
-
-             ai(0:ny,1:nz) = ar(0:ny,1:nz)
-             ai(ny+1:,:)   = 0.0_wp
-
-             CALL fft991cy( ai, work1, trigs_y, ifax_y, 1, siza, ny+1, nz, -1 )
-
-             DO  k = 1, nz
-                DO  j = 0, (ny+1)/2
-                   ar(j,k) = ai(2*j,k)
-                ENDDO
-                DO  j = 1, (ny+1)/2 - 1
-                   ar(ny+1-j,k) = ai(2*j+1,k)
-                ENDDO
-             ENDDO
-
-          ELSE
-
-             DO  k = 1, nz
-                DO  j = 0, (ny+1)/2
-                   ai(2*j,k) = ar(j,k)
-                ENDDO
-                DO  j = 1, (ny+1)/2 - 1
-                   ai(2*j+1,k) = ar(ny+1-j,k)
-                ENDDO
-                ai(1,k) = 0.0_wp
-                ai(ny+2,k) = 0.0_wp
-             ENDDO
-
-             CALL fft991cy( ai, work1, trigs_y, ifax_y, 1, siza, ny+1, nz, 1 )
-
-             ar(0:ny,1:nz) = ai(0:ny,1:nz)
-
-          ENDIF
-
-       ELSEIF ( fft_method == 'system-specific' )  THEN
-
-#if defined( __nec )
-          siza = SIZE( ai, 1 )
-          sizw = SIZE( work, 1 )
-
-          IF ( direction == 'forward')  THEN
-
-!
-!--          Tables are initialized once more. This call should not be
-!--          necessary, but otherwise program aborts in asymmetric case
-             CALL DZFFTM( 0, ny+1, nz1, sqr_dny, work, ny+4, work, ny+4, &
-                          trig_yf, work1, 0 )
-
-             ai(0:ny,1:nz) = ar(0:ny,1:nz)
-             IF ( nz1 > nz )  THEN
-                ai(:,nz1) = 0.0_wp
-             ENDIF
-
-             CALL DZFFTM( 1, ny+1, nz1, sqr_dny, ai, siza, work, sizw, &
-                          trig_yf, work1, 0 )
-
-             DO  k = 1, nz
-                DO  j = 0, (ny+1)/2
-                   ar(j,k) = REAL( work(j+1,k), KIND=wp )
-                ENDDO
-                DO  j = 1, (ny+1)/2 - 1
-                   ar(ny+1-j,k) = AIMAG( work(j+1,k) )
-                ENDDO
-             ENDDO
-
-          ELSE
-
-!
-!--          Tables are initialized once more. This call should not be
-!--          necessary, but otherwise program aborts in asymmetric case
-             CALL ZDFFTM( 0, ny+1, nz1, sqr_dny, work, ny+4, work, ny+4, &
-                          trig_yb, work1, 0 )
-
-             IF ( nz1 > nz )  THEN
-                work(:,nz1) = 0.0_wp
-             ENDIF
-             DO  k = 1, nz
-                work(1,k) = CMPLX( ar(0,k), 0.0_wp, KIND=wp )
-                DO  j = 1, (ny+1)/2 - 1
-                   work(j+1,k) = CMPLX( ar(j,k), ar(ny+1-j,k), KIND=wp )
-                ENDDO
-                work(((ny+1)/2)+1,k) = CMPLX( ar((ny+1)/2,k), 0.0_wp, KIND=wp )
-             ENDDO
-
-             CALL ZDFFTM( -1, ny+1, nz1, sqr_dny, work, sizw, ai, siza, &
-                          trig_yb, work1, 0 )
-
-             ar(0:ny,1:nz) = ai(0:ny,1:nz)
-
-          ENDIF
-
-#else
-          message_string = 'no system-specific fft-call available'
-          CALL message( 'fft_y_m', 'PA0188', 1, 2, 0, 6, 0 ) 
-#endif
-
-       ELSE
-         
-          message_string = 'fft method "' // TRIM( fft_method) // &
-                           '" not available'
-          CALL message( 'fft_x_m', 'PA0189', 1, 2, 0, 6, 0 )
-
-       ENDIF
-
-    END SUBROUTINE fft_y_m
-
-
- END MODULE fft_xy
Index: /palm/trunk/SOURCE/fft_xy_mod.f90
===================================================================
--- /palm/trunk/SOURCE/fft_xy_mod.f90	(revision 1850)
+++ /palm/trunk/SOURCE/fft_xy_mod.f90	(revision 1850)
@@ -0,0 +1,1934 @@
+!> @file fft_xy_mod.f90
+!--------------------------------------------------------------------------------!
+! This file is part of PALM.
+!
+! PALM is free software: you can redistribute it and/or modify it under the terms
+! of the GNU General Public License as published by the Free Software Foundation,
+! either version 3 of the License, or (at your option) any later version.
+!
+! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
+! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
+! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along with
+! PALM. If not, see <http://www.gnu.org/licenses/>.
+!
+! Copyright 1997-2016 Leibniz Universitaet Hannover
+!------------------------------------------------------------------------------!
+!
+! Current revisions:
+! -----------------
+! Module renamed
+! 
+! 
+! Former revisions:
+! -----------------
+! $Id$
+!
+! 1815 2016-04-06 13:49:59Z raasch
+! cpp-directives for ibmy removed
+!
+! 1749 2016-02-09 12:19:56Z raasch
+! small OpenACC bugfix
+!
+! 1682 2015-10-07 23:56:08Z knoop
+! Code annotations made doxygen readable
+!
+! 1600 2015-06-11 15:50:12Z raasch
+! bugfix: openMP threadprivate statement moved after variable declaration
+!
+! 1482 2014-10-18 12:34:45Z raasch
+! cudafft workaround for data declaration of ar_tmp because of PGI 14.1 bug
+!
+! 1402 2014-05-09 14:25:13Z raasch
+! fortran bugfix for r1392
+! 
+! 1398 2014-05-07 11:15:00Z heinze
+! bugfix: typo removed for KIND in CMPLX function
+!
+! 1392 2014-05-06 09:10:05Z raasch
+! bugfix: KIND attribute added to CMPLX functions
+!
+! 1374 2014-04-25 12:55:07Z raasch
+! bugfixes: missing variables added to ONLY list, dpk renamed dp
+!
+! 1372 2014-04-24 06:29:32Z raasch
+! openMP-bugfix for fftw: some arrays defined as threadprivate
+!
+! 1353 2014-04-08 15:21:23Z heinze
+! REAL constants provided with KIND-attribute 
+! 
+! 1342 2014-03-26 17:04:47Z kanani
+! REAL constants defined as wp-kind
+!
+! 1322 2014-03-20 16:38:49Z raasch
+! REAL functions provided with KIND-attribute
+!
+! 1320 2014-03-20 08:40:49Z raasch
+! ONLY-attribute added to USE-statements,
+! kind-parameters added to all INTEGER and REAL declaration statements, 
+! kinds are defined in new module kinds, 
+! old module precision_kind is removed,
+! revision history before 2012 removed,
+! comment fields (!:) to be used for variable explanations added to
+! all variable declaration statements 
+!
+! 1304 2014-03-12 10:29:42Z raasch
+! openmp bugfix: work1 used in Temperton algorithm must be private
+!
+! 1257 2013-11-08 15:18:40Z raasch
+! openacc loop and loop vector clauses removed, declare create moved after
+! the FORTRAN declaration statement
+!
+! 1219 2013-08-30 09:33:18Z heinze
+! bugfix: use own branch for fftw
+!
+! 1216 2013-08-26 09:31:42Z raasch
+! fft_x and fft_y modified for parallel / ovverlapping execution of fft and
+! transpositions,
+! fftw implemented for 1d-decomposition (fft_x_1d, fft_y_1d)
+!
+! 1210 2013-08-14 10:58:20Z raasch
+! fftw added
+!
+! 1166 2013-05-24 13:55:44Z raasch
+! C_DOUBLE/COMPLEX reset to dpk
+!
+! 1153 2013-05-10 14:33:08Z raasch
+! code adjustment of data types for CUDA fft required by PGI 12.3 / CUDA 5.0
+!
+! 1111 2013-03-08 23:54:10Z raasch
+! further openACC statements added, CUDA branch completely runs on GPU
+! bugfix: CUDA fft plans adjusted for domain decomposition (before they always
+! used total domain)
+!
+! 1106 2013-03-04 05:31:38Z raasch
+! CUDA fft added
+! array_kind renamed precision_kind, 3D- instead of 1D-loops in fft_x and fft_y
+! old fft_x, fft_y become fft_x_1d, fft_y_1d and are used for 1D-decomposition
+!
+! 1092 2013-02-02 11:24:22Z raasch
+! variable sizw declared for NEC case only
+!
+! 1036 2012-10-22 13:43:42Z raasch
+! code put under GPL (PALM 3.9)
+!
+! Revision 1.1  2002/06/11 13:00:49  raasch
+! Initial revision
+!
+!
+! Description:
+! ------------
+!> Fast Fourier transformation along x and y for 1d domain decomposition along x.
+!> Original version: Klaus Ketelsen (May 2002)
+!------------------------------------------------------------------------------!
+ MODULE fft_xy
+ 
+
+    USE control_parameters,                                                    &
+        ONLY:  fft_method, message_string
+        
+    USE indices,                                                               &
+        ONLY:  nx, ny, nz
+        
+#if defined( __cuda_fft )
+    USE ISO_C_BINDING
+#elif defined( __fftw )
+    USE, INTRINSIC ::  ISO_C_BINDING
+#endif
+
+    USE kinds
+    
+    USE singleton,                                                             &
+        ONLY: fftn
+    
+    USE temperton_fft
+    
+    USE transpose_indices,                                                     &
+        ONLY:  nxl_y, nxr_y, nyn_x, nys_x, nzb_x, nzb_y, nzt_x, nzt_y
+
+    IMPLICIT NONE
+
+    PRIVATE
+    PUBLIC fft_x, fft_x_1d, fft_y, fft_y_1d, fft_init, fft_x_m, fft_y_m
+
+    INTEGER(iwp), DIMENSION(:), ALLOCATABLE, SAVE ::  ifax_x  !<
+    INTEGER(iwp), DIMENSION(:), ALLOCATABLE, SAVE ::  ifax_y  !<
+
+    LOGICAL, SAVE ::  init_fft = .FALSE.  !<
+
+    REAL(wp), SAVE ::  dnx      !<
+    REAL(wp), SAVE ::  dny      !<
+    REAL(wp), SAVE ::  sqr_dnx  !<
+    REAL(wp), SAVE ::  sqr_dny  !<
+    
+    REAL(wp), DIMENSION(:), ALLOCATABLE, SAVE ::  trigs_x  !< 
+    REAL(wp), DIMENSION(:), ALLOCATABLE, SAVE ::  trigs_y  !<
+
+#if defined( __ibm )
+    INTEGER(iwp), PARAMETER ::  nau1 = 20000  !< 
+    INTEGER(iwp), PARAMETER ::  nau2 = 22000  !<
+!
+!-- The following working arrays contain tables and have to be "save" and
+!-- shared in OpenMP sense
+    REAL(wp), DIMENSION(nau1), SAVE ::  aux1  !< 
+    REAL(wp), DIMENSION(nau1), SAVE ::  auy1  !<
+    REAL(wp), DIMENSION(nau1), SAVE ::  aux3  !< 
+    REAL(wp), DIMENSION(nau1), SAVE ::  auy3  !<
+    
+#elif defined( __nec )
+    INTEGER(iwp), SAVE ::  nz1  !<
+    
+    REAL(wp), DIMENSION(:), ALLOCATABLE, SAVE ::  trig_xb  !<
+    REAL(wp), DIMENSION(:), ALLOCATABLE, SAVE ::  trig_xf  !< 
+    REAL(wp), DIMENSION(:), ALLOCATABLE, SAVE ::  trig_yb  !<
+    REAL(wp), DIMENSION(:), ALLOCATABLE, SAVE ::  trig_yf  !<
+    
+#elif defined( __cuda_fft )
+    INTEGER(C_INT), SAVE ::  plan_xf  !<
+    INTEGER(C_INT), SAVE ::  plan_xi  !<
+    INTEGER(C_INT), SAVE ::  plan_yf  !<
+    INTEGER(C_INT), SAVE ::  plan_yi  !<
+    
+    INTEGER(iwp), SAVE   ::  total_points_x_transpo  !<
+    INTEGER(iwp), SAVE   ::  total_points_y_transpo  !<
+#endif
+
+#if defined( __fftw )
+    INCLUDE  'fftw3.f03'
+    INTEGER(KIND=C_INT) ::  nx_c  !<
+    INTEGER(KIND=C_INT) ::  ny_c  !<
+    
+    COMPLEX(KIND=C_DOUBLE_COMPLEX), DIMENSION(:), ALLOCATABLE, SAVE ::  x_out  !<
+    COMPLEX(KIND=C_DOUBLE_COMPLEX), DIMENSION(:), ALLOCATABLE, SAVE ::         &
+       y_out  !<
+    
+    REAL(KIND=C_DOUBLE), DIMENSION(:), ALLOCATABLE, SAVE ::                    &
+       x_in   !<
+    REAL(KIND=C_DOUBLE), DIMENSION(:), ALLOCATABLE, SAVE ::                    &
+       y_in   !<
+    !$OMP THREADPRIVATE( x_out, y_out, x_in, y_in )
+    
+    
+    TYPE(C_PTR), SAVE ::  plan_xf, plan_xi, plan_yf, plan_yi
+#endif
+
+!
+!-- Public interfaces
+    INTERFACE fft_init
+       MODULE PROCEDURE fft_init
+    END INTERFACE fft_init
+
+    INTERFACE fft_x
+       MODULE PROCEDURE fft_x
+    END INTERFACE fft_x
+
+    INTERFACE fft_x_1d
+       MODULE PROCEDURE fft_x_1d
+    END INTERFACE fft_x_1d
+
+    INTERFACE fft_y
+       MODULE PROCEDURE fft_y
+    END INTERFACE fft_y
+
+    INTERFACE fft_y_1d
+       MODULE PROCEDURE fft_y_1d
+    END INTERFACE fft_y_1d
+
+    INTERFACE fft_x_m
+       MODULE PROCEDURE fft_x_m
+    END INTERFACE fft_x_m
+
+    INTERFACE fft_y_m
+       MODULE PROCEDURE fft_y_m
+    END INTERFACE fft_y_m
+
+ CONTAINS
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> @todo Missing subroutine description.
+!------------------------------------------------------------------------------!
+    SUBROUTINE fft_init
+
+       USE cuda_fft_interfaces
+
+       IMPLICIT NONE
+
+!
+!--    The following temporary working arrays have to be on stack or private
+!--    in OpenMP sense
+#if defined( __ibm )
+       REAL(wp), DIMENSION(0:nx+2) ::  workx  !<
+       REAL(wp), DIMENSION(0:ny+2) ::  worky  !<
+       REAL(wp), DIMENSION(nau2)   ::  aux2   !< 
+       REAL(wp), DIMENSION(nau2)   ::  auy2   !< 
+       REAL(wp), DIMENSION(nau2)   ::  aux4   !< 
+       REAL(wp), DIMENSION(nau2)   ::  auy4   !<
+#elif defined( __nec )
+       REAL(wp), DIMENSION(0:nx+3,nz+1)   ::  work_x  !<
+       REAL(wp), DIMENSION(0:ny+3,nz+1)   ::  work_y  !<
+       REAL(wp), DIMENSION(6*(nx+3),nz+1) ::  workx   !<
+       REAL(wp), DIMENSION(6*(ny+3),nz+1) ::  worky   !<
+#endif 
+
+!
+!--    Return, if already called
+       IF ( init_fft )  THEN
+          RETURN
+       ELSE
+          init_fft = .TRUE.
+       ENDIF
+
+       IF ( fft_method == 'system-specific' )  THEN
+
+          dnx = 1.0_wp / ( nx + 1.0_wp )
+          dny = 1.0_wp / ( ny + 1.0_wp )
+          sqr_dnx = SQRT( dnx )
+          sqr_dny = SQRT( dny )
+#if defined( __ibm )
+!
+!--       Initialize tables for fft along x
+          CALL DRCFT( 1, workx, 1, workx, 1, nx+1, 1,  1, sqr_dnx, aux1, nau1, &
+                      aux2, nau2 )
+          CALL DCRFT( 1, workx, 1, workx, 1, nx+1, 1, -1, sqr_dnx, aux3, nau1, &
+                      aux4, nau2 )
+!
+!--       Initialize tables for fft along y
+          CALL DRCFT( 1, worky, 1, worky, 1, ny+1, 1,  1, sqr_dny, auy1, nau1, &
+                      auy2, nau2 )
+          CALL DCRFT( 1, worky, 1, worky, 1, ny+1, 1, -1, sqr_dny, auy3, nau1, &
+                      auy4, nau2 )
+#elif defined( __nec )
+          message_string = 'fft method "' // TRIM( fft_method) // &
+                           '" currently does not work on NEC'
+          CALL message( 'fft_init', 'PA0187', 1, 2, 0, 6, 0 )
+
+          ALLOCATE( trig_xb(2*(nx+1)), trig_xf(2*(nx+1)),                      &
+                    trig_yb(2*(ny+1)), trig_yf(2*(ny+1)) )
+
+          work_x = 0.0_wp
+          work_y = 0.0_wp
+          nz1  = nz + MOD( nz+1, 2 )  ! odd nz slows down fft significantly
+                                      ! when using the NEC ffts
+
+!
+!--       Initialize tables for fft along x (non-vector and vector case (M))
+          CALL DZFFT( 0, nx+1, sqr_dnx, work_x, work_x, trig_xf, workx, 0 )
+          CALL ZDFFT( 0, nx+1, sqr_dnx, work_x, work_x, trig_xb, workx, 0 )
+          CALL DZFFTM( 0, nx+1, nz1, sqr_dnx, work_x, nx+4, work_x, nx+4,      &
+                       trig_xf, workx, 0 )
+          CALL ZDFFTM( 0, nx+1, nz1, sqr_dnx, work_x, nx+4, work_x, nx+4,      &
+                       trig_xb, workx, 0 )
+!
+!--       Initialize tables for fft along y (non-vector and vector case (M))
+          CALL DZFFT( 0, ny+1, sqr_dny, work_y, work_y, trig_yf, worky, 0 )
+          CALL ZDFFT( 0, ny+1, sqr_dny, work_y, work_y, trig_yb, worky, 0 )
+          CALL DZFFTM( 0, ny+1, nz1, sqr_dny, work_y, ny+4, work_y, ny+4,      &
+                       trig_yf, worky, 0 )
+          CALL ZDFFTM( 0, ny+1, nz1, sqr_dny, work_y, ny+4, work_y, ny+4,      &
+                       trig_yb, worky, 0 )
+#elif defined( __cuda_fft )
+          total_points_x_transpo = (nx+1) * (nyn_x-nys_x+1) * (nzt_x-nzb_x+1)
+          total_points_y_transpo = (ny+1) * (nxr_y-nxl_y+1) * (nzt_y-nzb_y+1)
+          CALL CUFFTPLAN1D( plan_xf, nx+1, CUFFT_D2Z, (nyn_x-nys_x+1) * (nzt_x-nzb_x+1) )
+          CALL CUFFTPLAN1D( plan_xi, nx+1, CUFFT_Z2D, (nyn_x-nys_x+1) * (nzt_x-nzb_x+1) )
+          CALL CUFFTPLAN1D( plan_yf, ny+1, CUFFT_D2Z, (nxr_y-nxl_y+1) * (nzt_y-nzb_y+1) )
+          CALL CUFFTPLAN1D( plan_yi, ny+1, CUFFT_Z2D, (nxr_y-nxl_y+1) * (nzt_y-nzb_y+1) )
+#else
+          message_string = 'no system-specific fft-call available'
+          CALL message( 'fft_init', 'PA0188', 1, 2, 0, 6, 0 )
+#endif
+       ELSEIF ( fft_method == 'temperton-algorithm' )  THEN
+!
+!--       Temperton-algorithm
+!--       Initialize tables for fft along x and y
+          ALLOCATE( ifax_x(nx+1), ifax_y(ny+1), trigs_x(nx+1), trigs_y(ny+1) )
+
+          CALL set99( trigs_x, ifax_x, nx+1 )
+          CALL set99( trigs_y, ifax_y, ny+1 )
+
+       ELSEIF ( fft_method == 'fftw' )  THEN
+!
+!--       FFTW
+#if defined( __fftw )
+          nx_c = nx+1
+          ny_c = ny+1
+          !$OMP PARALLEL
+          ALLOCATE( x_in(0:nx+2), y_in(0:ny+2), x_out(0:(nx+1)/2),             &
+                    y_out(0:(ny+1)/2) )
+          !$OMP END PARALLEL
+          plan_xf = FFTW_PLAN_DFT_R2C_1D( nx_c, x_in, x_out, FFTW_ESTIMATE )
+          plan_xi = FFTW_PLAN_DFT_C2R_1D( nx_c, x_out, x_in, FFTW_ESTIMATE )
+          plan_yf = FFTW_PLAN_DFT_R2C_1D( ny_c, y_in, y_out, FFTW_ESTIMATE )
+          plan_yi = FFTW_PLAN_DFT_C2R_1D( ny_c, y_out, y_in, FFTW_ESTIMATE )
+#else
+          message_string = 'preprocessor switch for fftw is missing'
+          CALL message( 'fft_init', 'PA0080', 1, 2, 0, 6, 0 )
+#endif
+
+       ELSEIF ( fft_method == 'singleton-algorithm' )  THEN
+
+          CONTINUE
+
+       ELSE
+
+          message_string = 'fft method "' // TRIM( fft_method) // &
+                           '" not available'
+          CALL message( 'fft_init', 'PA0189', 1, 2, 0, 6, 0 )
+       ENDIF
+
+    END SUBROUTINE fft_init
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Fourier-transformation along x-direction.                 
+!> Version for 2D-decomposition.
+!> It uses internal algorithms (Singleton or Temperton) or      
+!> system-specific routines, if they are available           
+!------------------------------------------------------------------------------!
+ 
+    SUBROUTINE fft_x( ar, direction, ar_2d )
+
+
+       USE cuda_fft_interfaces
+#if defined( __cuda_fft )
+       USE ISO_C_BINDING
+#endif
+
+       IMPLICIT NONE
+
+       CHARACTER (LEN=*) ::  direction  !<
+       
+       COMPLEX(wp), DIMENSION(:), ALLOCATABLE ::  cwork  !<
+
+       INTEGER(iwp) ::  i          !< 
+       INTEGER(iwp) ::  ishape(1)  !<
+       INTEGER(iwp) ::  j          !<
+       INTEGER(iwp) ::  k          !<
+
+       LOGICAL ::  forward_fft !<
+       
+       REAL(wp), DIMENSION(0:nx+2) ::  work   !<
+       REAL(wp), DIMENSION(nx+2)   ::  work1  !<
+       
+#if defined( __ibm )
+       REAL(wp), DIMENSION(nau2) ::  aux2  !< 
+       REAL(wp), DIMENSION(nau2) ::  aux4  !<
+#elif defined( __nec )
+       REAL(wp), DIMENSION(6*(nx+1)) ::  work2  !<
+#elif defined( __cuda_fft )
+       COMPLEX(dp), DIMENSION(0:(nx+1)/2,nys_x:nyn_x,nzb_x:nzt_x) ::           &
+          ar_tmp  !<
+       ! following does not work for PGI 14.1 -> to be removed later
+       ! !$acc declare create( ar_tmp )
+#endif
+
+       REAL(wp), DIMENSION(0:nx,nys_x:nyn_x), OPTIONAL   ::                    &
+          ar_2d   !<
+       REAL(wp), DIMENSION(0:nx,nys_x:nyn_x,nzb_x:nzt_x) ::                    &
+          ar      !<
+
+       IF ( direction == 'forward' )  THEN
+          forward_fft = .TRUE.
+       ELSE
+          forward_fft = .FALSE.
+       ENDIF
+
+       IF ( fft_method == 'singleton-algorithm' )  THEN
+
+!
+!--       Performing the fft with singleton's software works on every system,
+!--       since it is part of the model
+          ALLOCATE( cwork(0:nx) )
+      
+          IF ( forward_fft )   then
+
+             !$OMP PARALLEL PRIVATE ( cwork, i, ishape, j, k )
+             !$OMP DO
+             DO  k = nzb_x, nzt_x
+                DO  j = nys_x, nyn_x
+
+                   DO  i = 0, nx
+                      cwork(i) = CMPLX( ar(i,j,k), KIND=wp )
+                   ENDDO
+
+                   ishape = SHAPE( cwork )
+                   CALL FFTN( cwork, ishape )
+
+                   DO  i = 0, (nx+1)/2
+                      ar(i,j,k) = REAL( cwork(i), KIND=wp )
+                   ENDDO
+                   DO  i = 1, (nx+1)/2 - 1
+                      ar(nx+1-i,j,k) = -AIMAG( cwork(i) )
+                   ENDDO
+
+                ENDDO
+             ENDDO
+             !$OMP END PARALLEL
+
+          ELSE
+
+             !$OMP PARALLEL PRIVATE ( cwork, i, ishape, j, k )
+             !$OMP DO
+             DO  k = nzb_x, nzt_x
+                DO  j = nys_x, nyn_x
+
+                   cwork(0) = CMPLX( ar(0,j,k), 0.0_wp, KIND=wp )
+                   DO  i = 1, (nx+1)/2 - 1
+                      cwork(i)      = CMPLX( ar(i,j,k), -ar(nx+1-i,j,k),       &
+                                             KIND=wp )
+                      cwork(nx+1-i) = CMPLX( ar(i,j,k),  ar(nx+1-i,j,k),       &
+                                             KIND=wp )
+                   ENDDO
+                   cwork((nx+1)/2) = CMPLX( ar((nx+1)/2,j,k), 0.0_wp, KIND=wp )
+
+                   ishape = SHAPE( cwork )
+                   CALL FFTN( cwork, ishape, inv = .TRUE. )
+
+                   DO  i = 0, nx
+                      ar(i,j,k) = REAL( cwork(i), KIND=wp )
+                   ENDDO
+
+                ENDDO
+             ENDDO
+             !$OMP END PARALLEL
+
+          ENDIF
+
+          DEALLOCATE( cwork )
+
+       ELSEIF ( fft_method == 'temperton-algorithm' )  THEN
+
+!
+!--       Performing the fft with Temperton's software works on every system,
+!--       since it is part of the model
+          IF ( forward_fft )  THEN
+
+             !$OMP PARALLEL PRIVATE ( work, work1, i, j, k )
+             !$OMP DO
+             DO  k = nzb_x, nzt_x
+                DO  j = nys_x, nyn_x
+
+                   work(0:nx) = ar(0:nx,j,k)
+                   CALL fft991cy( work, work1, trigs_x, ifax_x, 1, nx+1, nx+1, 1, -1 )
+
+                   DO  i = 0, (nx+1)/2
+                      ar(i,j,k) = work(2*i)
+                   ENDDO
+                   DO  i = 1, (nx+1)/2 - 1
+                      ar(nx+1-i,j,k) = work(2*i+1)
+                   ENDDO
+
+                ENDDO
+             ENDDO
+             !$OMP END PARALLEL
+
+          ELSE
+
+             !$OMP PARALLEL PRIVATE ( work, work1, i, j, k )
+             !$OMP DO
+             DO  k = nzb_x, nzt_x
+                DO  j = nys_x, nyn_x
+
+                   DO  i = 0, (nx+1)/2
+                      work(2*i) = ar(i,j,k)
+                   ENDDO
+                   DO  i = 1, (nx+1)/2 - 1
+                      work(2*i+1) = ar(nx+1-i,j,k)
+                   ENDDO
+                   work(1)    = 0.0_wp
+                   work(nx+2) = 0.0_wp
+
+                   CALL fft991cy( work, work1, trigs_x, ifax_x, 1, nx+1, nx+1, 1, 1 )
+                   ar(0:nx,j,k) = work(0:nx)
+
+                ENDDO
+             ENDDO
+             !$OMP END PARALLEL
+
+          ENDIF
+
+       ELSEIF ( fft_method == 'fftw' )  THEN
+
+#if defined( __fftw )
+          IF ( forward_fft )  THEN
+
+             !$OMP PARALLEL PRIVATE ( work, i, j, k )
+             !$OMP DO
+             DO  k = nzb_x, nzt_x
+                DO  j = nys_x, nyn_x
+
+                   x_in(0:nx) = ar(0:nx,j,k)
+                   CALL FFTW_EXECUTE_DFT_R2C( plan_xf, x_in, x_out )
+
+                   IF ( PRESENT( ar_2d ) )  THEN
+
+                      DO  i = 0, (nx+1)/2
+                         ar_2d(i,j) = REAL( x_out(i), KIND=wp ) / ( nx+1 )
+                      ENDDO
+                      DO  i = 1, (nx+1)/2 - 1
+                         ar_2d(nx+1-i,j) = AIMAG( x_out(i) ) / ( nx+1 )
+                      ENDDO
+
+                   ELSE
+
+                      DO  i = 0, (nx+1)/2
+                         ar(i,j,k) = REAL( x_out(i), KIND=wp ) / ( nx+1 )
+                      ENDDO
+                      DO  i = 1, (nx+1)/2 - 1
+                         ar(nx+1-i,j,k) = AIMAG( x_out(i) ) / ( nx+1 )
+                      ENDDO
+
+                   ENDIF
+
+                ENDDO
+             ENDDO
+             !$OMP END PARALLEL
+
+          ELSE
+             !$OMP PARALLEL PRIVATE ( work, i, j, k )
+             !$OMP DO
+             DO  k = nzb_x, nzt_x
+                DO  j = nys_x, nyn_x
+
+                   IF ( PRESENT( ar_2d ) )  THEN
+
+                      x_out(0) = CMPLX( ar_2d(0,j), 0.0_wp, KIND=wp )
+                      DO  i = 1, (nx+1)/2 - 1
+                         x_out(i) = CMPLX( ar_2d(i,j), ar_2d(nx+1-i,j),        &
+                                           KIND=wp )
+                      ENDDO
+                      x_out((nx+1)/2) = CMPLX( ar_2d((nx+1)/2,j), 0.0_wp,      &
+                                               KIND=wp )
+
+                   ELSE
+
+                      x_out(0) = CMPLX( ar(0,j,k), 0.0_wp, KIND=wp )
+                      DO  i = 1, (nx+1)/2 - 1
+                         x_out(i) = CMPLX( ar(i,j,k), ar(nx+1-i,j,k), KIND=wp )
+                      ENDDO
+                      x_out((nx+1)/2) = CMPLX( ar((nx+1)/2,j,k), 0.0_wp,       &
+                                               KIND=wp )
+
+                   ENDIF
+
+                   CALL FFTW_EXECUTE_DFT_C2R( plan_xi, x_out, x_in)
+                   ar(0:nx,j,k) = x_in(0:nx)
+
+                ENDDO
+             ENDDO
+             !$OMP END PARALLEL
+
+          ENDIF
+#endif
+
+       ELSEIF ( fft_method == 'system-specific' )  THEN
+
+#if defined( __ibm )
+          IF ( forward_fft )  THEN
+
+             !$OMP PARALLEL PRIVATE ( work, i, j, k )
+             !$OMP DO
+             DO  k = nzb_x, nzt_x
+                DO  j = nys_x, nyn_x
+
+                   CALL DRCFT( 0, ar, 1, work, 1, nx+1, 1, 1, sqr_dnx, aux1,   &
+                               nau1, aux2, nau2 )
+
+                   DO  i = 0, (nx+1)/2
+                      ar(i,j,k) = work(2*i)
+                   ENDDO
+                   DO  i = 1, (nx+1)/2 - 1
+                      ar(nx+1-i,j,k) = work(2*i+1)
+                   ENDDO
+
+                ENDDO
+             ENDDO
+             !$OMP END PARALLEL
+
+          ELSE
+
+             !$OMP PARALLEL PRIVATE ( work, i, j, k )
+             !$OMP DO
+             DO  k = nzb_x, nzt_x
+                DO  j = nys_x, nyn_x
+
+                   DO  i = 0, (nx+1)/2
+                      work(2*i) = ar(i,j,k)
+                   ENDDO
+                   DO  i = 1, (nx+1)/2 - 1
+                      work(2*i+1) = ar(nx+1-i,j,k)
+                   ENDDO
+                   work(1) = 0.0_wp
+                   work(nx+2) = 0.0_wp
+
+                   CALL DCRFT( 0, work, 1, work, 1, nx+1, 1, -1, sqr_dnx,      & 
+                               aux3, nau1, aux4, nau2 )
+
+                   DO  i = 0, nx
+                      ar(i,j,k) = work(i)
+                   ENDDO
+
+                ENDDO
+             ENDDO
+             !$OMP END PARALLEL
+
+          ENDIF
+
+#elif defined( __nec )
+
+          IF ( forward_fft )  THEN
+
+             !$OMP PARALLEL PRIVATE ( work, i, j, k )
+             !$OMP DO
+             DO  k = nzb_x, nzt_x
+                DO  j = nys_x, nyn_x
+
+                   work(0:nx) = ar(0:nx,j,k)
+
+                   CALL DZFFT( 1, nx+1, sqr_dnx, work, work, trig_xf, work2, 0 )
+      
+                   DO  i = 0, (nx+1)/2
+                      ar(i,j,k) = work(2*i)
+                   ENDDO
+                   DO  i = 1, (nx+1)/2 - 1
+                      ar(nx+1-i,j,k) = work(2*i+1)
+                   ENDDO
+
+                ENDDO
+             ENDDO
+             !$END OMP PARALLEL
+
+          ELSE
+
+             !$OMP PARALLEL PRIVATE ( work, i, j, k )
+             !$OMP DO
+             DO  k = nzb_x, nzt_x
+                DO  j = nys_x, nyn_x
+
+                   DO  i = 0, (nx+1)/2
+                      work(2*i) = ar(i,j,k)
+                   ENDDO
+                   DO  i = 1, (nx+1)/2 - 1
+                      work(2*i+1) = ar(nx+1-i,j,k)
+                   ENDDO
+                   work(1) = 0.0_wp
+                   work(nx+2) = 0.0_wp
+
+                   CALL ZDFFT( -1, nx+1, sqr_dnx, work, work, trig_xb, work2, 0 )
+
+                   ar(0:nx,j,k) = work(0:nx)
+
+                ENDDO
+             ENDDO
+             !$OMP END PARALLEL
+
+          ENDIF
+
+#elif defined( __cuda_fft )
+
+          !$acc data create( ar_tmp )
+          IF ( forward_fft )  THEN
+
+             !$acc data present( ar )
+             CALL CUFFTEXECD2Z( plan_xf, ar, ar_tmp )
+
+             !$acc kernels
+             DO  k = nzb_x, nzt_x
+                DO  j = nys_x, nyn_x
+
+                   DO  i = 0, (nx+1)/2
+                      ar(i,j,k)      = REAL( ar_tmp(i,j,k), KIND=wp )  * dnx
+                   ENDDO
+
+                   DO  i = 1, (nx+1)/2 - 1
+                      ar(nx+1-i,j,k) = AIMAG( ar_tmp(i,j,k) ) * dnx
+                   ENDDO
+
+                ENDDO
+             ENDDO
+             !$acc end kernels
+             !$acc end data
+
+          ELSE
+
+             !$acc data present( ar )
+             !$acc kernels
+             DO  k = nzb_x, nzt_x
+                DO  j = nys_x, nyn_x
+
+                   ar_tmp(0,j,k) = CMPLX( ar(0,j,k), 0.0_wp, KIND=wp )
+
+                   DO  i = 1, (nx+1)/2 - 1
+                      ar_tmp(i,j,k) = CMPLX( ar(i,j,k), ar(nx+1-i,j,k),        &
+                                             KIND=wp )
+                   ENDDO
+                   ar_tmp((nx+1)/2,j,k) = CMPLX( ar((nx+1)/2,j,k), 0.0_wp,     &
+                                                 KIND=wp )
+
+                ENDDO
+             ENDDO
+             !$acc end kernels
+
+             CALL CUFFTEXECZ2D( plan_xi, ar_tmp, ar )
+             !$acc end data
+
+          ENDIF
+          !$acc end data
+
+#else
+          message_string = 'no system-specific fft-call available'
+          CALL message( 'fft_x', 'PA0188', 1, 2, 0, 6, 0 )
+#endif
+
+       ELSE
+
+          message_string = 'fft method "' // TRIM( fft_method) // &
+                           '" not available'
+          CALL message( 'fft_x', 'PA0189', 1, 2, 0, 6, 0 )
+
+       ENDIF
+
+    END SUBROUTINE fft_x
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Fourier-transformation along x-direction.
+!> Version for 1D-decomposition.
+!> It uses internal algorithms (Singleton or Temperton) or
+!> system-specific routines, if they are available
+!------------------------------------------------------------------------------!
+ 
+    SUBROUTINE fft_x_1d( ar, direction )
+
+
+       IMPLICIT NONE
+
+       CHARACTER (LEN=*) ::  direction  !<
+       
+       INTEGER(iwp) ::  i               !<
+       INTEGER(iwp) ::  ishape(1)       !<
+
+       LOGICAL ::  forward_fft          !<
+
+       REAL(wp), DIMENSION(0:nx)   ::  ar     !<
+       REAL(wp), DIMENSION(0:nx+2) ::  work   !<
+       REAL(wp), DIMENSION(nx+2)   ::  work1  !<
+       
+       COMPLEX(wp), DIMENSION(:), ALLOCATABLE ::  cwork  !<
+       
+#if defined( __ibm )
+       REAL(wp), DIMENSION(nau2) ::  aux2       !<
+       REAL(wp), DIMENSION(nau2) ::  aux4       !<
+#elif defined( __nec )
+       REAL(wp), DIMENSION(6*(nx+1)) ::  work2  !<
+#endif
+
+       IF ( direction == 'forward' )  THEN
+          forward_fft = .TRUE.
+       ELSE
+          forward_fft = .FALSE.
+       ENDIF
+
+       IF ( fft_method == 'singleton-algorithm' )  THEN
+
+!
+!--       Performing the fft with singleton's software works on every system,
+!--       since it is part of the model
+          ALLOCATE( cwork(0:nx) )
+      
+          IF ( forward_fft )   then
+
+             DO  i = 0, nx
+                cwork(i) = CMPLX( ar(i), KIND=wp )
+             ENDDO
+             ishape = SHAPE( cwork )
+             CALL FFTN( cwork, ishape )
+             DO  i = 0, (nx+1)/2
+                ar(i) = REAL( cwork(i), KIND=wp )
+             ENDDO
+             DO  i = 1, (nx+1)/2 - 1
+                ar(nx+1-i) = -AIMAG( cwork(i) )
+             ENDDO
+
+          ELSE
+
+             cwork(0) = CMPLX( ar(0), 0.0_wp, KIND=wp )
+             DO  i = 1, (nx+1)/2 - 1
+                cwork(i)      = CMPLX( ar(i), -ar(nx+1-i), KIND=wp )
+                cwork(nx+1-i) = CMPLX( ar(i),  ar(nx+1-i), KIND=wp )
+             ENDDO
+             cwork((nx+1)/2) = CMPLX( ar((nx+1)/2), 0.0_wp, KIND=wp )
+
+             ishape = SHAPE( cwork )
+             CALL FFTN( cwork, ishape, inv = .TRUE. )
+
+             DO  i = 0, nx
+                ar(i) = REAL( cwork(i), KIND=wp )
+             ENDDO
+
+          ENDIF
+
+          DEALLOCATE( cwork )
+
+       ELSEIF ( fft_method == 'temperton-algorithm' )  THEN
+
+!
+!--       Performing the fft with Temperton's software works on every system,
+!--       since it is part of the model
+          IF ( forward_fft )  THEN
+
+             work(0:nx) = ar
+             CALL fft991cy( work, work1, trigs_x, ifax_x, 1, nx+1, nx+1, 1, -1 )
+
+             DO  i = 0, (nx+1)/2
+                ar(i) = work(2*i)
+             ENDDO
+             DO  i = 1, (nx+1)/2 - 1
+                ar(nx+1-i) = work(2*i+1)
+             ENDDO
+
+          ELSE
+
+             DO  i = 0, (nx+1)/2
+                work(2*i) = ar(i)
+             ENDDO
+             DO  i = 1, (nx+1)/2 - 1
+                work(2*i+1) = ar(nx+1-i)
+             ENDDO
+             work(1)    = 0.0_wp
+             work(nx+2) = 0.0_wp
+
+             CALL fft991cy( work, work1, trigs_x, ifax_x, 1, nx+1, nx+1, 1, 1 )
+             ar = work(0:nx)
+
+          ENDIF
+
+       ELSEIF ( fft_method == 'fftw' )  THEN
+
+#if defined( __fftw )
+          IF ( forward_fft )  THEN
+
+             x_in(0:nx) = ar(0:nx)
+             CALL FFTW_EXECUTE_DFT_R2C( plan_xf, x_in, x_out )
+
+             DO  i = 0, (nx+1)/2
+                ar(i) = REAL( x_out(i), KIND=wp ) / ( nx+1 )
+             ENDDO
+             DO  i = 1, (nx+1)/2 - 1
+                ar(nx+1-i) = AIMAG( x_out(i) ) / ( nx+1 )
+             ENDDO
+
+         ELSE
+
+             x_out(0) = CMPLX( ar(0), 0.0_wp, KIND=wp )
+             DO  i = 1, (nx+1)/2 - 1
+                x_out(i) = CMPLX( ar(i), ar(nx+1-i), KIND=wp )
+             ENDDO
+             x_out((nx+1)/2) = CMPLX( ar((nx+1)/2), 0.0_wp, KIND=wp )
+
+             CALL FFTW_EXECUTE_DFT_C2R( plan_xi, x_out, x_in)
+             ar(0:nx) = x_in(0:nx)
+
+         ENDIF
+#endif
+
+       ELSEIF ( fft_method == 'system-specific' )  THEN
+
+#if defined( __ibm )
+          IF ( forward_fft )  THEN
+
+             CALL DRCFT( 0, ar, 1, work, 1, nx+1, 1, 1, sqr_dnx, aux1, nau1,   &
+                         aux2, nau2 )
+
+             DO  i = 0, (nx+1)/2
+                ar(i) = work(2*i)
+             ENDDO
+             DO  i = 1, (nx+1)/2 - 1
+                ar(nx+1-i) = work(2*i+1)
+             ENDDO
+
+          ELSE
+
+             DO  i = 0, (nx+1)/2
+                work(2*i) = ar(i)
+             ENDDO
+             DO  i = 1, (nx+1)/2 - 1
+                work(2*i+1) = ar(nx+1-i)
+             ENDDO
+             work(1) = 0.0_wp
+             work(nx+2) = 0.0_wp
+
+             CALL DCRFT( 0, work, 1, work, 1, nx+1, 1, -1, sqr_dnx, aux3, nau1, &
+                         aux4, nau2 )
+
+             DO  i = 0, nx
+                ar(i) = work(i)
+             ENDDO
+
+          ENDIF
+#elif defined( __nec )
+          IF ( forward_fft )  THEN
+
+             work(0:nx) = ar(0:nx)
+
+             CALL DZFFT( 1, nx+1, sqr_dnx, work, work, trig_xf, work2, 0 )
+      
+             DO  i = 0, (nx+1)/2
+                ar(i) = work(2*i)
+             ENDDO
+             DO  i = 1, (nx+1)/2 - 1
+                ar(nx+1-i) = work(2*i+1)
+             ENDDO
+
+          ELSE
+
+             DO  i = 0, (nx+1)/2
+                work(2*i) = ar(i)
+             ENDDO
+             DO  i = 1, (nx+1)/2 - 1
+                work(2*i+1) = ar(nx+1-i)
+             ENDDO
+             work(1) = 0.0_wp
+             work(nx+2) = 0.0_wp
+
+             CALL ZDFFT( -1, nx+1, sqr_dnx, work, work, trig_xb, work2, 0 )
+
+             ar(0:nx) = work(0:nx)
+
+          ENDIF
+#else
+          message_string = 'no system-specific fft-call available'
+          CALL message( 'fft_x_1d', 'PA0188', 1, 2, 0, 6, 0 )
+#endif
+       ELSE
+          message_string = 'fft method "' // TRIM( fft_method) // &
+                           '" not available'
+          CALL message( 'fft_x_1d', 'PA0189', 1, 2, 0, 6, 0 )
+
+       ENDIF
+
+    END SUBROUTINE fft_x_1d
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Fourier-transformation along y-direction.
+!> Version for 2D-decomposition.
+!> It uses internal algorithms (Singleton or Temperton) or
+!> system-specific routines, if they are available.
+!> 
+!> direction:  'forward' or 'backward'
+!> ar, ar_tr:  3D data arrays 
+!>             forward:   ar: before  ar_tr: after transformation
+!>             backward:  ar_tr: before  ar: after transfosition
+!> 
+!> In case of non-overlapping transposition/transformation:
+!> nxl_y_bound = nxl_y_l = nxl_y 
+!> nxr_y_bound = nxr_y_l = nxr_y 
+!> 
+!> In case of overlapping transposition/transformation
+!> - nxl_y_bound  and  nxr_y_bound have the original values of
+!>   nxl_y, nxr_y.  ar_tr is dimensioned using these values.
+!> - nxl_y_l = nxr_y_r.  ar is dimensioned with these values, so that
+!>   transformation is carried out for a 2D-plane only.
+!------------------------------------------------------------------------------!
+ 
+    SUBROUTINE fft_y( ar, direction, ar_tr, nxl_y_bound, nxr_y_bound, nxl_y_l, &
+                      nxr_y_l )
+
+
+       USE cuda_fft_interfaces
+#if defined( __cuda_fft )
+       USE ISO_C_BINDING
+#endif
+
+       IMPLICIT NONE
+
+       CHARACTER (LEN=*) ::  direction  !<
+       
+       INTEGER(iwp) ::  i            !<
+       INTEGER(iwp) ::  j            !< 
+       INTEGER(iwp) ::  jshape(1)    !<
+       INTEGER(iwp) ::  k            !<
+       INTEGER(iwp) ::  nxl_y_bound  !<
+       INTEGER(iwp) ::  nxl_y_l      !<
+       INTEGER(iwp) ::  nxr_y_bound  !<
+       INTEGER(iwp) ::  nxr_y_l      !<
+
+       LOGICAL ::  forward_fft  !<
+
+       REAL(wp), DIMENSION(0:ny+2) ::  work   !<
+       REAL(wp), DIMENSION(ny+2)   ::  work1  !<
+       
+       COMPLEX(wp), DIMENSION(:), ALLOCATABLE ::  cwork  !<
+       
+#if defined( __ibm )
+       REAL(wp), DIMENSION(nau2) ::  auy2  !<
+       REAL(wp), DIMENSION(nau2) ::  auy4  !<
+#elif defined( __nec )
+       REAL(wp), DIMENSION(6*(ny+1)) ::  work2  !<
+#elif defined( __cuda_fft )
+       COMPLEX(dp), DIMENSION(0:(ny+1)/2,nxl_y:nxr_y,nzb_y:nzt_y) ::           &
+          ar_tmp  !<
+       ! following does not work for PGI 14.1 -> to be removed later
+       ! !$acc declare create( ar_tmp )
+#endif
+
+       REAL(wp), DIMENSION(0:ny,nxl_y_l:nxr_y_l,nzb_y:nzt_y)         ::        &
+          ar     !<
+       REAL(wp), DIMENSION(0:ny,nxl_y_bound:nxr_y_bound,nzb_y:nzt_y) ::        &
+          ar_tr  !<
+
+       IF ( direction == 'forward' )  THEN
+          forward_fft = .TRUE.
+       ELSE
+          forward_fft = .FALSE.
+       ENDIF
+
+       IF ( fft_method == 'singleton-algorithm' )  THEN
+
+!
+!--       Performing the fft with singleton's software works on every system,
+!--       since it is part of the model
+          ALLOCATE( cwork(0:ny) )
+
+          IF ( forward_fft )   then
+
+             !$OMP PARALLEL PRIVATE ( cwork, i, jshape, j, k )
+             !$OMP DO
+             DO  k = nzb_y, nzt_y
+                DO  i = nxl_y_l, nxr_y_l
+
+                   DO  j = 0, ny
+                      cwork(j) = CMPLX( ar(j,i,k), KIND=wp )
+                   ENDDO
+
+                   jshape = SHAPE( cwork )
+                   CALL FFTN( cwork, jshape )
+
+                   DO  j = 0, (ny+1)/2
+                      ar_tr(j,i,k) = REAL( cwork(j), KIND=wp )
+                   ENDDO
+                   DO  j = 1, (ny+1)/2 - 1
+                      ar_tr(ny+1-j,i,k) = -AIMAG( cwork(j) )
+                   ENDDO
+
+                ENDDO
+             ENDDO
+             !$OMP END PARALLEL
+
+          ELSE
+
+             !$OMP PARALLEL PRIVATE ( cwork, i, jshape, j, k )
+             !$OMP DO
+             DO  k = nzb_y, nzt_y
+                DO  i = nxl_y_l, nxr_y_l
+
+                   cwork(0) = CMPLX( ar_tr(0,i,k), 0.0_wp, KIND=wp )
+                   DO  j = 1, (ny+1)/2 - 1
+                      cwork(j)      = CMPLX( ar_tr(j,i,k), -ar_tr(ny+1-j,i,k), &
+                                             KIND=wp )
+                      cwork(ny+1-j) = CMPLX( ar_tr(j,i,k),  ar_tr(ny+1-j,i,k), &
+                                             KIND=wp )
+                   ENDDO
+                   cwork((ny+1)/2) = CMPLX( ar_tr((ny+1)/2,i,k), 0.0_wp,       &
+                                            KIND=wp )
+
+                   jshape = SHAPE( cwork )
+                   CALL FFTN( cwork, jshape, inv = .TRUE. )
+
+                   DO  j = 0, ny
+                      ar(j,i,k) = REAL( cwork(j), KIND=wp )
+                   ENDDO
+
+                ENDDO
+             ENDDO
+             !$OMP END PARALLEL
+
+          ENDIF
+
+          DEALLOCATE( cwork )
+
+       ELSEIF ( fft_method == 'temperton-algorithm' )  THEN
+
+!
+!--       Performing the fft with Temperton's software works on every system,
+!--       since it is part of the model
+          IF ( forward_fft )  THEN
+
+             !$OMP PARALLEL PRIVATE ( work, work1, i, j, k )
+             !$OMP DO
+             DO  k = nzb_y, nzt_y
+                DO  i = nxl_y_l, nxr_y_l
+
+                   work(0:ny) = ar(0:ny,i,k)
+                   CALL fft991cy( work, work1, trigs_y, ifax_y, 1, ny+1, ny+1, 1, -1 )
+
+                   DO  j = 0, (ny+1)/2
+                      ar_tr(j,i,k) = work(2*j)
+                   ENDDO
+                   DO  j = 1, (ny+1)/2 - 1
+                      ar_tr(ny+1-j,i,k) = work(2*j+1)
+                   ENDDO
+
+                ENDDO
+             ENDDO
+             !$OMP END PARALLEL
+
+          ELSE
+
+             !$OMP PARALLEL PRIVATE ( work, work1, i, j, k )
+             !$OMP DO
+             DO  k = nzb_y, nzt_y
+                DO  i = nxl_y_l, nxr_y_l
+
+                   DO  j = 0, (ny+1)/2
+                      work(2*j) = ar_tr(j,i,k)
+                   ENDDO
+                   DO  j = 1, (ny+1)/2 - 1
+                      work(2*j+1) = ar_tr(ny+1-j,i,k)
+                   ENDDO
+                   work(1)    = 0.0_wp
+                   work(ny+2) = 0.0_wp
+
+                   CALL fft991cy( work, work1, trigs_y, ifax_y, 1, ny+1, ny+1, 1, 1 )
+                   ar(0:ny,i,k) = work(0:ny)
+
+                ENDDO
+             ENDDO
+             !$OMP END PARALLEL
+
+          ENDIF
+
+       ELSEIF ( fft_method == 'fftw' )  THEN
+
+#if defined( __fftw )
+          IF ( forward_fft )  THEN
+
+             !$OMP PARALLEL PRIVATE ( work, i, j, k )
+             !$OMP DO
+             DO  k = nzb_y, nzt_y
+                DO  i = nxl_y_l, nxr_y_l
+
+                   y_in(0:ny) = ar(0:ny,i,k)
+                   CALL FFTW_EXECUTE_DFT_R2C( plan_yf, y_in, y_out )
+
+                   DO  j = 0, (ny+1)/2
+                      ar_tr(j,i,k) = REAL( y_out(j), KIND=wp ) / (ny+1)
+                   ENDDO
+                   DO  j = 1, (ny+1)/2 - 1
+                      ar_tr(ny+1-j,i,k) = AIMAG( y_out(j) ) / (ny+1)
+                   ENDDO
+
+                ENDDO
+             ENDDO
+             !$OMP END PARALLEL
+
+          ELSE
+
+             !$OMP PARALLEL PRIVATE ( work, i, j, k )
+             !$OMP DO
+             DO  k = nzb_y, nzt_y
+                DO  i = nxl_y_l, nxr_y_l
+
+                   y_out(0) = CMPLX( ar_tr(0,i,k), 0.0_wp, KIND=wp )
+                   DO  j = 1, (ny+1)/2 - 1
+                      y_out(j) = CMPLX( ar_tr(j,i,k), ar_tr(ny+1-j,i,k),       &
+                                        KIND=wp )
+                   ENDDO
+                   y_out((ny+1)/2) = CMPLX( ar_tr((ny+1)/2,i,k), 0.0_wp,       &
+                                            KIND=wp )
+
+                   CALL FFTW_EXECUTE_DFT_C2R( plan_yi, y_out, y_in )
+                   ar(0:ny,i,k) = y_in(0:ny)
+
+                ENDDO
+             ENDDO
+             !$OMP END PARALLEL
+
+          ENDIF
+#endif
+
+       ELSEIF ( fft_method == 'system-specific' )  THEN
+
+#if defined( __ibm )
+          IF ( forward_fft)  THEN
+
+             !$OMP PARALLEL PRIVATE ( work, i, j, k )
+             !$OMP DO
+             DO  k = nzb_y, nzt_y
+                DO  i = nxl_y_l, nxr_y_l
+
+                   CALL DRCFT( 0, ar, 1, work, 1, ny+1, 1, 1, sqr_dny, auy1,   & 
+                               nau1, auy2, nau2 )
+
+                   DO  j = 0, (ny+1)/2
+                      ar_tr(j,i,k) = work(2*j)
+                   ENDDO
+                   DO  j = 1, (ny+1)/2 - 1
+                      ar_tr(ny+1-j,i,k) = work(2*j+1)
+                   ENDDO
+
+                ENDDO
+             ENDDO
+             !$OMP END PARALLEL
+
+          ELSE
+
+             !$OMP PARALLEL PRIVATE ( work, i, j, k )
+             !$OMP DO
+             DO  k = nzb_y, nzt_y
+                DO  i = nxl_y_l, nxr_y_l
+
+                   DO  j = 0, (ny+1)/2
+                      work(2*j) = ar_tr(j,i,k)
+                   ENDDO
+                   DO  j = 1, (ny+1)/2 - 1
+                      work(2*j+1) = ar_tr(ny+1-j,i,k)
+                   ENDDO
+                   work(1)    = 0.0_wp
+                   work(ny+2) = 0.0_wp
+
+                   CALL DCRFT( 0, work, 1, work, 1, ny+1, 1, -1, sqr_dny,      &
+                               auy3, nau1, auy4, nau2 )
+
+                   DO  j = 0, ny
+                      ar(j,i,k) = work(j)
+                   ENDDO
+
+                ENDDO
+             ENDDO
+             !$OMP END PARALLEL
+
+          ENDIF
+#elif defined( __nec )
+          IF ( forward_fft )  THEN
+
+             !$OMP PARALLEL PRIVATE ( work, i, j, k )
+             !$OMP DO
+             DO  k = nzb_y, nzt_y
+                DO  i = nxl_y_l, nxr_y_l
+
+                   work(0:ny) = ar(0:ny,i,k)
+
+                   CALL DZFFT( 1, ny+1, sqr_dny, work, work, trig_yf, work2, 0 )
+
+                   DO  j = 0, (ny+1)/2
+                      ar_tr(j,i,k) = work(2*j)
+                   ENDDO
+                   DO  j = 1, (ny+1)/2 - 1
+                      ar_tr(ny+1-j,i,k) = work(2*j+1)
+                   ENDDO
+
+                ENDDO
+             ENDDO
+             !$END OMP PARALLEL
+
+          ELSE
+
+             !$OMP PARALLEL PRIVATE ( work, i, j, k )
+             !$OMP DO
+             DO  k = nzb_y, nzt_y
+                DO  i = nxl_y_l, nxr_y_l
+
+                   DO  j = 0, (ny+1)/2
+                      work(2*j) = ar_tr(j,i,k)
+                   ENDDO
+                   DO  j = 1, (ny+1)/2 - 1
+                      work(2*j+1) = ar_tr(ny+1-j,i,k)
+                   ENDDO
+                   work(1) = 0.0_wp
+                   work(ny+2) = 0.0_wp
+
+                   CALL ZDFFT( -1, ny+1, sqr_dny, work, work, trig_yb, work2, 0 )
+
+                   ar(0:ny,i,k) = work(0:ny)
+
+                ENDDO
+             ENDDO
+             !$OMP END PARALLEL
+
+          ENDIF
+#elif defined( __cuda_fft )
+
+          !$acc data create( ar_tmp )
+          IF ( forward_fft )  THEN
+
+             !$acc data present( ar )
+             CALL CUFFTEXECD2Z( plan_yf, ar, ar_tmp )
+
+             !$acc kernels
+             DO  k = nzb_y, nzt_y
+                DO  i = nxl_y, nxr_y
+
+                   DO  j = 0, (ny+1)/2
+                      ar(j,i,k)      = REAL( ar_tmp(j,i,k), KIND=wp )  * dny
+                   ENDDO
+
+                   DO  j = 1, (ny+1)/2 - 1
+                      ar(ny+1-j,i,k) = AIMAG( ar_tmp(j,i,k) ) * dny
+                   ENDDO
+
+                ENDDO
+             ENDDO
+             !$acc end kernels
+             !$acc end data
+
+          ELSE
+
+             !$acc data present( ar )
+             !$acc kernels
+             DO  k = nzb_y, nzt_y
+                DO  i = nxl_y, nxr_y
+
+                   ar_tmp(0,i,k) = CMPLX( ar(0,i,k), 0.0_wp, KIND=wp )
+
+                   DO  j = 1, (ny+1)/2 - 1
+                      ar_tmp(j,i,k) = CMPLX( ar(j,i,k), ar(ny+1-j,i,k),        &
+                                             KIND=wp )
+                   ENDDO
+                   ar_tmp((ny+1)/2,i,k) = CMPLX( ar((ny+1)/2,i,k), 0.0_wp,     &
+                                                 KIND=wp )
+
+                ENDDO
+             ENDDO
+             !$acc end kernels
+
+             CALL CUFFTEXECZ2D( plan_yi, ar_tmp, ar )
+             !$acc end data
+
+          ENDIF
+          !$acc end data
+
+#else
+          message_string = 'no system-specific fft-call available'
+          CALL message( 'fft_y', 'PA0188', 1, 2, 0, 6, 0 ) 
+#endif
+
+       ELSE
+
+          message_string = 'fft method "' // TRIM( fft_method) // &
+                           '" not available'
+          CALL message( 'fft_y', 'PA0189', 1, 2, 0, 6, 0 )
+
+       ENDIF
+
+    END SUBROUTINE fft_y
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Fourier-transformation along y-direction.
+!> Version for 1D-decomposition.
+!> It uses internal algorithms (Singleton or Temperton) or
+!> system-specific routines, if they are available.
+!------------------------------------------------------------------------------!
+ 
+    SUBROUTINE fft_y_1d( ar, direction )
+
+
+       IMPLICIT NONE
+
+       CHARACTER (LEN=*) ::  direction
+       
+       INTEGER(iwp) ::  j          !<
+       INTEGER(iwp) ::  jshape(1)  !<
+
+       LOGICAL ::  forward_fft  !<
+
+       REAL(wp), DIMENSION(0:ny)    ::  ar     !<
+       REAL(wp), DIMENSION(0:ny+2)  ::  work   !<
+       REAL(wp), DIMENSION(ny+2)    ::  work1  !<
+       
+       COMPLEX(wp), DIMENSION(:), ALLOCATABLE ::  cwork  !<
+       
+#if defined( __ibm )
+       REAL(wp), DIMENSION(nau2) ::  auy2  !<
+       REAL(wp), DIMENSION(nau2) ::  auy4  !<
+#elif defined( __nec )
+       REAL(wp), DIMENSION(6*(ny+1)) ::  work2  !<
+#endif
+
+       IF ( direction == 'forward' )  THEN
+          forward_fft = .TRUE.
+       ELSE
+          forward_fft = .FALSE.
+       ENDIF
+
+       IF ( fft_method == 'singleton-algorithm' )  THEN
+
+!
+!--       Performing the fft with singleton's software works on every system,
+!--       since it is part of the model
+          ALLOCATE( cwork(0:ny) )
+
+          IF ( forward_fft )  THEN
+
+             DO  j = 0, ny
+                cwork(j) = CMPLX( ar(j), KIND=wp )
+             ENDDO
+
+             jshape = SHAPE( cwork )
+             CALL FFTN( cwork, jshape )
+
+             DO  j = 0, (ny+1)/2
+                ar(j) = REAL( cwork(j), KIND=wp )
+             ENDDO
+             DO  j = 1, (ny+1)/2 - 1
+                ar(ny+1-j) = -AIMAG( cwork(j) )
+             ENDDO
+
+          ELSE
+
+             cwork(0) = CMPLX( ar(0), 0.0_wp, KIND=wp )
+             DO  j = 1, (ny+1)/2 - 1
+                cwork(j)      = CMPLX( ar(j), -ar(ny+1-j), KIND=wp )
+                cwork(ny+1-j) = CMPLX( ar(j),  ar(ny+1-j), KIND=wp )
+             ENDDO
+             cwork((ny+1)/2) = CMPLX( ar((ny+1)/2), 0.0_wp, KIND=wp )
+
+             jshape = SHAPE( cwork )
+             CALL FFTN( cwork, jshape, inv = .TRUE. )
+
+             DO  j = 0, ny
+                ar(j) = REAL( cwork(j), KIND=wp )
+             ENDDO
+
+          ENDIF
+
+          DEALLOCATE( cwork )
+
+       ELSEIF ( fft_method == 'temperton-algorithm' )  THEN
+
+!
+!--       Performing the fft with Temperton's software works on every system,
+!--       since it is part of the model
+          IF ( forward_fft )  THEN
+
+             work(0:ny) = ar
+             CALL fft991cy( work, work1, trigs_y, ifax_y, 1, ny+1, ny+1, 1, -1 )
+
+             DO  j = 0, (ny+1)/2
+                ar(j) = work(2*j)
+             ENDDO
+             DO  j = 1, (ny+1)/2 - 1
+                ar(ny+1-j) = work(2*j+1)
+             ENDDO
+
+          ELSE
+
+             DO  j = 0, (ny+1)/2
+                work(2*j) = ar(j)
+             ENDDO
+             DO  j = 1, (ny+1)/2 - 1
+                work(2*j+1) = ar(ny+1-j)
+             ENDDO
+             work(1)    = 0.0_wp
+             work(ny+2) = 0.0_wp
+
+             CALL fft991cy( work, work1, trigs_y, ifax_y, 1, ny+1, ny+1, 1, 1 )
+             ar = work(0:ny)
+
+          ENDIF
+
+       ELSEIF ( fft_method == 'fftw' )  THEN
+
+#if defined( __fftw )
+          IF ( forward_fft )  THEN
+
+             y_in(0:ny) = ar(0:ny)
+             CALL FFTW_EXECUTE_DFT_R2C( plan_yf, y_in, y_out )
+
+             DO  j = 0, (ny+1)/2
+                ar(j) = REAL( y_out(j), KIND=wp ) / (ny+1)
+             ENDDO
+             DO  j = 1, (ny+1)/2 - 1
+                ar(ny+1-j) = AIMAG( y_out(j) ) / (ny+1)
+             ENDDO
+
+          ELSE
+
+             y_out(0) = CMPLX( ar(0), 0.0_wp, KIND=wp )
+             DO  j = 1, (ny+1)/2 - 1
+                y_out(j) = CMPLX( ar(j), ar(ny+1-j), KIND=wp )
+             ENDDO
+             y_out((ny+1)/2) = CMPLX( ar((ny+1)/2), 0.0_wp, KIND=wp )
+
+             CALL FFTW_EXECUTE_DFT_C2R( plan_yi, y_out, y_in )
+             ar(0:ny) = y_in(0:ny)
+
+          ENDIF
+#endif
+
+       ELSEIF ( fft_method == 'system-specific' )  THEN
+
+#if defined( __ibm )
+          IF ( forward_fft )  THEN
+
+             CALL DRCFT( 0, ar, 1, work, 1, ny+1, 1, 1, sqr_dny, auy1, nau1,   &
+                         auy2, nau2 )
+
+             DO  j = 0, (ny+1)/2
+                ar(j) = work(2*j)
+             ENDDO
+             DO  j = 1, (ny+1)/2 - 1
+                ar(ny+1-j) = work(2*j+1)
+             ENDDO
+
+          ELSE
+
+             DO  j = 0, (ny+1)/2
+                work(2*j) = ar(j)
+             ENDDO
+             DO  j = 1, (ny+1)/2 - 1
+                work(2*j+1) = ar(ny+1-j)
+             ENDDO
+             work(1)    = 0.0_wp
+             work(ny+2) = 0.0_wp
+
+             CALL DCRFT( 0, work, 1, work, 1, ny+1, 1, -1, sqr_dny, auy3,      &
+                         nau1, auy4, nau2 )
+
+             DO  j = 0, ny
+                ar(j) = work(j)
+             ENDDO
+
+          ENDIF
+#elif defined( __nec )
+          IF ( forward_fft )  THEN
+
+             work(0:ny) = ar(0:ny)
+
+             CALL DZFFT( 1, ny+1, sqr_dny, work, work, trig_yf, work2, 0 )
+
+             DO  j = 0, (ny+1)/2
+                ar(j) = work(2*j)
+             ENDDO
+             DO  j = 1, (ny+1)/2 - 1
+                ar(ny+1-j) = work(2*j+1)
+             ENDDO
+
+          ELSE
+
+             DO  j = 0, (ny+1)/2
+                work(2*j) = ar(j)
+             ENDDO
+             DO  j = 1, (ny+1)/2 - 1
+                work(2*j+1) = ar(ny+1-j)
+             ENDDO
+             work(1) = 0.0_wp
+             work(ny+2) = 0.0_wp
+
+             CALL ZDFFT( -1, ny+1, sqr_dny, work, work, trig_yb, work2, 0 )
+
+             ar(0:ny) = work(0:ny)
+
+          ENDIF
+#else
+          message_string = 'no system-specific fft-call available'
+          CALL message( 'fft_y_1d', 'PA0188', 1, 2, 0, 6, 0 ) 
+
+#endif
+
+       ELSE
+
+          message_string = 'fft method "' // TRIM( fft_method) // &
+                           '" not available'
+          CALL message( 'fft_y_1d', 'PA0189', 1, 2, 0, 6, 0 )
+
+       ENDIF
+
+    END SUBROUTINE fft_y_1d
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Fourier-transformation along x-direction.
+!> Version for 1d domain decomposition
+!> using multiple 1D FFT from Math Keisan on NEC or Temperton-algorithm
+!> (no singleton-algorithm on NEC because it does not vectorize)
+!------------------------------------------------------------------------------!
+ 
+    SUBROUTINE fft_x_m( ar, direction )
+
+
+       IMPLICIT NONE
+
+       CHARACTER (LEN=*) ::  direction  !<
+       
+       INTEGER(iwp) ::  i     !<
+       INTEGER(iwp) ::  k     !<
+       INTEGER(iwp) ::  siza  !<
+
+       REAL(wp), DIMENSION(0:nx,nz)       ::  ar     !<
+       REAL(wp), DIMENSION(0:nx+3,nz+1)   ::  ai     !<
+       REAL(wp), DIMENSION(6*(nx+4),nz+1) ::  work1  !<
+       
+#if defined( __nec )
+       INTEGER(iwp) ::  sizw  !<
+       
+       COMPLEX(wp), DIMENSION((nx+4)/2+1,nz+1) ::  work  !<
+#endif
+
+       IF ( fft_method == 'temperton-algorithm' )  THEN
+
+          siza = SIZE( ai, 1 )
+
+          IF ( direction == 'forward')  THEN
+
+             ai(0:nx,1:nz) = ar(0:nx,1:nz)
+             ai(nx+1:,:)   = 0.0_wp
+
+             CALL fft991cy( ai, work1, trigs_x, ifax_x, 1, siza, nx+1, nz, -1 )
+
+             DO  k = 1, nz
+                DO  i = 0, (nx+1)/2
+                   ar(i,k) = ai(2*i,k)
+                ENDDO
+                DO  i = 1, (nx+1)/2 - 1
+                   ar(nx+1-i,k) = ai(2*i+1,k)
+                ENDDO
+             ENDDO
+
+          ELSE
+
+             DO  k = 1, nz
+                DO  i = 0, (nx+1)/2
+                   ai(2*i,k) = ar(i,k)
+                ENDDO
+                DO  i = 1, (nx+1)/2 - 1
+                   ai(2*i+1,k) = ar(nx+1-i,k)
+                ENDDO
+                ai(1,k) = 0.0_wp
+                ai(nx+2,k) = 0.0_wp
+             ENDDO
+
+             CALL fft991cy( ai, work1, trigs_x, ifax_x, 1, siza, nx+1, nz, 1 )
+
+             ar(0:nx,1:nz) = ai(0:nx,1:nz)
+
+          ENDIF
+
+       ELSEIF ( fft_method == 'system-specific' )  THEN
+
+#if defined( __nec )
+          siza = SIZE( ai, 1 )
+          sizw = SIZE( work, 1 )
+
+          IF ( direction == 'forward')  THEN
+
+!
+!--          Tables are initialized once more. This call should not be
+!--          necessary, but otherwise program aborts in asymmetric case
+             CALL DZFFTM( 0, nx+1, nz1, sqr_dnx, work, nx+4, work, nx+4,       &
+                          trig_xf, work1, 0 )
+
+             ai(0:nx,1:nz) = ar(0:nx,1:nz)
+             IF ( nz1 > nz )  THEN
+                ai(:,nz1) = 0.0_wp
+             ENDIF
+
+             CALL DZFFTM( 1, nx+1, nz1, sqr_dnx, ai, siza, work, sizw,         &
+                          trig_xf, work1, 0 )
+
+             DO  k = 1, nz
+                DO  i = 0, (nx+1)/2
+                   ar(i,k) = REAL( work(i+1,k), KIND=wp )
+                ENDDO
+                DO  i = 1, (nx+1)/2 - 1
+                   ar(nx+1-i,k) = AIMAG( work(i+1,k) )
+                ENDDO
+             ENDDO
+
+          ELSE
+
+!
+!--          Tables are initialized once more. This call should not be
+!--          necessary, but otherwise program aborts in asymmetric case
+             CALL ZDFFTM( 0, nx+1, nz1, sqr_dnx, work, nx+4, work, nx+4,       &
+                          trig_xb, work1, 0 )
+
+             IF ( nz1 > nz )  THEN
+                work(:,nz1) = 0.0_wp
+             ENDIF
+             DO  k = 1, nz
+                work(1,k) = CMPLX( ar(0,k), 0.0_wp, KIND=wp )
+                DO  i = 1, (nx+1)/2 - 1
+                   work(i+1,k) = CMPLX( ar(i,k), ar(nx+1-i,k), KIND=wp )
+                ENDDO
+                work(((nx+1)/2)+1,k) = CMPLX( ar((nx+1)/2,k), 0.0_wp, KIND=wp )
+             ENDDO
+
+             CALL ZDFFTM( -1, nx+1, nz1, sqr_dnx, work, sizw, ai, siza, &
+                          trig_xb, work1, 0 )
+
+             ar(0:nx,1:nz) = ai(0:nx,1:nz)
+
+          ENDIF
+
+#else
+          message_string = 'no system-specific fft-call available'
+          CALL message( 'fft_x_m', 'PA0188', 1, 2, 0, 6, 0 ) 
+#endif
+
+       ELSE
+
+          message_string = 'fft method "' // TRIM( fft_method) // &
+                           '" not available'
+          CALL message( 'fft_x_m', 'PA0189', 1, 2, 0, 6, 0 )
+
+       ENDIF
+
+    END SUBROUTINE fft_x_m
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Fourier-transformation along y-direction.
+!> Version for 1d domain decomposition
+!> using multiple 1D FFT from Math Keisan on NEC or Temperton-algorithm
+!> (no singleton-algorithm on NEC because it does not vectorize)
+!------------------------------------------------------------------------------!
+ 
+    SUBROUTINE fft_y_m( ar, ny1, direction )
+
+
+       IMPLICIT NONE
+
+       CHARACTER (LEN=*) ::  direction  !<
+       
+       INTEGER(iwp) ::  j     !< 
+       INTEGER(iwp) ::  k     !<
+       INTEGER(iwp) ::  ny1   !<
+       INTEGER(iwp) ::  siza  !<
+
+       REAL(wp), DIMENSION(0:ny1,nz)      ::  ar     !<
+       REAL(wp), DIMENSION(0:ny+3,nz+1)   ::  ai     !<
+       REAL(wp), DIMENSION(6*(ny+4),nz+1) ::  work1  !<
+       
+#if defined( __nec )
+       INTEGER(iwp) ::  sizw  !<
+       
+       COMPLEX(wp), DIMENSION((ny+4)/2+1,nz+1) ::  work !<
+#endif
+
+       IF ( fft_method == 'temperton-algorithm' )  THEN
+
+          siza = SIZE( ai, 1 )
+
+          IF ( direction == 'forward')  THEN
+
+             ai(0:ny,1:nz) = ar(0:ny,1:nz)
+             ai(ny+1:,:)   = 0.0_wp
+
+             CALL fft991cy( ai, work1, trigs_y, ifax_y, 1, siza, ny+1, nz, -1 )
+
+             DO  k = 1, nz
+                DO  j = 0, (ny+1)/2
+                   ar(j,k) = ai(2*j,k)
+                ENDDO
+                DO  j = 1, (ny+1)/2 - 1
+                   ar(ny+1-j,k) = ai(2*j+1,k)
+                ENDDO
+             ENDDO
+
+          ELSE
+
+             DO  k = 1, nz
+                DO  j = 0, (ny+1)/2
+                   ai(2*j,k) = ar(j,k)
+                ENDDO
+                DO  j = 1, (ny+1)/2 - 1
+                   ai(2*j+1,k) = ar(ny+1-j,k)
+                ENDDO
+                ai(1,k) = 0.0_wp
+                ai(ny+2,k) = 0.0_wp
+             ENDDO
+
+             CALL fft991cy( ai, work1, trigs_y, ifax_y, 1, siza, ny+1, nz, 1 )
+
+             ar(0:ny,1:nz) = ai(0:ny,1:nz)
+
+          ENDIF
+
+       ELSEIF ( fft_method == 'system-specific' )  THEN
+
+#if defined( __nec )
+          siza = SIZE( ai, 1 )
+          sizw = SIZE( work, 1 )
+
+          IF ( direction == 'forward')  THEN
+
+!
+!--          Tables are initialized once more. This call should not be
+!--          necessary, but otherwise program aborts in asymmetric case
+             CALL DZFFTM( 0, ny+1, nz1, sqr_dny, work, ny+4, work, ny+4, &
+                          trig_yf, work1, 0 )
+
+             ai(0:ny,1:nz) = ar(0:ny,1:nz)
+             IF ( nz1 > nz )  THEN
+                ai(:,nz1) = 0.0_wp
+             ENDIF
+
+             CALL DZFFTM( 1, ny+1, nz1, sqr_dny, ai, siza, work, sizw, &
+                          trig_yf, work1, 0 )
+
+             DO  k = 1, nz
+                DO  j = 0, (ny+1)/2
+                   ar(j,k) = REAL( work(j+1,k), KIND=wp )
+                ENDDO
+                DO  j = 1, (ny+1)/2 - 1
+                   ar(ny+1-j,k) = AIMAG( work(j+1,k) )
+                ENDDO
+             ENDDO
+
+          ELSE
+
+!
+!--          Tables are initialized once more. This call should not be
+!--          necessary, but otherwise program aborts in asymmetric case
+             CALL ZDFFTM( 0, ny+1, nz1, sqr_dny, work, ny+4, work, ny+4, &
+                          trig_yb, work1, 0 )
+
+             IF ( nz1 > nz )  THEN
+                work(:,nz1) = 0.0_wp
+             ENDIF
+             DO  k = 1, nz
+                work(1,k) = CMPLX( ar(0,k), 0.0_wp, KIND=wp )
+                DO  j = 1, (ny+1)/2 - 1
+                   work(j+1,k) = CMPLX( ar(j,k), ar(ny+1-j,k), KIND=wp )
+                ENDDO
+                work(((ny+1)/2)+1,k) = CMPLX( ar((ny+1)/2,k), 0.0_wp, KIND=wp )
+             ENDDO
+
+             CALL ZDFFTM( -1, ny+1, nz1, sqr_dny, work, sizw, ai, siza, &
+                          trig_yb, work1, 0 )
+
+             ar(0:ny,1:nz) = ai(0:ny,1:nz)
+
+          ENDIF
+
+#else
+          message_string = 'no system-specific fft-call available'
+          CALL message( 'fft_y_m', 'PA0188', 1, 2, 0, 6, 0 ) 
+#endif
+
+       ELSE
+         
+          message_string = 'fft method "' // TRIM( fft_method) // &
+                           '" not available'
+          CALL message( 'fft_x_m', 'PA0189', 1, 2, 0, 6, 0 )
+
+       ENDIF
+
+    END SUBROUTINE fft_y_m
+
+
+ END MODULE fft_xy
Index: lm/trunk/SOURCE/interaction_droplets_ptq.f90
===================================================================
--- /palm/trunk/SOURCE/interaction_droplets_ptq.f90	(revision 1849)
+++ 	(revision )
@@ -1,156 +1,0 @@
-!> @file interaction_droplets_ptq.f90
-!--------------------------------------------------------------------------------!
-! This file is part of PALM.
-!
-! PALM is free software: you can redistribute it and/or modify it under the terms
-! of the GNU General Public License as published by the Free Software Foundation,
-! either version 3 of the License, or (at your option) any later version.
-!
-! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
-! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
-! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along with
-! PALM. If not, see <http://www.gnu.org/licenses/>.
-!
-! Copyright 1997-2016 Leibniz Universitaet Hannover
-!--------------------------------------------------------------------------------!
-!
-! Current revisions:
-! -----------------
-! 
-! 
-! Former revisions:
-! -----------------
-! $Id$
-!
-! 1845 2016-04-08 08:29:13Z raasch
-! nzb_2d replaced by nzb_s_inner
-!
-! 1822 2016-04-07 07:49:42Z hoffmann
-! Unused variables removed.
-!
-! 1779 2016-03-03 08:01:28Z raasch
-! bugfix: module procedure names shortened to avoid Intel compiler warnings
-! about too long names
-!
-! 1682 2015-10-07 23:56:08Z knoop
-! Code annotations made doxygen readable
-!
-! 1320 2014-03-20 08:40:49Z raasch
-! ONLY-attribute added to USE-statements,
-! kind-parameters added to all INTEGER and REAL declaration statements,
-! kinds are defined in new module kinds,
-! revision history before 2012 removed,
-! comment fields (!:) to be used for variable explanations added to
-! all variable declaration statements
-!
-! 1036 2012-10-22 13:43:42Z raasch
-! code put under GPL (PALM 3.9)
-!
-! 799 2011-12-21 17:48:03Z franke
-! Bugfix: pt_d_t(k) was missing in calculation of pt_p
-!
-! RCS Log replace by Id keyword, revision history cleaned up
-!
-! Revision 1.1  2005/06/26 19:57:47  raasch
-! Initial revision
-!
-!
-! Description:
-! ------------
-!> Release of latent heat and change of specific humidity due to condensation /
-!> evaporation of droplets.
-!------------------------------------------------------------------------------!
- MODULE interaction_droplets_ptq_mod
- 
-
-    PRIVATE
-    PUBLIC interaction_droplets_ptq
-
-    INTERFACE interaction_droplets_ptq
-!
-!--    Internal names shortened in order ro avoid Intel compiler messages
-!--    about too long names
-       MODULE PROCEDURE i_droplets_ptq
-       MODULE PROCEDURE i_droplets_ptq_ij
-    END INTERFACE interaction_droplets_ptq
- 
- CONTAINS
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Call for all grid points
-!------------------------------------------------------------------------------!
-    SUBROUTINE i_droplets_ptq
-
-       USE arrays_3d,                                                          &
-           ONLY:  pt_p, ql_c, q_p
-           
-       USE cloud_parameters,                                                   &
-           ONLY:  l_d_cp, pt_d_t
-           
-       USE indices,                                                            &
-           ONLY:  nxl, nxr, nyn, nys, nzb_s_inner, nzt
-           
-       USE kinds
-
-       USE pegrid
-
-       IMPLICIT NONE
-
-       INTEGER(iwp) ::  i !<
-       INTEGER(iwp) ::  j !<
-       INTEGER(iwp) ::  k !<
-
- 
-       DO  i = nxl, nxr
-          DO  j = nys, nyn
-             DO  k = nzb_s_inner(j,i)+1, nzt
-                q_p(k,j,i)  = q_p(k,j,i)  - ql_c(k,j,i)
-                pt_p(k,j,i) = pt_p(k,j,i) + l_d_cp * ql_c(k,j,i) * pt_d_t(k)
-             ENDDO
-          ENDDO
-       ENDDO
-
-    END SUBROUTINE i_droplets_ptq
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Call for grid point i,j
-!------------------------------------------------------------------------------!
-    SUBROUTINE i_droplets_ptq_ij( i, j )
-
-       USE arrays_3d,                                                          &
-           ONLY:  pt_p, ql_c, q_p
-
-       USE cloud_parameters,                                                   &
-           ONLY:  l_d_cp, pt_d_t
-
-       USE indices,                                                            &
-           ONLY:  nzb_s_inner, nzt
-
-       USE kinds,                                                              &
-           ONLY:  iwp, wp
-
-       USE pegrid
-
-       IMPLICIT NONE
-
-       INTEGER(iwp) ::  i !<
-       INTEGER(iwp) ::  j !<
-       INTEGER(iwp) ::  k !<
-
-
-       DO  k = nzb_s_inner(j,i)+1, nzt
-          q_p(k,j,i)  = q_p(k,j,i)  - ql_c(k,j,i)
-          pt_p(k,j,i) = pt_p(k,j,i) + l_d_cp * ql_c(k,j,i) * pt_d_t(k)
-       ENDDO
-
-    END SUBROUTINE i_droplets_ptq_ij
-
- END MODULE interaction_droplets_ptq_mod
Index: /palm/trunk/SOURCE/interaction_droplets_ptq_mod.f90
===================================================================
--- /palm/trunk/SOURCE/interaction_droplets_ptq_mod.f90	(revision 1850)
+++ /palm/trunk/SOURCE/interaction_droplets_ptq_mod.f90	(revision 1850)
@@ -0,0 +1,157 @@
+!> @file interaction_droplets_ptq_mod.f90
+!--------------------------------------------------------------------------------!
+! This file is part of PALM.
+!
+! PALM is free software: you can redistribute it and/or modify it under the terms
+! of the GNU General Public License as published by the Free Software Foundation,
+! either version 3 of the License, or (at your option) any later version.
+!
+! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
+! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
+! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along with
+! PALM. If not, see <http://www.gnu.org/licenses/>.
+!
+! Copyright 1997-2016 Leibniz Universitaet Hannover
+!--------------------------------------------------------------------------------!
+!
+! Current revisions:
+! -----------------
+! Module renamed
+! 
+! 
+! Former revisions:
+! -----------------
+! $Id$
+!
+! 1845 2016-04-08 08:29:13Z raasch
+! nzb_2d replaced by nzb_s_inner
+!
+! 1822 2016-04-07 07:49:42Z hoffmann
+! Unused variables removed.
+!
+! 1779 2016-03-03 08:01:28Z raasch
+! bugfix: module procedure names shortened to avoid Intel compiler warnings
+! about too long names
+!
+! 1682 2015-10-07 23:56:08Z knoop
+! Code annotations made doxygen readable
+!
+! 1320 2014-03-20 08:40:49Z raasch
+! ONLY-attribute added to USE-statements,
+! kind-parameters added to all INTEGER and REAL declaration statements,
+! kinds are defined in new module kinds,
+! revision history before 2012 removed,
+! comment fields (!:) to be used for variable explanations added to
+! all variable declaration statements
+!
+! 1036 2012-10-22 13:43:42Z raasch
+! code put under GPL (PALM 3.9)
+!
+! 799 2011-12-21 17:48:03Z franke
+! Bugfix: pt_d_t(k) was missing in calculation of pt_p
+!
+! RCS Log replace by Id keyword, revision history cleaned up
+!
+! Revision 1.1  2005/06/26 19:57:47  raasch
+! Initial revision
+!
+!
+! Description:
+! ------------
+!> Release of latent heat and change of specific humidity due to condensation /
+!> evaporation of droplets.
+!------------------------------------------------------------------------------!
+ MODULE interaction_droplets_ptq_mod
+ 
+
+    PRIVATE
+    PUBLIC interaction_droplets_ptq
+
+    INTERFACE interaction_droplets_ptq
+!
+!--    Internal names shortened in order ro avoid Intel compiler messages
+!--    about too long names
+       MODULE PROCEDURE i_droplets_ptq
+       MODULE PROCEDURE i_droplets_ptq_ij
+    END INTERFACE interaction_droplets_ptq
+ 
+ CONTAINS
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Call for all grid points
+!------------------------------------------------------------------------------!
+    SUBROUTINE i_droplets_ptq
+
+       USE arrays_3d,                                                          &
+           ONLY:  pt_p, ql_c, q_p
+           
+       USE cloud_parameters,                                                   &
+           ONLY:  l_d_cp, pt_d_t
+           
+       USE indices,                                                            &
+           ONLY:  nxl, nxr, nyn, nys, nzb_s_inner, nzt
+           
+       USE kinds
+
+       USE pegrid
+
+       IMPLICIT NONE
+
+       INTEGER(iwp) ::  i !<
+       INTEGER(iwp) ::  j !<
+       INTEGER(iwp) ::  k !<
+
+ 
+       DO  i = nxl, nxr
+          DO  j = nys, nyn
+             DO  k = nzb_s_inner(j,i)+1, nzt
+                q_p(k,j,i)  = q_p(k,j,i)  - ql_c(k,j,i)
+                pt_p(k,j,i) = pt_p(k,j,i) + l_d_cp * ql_c(k,j,i) * pt_d_t(k)
+             ENDDO
+          ENDDO
+       ENDDO
+
+    END SUBROUTINE i_droplets_ptq
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Call for grid point i,j
+!------------------------------------------------------------------------------!
+    SUBROUTINE i_droplets_ptq_ij( i, j )
+
+       USE arrays_3d,                                                          &
+           ONLY:  pt_p, ql_c, q_p
+
+       USE cloud_parameters,                                                   &
+           ONLY:  l_d_cp, pt_d_t
+
+       USE indices,                                                            &
+           ONLY:  nzb_s_inner, nzt
+
+       USE kinds,                                                              &
+           ONLY:  iwp, wp
+
+       USE pegrid
+
+       IMPLICIT NONE
+
+       INTEGER(iwp) ::  i !<
+       INTEGER(iwp) ::  j !<
+       INTEGER(iwp) ::  k !<
+
+
+       DO  k = nzb_s_inner(j,i)+1, nzt
+          q_p(k,j,i)  = q_p(k,j,i)  - ql_c(k,j,i)
+          pt_p(k,j,i) = pt_p(k,j,i) + l_d_cp * ql_c(k,j,i) * pt_d_t(k)
+       ENDDO
+
+    END SUBROUTINE i_droplets_ptq_ij
+
+ END MODULE interaction_droplets_ptq_mod
Index: lm/trunk/SOURCE/lpm_collision_kernels.f90
===================================================================
--- /palm/trunk/SOURCE/lpm_collision_kernels.f90	(revision 1849)
+++ 	(revision )
@@ -1,1000 +1,0 @@
-!> @file lpm_collision_kernels.f90
-!--------------------------------------------------------------------------------!
-! This file is part of PALM.
-!
-! PALM is free software: you can redistribute it and/or modify it under the terms
-! of the GNU General Public License as published by the Free Software Foundation,
-! either version 3 of the License, or (at your option) any later version.
-!
-! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
-! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
-! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along with
-! PALM. If not, see <http://www.gnu.org/licenses/>.
-!
-! Copyright 1997-2016 Leibniz Universitaet Hannover
-!--------------------------------------------------------------------------------!
-!
-! Current revisions:
-! -----------------
-!
-! 
-! Former revisions:
-! -----------------
-! $Id$
-!
-! 1822 2016-04-07 07:49:42Z hoffmann
-! PALM kernel has been deleted.
-! Bugfix in the calculation of the turbulent enhancement factor of the
-! collection efficiency.
-!
-! Unused variables removed.
-!
-! 1776 2016-03-02 17:54:58Z hoffmann
-! Bugfix: Collection efficiencies must be calculated for the larger droplet.
-!
-! 1682 2015-10-07 23:56:08Z knoop
-! Code annotations made doxygen readable
-! 
-! 1519 2015-01-08 10:20:42Z hoffmann
-! Bugfix: Using the new particle structure, particles are not sorted by size.
-! Hence, computation of collision efficiencies must ensure that the ratio of 
-! two colliding droplets is < 1.
-!
-! 1359 2014-04-11 17:15:14Z hoffmann
-! New particle structure integrated.
-! Kind definition added to all floating point numbers.
-! 
-! 1346 2014-03-27 13:18:20Z heinze
-! Bugfix: REAL constants provided with KIND-attribute especially in call of 
-! intrinsic function like MAX, MIN, SIGN
-!
-! 1322 2014-03-20 16:38:49Z raasch
-! REAL constants defined as wp_kind
-!
-! 1320 2014-03-20 08:40:49Z 
-! ONLY-attribute added to USE-statements,
-! kind-parameters added to all INTEGER and REAL declaration statements,
-! kinds are defined in new module kinds,
-! revision history before 2012 removed,
-! comment fields (!:) to be used for variable explanations added to
-! all variable declaration statements
-!
-! 1092 2013-02-02 11:24:22Z raasch
-! unused variables removed
-!
-! 1071 2012-11-29 16:54:55Z franke
-! Bugfix: collision efficiencies for Hall kernel should not be < 1.0E-20
-!
-! 1036 2012-10-22 13:43:42Z raasch
-! code put under GPL (PALM 3.9)
-!
-! 1007 2012-09-19 14:30:36Z franke
-! converted all units to SI units and replaced some parameters by corresponding
-! PALM parameters
-! Bugfix: factor in calculation of enhancement factor for collision efficencies
-! changed from 10. to 1.0
-!
-! 849 2012-03-15 10:35:09Z raasch
-! routine collision_efficiency_rogers added (moved from former advec_particles
-! to here)
-!
-! 835 2012-02-22 11:21:19Z raasch $
-! Bugfix: array diss can be used only in case of Wang kernel
-!
-! 828 2012-02-21 12:00:36Z raasch
-! code has been completely reformatted, routine colker renamed
-! recalculate_kernel,
-! routine init_kernels added, radius is now communicated to the collision
-! routines by array radclass
-!
-! Bugfix: transformation factor for dissipation changed from 1E5 to 1E4
-!
-! 825 2012-02-19 03:03:44Z raasch
-! routine renamed from wang_kernel to lpm_collision_kernels,
-! turbulence_effects on collision replaced by wang_kernel
-!
-! 790 2011-11-29 03:11:20Z raasch
-! initial revision
-!
-! Description:
-! ------------
-!> This module calculates collision efficiencies either due to pure gravitational
-!> effects (Hall kernel, see Hall, 1980: J. Atmos. Sci., 2486-2507) or
-!> including the effects of turbulence (Wang kernel, see Wang and
-!> Grabowski, 2009: Atmos. Sci. Lett., 10, 1-8, and Ayala et al., 2008: 
-!> New J. Phys., 10, 075016). The original code has been
-!> provided by L.-P. Wang but is substantially reformatted and speed optimized
-!> here.
-!------------------------------------------------------------------------------!
- MODULE lpm_collision_kernels_mod
- 
-
-    USE constants,                                                             &
-        ONLY:  pi
-        
-    USE kinds
-
-    USE particle_attributes,                                                   &
-        ONLY:  collision_kernel, dissipation_classes, particles,               &
-               radius_classes
-
-    USE pegrid
-
-
-    IMPLICIT NONE
-
-    PRIVATE
-
-    PUBLIC  ckernel, init_kernels, rclass_lbound, rclass_ubound,               &
-            recalculate_kernel
-
-    REAL(wp) ::  epsilon       !<
-    REAL(wp) ::  rclass_lbound !<
-    REAL(wp) ::  rclass_ubound !<
-    REAL(wp) ::  urms          !<
-
-    REAL(wp), DIMENSION(:),   ALLOCATABLE ::  epsclass  !< dissipation rate class
-    REAL(wp), DIMENSION(:),   ALLOCATABLE ::  radclass  !< radius class
-    REAL(wp), DIMENSION(:),   ALLOCATABLE ::  winf      !<
-    
-    REAL(wp), DIMENSION(:,:), ALLOCATABLE ::  ec        !<
-    REAL(wp), DIMENSION(:,:), ALLOCATABLE ::  ecf       !<
-    REAL(wp), DIMENSION(:,:), ALLOCATABLE ::  gck       !<
-    REAL(wp), DIMENSION(:,:), ALLOCATABLE ::  hkernel   !<
-    REAL(wp), DIMENSION(:,:), ALLOCATABLE ::  hwratio   !<
-    
-    REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::  ckernel !<
-
-    SAVE
-
-!
-!-- Public interfaces
-    INTERFACE init_kernels
-       MODULE PROCEDURE init_kernels
-    END INTERFACE init_kernels
-
-    INTERFACE recalculate_kernel
-       MODULE PROCEDURE recalculate_kernel
-    END INTERFACE recalculate_kernel
-
-
-    CONTAINS
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Initialization of the collision efficiency matrix with fixed radius and
-!> dissipation classes, calculated at simulation start only.
-!------------------------------------------------------------------------------!
- 
-    SUBROUTINE init_kernels
-
-       IMPLICIT NONE
-
-       INTEGER(iwp) ::  i !<
-       INTEGER(iwp) ::  j !<
-       INTEGER(iwp) ::  k !<
-
-
-!
-!--    Calculate collision efficiencies for fixed radius- and dissipation
-!--    classes
-       IF ( collision_kernel(6:9) == 'fast' )  THEN
-
-          ALLOCATE( ckernel(1:radius_classes,1:radius_classes,                 &
-                    0:dissipation_classes), epsclass(1:dissipation_classes),   &
-                    radclass(1:radius_classes) )
-
-!
-!--       Calculate the radius class bounds with logarithmic distances
-!--       in the interval [1.0E-6, 2.0E-4] m
-          rclass_lbound = LOG( 1.0E-6_wp )
-          rclass_ubound = LOG( 2.0E-4_wp )
-          radclass(1)   = EXP( rclass_lbound )
-          DO  i = 2, radius_classes
-             radclass(i) = EXP( rclass_lbound +                                &
-                                ( rclass_ubound - rclass_lbound ) *            &
-                                ( i - 1.0_wp ) / ( radius_classes - 1.0_wp ) )
-          ENDDO
-
-!
-!--       Set the class bounds for dissipation in interval [0.0, 0.1] m**2/s**3
-          DO  i = 1, dissipation_classes
-             epsclass(i) = 0.1_wp * REAL( i, KIND=wp ) / dissipation_classes
-          ENDDO
-!
-!--       Calculate collision efficiencies of the Wang/ayala kernel
-          ALLOCATE( ec(1:radius_classes,1:radius_classes),  &
-                    ecf(1:radius_classes,1:radius_classes), &
-                    gck(1:radius_classes,1:radius_classes), &
-                    winf(1:radius_classes) )
-
-          DO  k = 1, dissipation_classes
-
-             epsilon = epsclass(k)
-             urms    = 2.02_wp * ( epsilon / 0.04_wp )**( 1.0_wp / 3.0_wp )
-
-             CALL turbsd
-             CALL turb_enhance_eff
-             CALL effic
-
-             DO  j = 1, radius_classes
-                DO  i = 1, radius_classes
-                   ckernel(i,j,k) = ec(i,j) * gck(i,j) * ecf(i,j)
-                ENDDO
-             ENDDO
-
-          ENDDO
-
-!
-!--       Calculate collision efficiencies of the Hall kernel
-          ALLOCATE( hkernel(1:radius_classes,1:radius_classes), &
-                    hwratio(1:radius_classes,1:radius_classes) )
-
-          CALL fallg
-          CALL effic
-
-          DO  j = 1, radius_classes
-             DO  i =  1, radius_classes
-                hkernel(i,j) = pi * ( radclass(j) + radclass(i) )**2 &
-                                  * ec(i,j) * ABS( winf(j) - winf(i) )
-                ckernel(i,j,0) = hkernel(i,j)  ! hall kernel stored on index 0
-              ENDDO
-          ENDDO
-
-!
-!--       Test output of efficiencies
-          IF ( j == -1 )  THEN
-
-             PRINT*, '*** Hall kernel'
-             WRITE ( *,'(5X,20(F4.0,1X))' ) ( radclass(i)*1.0E6_wp, &
-                                              i = 1,radius_classes )
-             DO  j = 1, radius_classes
-                WRITE ( *,'(F4.0,1X,20(F8.4,1X))' ) radclass(j),  &
-                                          ( hkernel(i,j), i = 1,radius_classes )
-             ENDDO
-
-             DO  k = 1, dissipation_classes
-                DO  i = 1, radius_classes
-                   DO  j = 1, radius_classes
-                      IF ( hkernel(i,j) == 0.0_wp )  THEN
-                         hwratio(i,j) = 9999999.9_wp
-                      ELSE
-                         hwratio(i,j) = ckernel(i,j,k) / hkernel(i,j)
-                      ENDIF
-                   ENDDO
-                ENDDO
-
-                PRINT*, '*** epsilon = ', epsclass(k)
-                WRITE ( *,'(5X,20(F4.0,1X))' ) ( radclass(i) * 1.0E6_wp, &
-                                                 i = 1,radius_classes )
-                DO  j = 1, radius_classes
-                   WRITE ( *,'(F4.0,1X,20(F8.4,1X))' ) radclass(j) * 1.0E6_wp, &
-                                          ( hwratio(i,j), i = 1,radius_classes )
-                ENDDO
-             ENDDO
-
-          ENDIF
-
-          DEALLOCATE( ec, ecf, epsclass, gck, hkernel, winf )
-
-       ELSEIF( collision_kernel == 'hall'  .OR.  collision_kernel == 'wang' ) &
-       THEN
-!
-!--       Initial settings for Hall- and Wang-Kernel
-!--       To be done: move here parts from turbsd, fallg, ecoll, etc.
-       ENDIF
-
-    END SUBROUTINE init_kernels
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Calculation of collision kernels during each timestep and for each grid box
-!------------------------------------------------------------------------------!
-    SUBROUTINE recalculate_kernel( i1, j1, k1 )
-
-       USE arrays_3d,                                                          &
-           ONLY:  diss
-
-       USE particle_attributes,                                                &
-           ONLY:  prt_count, radius_classes, wang_kernel
-
-       IMPLICIT NONE
-
-       INTEGER(iwp) ::  i      !<
-       INTEGER(iwp) ::  i1     !<
-       INTEGER(iwp) ::  j      !<
-       INTEGER(iwp) ::  j1     !<
-       INTEGER(iwp) ::  k1     !<
-       INTEGER(iwp) ::  pend   !<
-       INTEGER(iwp) ::  pstart !<
-
-
-       pstart = 1
-       pend   = prt_count(k1,j1,i1)
-       radius_classes = prt_count(k1,j1,i1)
-
-       ALLOCATE( ec(1:radius_classes,1:radius_classes), &
-                 radclass(1:radius_classes), winf(1:radius_classes) )
-
-!
-!--    Store particle radii on the radclass array
-       radclass(1:radius_classes) = particles(pstart:pend)%radius
-
-       IF ( wang_kernel )  THEN
-          epsilon = diss(k1,j1,i1)   ! dissipation rate in m**2/s**3
-       ELSE
-          epsilon = 0.0_wp
-       ENDIF
-       urms    = 2.02_wp * ( epsilon / 0.04_wp )**( 0.33333333333_wp )
-
-       IF ( wang_kernel  .AND.  epsilon > 1.0E-7_wp )  THEN
-!
-!--       Call routines to calculate efficiencies for the Wang kernel
-          ALLOCATE( gck(1:radius_classes,1:radius_classes), &
-                    ecf(1:radius_classes,1:radius_classes) )
-
-          CALL turbsd
-          CALL turb_enhance_eff
-          CALL effic
-
-          DO  j = 1, radius_classes
-             DO  i =  1, radius_classes
-                ckernel(pstart+i-1,pstart+j-1,1) = ec(i,j) * gck(i,j) * ecf(i,j)
-             ENDDO
-          ENDDO
-
-          DEALLOCATE( gck, ecf )
-
-       ELSE
-!
-!--       Call routines to calculate efficiencies for the Hall kernel
-          CALL fallg
-          CALL effic
-
-          DO  j = 1, radius_classes
-             DO  i =  1, radius_classes
-                ckernel(pstart+i-1,pstart+j-1,1) = pi *                       &
-                                          ( radclass(j) + radclass(i) )**2    &
-                                          * ec(i,j) * ABS( winf(j) - winf(i) )
-             ENDDO
-          ENDDO
-
-       ENDIF
-
-       DEALLOCATE( ec, radclass, winf )
-
-    END SUBROUTINE recalculate_kernel
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Calculation of effects of turbulence on the geometric collision kernel 
-!> (by including the droplets' average radial relative velocities and their 
-!> radial distribution function) following the analytic model by Aayala et al. 
-!> (2008, New J. Phys.). For details check the second part 2 of the publication,
-!> page 37ff.
-!>
-!> Input parameters, which need to be replaced by PALM parameters:
-!>    water density, air density
-!------------------------------------------------------------------------------!
-    SUBROUTINE turbsd
-
-       USE control_parameters,                                                 &
-           ONLY:  g, molecular_viscosity
-    
-       USE particle_attributes,                                                &
-           ONLY:  radius_classes
-
-       IMPLICIT NONE
-
-       INTEGER(iwp) ::  i     !<
-       INTEGER(iwp) ::  j     !<
-
-       REAL(wp) ::  ao        !<
-       REAL(wp) ::  ao_gr     !<
-       REAL(wp) ::  bbb       !<
-       REAL(wp) ::  be        !<
-       REAL(wp) ::  b1        !<
-       REAL(wp) ::  b2        !<
-       REAL(wp) ::  ccc       !<
-       REAL(wp) ::  c1        !<
-       REAL(wp) ::  c1_gr     !<
-       REAL(wp) ::  c2        !<
-       REAL(wp) ::  d1        !<
-       REAL(wp) ::  d2        !<
-       REAL(wp) ::  eta       !<
-       REAL(wp) ::  e1        !<
-       REAL(wp) ::  e2        !<
-       REAL(wp) ::  fao_gr    !<
-       REAL(wp) ::  fr        !<
-       REAL(wp) ::  grfin     !<
-       REAL(wp) ::  lambda    !<
-       REAL(wp) ::  lambda_re !<
-       REAL(wp) ::  lf        !<
-       REAL(wp) ::  rc        !<
-       REAL(wp) ::  rrp       !<
-       REAL(wp) ::  sst       !<
-       REAL(wp) ::  tauk      !<
-       REAL(wp) ::  tl        !<
-       REAL(wp) ::  t2        !<
-       REAL(wp) ::  tt        !<
-       REAL(wp) ::  t1        !<
-       REAL(wp) ::  vk        !<
-       REAL(wp) ::  vrms1xy   !<
-       REAL(wp) ::  vrms2xy   !<
-       REAL(wp) ::  v1        !<
-       REAL(wp) ::  v1v2xy    !<
-       REAL(wp) ::  v1xysq    !<
-       REAL(wp) ::  v2        !<
-       REAL(wp) ::  v2xysq    !<
-       REAL(wp) ::  wrfin     !<
-       REAL(wp) ::  wrgrav2   !<
-       REAL(wp) ::  wrtur2xy  !<
-       REAL(wp) ::  xx        !<
-       REAL(wp) ::  yy        !<
-       REAL(wp) ::  z         !<
-
-       REAL(wp), DIMENSION(1:radius_classes) ::  st  !< Stokes number
-       REAL(wp), DIMENSION(1:radius_classes) ::  tau !< inertial time scale
-
-       lambda    = urms * SQRT( 15.0_wp * molecular_viscosity / epsilon )
-       lambda_re = urms**2 * SQRT( 15.0_wp / epsilon / molecular_viscosity )
-       tl        = urms**2 / epsilon
-       lf        = 0.5_wp * urms**3 / epsilon
-       tauk      = SQRT( molecular_viscosity / epsilon )
-       eta       = ( molecular_viscosity**3 / epsilon )**0.25_wp
-       vk        = eta / tauk
-
-       ao = ( 11.0_wp + 7.0_wp * lambda_re ) / ( 205.0_wp + lambda_re )
-       tt = SQRT( 2.0_wp * lambda_re / ( SQRT( 15.0_wp ) * ao ) ) * tauk
-
-!
-!--    Get terminal velocity of droplets
-       CALL fallg
-
-       DO  i = 1, radius_classes
-          tau(i) = winf(i) / g    ! inertial time scale
-          st(i)  = tau(i) / tauk  ! Stokes number
-       ENDDO
-
-!
-!--    Calculate average radial relative velocity at contact (wrfin)
-       z   = tt / tl
-       be  = SQRT( 2.0_wp ) * lambda / lf
-       bbb = SQRT( 1.0_wp - 2.0_wp * be**2 )
-       d1  = ( 1.0_wp + bbb ) / ( 2.0_wp * bbb )
-       e1  = lf * ( 1.0_wp + bbb ) * 0.5_wp
-       d2  = ( 1.0_wp - bbb ) * 0.5_wp / bbb
-       e2  = lf * ( 1.0_wp - bbb ) * 0.5_wp
-       ccc = SQRT( 1.0_wp - 2.0_wp * z**2 )
-       b1  = ( 1.0_wp + ccc ) * 0.5_wp / ccc
-       c1  = tl * ( 1.0_wp + ccc ) * 0.5_wp
-       b2  = ( 1.0_wp - ccc ) * 0.5_wp / ccc
-       c2  = tl * ( 1.0_wp - ccc ) * 0.5_wp
-
-       DO  i = 1, radius_classes
-
-          v1 = winf(i)
-          t1 = tau(i)
-
-          DO  j = 1, i
-             rrp = radclass(i) + radclass(j)
-             v2  = winf(j)
-             t2  = tau(j)
-
-             v1xysq  = b1 * d1 * phi_w(c1,e1,v1,t1) - b1 * d2 * phi_w(c1,e2,v1,t1) &
-                     - b2 * d1 * phi_w(c2,e1,v1,t1) + b2 * d2 * phi_w(c2,e2,v1,t1)
-             v1xysq  = v1xysq * urms**2 / t1
-             vrms1xy = SQRT( v1xysq )
-
-             v2xysq  = b1 * d1 * phi_w(c1,e1,v2,t2) - b1 * d2 * phi_w(c1,e2,v2,t2) &
-                     - b2 * d1 * phi_w(c2,e1,v2,t2) + b2 * d2 * phi_w(c2,e2,v2,t2)
-             v2xysq  = v2xysq * urms**2 / t2
-             vrms2xy = SQRT( v2xysq )
-
-             IF ( winf(i) >= winf(j) )  THEN
-                v1 = winf(i)
-                t1 = tau(i)
-                v2 = winf(j)
-                t2 = tau(j)
-             ELSE
-                v1 = winf(j)
-                t1 = tau(j)
-                v2 = winf(i)
-                t2 = tau(i)
-             ENDIF
-
-             v1v2xy   =  b1 * d1 * zhi(c1,e1,v1,t1,v2,t2) - &
-                         b1 * d2 * zhi(c1,e2,v1,t1,v2,t2) - &
-                         b2 * d1 * zhi(c2,e1,v1,t1,v2,t2) + &
-                         b2 * d2* zhi(c2,e2,v1,t1,v2,t2)
-             fr       = d1 * EXP( -rrp / e1 ) - d2 * EXP( -rrp / e2 )
-             v1v2xy   = v1v2xy * fr * urms**2 / tau(i) / tau(j)
-             wrtur2xy = vrms1xy**2 + vrms2xy**2 - 2.0_wp * v1v2xy
-             IF ( wrtur2xy < 0.0_wp )  wrtur2xy = 0.0_wp
-             wrgrav2  = pi / 8.0_wp * ( winf(j) - winf(i) )**2
-             wrfin    = SQRT( ( 2.0_wp / pi ) * ( wrtur2xy + wrgrav2) )
-
-!
-!--          Calculate radial distribution function (grfin)
-             IF ( st(j) > st(i) )  THEN
-                sst = st(j)
-             ELSE
-                sst = st(i)
-             ENDIF
-
-             xx = -0.1988_wp * sst**4 + 1.5275_wp * sst**3 - 4.2942_wp *       &
-                   sst**2 + 5.3406_wp * sst
-             IF ( xx < 0.0_wp )  xx = 0.0_wp
-             yy = 0.1886_wp * EXP( 20.306_wp / lambda_re )
-
-             c1_gr  =  xx / ( g / vk * tauk )**yy
-
-             ao_gr  = ao + ( pi / 8.0_wp) * ( g / vk * tauk )**2
-             fao_gr = 20.115_wp * SQRT( ao_gr / lambda_re )
-             rc     = SQRT( fao_gr * ABS( st(j) - st(i) ) ) * eta
-
-             grfin  = ( ( eta**2 + rc**2 ) / ( rrp**2 + rc**2) )**( c1_gr*0.5_wp )
-             IF ( grfin < 1.0_wp )  grfin = 1.0_wp
-
-!
-!--          Calculate general collection kernel (without the consideration of
-!--          collection efficiencies)
-             gck(i,j) = 2.0_wp * pi * rrp**2 * wrfin * grfin
-             gck(j,i) = gck(i,j)
-
-          ENDDO
-       ENDDO
-
-    END SUBROUTINE turbsd
-
-    REAL(wp) FUNCTION phi_w( a, b, vsett, tau0 )
-!
-!--    Function used in the Ayala et al. (2008) analytical model for turbulent
-!--    effects on the collision kernel
-       IMPLICIT NONE
-
-       REAL(wp) ::  a     !<
-       REAL(wp) ::  aa1   !<
-       REAL(wp) ::  b     !<
-       REAL(wp) ::  tau0  !<
-       REAL(wp) ::  vsett !<
-
-       aa1 = 1.0_wp / tau0 + 1.0_wp / a + vsett / b
-       phi_w = 1.0_wp / aa1  - 0.5_wp * vsett / b / aa1**2
-
-    END FUNCTION phi_w
-
-    REAL(wp) FUNCTION zhi( a, b, vsett1, tau1, vsett2, tau2 )
-!
-!--    Function used in the Ayala et al. (2008) analytical model for turbulent
-!--    effects on the collision kernel
-       IMPLICIT NONE
-
-       REAL(wp) ::  a      !<
-       REAL(wp) ::  aa1    !<
-       REAL(wp) ::  aa2    !<
-       REAL(wp) ::  aa3    !<
-       REAL(wp) ::  aa4    !<
-       REAL(wp) ::  aa5    !<
-       REAL(wp) ::  aa6    !<
-       REAL(wp) ::  b      !<
-       REAL(wp) ::  tau1   !<
-       REAL(wp) ::  tau2   !<
-       REAL(wp) ::  vsett1 !<
-       REAL(wp) ::  vsett2 !<
-
-       aa1 = vsett2 / b - 1.0_wp / tau2 - 1.0_wp / a
-       aa2 = vsett1 / b + 1.0_wp / tau1 + 1.0_wp / a
-       aa3 = ( vsett1 - vsett2 ) / b + 1.0_wp / tau1 + 1.0_wp / tau2
-       aa4 = ( vsett2 / b )**2 - ( 1.0_wp / tau2 + 1.0_wp / a )**2
-       aa5 = vsett2 / b + 1.0_wp / tau2 + 1.0_wp / a
-       aa6 = 1.0_wp / tau1 - 1.0_wp / a + ( 1.0_wp / tau2 + 1.0_wp / a) *      &
-             vsett1 / vsett2
-       zhi = (1.0_wp / aa1 - 1.0_wp / aa2 ) * ( vsett1 - vsett2 ) * 0.5_wp /   &
-             b / aa3**2 + ( 4.0_wp / aa4 - 1.0_wp / aa5**2 - 1.0_wp / aa1**2 ) &
-             * vsett2 * 0.5_wp / b /aa6 + ( 2.0_wp * ( b / aa2 - b / aa1 ) -   &
-             vsett1 / aa2**2 + vsett2 / aa1**2 ) * 0.5_wp / b / aa3
-
-    END FUNCTION zhi
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Parameterization of terminal velocity following Rogers et al. (1993, J. Appl.
-!> Meteorol.)
-!------------------------------------------------------------------------------!
-    SUBROUTINE fallg
-
-       USE particle_attributes,                                                &
-           ONLY:  radius_classes
-
-       IMPLICIT NONE
-
-       INTEGER(iwp) ::  j                            !<
-
-       REAL(wp), PARAMETER ::  k_cap_rog = 4.0_wp    !< parameter
-       REAL(wp), PARAMETER ::  k_low_rog = 12.0_wp   !< parameter
-       REAL(wp), PARAMETER ::  a_rog     = 9.65_wp   !< parameter
-       REAL(wp), PARAMETER ::  b_rog     = 10.43_wp  !< parameter
-       REAL(wp), PARAMETER ::  c_rog     = 0.6_wp    !< parameter
-       REAL(wp), PARAMETER ::  d0_rog    = 0.745_wp  !< seperation diameter
-
-       REAL(wp)            ::  diameter              !< droplet diameter in mm
-
-
-       DO  j = 1, radius_classes
-
-          diameter = radclass(j) * 2000.0_wp
-
-          IF ( diameter <= d0_rog )  THEN
-             winf(j) = k_cap_rog * diameter * ( 1.0_wp -                       &
-                                                EXP( -k_low_rog * diameter ) )
-          ELSE
-             winf(j) = a_rog - b_rog * EXP( -c_rog * diameter )
-          ENDIF
-
-       ENDDO
-
-    END SUBROUTINE fallg
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Interpolation of collision efficiencies (Hall, 1980, J. Atmos. Sci.)
-!------------------------------------------------------------------------------!
-    SUBROUTINE effic
- 
-       USE particle_attributes,                                                &
-           ONLY:  radius_classes
-
-       IMPLICIT NONE
-
-       INTEGER(iwp) ::  i  !<
-       INTEGER(iwp) ::  iq !<
-       INTEGER(iwp) ::  ir !<
-       INTEGER(iwp) ::  j  !<
-       INTEGER(iwp) ::  k  !<
-
-       INTEGER(iwp), DIMENSION(:), ALLOCATABLE ::  ira !<
-
-       LOGICAL, SAVE ::  first = .TRUE. !<
-
-       REAL(wp) ::  ek              !<
-       REAL(wp) ::  particle_radius !<
-       REAL(wp) ::  pp              !<
-       REAL(wp) ::  qq              !<
-       REAL(wp) ::  rq              !<
-
-       REAL(wp), DIMENSION(1:21), SAVE ::  rat        !<
-       
-       REAL(wp), DIMENSION(1:15), SAVE ::  r0         !<
-       
-       REAL(wp), DIMENSION(1:15,1:21), SAVE ::  ecoll !<
-
-!
-!--    Initial assignment of constants
-       IF ( first )  THEN
-
-         first = .FALSE.
-         r0  = (/   6.0_wp,   8.0_wp,  10.0_wp, 15.0_wp,  20.0_wp,  25.0_wp,   &
-                   30.0_wp,  40.0_wp,  50.0_wp, 60.0_wp,  70.0_wp, 100.0_wp,   &
-                  150.0_wp, 200.0_wp, 300.0_wp /)
-
-         rat = (/ 0.00_wp, 0.05_wp, 0.10_wp, 0.15_wp, 0.20_wp, 0.25_wp,        &
-                  0.30_wp, 0.35_wp, 0.40_wp, 0.45_wp, 0.50_wp, 0.55_wp,        &
-                  0.60_wp, 0.65_wp, 0.70_wp, 0.75_wp, 0.80_wp, 0.85_wp,        &
-                  0.90_wp, 0.95_wp, 1.00_wp /)
-
-         ecoll(:,1)  = (/ 0.001_wp, 0.001_wp, 0.001_wp, 0.001_wp, 0.001_wp,    &
-                          0.001_wp, 0.001_wp, 0.001_wp, 0.001_wp, 0.001_wp,    &
-                          0.001_wp, 0.001_wp, 0.001_wp, 0.001_wp, 0.001_wp /)
-         ecoll(:,2)  = (/ 0.003_wp, 0.003_wp, 0.003_wp, 0.004_wp, 0.005_wp,    &
-                          0.005_wp, 0.005_wp, 0.010_wp, 0.100_wp, 0.050_wp,    &
-                          0.200_wp, 0.500_wp, 0.770_wp, 0.870_wp, 0.970_wp /)
-         ecoll(:,3)  = (/ 0.007_wp, 0.007_wp, 0.007_wp, 0.008_wp, 0.009_wp,    &
-                          0.010_wp, 0.010_wp, 0.070_wp, 0.400_wp, 0.430_wp,    &
-                          0.580_wp, 0.790_wp, 0.930_wp, 0.960_wp, 1.000_wp /)
-         ecoll(:,4)  = (/ 0.009_wp, 0.009_wp, 0.009_wp, 0.012_wp, 0.015_wp,    &
-                          0.010_wp, 0.020_wp, 0.280_wp, 0.600_wp, 0.640_wp,    &
-                          0.750_wp, 0.910_wp, 0.970_wp, 0.980_wp, 1.000_wp /)
-         ecoll(:,5)  = (/ 0.014_wp, 0.014_wp, 0.014_wp, 0.015_wp, 0.016_wp,    &
-                          0.030_wp, 0.060_wp, 0.500_wp, 0.700_wp, 0.770_wp,    &
-                          0.840_wp, 0.950_wp, 0.970_wp, 1.000_wp, 1.000_wp /)
-         ecoll(:,6)  = (/ 0.017_wp, 0.017_wp, 0.017_wp, 0.020_wp, 0.022_wp,    &
-                          0.060_wp, 0.100_wp, 0.620_wp, 0.780_wp, 0.840_wp,    &
-                          0.880_wp, 0.950_wp, 1.000_wp, 1.000_wp, 1.000_wp /)
-         ecoll(:,7)  = (/ 0.030_wp, 0.030_wp, 0.024_wp, 0.022_wp, 0.032_wp,    &
-                          0.062_wp, 0.200_wp, 0.680_wp, 0.830_wp, 0.870_wp,    &
-                          0.900_wp, 0.950_wp, 1.000_wp, 1.000_wp, 1.000_wp /)
-         ecoll(:,8)  = (/ 0.025_wp, 0.025_wp, 0.025_wp, 0.036_wp, 0.043_wp,    &
-                          0.130_wp, 0.270_wp, 0.740_wp, 0.860_wp, 0.890_wp,    &
-                          0.920_wp, 1.000_wp, 1.000_wp, 1.000_wp, 1.000_wp /)
-         ecoll(:,9)  = (/ 0.027_wp, 0.027_wp, 0.027_wp, 0.040_wp, 0.052_wp,    &
-                          0.200_wp, 0.400_wp, 0.780_wp, 0.880_wp, 0.900_wp,    &
-                          0.940_wp, 1.000_wp, 1.000_wp, 1.000_wp, 1.000_wp /)
-         ecoll(:,10) = (/ 0.030_wp, 0.030_wp, 0.030_wp, 0.047_wp, 0.064_wp,    &
-                          0.250_wp, 0.500_wp, 0.800_wp, 0.900_wp, 0.910_wp,    &
-                          0.950_wp, 1.000_wp, 1.000_wp, 1.000_wp, 1.000_wp /)
-         ecoll(:,11) = (/ 0.040_wp, 0.040_wp, 0.033_wp, 0.037_wp, 0.068_wp,    &
-                          0.240_wp, 0.550_wp, 0.800_wp, 0.900_wp, 0.910_wp,    &
-                          0.950_wp, 1.000_wp, 1.000_wp, 1.000_wp, 1.000_wp /)
-         ecoll(:,12) = (/ 0.035_wp, 0.035_wp, 0.035_wp, 0.055_wp, 0.079_wp,    &
-                          0.290_wp, 0.580_wp, 0.800_wp, 0.900_wp, 0.910_wp,    &
-                          0.950_wp, 1.000_wp, 1.000_wp, 1.000_wp, 1.000_wp /)
-         ecoll(:,13) = (/ 0.037_wp, 0.037_wp, 0.037_wp, 0.062_wp, 0.082_wp,    &
-                          0.290_wp, 0.590_wp, 0.780_wp, 0.900_wp, 0.910_wp,    &
-                          0.950_wp, 1.000_wp, 1.000_wp, 1.000_wp, 1.000_wp /)
-         ecoll(:,14) = (/ 0.037_wp, 0.037_wp, 0.037_wp, 0.060_wp, 0.080_wp,    &
-                          0.290_wp, 0.580_wp, 0.770_wp, 0.890_wp, 0.910_wp,    &
-                          0.950_wp, 1.000_wp, 1.000_wp, 1.000_wp, 1.000_wp /)
-         ecoll(:,15) = (/ 0.037_wp, 0.037_wp, 0.037_wp, 0.041_wp, 0.075_wp,    &
-                          0.250_wp, 0.540_wp, 0.760_wp, 0.880_wp, 0.920_wp,    &
-                          0.950_wp, 1.000_wp, 1.000_wp, 1.000_wp, 1.000_wp /)
-         ecoll(:,16) = (/ 0.037_wp, 0.037_wp, 0.037_wp, 0.052_wp, 0.067_wp,    &
-                          0.250_wp, 0.510_wp, 0.770_wp, 0.880_wp, 0.930_wp,    &
-                          0.970_wp, 1.000_wp, 1.000_wp, 1.000_wp, 1.000_wp /)
-         ecoll(:,17) = (/ 0.037_wp, 0.037_wp, 0.037_wp, 0.047_wp, 0.057_wp,    &
-                          0.250_wp, 0.490_wp, 0.770_wp, 0.890_wp, 0.950_wp,    &
-                          1.000_wp, 1.000_wp, 1.000_wp, 1.000_wp, 1.000_wp /)
-         ecoll(:,18) = (/ 0.036_wp, 0.036_wp, 0.036_wp, 0.042_wp, 0.048_wp,    &
-                          0.230_wp, 0.470_wp, 0.780_wp, 0.920_wp, 1.000_wp,    &
-                          1.020_wp, 1.020_wp, 1.020_wp, 1.020_wp, 1.020_wp /)
-         ecoll(:,19) = (/ 0.040_wp, 0.040_wp, 0.035_wp, 0.033_wp, 0.040_wp,    &
-                          0.112_wp, 0.450_wp, 0.790_wp, 1.010_wp, 1.030_wp,    &
-                          1.040_wp, 1.040_wp, 1.040_wp, 1.040_wp, 1.040_wp /)
-         ecoll(:,20) = (/ 0.033_wp, 0.033_wp, 0.033_wp, 0.033_wp, 0.033_wp,    &
-                          0.119_wp, 0.470_wp, 0.950_wp, 1.300_wp, 1.700_wp,    &
-                          2.300_wp, 2.300_wp, 2.300_wp, 2.300_wp, 2.300_wp /)
-         ecoll(:,21) = (/ 0.027_wp, 0.027_wp, 0.027_wp, 0.027_wp, 0.027_wp,    &
-                          0.125_wp, 0.520_wp, 1.400_wp, 2.300_wp, 3.000_wp,    &
-                          4.000_wp, 4.000_wp, 4.000_wp, 4.000_wp, 4.000_wp /)
-       ENDIF
-
-!
-!--    Calculate the radius class index of particles with respect to array r
-!--    Radius has to be in microns
-       ALLOCATE( ira(1:radius_classes) )
-       DO  j = 1, radius_classes
-          particle_radius = radclass(j) * 1.0E6_wp
-          DO  k = 1, 15
-             IF ( particle_radius < r0(k) )  THEN
-                ira(j) = k
-                EXIT
-             ENDIF
-          ENDDO
-          IF ( particle_radius >= r0(15) )  ira(j) = 16
-       ENDDO
-
-!
-!--    Two-dimensional linear interpolation of the collision efficiency.
-!--    Radius has to be in microns
-       DO  j = 1, radius_classes
-          DO  i = 1, j
-
-             ir = ira(j)
-             rq = MIN( radclass(i) / radclass(j), radclass(j) / radclass(i) )
-             iq = INT( rq * 20 ) + 1
-             iq = MAX( iq , 2)
-
-             IF ( ir < 16 )  THEN
-                IF ( ir >= 2 )  THEN
-                   pp = ( ( MAX( radclass(j), radclass(i) ) * 1.0E6_wp ) -     &
-                          r0(ir-1) ) / ( r0(ir) - r0(ir-1) )
-                   qq = ( rq - rat(iq-1) ) / ( rat(iq) - rat(iq-1) )
-                   ec(j,i) = ( 1.0_wp - pp ) * ( 1.0_wp - qq )                 &
-                             * ecoll(ir-1,iq-1)                                &
-                             + pp * ( 1.0_wp - qq ) * ecoll(ir,iq-1)           &
-                             + qq * ( 1.0_wp - pp ) * ecoll(ir-1,iq)           &
-                             + pp * qq * ecoll(ir,iq)
-                ELSE
-                   qq = ( rq - rat(iq-1) ) / ( rat(iq) - rat(iq-1) )
-                   ec(j,i) = ( 1.0_wp - qq ) * ecoll(1,iq-1) + qq * ecoll(1,iq)
-                ENDIF
-             ELSE
-                qq = ( rq - rat(iq-1) ) / ( rat(iq) - rat(iq-1) )
-                ek = ( 1.0_wp - qq ) * ecoll(15,iq-1) + qq * ecoll(15,iq)
-                ec(j,i) = MIN( ek, 1.0_wp )
-             ENDIF
-
-             IF ( ec(j,i) < 1.0E-20_wp )  ec(j,i) = 0.0_wp
-
-             ec(i,j) = ec(j,i)
-
-          ENDDO
-       ENDDO
-
-       DEALLOCATE( ira )
-
-    END SUBROUTINE effic
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Interpolation of turbulent enhancement factor for collision efficencies
-!> following Wang and Grabowski (2009, Atmos. Sci. Let.)
-!------------------------------------------------------------------------------!
-    SUBROUTINE turb_enhance_eff
-
-       USE particle_attributes,                                                &
-           ONLY:  radius_classes
-
-       IMPLICIT NONE
-
-       INTEGER(iwp) :: i  !<
-       INTEGER(iwp) :: iq !<
-       INTEGER(iwp) :: ir !<
-       INTEGER(iwp) :: j  !<
-       INTEGER(iwp) :: k  !<
-       INTEGER(iwp) :: kk !<
-
-       INTEGER(iwp), DIMENSION(:), ALLOCATABLE ::  ira !<
-       
-       LOGICAL, SAVE ::  first = .TRUE. !<
-
-       REAL(wp) ::  particle_radius !<
-       REAL(wp) ::  pp              !<
-       REAL(wp) ::  qq              !<
-       REAL(wp) ::  rq              !<
-       REAL(wp) ::  y1              !<
-       REAL(wp) ::  y2              !<
-       REAL(wp) ::  y3              !<
-
-       REAL(wp), DIMENSION(1:11), SAVE ::  rat           !<
-       REAL(wp), DIMENSION(1:7), SAVE  ::  r0            !<
-       
-       REAL(wp), DIMENSION(1:7,1:11), SAVE ::  ecoll_100 !<
-       REAL(wp), DIMENSION(1:7,1:11), SAVE ::  ecoll_400 !<
-
-!
-!--    Initial assignment of constants
-       IF ( first )  THEN
-
-          first = .FALSE.
-
-          r0  = (/  10.0_wp, 20.0_wp, 30.0_wp, 40.0_wp, 50.0_wp, 60.0_wp,  &
-                   100.0_wp /)
-
-          rat = (/ 0.0_wp, 0.1_wp, 0.2_wp, 0.3_wp, 0.4_wp, 0.5_wp, 0.6_wp, &
-                   0.7_wp, 0.8_wp, 0.9_wp, 1.0_wp /)
-!
-!--       Tabulated turbulent enhancement factor at 100 cm**2/s**3
-          ecoll_100(:,1)  = (/  1.74_wp,   1.74_wp,   1.773_wp, 1.49_wp,  &
-                                1.207_wp,  1.207_wp,  1.0_wp /)
-          ecoll_100(:,2)  = (/  1.46_wp,   1.46_wp,   1.421_wp, 1.245_wp, &
-                                1.069_wp,  1.069_wp,  1.0_wp /)
-          ecoll_100(:,3)  = (/  1.32_wp,   1.32_wp,   1.245_wp, 1.123_wp, &
-                                1.000_wp,  1.000_wp,  1.0_wp /)
-          ecoll_100(:,4)  = (/  1.250_wp,  1.250_wp,  1.148_wp, 1.087_wp, &
-                                1.025_wp,  1.025_wp,  1.0_wp /)
-          ecoll_100(:,5)  = (/  1.186_wp,  1.186_wp,  1.066_wp, 1.060_wp, &
-                                1.056_wp,  1.056_wp,  1.0_wp /)
-          ecoll_100(:,6)  = (/  1.045_wp,  1.045_wp,  1.000_wp, 1.014_wp, &
-                                1.028_wp,  1.028_wp,  1.0_wp /)
-          ecoll_100(:,7)  = (/  1.070_wp,  1.070_wp,  1.030_wp, 1.038_wp, &
-                                1.046_wp,  1.046_wp,  1.0_wp /)
-          ecoll_100(:,8)  = (/  1.000_wp,  1.000_wp,  1.054_wp, 1.042_wp, &
-                                1.029_wp,  1.029_wp,  1.0_wp /)
-          ecoll_100(:,9)  = (/  1.223_wp,  1.223_wp,  1.117_wp, 1.069_wp, &
-                                1.021_wp,  1.021_wp,  1.0_wp /)
-          ecoll_100(:,10) = (/  1.570_wp,  1.570_wp,  1.244_wp, 1.166_wp, &
-                                1.088_wp,  1.088_wp,  1.0_wp /)
-          ecoll_100(:,11) = (/ 20.3_wp,   20.3_wp,   14.6_wp,   8.61_wp,  &
-                                2.60_wp,   2.60_wp,   1.0_wp /)
-!
-!--       Tabulated turbulent enhancement factor at 400 cm**2/s**3
-          ecoll_400(:,1)  = (/  4.976_wp,  4.976_wp,  3.593_wp,  2.519_wp, &
-                                1.445_wp,  1.445_wp,  1.0_wp /)
-          ecoll_400(:,2)  = (/  2.984_wp,  2.984_wp,  2.181_wp,  1.691_wp, &
-                                1.201_wp,  1.201_wp,  1.0_wp /)
-          ecoll_400(:,3)  = (/  1.988_wp,  1.988_wp,  1.475_wp,  1.313_wp, &
-                                1.150_wp,  1.150_wp,  1.0_wp /)
-          ecoll_400(:,4)  = (/  1.490_wp,  1.490_wp,  1.187_wp,  1.156_wp, &
-                                1.126_wp,  1.126_wp,  1.0_wp /)
-          ecoll_400(:,5)  = (/  1.249_wp,  1.249_wp,  1.088_wp,  1.090_wp, &
-                                1.092_wp,  1.092_wp,  1.0_wp /)
-          ecoll_400(:,6)  = (/  1.139_wp,  1.139_wp,  1.130_wp,  1.091_wp, &
-                                1.051_wp,  1.051_wp,  1.0_wp /)
-          ecoll_400(:,7)  = (/  1.220_wp,  1.220_wp,  1.190_wp,  1.138_wp, &
-                                1.086_wp,  1.086_wp,  1.0_wp /)
-          ecoll_400(:,8)  = (/  1.325_wp,  1.325_wp,  1.267_wp,  1.165_wp, &
-                                1.063_wp,  1.063_wp,  1.0_wp /)
-          ecoll_400(:,9)  = (/  1.716_wp,  1.716_wp,  1.345_wp,  1.223_wp, &
-                                1.100_wp,  1.100_wp,  1.0_wp /)
-          ecoll_400(:,10) = (/  3.788_wp,  3.788_wp,  1.501_wp,  1.311_wp, &
-                                1.120_wp,  1.120_wp,  1.0_wp /)
-          ecoll_400(:,11) = (/ 36.52_wp,  36.52_wp,  19.16_wp,  22.80_wp,  &
-                               26.0_wp,   26.0_wp,    1.0_wp /)
-
-       ENDIF
-
-!
-!--    Calculate the radius class index of particles with respect to array r0
-!--    The droplet radius has to be given in microns.
-       ALLOCATE( ira(1:radius_classes) )
-
-       DO  j = 1, radius_classes
-          particle_radius = radclass(j) * 1.0E6_wp
-          DO  k = 1, 7
-             IF ( particle_radius < r0(k) )  THEN
-                ira(j) = k
-                EXIT
-             ENDIF
-          ENDDO
-          IF ( particle_radius >= r0(7) )  ira(j) = 8
-       ENDDO
-
-!
-!--    Two-dimensional linear interpolation of the turbulent enhancement factor.
-!--    The droplet radius has to be given in microns.
-       DO  j =  1, radius_classes
-          DO  i = 1, j
-
-             ir = ira(j)
-             rq = MIN( radclass(i) / radclass(j), radclass(j) / radclass(i) )
-
-             DO  kk = 2, 11
-                IF ( rq <= rat(kk) )  THEN
-                   iq = kk
-                   EXIT
-                ENDIF
-             ENDDO
-
-             y1 = 1.0_wp  ! turbulent enhancement factor at 0 m**2/s**3
-
-             IF ( ir < 8 )  THEN
-                IF ( ir >= 2 )  THEN
-                   pp = ( MAX( radclass(j), radclass(i) ) * 1.0E6_wp -  &
-                          r0(ir-1) ) / ( r0(ir) - r0(ir-1) )
-                   qq = ( rq - rat(iq-1) ) / ( rat(iq) - rat(iq-1) )
-                   y2 = ( 1.0_wp - pp ) * ( 1.0_wp - qq ) * ecoll_100(ir-1,iq-1) + &
-                                pp * ( 1.0_wp - qq ) * ecoll_100(ir,iq-1)        + &
-                                qq * ( 1.0_wp - pp ) * ecoll_100(ir-1,iq)        + &
-                                pp * qq              * ecoll_100(ir,iq)
-                   y3 = ( 1.0-pp ) * ( 1.0_wp - qq ) * ecoll_400(ir-1,iq-1)      + &
-                                pp * ( 1.0_wp - qq ) * ecoll_400(ir,iq-1)        + &
-                                qq * ( 1.0_wp - pp ) * ecoll_400(ir-1,iq)        + &
-                                pp * qq              * ecoll_400(ir,iq)
-                ELSE
-                   qq = ( rq - rat(iq-1) ) / ( rat(iq) - rat(iq-1) )
-                   y2 = ( 1.0_wp - qq ) * ecoll_100(1,iq-1) + qq * ecoll_100(1,iq)
-                   y3 = ( 1.0_wp - qq ) * ecoll_400(1,iq-1) + qq * ecoll_400(1,iq)
-                ENDIF
-             ELSE
-                qq = ( rq - rat(iq-1) ) / ( rat(iq) - rat(iq-1) )
-                y2 = ( 1.0_wp - qq ) * ecoll_100(7,iq-1) + qq * ecoll_100(7,iq)
-                y3 = ( 1.0_wp - qq ) * ecoll_400(7,iq-1) + qq * ecoll_400(7,iq)
-             ENDIF
-!
-!--          Linear interpolation of turbulent enhancement factor
-             IF ( epsilon <= 0.01_wp )  THEN
-                ecf(j,i) = ( epsilon - 0.01_wp ) / ( 0.0_wp  - 0.01_wp ) * y1 &
-                         + ( epsilon - 0.0_wp  ) / ( 0.01_wp - 0.0_wp  ) * y2
-             ELSEIF ( epsilon <= 0.06_wp )  THEN
-                ecf(j,i) = ( epsilon - 0.04_wp ) / ( 0.01_wp - 0.04_wp ) * y2 &
-                         + ( epsilon - 0.01_wp ) / ( 0.04_wp - 0.01_wp ) * y3
-             ELSE
-                ecf(j,i) = ( 0.06_wp - 0.04_wp ) / ( 0.01_wp - 0.04_wp ) * y2 &
-                         + ( 0.06_wp - 0.01_wp ) / ( 0.04_wp - 0.01_wp ) * y3
-             ENDIF
-
-             IF ( ecf(j,i) < 1.0_wp )  ecf(j,i) = 1.0_wp
-
-             ecf(i,j) = ecf(j,i)
-
-          ENDDO
-       ENDDO
-
-    END SUBROUTINE turb_enhance_eff
-
- END MODULE lpm_collision_kernels_mod
Index: /palm/trunk/SOURCE/lpm_collision_kernels_mod.f90
===================================================================
--- /palm/trunk/SOURCE/lpm_collision_kernels_mod.f90	(revision 1850)
+++ /palm/trunk/SOURCE/lpm_collision_kernels_mod.f90	(revision 1850)
@@ -0,0 +1,1001 @@
+!> @file lpm_collision_kernels_mod.f90
+!--------------------------------------------------------------------------------!
+! This file is part of PALM.
+!
+! PALM is free software: you can redistribute it and/or modify it under the terms
+! of the GNU General Public License as published by the Free Software Foundation,
+! either version 3 of the License, or (at your option) any later version.
+!
+! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
+! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
+! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along with
+! PALM. If not, see <http://www.gnu.org/licenses/>.
+!
+! Copyright 1997-2016 Leibniz Universitaet Hannover
+!--------------------------------------------------------------------------------!
+!
+! Current revisions:
+! -----------------
+! Module renamed
+!
+! 
+! Former revisions:
+! -----------------
+! $Id$
+!
+! 1822 2016-04-07 07:49:42Z hoffmann
+! PALM kernel has been deleted.
+! Bugfix in the calculation of the turbulent enhancement factor of the
+! collection efficiency.
+!
+! Unused variables removed.
+!
+! 1776 2016-03-02 17:54:58Z hoffmann
+! Bugfix: Collection efficiencies must be calculated for the larger droplet.
+!
+! 1682 2015-10-07 23:56:08Z knoop
+! Code annotations made doxygen readable
+! 
+! 1519 2015-01-08 10:20:42Z hoffmann
+! Bugfix: Using the new particle structure, particles are not sorted by size.
+! Hence, computation of collision efficiencies must ensure that the ratio of 
+! two colliding droplets is < 1.
+!
+! 1359 2014-04-11 17:15:14Z hoffmann
+! New particle structure integrated.
+! Kind definition added to all floating point numbers.
+! 
+! 1346 2014-03-27 13:18:20Z heinze
+! Bugfix: REAL constants provided with KIND-attribute especially in call of 
+! intrinsic function like MAX, MIN, SIGN
+!
+! 1322 2014-03-20 16:38:49Z raasch
+! REAL constants defined as wp_kind
+!
+! 1320 2014-03-20 08:40:49Z 
+! ONLY-attribute added to USE-statements,
+! kind-parameters added to all INTEGER and REAL declaration statements,
+! kinds are defined in new module kinds,
+! revision history before 2012 removed,
+! comment fields (!:) to be used for variable explanations added to
+! all variable declaration statements
+!
+! 1092 2013-02-02 11:24:22Z raasch
+! unused variables removed
+!
+! 1071 2012-11-29 16:54:55Z franke
+! Bugfix: collision efficiencies for Hall kernel should not be < 1.0E-20
+!
+! 1036 2012-10-22 13:43:42Z raasch
+! code put under GPL (PALM 3.9)
+!
+! 1007 2012-09-19 14:30:36Z franke
+! converted all units to SI units and replaced some parameters by corresponding
+! PALM parameters
+! Bugfix: factor in calculation of enhancement factor for collision efficencies
+! changed from 10. to 1.0
+!
+! 849 2012-03-15 10:35:09Z raasch
+! routine collision_efficiency_rogers added (moved from former advec_particles
+! to here)
+!
+! 835 2012-02-22 11:21:19Z raasch $
+! Bugfix: array diss can be used only in case of Wang kernel
+!
+! 828 2012-02-21 12:00:36Z raasch
+! code has been completely reformatted, routine colker renamed
+! recalculate_kernel,
+! routine init_kernels added, radius is now communicated to the collision
+! routines by array radclass
+!
+! Bugfix: transformation factor for dissipation changed from 1E5 to 1E4
+!
+! 825 2012-02-19 03:03:44Z raasch
+! routine renamed from wang_kernel to lpm_collision_kernels,
+! turbulence_effects on collision replaced by wang_kernel
+!
+! 790 2011-11-29 03:11:20Z raasch
+! initial revision
+!
+! Description:
+! ------------
+!> This module calculates collision efficiencies either due to pure gravitational
+!> effects (Hall kernel, see Hall, 1980: J. Atmos. Sci., 2486-2507) or
+!> including the effects of turbulence (Wang kernel, see Wang and
+!> Grabowski, 2009: Atmos. Sci. Lett., 10, 1-8, and Ayala et al., 2008: 
+!> New J. Phys., 10, 075016). The original code has been
+!> provided by L.-P. Wang but is substantially reformatted and speed optimized
+!> here.
+!------------------------------------------------------------------------------!
+ MODULE lpm_collision_kernels_mod
+ 
+
+    USE constants,                                                             &
+        ONLY:  pi
+        
+    USE kinds
+
+    USE particle_attributes,                                                   &
+        ONLY:  collision_kernel, dissipation_classes, particles,               &
+               radius_classes
+
+    USE pegrid
+
+
+    IMPLICIT NONE
+
+    PRIVATE
+
+    PUBLIC  ckernel, init_kernels, rclass_lbound, rclass_ubound,               &
+            recalculate_kernel
+
+    REAL(wp) ::  epsilon       !<
+    REAL(wp) ::  rclass_lbound !<
+    REAL(wp) ::  rclass_ubound !<
+    REAL(wp) ::  urms          !<
+
+    REAL(wp), DIMENSION(:),   ALLOCATABLE ::  epsclass  !< dissipation rate class
+    REAL(wp), DIMENSION(:),   ALLOCATABLE ::  radclass  !< radius class
+    REAL(wp), DIMENSION(:),   ALLOCATABLE ::  winf      !<
+    
+    REAL(wp), DIMENSION(:,:), ALLOCATABLE ::  ec        !<
+    REAL(wp), DIMENSION(:,:), ALLOCATABLE ::  ecf       !<
+    REAL(wp), DIMENSION(:,:), ALLOCATABLE ::  gck       !<
+    REAL(wp), DIMENSION(:,:), ALLOCATABLE ::  hkernel   !<
+    REAL(wp), DIMENSION(:,:), ALLOCATABLE ::  hwratio   !<
+    
+    REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::  ckernel !<
+
+    SAVE
+
+!
+!-- Public interfaces
+    INTERFACE init_kernels
+       MODULE PROCEDURE init_kernels
+    END INTERFACE init_kernels
+
+    INTERFACE recalculate_kernel
+       MODULE PROCEDURE recalculate_kernel
+    END INTERFACE recalculate_kernel
+
+
+    CONTAINS
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Initialization of the collision efficiency matrix with fixed radius and
+!> dissipation classes, calculated at simulation start only.
+!------------------------------------------------------------------------------!
+ 
+    SUBROUTINE init_kernels
+
+       IMPLICIT NONE
+
+       INTEGER(iwp) ::  i !<
+       INTEGER(iwp) ::  j !<
+       INTEGER(iwp) ::  k !<
+
+
+!
+!--    Calculate collision efficiencies for fixed radius- and dissipation
+!--    classes
+       IF ( collision_kernel(6:9) == 'fast' )  THEN
+
+          ALLOCATE( ckernel(1:radius_classes,1:radius_classes,                 &
+                    0:dissipation_classes), epsclass(1:dissipation_classes),   &
+                    radclass(1:radius_classes) )
+
+!
+!--       Calculate the radius class bounds with logarithmic distances
+!--       in the interval [1.0E-6, 2.0E-4] m
+          rclass_lbound = LOG( 1.0E-6_wp )
+          rclass_ubound = LOG( 2.0E-4_wp )
+          radclass(1)   = EXP( rclass_lbound )
+          DO  i = 2, radius_classes
+             radclass(i) = EXP( rclass_lbound +                                &
+                                ( rclass_ubound - rclass_lbound ) *            &
+                                ( i - 1.0_wp ) / ( radius_classes - 1.0_wp ) )
+          ENDDO
+
+!
+!--       Set the class bounds for dissipation in interval [0.0, 0.1] m**2/s**3
+          DO  i = 1, dissipation_classes
+             epsclass(i) = 0.1_wp * REAL( i, KIND=wp ) / dissipation_classes
+          ENDDO
+!
+!--       Calculate collision efficiencies of the Wang/ayala kernel
+          ALLOCATE( ec(1:radius_classes,1:radius_classes),  &
+                    ecf(1:radius_classes,1:radius_classes), &
+                    gck(1:radius_classes,1:radius_classes), &
+                    winf(1:radius_classes) )
+
+          DO  k = 1, dissipation_classes
+
+             epsilon = epsclass(k)
+             urms    = 2.02_wp * ( epsilon / 0.04_wp )**( 1.0_wp / 3.0_wp )
+
+             CALL turbsd
+             CALL turb_enhance_eff
+             CALL effic
+
+             DO  j = 1, radius_classes
+                DO  i = 1, radius_classes
+                   ckernel(i,j,k) = ec(i,j) * gck(i,j) * ecf(i,j)
+                ENDDO
+             ENDDO
+
+          ENDDO
+
+!
+!--       Calculate collision efficiencies of the Hall kernel
+          ALLOCATE( hkernel(1:radius_classes,1:radius_classes), &
+                    hwratio(1:radius_classes,1:radius_classes) )
+
+          CALL fallg
+          CALL effic
+
+          DO  j = 1, radius_classes
+             DO  i =  1, radius_classes
+                hkernel(i,j) = pi * ( radclass(j) + radclass(i) )**2 &
+                                  * ec(i,j) * ABS( winf(j) - winf(i) )
+                ckernel(i,j,0) = hkernel(i,j)  ! hall kernel stored on index 0
+              ENDDO
+          ENDDO
+
+!
+!--       Test output of efficiencies
+          IF ( j == -1 )  THEN
+
+             PRINT*, '*** Hall kernel'
+             WRITE ( *,'(5X,20(F4.0,1X))' ) ( radclass(i)*1.0E6_wp, &
+                                              i = 1,radius_classes )
+             DO  j = 1, radius_classes
+                WRITE ( *,'(F4.0,1X,20(F8.4,1X))' ) radclass(j),  &
+                                          ( hkernel(i,j), i = 1,radius_classes )
+             ENDDO
+
+             DO  k = 1, dissipation_classes
+                DO  i = 1, radius_classes
+                   DO  j = 1, radius_classes
+                      IF ( hkernel(i,j) == 0.0_wp )  THEN
+                         hwratio(i,j) = 9999999.9_wp
+                      ELSE
+                         hwratio(i,j) = ckernel(i,j,k) / hkernel(i,j)
+                      ENDIF
+                   ENDDO
+                ENDDO
+
+                PRINT*, '*** epsilon = ', epsclass(k)
+                WRITE ( *,'(5X,20(F4.0,1X))' ) ( radclass(i) * 1.0E6_wp, &
+                                                 i = 1,radius_classes )
+                DO  j = 1, radius_classes
+                   WRITE ( *,'(F4.0,1X,20(F8.4,1X))' ) radclass(j) * 1.0E6_wp, &
+                                          ( hwratio(i,j), i = 1,radius_classes )
+                ENDDO
+             ENDDO
+
+          ENDIF
+
+          DEALLOCATE( ec, ecf, epsclass, gck, hkernel, winf )
+
+       ELSEIF( collision_kernel == 'hall'  .OR.  collision_kernel == 'wang' ) &
+       THEN
+!
+!--       Initial settings for Hall- and Wang-Kernel
+!--       To be done: move here parts from turbsd, fallg, ecoll, etc.
+       ENDIF
+
+    END SUBROUTINE init_kernels
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Calculation of collision kernels during each timestep and for each grid box
+!------------------------------------------------------------------------------!
+    SUBROUTINE recalculate_kernel( i1, j1, k1 )
+
+       USE arrays_3d,                                                          &
+           ONLY:  diss
+
+       USE particle_attributes,                                                &
+           ONLY:  prt_count, radius_classes, wang_kernel
+
+       IMPLICIT NONE
+
+       INTEGER(iwp) ::  i      !<
+       INTEGER(iwp) ::  i1     !<
+       INTEGER(iwp) ::  j      !<
+       INTEGER(iwp) ::  j1     !<
+       INTEGER(iwp) ::  k1     !<
+       INTEGER(iwp) ::  pend   !<
+       INTEGER(iwp) ::  pstart !<
+
+
+       pstart = 1
+       pend   = prt_count(k1,j1,i1)
+       radius_classes = prt_count(k1,j1,i1)
+
+       ALLOCATE( ec(1:radius_classes,1:radius_classes), &
+                 radclass(1:radius_classes), winf(1:radius_classes) )
+
+!
+!--    Store particle radii on the radclass array
+       radclass(1:radius_classes) = particles(pstart:pend)%radius
+
+       IF ( wang_kernel )  THEN
+          epsilon = diss(k1,j1,i1)   ! dissipation rate in m**2/s**3
+       ELSE
+          epsilon = 0.0_wp
+       ENDIF
+       urms    = 2.02_wp * ( epsilon / 0.04_wp )**( 0.33333333333_wp )
+
+       IF ( wang_kernel  .AND.  epsilon > 1.0E-7_wp )  THEN
+!
+!--       Call routines to calculate efficiencies for the Wang kernel
+          ALLOCATE( gck(1:radius_classes,1:radius_classes), &
+                    ecf(1:radius_classes,1:radius_classes) )
+
+          CALL turbsd
+          CALL turb_enhance_eff
+          CALL effic
+
+          DO  j = 1, radius_classes
+             DO  i =  1, radius_classes
+                ckernel(pstart+i-1,pstart+j-1,1) = ec(i,j) * gck(i,j) * ecf(i,j)
+             ENDDO
+          ENDDO
+
+          DEALLOCATE( gck, ecf )
+
+       ELSE
+!
+!--       Call routines to calculate efficiencies for the Hall kernel
+          CALL fallg
+          CALL effic
+
+          DO  j = 1, radius_classes
+             DO  i =  1, radius_classes
+                ckernel(pstart+i-1,pstart+j-1,1) = pi *                       &
+                                          ( radclass(j) + radclass(i) )**2    &
+                                          * ec(i,j) * ABS( winf(j) - winf(i) )
+             ENDDO
+          ENDDO
+
+       ENDIF
+
+       DEALLOCATE( ec, radclass, winf )
+
+    END SUBROUTINE recalculate_kernel
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Calculation of effects of turbulence on the geometric collision kernel 
+!> (by including the droplets' average radial relative velocities and their 
+!> radial distribution function) following the analytic model by Aayala et al. 
+!> (2008, New J. Phys.). For details check the second part 2 of the publication,
+!> page 37ff.
+!>
+!> Input parameters, which need to be replaced by PALM parameters:
+!>    water density, air density
+!------------------------------------------------------------------------------!
+    SUBROUTINE turbsd
+
+       USE control_parameters,                                                 &
+           ONLY:  g, molecular_viscosity
+    
+       USE particle_attributes,                                                &
+           ONLY:  radius_classes
+
+       IMPLICIT NONE
+
+       INTEGER(iwp) ::  i     !<
+       INTEGER(iwp) ::  j     !<
+
+       REAL(wp) ::  ao        !<
+       REAL(wp) ::  ao_gr     !<
+       REAL(wp) ::  bbb       !<
+       REAL(wp) ::  be        !<
+       REAL(wp) ::  b1        !<
+       REAL(wp) ::  b2        !<
+       REAL(wp) ::  ccc       !<
+       REAL(wp) ::  c1        !<
+       REAL(wp) ::  c1_gr     !<
+       REAL(wp) ::  c2        !<
+       REAL(wp) ::  d1        !<
+       REAL(wp) ::  d2        !<
+       REAL(wp) ::  eta       !<
+       REAL(wp) ::  e1        !<
+       REAL(wp) ::  e2        !<
+       REAL(wp) ::  fao_gr    !<
+       REAL(wp) ::  fr        !<
+       REAL(wp) ::  grfin     !<
+       REAL(wp) ::  lambda    !<
+       REAL(wp) ::  lambda_re !<
+       REAL(wp) ::  lf        !<
+       REAL(wp) ::  rc        !<
+       REAL(wp) ::  rrp       !<
+       REAL(wp) ::  sst       !<
+       REAL(wp) ::  tauk      !<
+       REAL(wp) ::  tl        !<
+       REAL(wp) ::  t2        !<
+       REAL(wp) ::  tt        !<
+       REAL(wp) ::  t1        !<
+       REAL(wp) ::  vk        !<
+       REAL(wp) ::  vrms1xy   !<
+       REAL(wp) ::  vrms2xy   !<
+       REAL(wp) ::  v1        !<
+       REAL(wp) ::  v1v2xy    !<
+       REAL(wp) ::  v1xysq    !<
+       REAL(wp) ::  v2        !<
+       REAL(wp) ::  v2xysq    !<
+       REAL(wp) ::  wrfin     !<
+       REAL(wp) ::  wrgrav2   !<
+       REAL(wp) ::  wrtur2xy  !<
+       REAL(wp) ::  xx        !<
+       REAL(wp) ::  yy        !<
+       REAL(wp) ::  z         !<
+
+       REAL(wp), DIMENSION(1:radius_classes) ::  st  !< Stokes number
+       REAL(wp), DIMENSION(1:radius_classes) ::  tau !< inertial time scale
+
+       lambda    = urms * SQRT( 15.0_wp * molecular_viscosity / epsilon )
+       lambda_re = urms**2 * SQRT( 15.0_wp / epsilon / molecular_viscosity )
+       tl        = urms**2 / epsilon
+       lf        = 0.5_wp * urms**3 / epsilon
+       tauk      = SQRT( molecular_viscosity / epsilon )
+       eta       = ( molecular_viscosity**3 / epsilon )**0.25_wp
+       vk        = eta / tauk
+
+       ao = ( 11.0_wp + 7.0_wp * lambda_re ) / ( 205.0_wp + lambda_re )
+       tt = SQRT( 2.0_wp * lambda_re / ( SQRT( 15.0_wp ) * ao ) ) * tauk
+
+!
+!--    Get terminal velocity of droplets
+       CALL fallg
+
+       DO  i = 1, radius_classes
+          tau(i) = winf(i) / g    ! inertial time scale
+          st(i)  = tau(i) / tauk  ! Stokes number
+       ENDDO
+
+!
+!--    Calculate average radial relative velocity at contact (wrfin)
+       z   = tt / tl
+       be  = SQRT( 2.0_wp ) * lambda / lf
+       bbb = SQRT( 1.0_wp - 2.0_wp * be**2 )
+       d1  = ( 1.0_wp + bbb ) / ( 2.0_wp * bbb )
+       e1  = lf * ( 1.0_wp + bbb ) * 0.5_wp
+       d2  = ( 1.0_wp - bbb ) * 0.5_wp / bbb
+       e2  = lf * ( 1.0_wp - bbb ) * 0.5_wp
+       ccc = SQRT( 1.0_wp - 2.0_wp * z**2 )
+       b1  = ( 1.0_wp + ccc ) * 0.5_wp / ccc
+       c1  = tl * ( 1.0_wp + ccc ) * 0.5_wp
+       b2  = ( 1.0_wp - ccc ) * 0.5_wp / ccc
+       c2  = tl * ( 1.0_wp - ccc ) * 0.5_wp
+
+       DO  i = 1, radius_classes
+
+          v1 = winf(i)
+          t1 = tau(i)
+
+          DO  j = 1, i
+             rrp = radclass(i) + radclass(j)
+             v2  = winf(j)
+             t2  = tau(j)
+
+             v1xysq  = b1 * d1 * phi_w(c1,e1,v1,t1) - b1 * d2 * phi_w(c1,e2,v1,t1) &
+                     - b2 * d1 * phi_w(c2,e1,v1,t1) + b2 * d2 * phi_w(c2,e2,v1,t1)
+             v1xysq  = v1xysq * urms**2 / t1
+             vrms1xy = SQRT( v1xysq )
+
+             v2xysq  = b1 * d1 * phi_w(c1,e1,v2,t2) - b1 * d2 * phi_w(c1,e2,v2,t2) &
+                     - b2 * d1 * phi_w(c2,e1,v2,t2) + b2 * d2 * phi_w(c2,e2,v2,t2)
+             v2xysq  = v2xysq * urms**2 / t2
+             vrms2xy = SQRT( v2xysq )
+
+             IF ( winf(i) >= winf(j) )  THEN
+                v1 = winf(i)
+                t1 = tau(i)
+                v2 = winf(j)
+                t2 = tau(j)
+             ELSE
+                v1 = winf(j)
+                t1 = tau(j)
+                v2 = winf(i)
+                t2 = tau(i)
+             ENDIF
+
+             v1v2xy   =  b1 * d1 * zhi(c1,e1,v1,t1,v2,t2) - &
+                         b1 * d2 * zhi(c1,e2,v1,t1,v2,t2) - &
+                         b2 * d1 * zhi(c2,e1,v1,t1,v2,t2) + &
+                         b2 * d2* zhi(c2,e2,v1,t1,v2,t2)
+             fr       = d1 * EXP( -rrp / e1 ) - d2 * EXP( -rrp / e2 )
+             v1v2xy   = v1v2xy * fr * urms**2 / tau(i) / tau(j)
+             wrtur2xy = vrms1xy**2 + vrms2xy**2 - 2.0_wp * v1v2xy
+             IF ( wrtur2xy < 0.0_wp )  wrtur2xy = 0.0_wp
+             wrgrav2  = pi / 8.0_wp * ( winf(j) - winf(i) )**2
+             wrfin    = SQRT( ( 2.0_wp / pi ) * ( wrtur2xy + wrgrav2) )
+
+!
+!--          Calculate radial distribution function (grfin)
+             IF ( st(j) > st(i) )  THEN
+                sst = st(j)
+             ELSE
+                sst = st(i)
+             ENDIF
+
+             xx = -0.1988_wp * sst**4 + 1.5275_wp * sst**3 - 4.2942_wp *       &
+                   sst**2 + 5.3406_wp * sst
+             IF ( xx < 0.0_wp )  xx = 0.0_wp
+             yy = 0.1886_wp * EXP( 20.306_wp / lambda_re )
+
+             c1_gr  =  xx / ( g / vk * tauk )**yy
+
+             ao_gr  = ao + ( pi / 8.0_wp) * ( g / vk * tauk )**2
+             fao_gr = 20.115_wp * SQRT( ao_gr / lambda_re )
+             rc     = SQRT( fao_gr * ABS( st(j) - st(i) ) ) * eta
+
+             grfin  = ( ( eta**2 + rc**2 ) / ( rrp**2 + rc**2) )**( c1_gr*0.5_wp )
+             IF ( grfin < 1.0_wp )  grfin = 1.0_wp
+
+!
+!--          Calculate general collection kernel (without the consideration of
+!--          collection efficiencies)
+             gck(i,j) = 2.0_wp * pi * rrp**2 * wrfin * grfin
+             gck(j,i) = gck(i,j)
+
+          ENDDO
+       ENDDO
+
+    END SUBROUTINE turbsd
+
+    REAL(wp) FUNCTION phi_w( a, b, vsett, tau0 )
+!
+!--    Function used in the Ayala et al. (2008) analytical model for turbulent
+!--    effects on the collision kernel
+       IMPLICIT NONE
+
+       REAL(wp) ::  a     !<
+       REAL(wp) ::  aa1   !<
+       REAL(wp) ::  b     !<
+       REAL(wp) ::  tau0  !<
+       REAL(wp) ::  vsett !<
+
+       aa1 = 1.0_wp / tau0 + 1.0_wp / a + vsett / b
+       phi_w = 1.0_wp / aa1  - 0.5_wp * vsett / b / aa1**2
+
+    END FUNCTION phi_w
+
+    REAL(wp) FUNCTION zhi( a, b, vsett1, tau1, vsett2, tau2 )
+!
+!--    Function used in the Ayala et al. (2008) analytical model for turbulent
+!--    effects on the collision kernel
+       IMPLICIT NONE
+
+       REAL(wp) ::  a      !<
+       REAL(wp) ::  aa1    !<
+       REAL(wp) ::  aa2    !<
+       REAL(wp) ::  aa3    !<
+       REAL(wp) ::  aa4    !<
+       REAL(wp) ::  aa5    !<
+       REAL(wp) ::  aa6    !<
+       REAL(wp) ::  b      !<
+       REAL(wp) ::  tau1   !<
+       REAL(wp) ::  tau2   !<
+       REAL(wp) ::  vsett1 !<
+       REAL(wp) ::  vsett2 !<
+
+       aa1 = vsett2 / b - 1.0_wp / tau2 - 1.0_wp / a
+       aa2 = vsett1 / b + 1.0_wp / tau1 + 1.0_wp / a
+       aa3 = ( vsett1 - vsett2 ) / b + 1.0_wp / tau1 + 1.0_wp / tau2
+       aa4 = ( vsett2 / b )**2 - ( 1.0_wp / tau2 + 1.0_wp / a )**2
+       aa5 = vsett2 / b + 1.0_wp / tau2 + 1.0_wp / a
+       aa6 = 1.0_wp / tau1 - 1.0_wp / a + ( 1.0_wp / tau2 + 1.0_wp / a) *      &
+             vsett1 / vsett2
+       zhi = (1.0_wp / aa1 - 1.0_wp / aa2 ) * ( vsett1 - vsett2 ) * 0.5_wp /   &
+             b / aa3**2 + ( 4.0_wp / aa4 - 1.0_wp / aa5**2 - 1.0_wp / aa1**2 ) &
+             * vsett2 * 0.5_wp / b /aa6 + ( 2.0_wp * ( b / aa2 - b / aa1 ) -   &
+             vsett1 / aa2**2 + vsett2 / aa1**2 ) * 0.5_wp / b / aa3
+
+    END FUNCTION zhi
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Parameterization of terminal velocity following Rogers et al. (1993, J. Appl.
+!> Meteorol.)
+!------------------------------------------------------------------------------!
+    SUBROUTINE fallg
+
+       USE particle_attributes,                                                &
+           ONLY:  radius_classes
+
+       IMPLICIT NONE
+
+       INTEGER(iwp) ::  j                            !<
+
+       REAL(wp), PARAMETER ::  k_cap_rog = 4.0_wp    !< parameter
+       REAL(wp), PARAMETER ::  k_low_rog = 12.0_wp   !< parameter
+       REAL(wp), PARAMETER ::  a_rog     = 9.65_wp   !< parameter
+       REAL(wp), PARAMETER ::  b_rog     = 10.43_wp  !< parameter
+       REAL(wp), PARAMETER ::  c_rog     = 0.6_wp    !< parameter
+       REAL(wp), PARAMETER ::  d0_rog    = 0.745_wp  !< seperation diameter
+
+       REAL(wp)            ::  diameter              !< droplet diameter in mm
+
+
+       DO  j = 1, radius_classes
+
+          diameter = radclass(j) * 2000.0_wp
+
+          IF ( diameter <= d0_rog )  THEN
+             winf(j) = k_cap_rog * diameter * ( 1.0_wp -                       &
+                                                EXP( -k_low_rog * diameter ) )
+          ELSE
+             winf(j) = a_rog - b_rog * EXP( -c_rog * diameter )
+          ENDIF
+
+       ENDDO
+
+    END SUBROUTINE fallg
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Interpolation of collision efficiencies (Hall, 1980, J. Atmos. Sci.)
+!------------------------------------------------------------------------------!
+    SUBROUTINE effic
+ 
+       USE particle_attributes,                                                &
+           ONLY:  radius_classes
+
+       IMPLICIT NONE
+
+       INTEGER(iwp) ::  i  !<
+       INTEGER(iwp) ::  iq !<
+       INTEGER(iwp) ::  ir !<
+       INTEGER(iwp) ::  j  !<
+       INTEGER(iwp) ::  k  !<
+
+       INTEGER(iwp), DIMENSION(:), ALLOCATABLE ::  ira !<
+
+       LOGICAL, SAVE ::  first = .TRUE. !<
+
+       REAL(wp) ::  ek              !<
+       REAL(wp) ::  particle_radius !<
+       REAL(wp) ::  pp              !<
+       REAL(wp) ::  qq              !<
+       REAL(wp) ::  rq              !<
+
+       REAL(wp), DIMENSION(1:21), SAVE ::  rat        !<
+       
+       REAL(wp), DIMENSION(1:15), SAVE ::  r0         !<
+       
+       REAL(wp), DIMENSION(1:15,1:21), SAVE ::  ecoll !<
+
+!
+!--    Initial assignment of constants
+       IF ( first )  THEN
+
+         first = .FALSE.
+         r0  = (/   6.0_wp,   8.0_wp,  10.0_wp, 15.0_wp,  20.0_wp,  25.0_wp,   &
+                   30.0_wp,  40.0_wp,  50.0_wp, 60.0_wp,  70.0_wp, 100.0_wp,   &
+                  150.0_wp, 200.0_wp, 300.0_wp /)
+
+         rat = (/ 0.00_wp, 0.05_wp, 0.10_wp, 0.15_wp, 0.20_wp, 0.25_wp,        &
+                  0.30_wp, 0.35_wp, 0.40_wp, 0.45_wp, 0.50_wp, 0.55_wp,        &
+                  0.60_wp, 0.65_wp, 0.70_wp, 0.75_wp, 0.80_wp, 0.85_wp,        &
+                  0.90_wp, 0.95_wp, 1.00_wp /)
+
+         ecoll(:,1)  = (/ 0.001_wp, 0.001_wp, 0.001_wp, 0.001_wp, 0.001_wp,    &
+                          0.001_wp, 0.001_wp, 0.001_wp, 0.001_wp, 0.001_wp,    &
+                          0.001_wp, 0.001_wp, 0.001_wp, 0.001_wp, 0.001_wp /)
+         ecoll(:,2)  = (/ 0.003_wp, 0.003_wp, 0.003_wp, 0.004_wp, 0.005_wp,    &
+                          0.005_wp, 0.005_wp, 0.010_wp, 0.100_wp, 0.050_wp,    &
+                          0.200_wp, 0.500_wp, 0.770_wp, 0.870_wp, 0.970_wp /)
+         ecoll(:,3)  = (/ 0.007_wp, 0.007_wp, 0.007_wp, 0.008_wp, 0.009_wp,    &
+                          0.010_wp, 0.010_wp, 0.070_wp, 0.400_wp, 0.430_wp,    &
+                          0.580_wp, 0.790_wp, 0.930_wp, 0.960_wp, 1.000_wp /)
+         ecoll(:,4)  = (/ 0.009_wp, 0.009_wp, 0.009_wp, 0.012_wp, 0.015_wp,    &
+                          0.010_wp, 0.020_wp, 0.280_wp, 0.600_wp, 0.640_wp,    &
+                          0.750_wp, 0.910_wp, 0.970_wp, 0.980_wp, 1.000_wp /)
+         ecoll(:,5)  = (/ 0.014_wp, 0.014_wp, 0.014_wp, 0.015_wp, 0.016_wp,    &
+                          0.030_wp, 0.060_wp, 0.500_wp, 0.700_wp, 0.770_wp,    &
+                          0.840_wp, 0.950_wp, 0.970_wp, 1.000_wp, 1.000_wp /)
+         ecoll(:,6)  = (/ 0.017_wp, 0.017_wp, 0.017_wp, 0.020_wp, 0.022_wp,    &
+                          0.060_wp, 0.100_wp, 0.620_wp, 0.780_wp, 0.840_wp,    &
+                          0.880_wp, 0.950_wp, 1.000_wp, 1.000_wp, 1.000_wp /)
+         ecoll(:,7)  = (/ 0.030_wp, 0.030_wp, 0.024_wp, 0.022_wp, 0.032_wp,    &
+                          0.062_wp, 0.200_wp, 0.680_wp, 0.830_wp, 0.870_wp,    &
+                          0.900_wp, 0.950_wp, 1.000_wp, 1.000_wp, 1.000_wp /)
+         ecoll(:,8)  = (/ 0.025_wp, 0.025_wp, 0.025_wp, 0.036_wp, 0.043_wp,    &
+                          0.130_wp, 0.270_wp, 0.740_wp, 0.860_wp, 0.890_wp,    &
+                          0.920_wp, 1.000_wp, 1.000_wp, 1.000_wp, 1.000_wp /)
+         ecoll(:,9)  = (/ 0.027_wp, 0.027_wp, 0.027_wp, 0.040_wp, 0.052_wp,    &
+                          0.200_wp, 0.400_wp, 0.780_wp, 0.880_wp, 0.900_wp,    &
+                          0.940_wp, 1.000_wp, 1.000_wp, 1.000_wp, 1.000_wp /)
+         ecoll(:,10) = (/ 0.030_wp, 0.030_wp, 0.030_wp, 0.047_wp, 0.064_wp,    &
+                          0.250_wp, 0.500_wp, 0.800_wp, 0.900_wp, 0.910_wp,    &
+                          0.950_wp, 1.000_wp, 1.000_wp, 1.000_wp, 1.000_wp /)
+         ecoll(:,11) = (/ 0.040_wp, 0.040_wp, 0.033_wp, 0.037_wp, 0.068_wp,    &
+                          0.240_wp, 0.550_wp, 0.800_wp, 0.900_wp, 0.910_wp,    &
+                          0.950_wp, 1.000_wp, 1.000_wp, 1.000_wp, 1.000_wp /)
+         ecoll(:,12) = (/ 0.035_wp, 0.035_wp, 0.035_wp, 0.055_wp, 0.079_wp,    &
+                          0.290_wp, 0.580_wp, 0.800_wp, 0.900_wp, 0.910_wp,    &
+                          0.950_wp, 1.000_wp, 1.000_wp, 1.000_wp, 1.000_wp /)
+         ecoll(:,13) = (/ 0.037_wp, 0.037_wp, 0.037_wp, 0.062_wp, 0.082_wp,    &
+                          0.290_wp, 0.590_wp, 0.780_wp, 0.900_wp, 0.910_wp,    &
+                          0.950_wp, 1.000_wp, 1.000_wp, 1.000_wp, 1.000_wp /)
+         ecoll(:,14) = (/ 0.037_wp, 0.037_wp, 0.037_wp, 0.060_wp, 0.080_wp,    &
+                          0.290_wp, 0.580_wp, 0.770_wp, 0.890_wp, 0.910_wp,    &
+                          0.950_wp, 1.000_wp, 1.000_wp, 1.000_wp, 1.000_wp /)
+         ecoll(:,15) = (/ 0.037_wp, 0.037_wp, 0.037_wp, 0.041_wp, 0.075_wp,    &
+                          0.250_wp, 0.540_wp, 0.760_wp, 0.880_wp, 0.920_wp,    &
+                          0.950_wp, 1.000_wp, 1.000_wp, 1.000_wp, 1.000_wp /)
+         ecoll(:,16) = (/ 0.037_wp, 0.037_wp, 0.037_wp, 0.052_wp, 0.067_wp,    &
+                          0.250_wp, 0.510_wp, 0.770_wp, 0.880_wp, 0.930_wp,    &
+                          0.970_wp, 1.000_wp, 1.000_wp, 1.000_wp, 1.000_wp /)
+         ecoll(:,17) = (/ 0.037_wp, 0.037_wp, 0.037_wp, 0.047_wp, 0.057_wp,    &
+                          0.250_wp, 0.490_wp, 0.770_wp, 0.890_wp, 0.950_wp,    &
+                          1.000_wp, 1.000_wp, 1.000_wp, 1.000_wp, 1.000_wp /)
+         ecoll(:,18) = (/ 0.036_wp, 0.036_wp, 0.036_wp, 0.042_wp, 0.048_wp,    &
+                          0.230_wp, 0.470_wp, 0.780_wp, 0.920_wp, 1.000_wp,    &
+                          1.020_wp, 1.020_wp, 1.020_wp, 1.020_wp, 1.020_wp /)
+         ecoll(:,19) = (/ 0.040_wp, 0.040_wp, 0.035_wp, 0.033_wp, 0.040_wp,    &
+                          0.112_wp, 0.450_wp, 0.790_wp, 1.010_wp, 1.030_wp,    &
+                          1.040_wp, 1.040_wp, 1.040_wp, 1.040_wp, 1.040_wp /)
+         ecoll(:,20) = (/ 0.033_wp, 0.033_wp, 0.033_wp, 0.033_wp, 0.033_wp,    &
+                          0.119_wp, 0.470_wp, 0.950_wp, 1.300_wp, 1.700_wp,    &
+                          2.300_wp, 2.300_wp, 2.300_wp, 2.300_wp, 2.300_wp /)
+         ecoll(:,21) = (/ 0.027_wp, 0.027_wp, 0.027_wp, 0.027_wp, 0.027_wp,    &
+                          0.125_wp, 0.520_wp, 1.400_wp, 2.300_wp, 3.000_wp,    &
+                          4.000_wp, 4.000_wp, 4.000_wp, 4.000_wp, 4.000_wp /)
+       ENDIF
+
+!
+!--    Calculate the radius class index of particles with respect to array r
+!--    Radius has to be in microns
+       ALLOCATE( ira(1:radius_classes) )
+       DO  j = 1, radius_classes
+          particle_radius = radclass(j) * 1.0E6_wp
+          DO  k = 1, 15
+             IF ( particle_radius < r0(k) )  THEN
+                ira(j) = k
+                EXIT
+             ENDIF
+          ENDDO
+          IF ( particle_radius >= r0(15) )  ira(j) = 16
+       ENDDO
+
+!
+!--    Two-dimensional linear interpolation of the collision efficiency.
+!--    Radius has to be in microns
+       DO  j = 1, radius_classes
+          DO  i = 1, j
+
+             ir = ira(j)
+             rq = MIN( radclass(i) / radclass(j), radclass(j) / radclass(i) )
+             iq = INT( rq * 20 ) + 1
+             iq = MAX( iq , 2)
+
+             IF ( ir < 16 )  THEN
+                IF ( ir >= 2 )  THEN
+                   pp = ( ( MAX( radclass(j), radclass(i) ) * 1.0E6_wp ) -     &
+                          r0(ir-1) ) / ( r0(ir) - r0(ir-1) )
+                   qq = ( rq - rat(iq-1) ) / ( rat(iq) - rat(iq-1) )
+                   ec(j,i) = ( 1.0_wp - pp ) * ( 1.0_wp - qq )                 &
+                             * ecoll(ir-1,iq-1)                                &
+                             + pp * ( 1.0_wp - qq ) * ecoll(ir,iq-1)           &
+                             + qq * ( 1.0_wp - pp ) * ecoll(ir-1,iq)           &
+                             + pp * qq * ecoll(ir,iq)
+                ELSE
+                   qq = ( rq - rat(iq-1) ) / ( rat(iq) - rat(iq-1) )
+                   ec(j,i) = ( 1.0_wp - qq ) * ecoll(1,iq-1) + qq * ecoll(1,iq)
+                ENDIF
+             ELSE
+                qq = ( rq - rat(iq-1) ) / ( rat(iq) - rat(iq-1) )
+                ek = ( 1.0_wp - qq ) * ecoll(15,iq-1) + qq * ecoll(15,iq)
+                ec(j,i) = MIN( ek, 1.0_wp )
+             ENDIF
+
+             IF ( ec(j,i) < 1.0E-20_wp )  ec(j,i) = 0.0_wp
+
+             ec(i,j) = ec(j,i)
+
+          ENDDO
+       ENDDO
+
+       DEALLOCATE( ira )
+
+    END SUBROUTINE effic
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Interpolation of turbulent enhancement factor for collision efficencies
+!> following Wang and Grabowski (2009, Atmos. Sci. Let.)
+!------------------------------------------------------------------------------!
+    SUBROUTINE turb_enhance_eff
+
+       USE particle_attributes,                                                &
+           ONLY:  radius_classes
+
+       IMPLICIT NONE
+
+       INTEGER(iwp) :: i  !<
+       INTEGER(iwp) :: iq !<
+       INTEGER(iwp) :: ir !<
+       INTEGER(iwp) :: j  !<
+       INTEGER(iwp) :: k  !<
+       INTEGER(iwp) :: kk !<
+
+       INTEGER(iwp), DIMENSION(:), ALLOCATABLE ::  ira !<
+       
+       LOGICAL, SAVE ::  first = .TRUE. !<
+
+       REAL(wp) ::  particle_radius !<
+       REAL(wp) ::  pp              !<
+       REAL(wp) ::  qq              !<
+       REAL(wp) ::  rq              !<
+       REAL(wp) ::  y1              !<
+       REAL(wp) ::  y2              !<
+       REAL(wp) ::  y3              !<
+
+       REAL(wp), DIMENSION(1:11), SAVE ::  rat           !<
+       REAL(wp), DIMENSION(1:7), SAVE  ::  r0            !<
+       
+       REAL(wp), DIMENSION(1:7,1:11), SAVE ::  ecoll_100 !<
+       REAL(wp), DIMENSION(1:7,1:11), SAVE ::  ecoll_400 !<
+
+!
+!--    Initial assignment of constants
+       IF ( first )  THEN
+
+          first = .FALSE.
+
+          r0  = (/  10.0_wp, 20.0_wp, 30.0_wp, 40.0_wp, 50.0_wp, 60.0_wp,  &
+                   100.0_wp /)
+
+          rat = (/ 0.0_wp, 0.1_wp, 0.2_wp, 0.3_wp, 0.4_wp, 0.5_wp, 0.6_wp, &
+                   0.7_wp, 0.8_wp, 0.9_wp, 1.0_wp /)
+!
+!--       Tabulated turbulent enhancement factor at 100 cm**2/s**3
+          ecoll_100(:,1)  = (/  1.74_wp,   1.74_wp,   1.773_wp, 1.49_wp,  &
+                                1.207_wp,  1.207_wp,  1.0_wp /)
+          ecoll_100(:,2)  = (/  1.46_wp,   1.46_wp,   1.421_wp, 1.245_wp, &
+                                1.069_wp,  1.069_wp,  1.0_wp /)
+          ecoll_100(:,3)  = (/  1.32_wp,   1.32_wp,   1.245_wp, 1.123_wp, &
+                                1.000_wp,  1.000_wp,  1.0_wp /)
+          ecoll_100(:,4)  = (/  1.250_wp,  1.250_wp,  1.148_wp, 1.087_wp, &
+                                1.025_wp,  1.025_wp,  1.0_wp /)
+          ecoll_100(:,5)  = (/  1.186_wp,  1.186_wp,  1.066_wp, 1.060_wp, &
+                                1.056_wp,  1.056_wp,  1.0_wp /)
+          ecoll_100(:,6)  = (/  1.045_wp,  1.045_wp,  1.000_wp, 1.014_wp, &
+                                1.028_wp,  1.028_wp,  1.0_wp /)
+          ecoll_100(:,7)  = (/  1.070_wp,  1.070_wp,  1.030_wp, 1.038_wp, &
+                                1.046_wp,  1.046_wp,  1.0_wp /)
+          ecoll_100(:,8)  = (/  1.000_wp,  1.000_wp,  1.054_wp, 1.042_wp, &
+                                1.029_wp,  1.029_wp,  1.0_wp /)
+          ecoll_100(:,9)  = (/  1.223_wp,  1.223_wp,  1.117_wp, 1.069_wp, &
+                                1.021_wp,  1.021_wp,  1.0_wp /)
+          ecoll_100(:,10) = (/  1.570_wp,  1.570_wp,  1.244_wp, 1.166_wp, &
+                                1.088_wp,  1.088_wp,  1.0_wp /)
+          ecoll_100(:,11) = (/ 20.3_wp,   20.3_wp,   14.6_wp,   8.61_wp,  &
+                                2.60_wp,   2.60_wp,   1.0_wp /)
+!
+!--       Tabulated turbulent enhancement factor at 400 cm**2/s**3
+          ecoll_400(:,1)  = (/  4.976_wp,  4.976_wp,  3.593_wp,  2.519_wp, &
+                                1.445_wp,  1.445_wp,  1.0_wp /)
+          ecoll_400(:,2)  = (/  2.984_wp,  2.984_wp,  2.181_wp,  1.691_wp, &
+                                1.201_wp,  1.201_wp,  1.0_wp /)
+          ecoll_400(:,3)  = (/  1.988_wp,  1.988_wp,  1.475_wp,  1.313_wp, &
+                                1.150_wp,  1.150_wp,  1.0_wp /)
+          ecoll_400(:,4)  = (/  1.490_wp,  1.490_wp,  1.187_wp,  1.156_wp, &
+                                1.126_wp,  1.126_wp,  1.0_wp /)
+          ecoll_400(:,5)  = (/  1.249_wp,  1.249_wp,  1.088_wp,  1.090_wp, &
+                                1.092_wp,  1.092_wp,  1.0_wp /)
+          ecoll_400(:,6)  = (/  1.139_wp,  1.139_wp,  1.130_wp,  1.091_wp, &
+                                1.051_wp,  1.051_wp,  1.0_wp /)
+          ecoll_400(:,7)  = (/  1.220_wp,  1.220_wp,  1.190_wp,  1.138_wp, &
+                                1.086_wp,  1.086_wp,  1.0_wp /)
+          ecoll_400(:,8)  = (/  1.325_wp,  1.325_wp,  1.267_wp,  1.165_wp, &
+                                1.063_wp,  1.063_wp,  1.0_wp /)
+          ecoll_400(:,9)  = (/  1.716_wp,  1.716_wp,  1.345_wp,  1.223_wp, &
+                                1.100_wp,  1.100_wp,  1.0_wp /)
+          ecoll_400(:,10) = (/  3.788_wp,  3.788_wp,  1.501_wp,  1.311_wp, &
+                                1.120_wp,  1.120_wp,  1.0_wp /)
+          ecoll_400(:,11) = (/ 36.52_wp,  36.52_wp,  19.16_wp,  22.80_wp,  &
+                               26.0_wp,   26.0_wp,    1.0_wp /)
+
+       ENDIF
+
+!
+!--    Calculate the radius class index of particles with respect to array r0
+!--    The droplet radius has to be given in microns.
+       ALLOCATE( ira(1:radius_classes) )
+
+       DO  j = 1, radius_classes
+          particle_radius = radclass(j) * 1.0E6_wp
+          DO  k = 1, 7
+             IF ( particle_radius < r0(k) )  THEN
+                ira(j) = k
+                EXIT
+             ENDIF
+          ENDDO
+          IF ( particle_radius >= r0(7) )  ira(j) = 8
+       ENDDO
+
+!
+!--    Two-dimensional linear interpolation of the turbulent enhancement factor.
+!--    The droplet radius has to be given in microns.
+       DO  j =  1, radius_classes
+          DO  i = 1, j
+
+             ir = ira(j)
+             rq = MIN( radclass(i) / radclass(j), radclass(j) / radclass(i) )
+
+             DO  kk = 2, 11
+                IF ( rq <= rat(kk) )  THEN
+                   iq = kk
+                   EXIT
+                ENDIF
+             ENDDO
+
+             y1 = 1.0_wp  ! turbulent enhancement factor at 0 m**2/s**3
+
+             IF ( ir < 8 )  THEN
+                IF ( ir >= 2 )  THEN
+                   pp = ( MAX( radclass(j), radclass(i) ) * 1.0E6_wp -  &
+                          r0(ir-1) ) / ( r0(ir) - r0(ir-1) )
+                   qq = ( rq - rat(iq-1) ) / ( rat(iq) - rat(iq-1) )
+                   y2 = ( 1.0_wp - pp ) * ( 1.0_wp - qq ) * ecoll_100(ir-1,iq-1) + &
+                                pp * ( 1.0_wp - qq ) * ecoll_100(ir,iq-1)        + &
+                                qq * ( 1.0_wp - pp ) * ecoll_100(ir-1,iq)        + &
+                                pp * qq              * ecoll_100(ir,iq)
+                   y3 = ( 1.0-pp ) * ( 1.0_wp - qq ) * ecoll_400(ir-1,iq-1)      + &
+                                pp * ( 1.0_wp - qq ) * ecoll_400(ir,iq-1)        + &
+                                qq * ( 1.0_wp - pp ) * ecoll_400(ir-1,iq)        + &
+                                pp * qq              * ecoll_400(ir,iq)
+                ELSE
+                   qq = ( rq - rat(iq-1) ) / ( rat(iq) - rat(iq-1) )
+                   y2 = ( 1.0_wp - qq ) * ecoll_100(1,iq-1) + qq * ecoll_100(1,iq)
+                   y3 = ( 1.0_wp - qq ) * ecoll_400(1,iq-1) + qq * ecoll_400(1,iq)
+                ENDIF
+             ELSE
+                qq = ( rq - rat(iq-1) ) / ( rat(iq) - rat(iq-1) )
+                y2 = ( 1.0_wp - qq ) * ecoll_100(7,iq-1) + qq * ecoll_100(7,iq)
+                y3 = ( 1.0_wp - qq ) * ecoll_400(7,iq-1) + qq * ecoll_400(7,iq)
+             ENDIF
+!
+!--          Linear interpolation of turbulent enhancement factor
+             IF ( epsilon <= 0.01_wp )  THEN
+                ecf(j,i) = ( epsilon - 0.01_wp ) / ( 0.0_wp  - 0.01_wp ) * y1 &
+                         + ( epsilon - 0.0_wp  ) / ( 0.01_wp - 0.0_wp  ) * y2
+             ELSEIF ( epsilon <= 0.06_wp )  THEN
+                ecf(j,i) = ( epsilon - 0.04_wp ) / ( 0.01_wp - 0.04_wp ) * y2 &
+                         + ( epsilon - 0.01_wp ) / ( 0.04_wp - 0.01_wp ) * y3
+             ELSE
+                ecf(j,i) = ( 0.06_wp - 0.04_wp ) / ( 0.01_wp - 0.04_wp ) * y2 &
+                         + ( 0.06_wp - 0.01_wp ) / ( 0.04_wp - 0.01_wp ) * y3
+             ENDIF
+
+             IF ( ecf(j,i) < 1.0_wp )  ecf(j,i) = 1.0_wp
+
+             ecf(i,j) = ecf(j,i)
+
+          ENDDO
+       ENDDO
+
+    END SUBROUTINE turb_enhance_eff
+
+ END MODULE lpm_collision_kernels_mod
Index: lm/trunk/SOURCE/lpm_exchange_horiz.f90
===================================================================
--- /palm/trunk/SOURCE/lpm_exchange_horiz.f90	(revision 1849)
+++ 	(revision )
@@ -1,1037 +1,0 @@
-!> @file lpm_exchange_horiz.f90
-!--------------------------------------------------------------------------------!
-! This file is part of PALM.
-!
-! PALM is free software: you can redistribute it and/or modify it under the terms
-! of the GNU General Public License as published by the Free Software Foundation,
-! either version 3 of the License, or (at your option) any later version.
-!
-! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
-! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
-! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along with
-! PALM. If not, see <http://www.gnu.org/licenses/>.
-!
-! Copyright 1997-2016 Leibniz Universitaet Hannover
-!--------------------------------------------------------------------------------!
-!
-! Current revisions:
-! ------------------
-!
-!
-! Former revisions:
-! -----------------
-! $Id$
-!
-! 1822 2016-04-07 07:49:42Z hoffmann
-! Tails removed. Unused variables removed.
-!
-! 1783 2016-03-06 18:36:17Z raasch
-! new netcdf-module included
-!
-! 1691 2015-10-26 16:17:44Z maronga
-! Formatting corrections.
-!
-! 1685 2015-10-08 07:32:13Z raasch
-! bugfix concerning vertical index offset in case of ocean
-!
-! 1682 2015-10-07 23:56:08Z knoop
-! Code annotations made doxygen readable 
-! 
-! 1359 2014-04-11 17:15:14Z hoffmann
-! New particle structure integrated. 
-! Kind definition added to all floating point numbers.
-! 
-! 1327 2014-03-21 11:00:16Z raasch
-! -netcdf output queries
-!
-! 1320 2014-03-20 08:40:49Z raasch
-! ONLY-attribute added to USE-statements,
-! kind-parameters added to all INTEGER and REAL declaration statements,
-! kinds are defined in new module kinds,
-! comment fields (!:) to be used for variable explanations added to
-! all variable declaration statements
-!
-! 1318 2014-03-17 13:35:16Z raasch
-! module interfaces removed
-!
-! 1036 2012-10-22 13:43:42Z raasch
-! code put under GPL (PALM 3.9)
-!
-! 851 2012-03-15 14:32:58Z raasch
-! Bugfix: resetting of particle_mask and tail mask moved from end of this
-! routine to lpm
-!
-! 849 2012-03-15 10:35:09Z raasch
-! initial revision (former part of advec_particles)
-!
-!
-! Description:
-! ------------
-! Exchange of particles between the subdomains.
-!------------------------------------------------------------------------------!
- MODULE lpm_exchange_horiz_mod
- 
-
-    USE control_parameters,                                                    &
-        ONLY:  dz, message_string, simulated_time
-
-    USE cpulog,                                                                &
-        ONLY:  cpu_log, log_point_s
-
-    USE grid_variables,                                                        &
-        ONLY:  ddx, ddy, dx, dy
-
-    USE indices,                                                               &
-        ONLY:  nx, nxl, nxr, ny, nyn, nys, nzb, nzt
-
-    USE kinds
-
-    USE lpm_pack_arrays_mod,                                                   &
-        ONLY:  lpm_pack_arrays
-
-    USE netcdf_interface,                                                      &
-        ONLY:  netcdf_data_format
-
-    USE particle_attributes,                                                   &
-        ONLY:  alloc_factor, deleted_particles, grid_particles,                &
-               ibc_par_lr, ibc_par_ns, min_nr_particle,                        &
-               mpi_particle_type, number_of_particles,                         &
-               offset_ocean_nzt, offset_ocean_nzt_m1, particles,               &
-               particle_type, prt_count, trlp_count_sum,                       &
-               trlp_count_recv_sum, trnp_count_sum, trnp_count_recv_sum,       &
-               trrp_count_sum, trrp_count_recv_sum, trsp_count_sum,            &
-               trsp_count_recv_sum, zero_particle
-
-    USE pegrid
-
-    IMPLICIT NONE
-
-    INTEGER(iwp), PARAMETER ::  NR_2_direction_move = 10000 !<
-    INTEGER(iwp)            ::  nr_move_north               !<
-    INTEGER(iwp)            ::  nr_move_south               !<
-
-    TYPE(particle_type), DIMENSION(NR_2_direction_move) ::  move_also_north
-    TYPE(particle_type), DIMENSION(NR_2_direction_move) ::  move_also_south
-
-    SAVE
-
-    PRIVATE
-    PUBLIC lpm_exchange_horiz, lpm_move_particle, realloc_particles_array
-
-    INTERFACE lpm_exchange_horiz
-       MODULE PROCEDURE lpm_exchange_horiz
-    END INTERFACE lpm_exchange_horiz
-
-    INTERFACE lpm_move_particle
-       MODULE PROCEDURE lpm_move_particle
-    END INTERFACE lpm_move_particle
-
-    INTERFACE realloc_particles_array
-       MODULE PROCEDURE realloc_particles_array
-    END INTERFACE realloc_particles_array
-
-CONTAINS
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Exchange between subdomains.
-!> As soon as one particle has moved beyond the boundary of the domain, it
-!> is included in the relevant transfer arrays and marked for subsequent
-!> deletion on this PE.
-!> First sweep for crossings in x direction. Find out first the number of
-!> particles to be transferred and allocate temporary arrays needed to store
-!> them.
-!> For a one-dimensional decomposition along y, no transfer is necessary,
-!> because the particle remains on the PE, but the particle coordinate has to
-!> be adjusted.
-!------------------------------------------------------------------------------!
- SUBROUTINE lpm_exchange_horiz
-
-    IMPLICIT NONE
-
-    INTEGER(iwp) ::  i                                       !<
-    INTEGER(iwp) ::  ip                                      !<
-    INTEGER(iwp) ::  j                                       !<
-    INTEGER(iwp) ::  jp                                      !<
-    INTEGER(iwp) ::  kp                                      !<
-    INTEGER(iwp) ::  n                                       !<
-    INTEGER(iwp) ::  trlp_count                              !<
-    INTEGER(iwp) ::  trlp_count_recv                         !<
-    INTEGER(iwp) ::  trlpt_count                             !<
-    INTEGER(iwp) ::  trlpt_count_recv                        !<
-    INTEGER(iwp) ::  trnp_count                              !<
-    INTEGER(iwp) ::  trnp_count_recv                         !<
-    INTEGER(iwp) ::  trnpt_count                             !<
-    INTEGER(iwp) ::  trnpt_count_recv                        !<
-    INTEGER(iwp) ::  trrp_count                              !<
-    INTEGER(iwp) ::  trrp_count_recv                         !<
-    INTEGER(iwp) ::  trrpt_count                             !<
-    INTEGER(iwp) ::  trrpt_count_recv                        !<
-    INTEGER(iwp) ::  trsp_count                              !<
-    INTEGER(iwp) ::  trsp_count_recv                         !<
-    INTEGER(iwp) ::  trspt_count                             !<
-    INTEGER(iwp) ::  trspt_count_recv                        !<
-
-    TYPE(particle_type), DIMENSION(:), ALLOCATABLE ::  rvlp  !<
-    TYPE(particle_type), DIMENSION(:), ALLOCATABLE ::  rvnp  !<
-    TYPE(particle_type), DIMENSION(:), ALLOCATABLE ::  rvrp  !<
-    TYPE(particle_type), DIMENSION(:), ALLOCATABLE ::  rvsp  !<
-    TYPE(particle_type), DIMENSION(:), ALLOCATABLE ::  trlp  !<
-    TYPE(particle_type), DIMENSION(:), ALLOCATABLE ::  trnp  !<
-    TYPE(particle_type), DIMENSION(:), ALLOCATABLE ::  trrp  !<
-    TYPE(particle_type), DIMENSION(:), ALLOCATABLE ::  trsp  !<
-
-    CALL cpu_log( log_point_s(23), 'lpm_exchange_horiz', 'start' )
-
-#if defined( __parallel )
-
-!
-!-- Exchange between subdomains.
-!-- As soon as one particle has moved beyond the boundary of the domain, it
-!-- is included in the relevant transfer arrays and marked for subsequent
-!-- deletion on this PE.
-!-- First sweep for crossings in x direction. Find out first the number of
-!-- particles to be transferred and allocate temporary arrays needed to store
-!-- them.
-!-- For a one-dimensional decomposition along y, no transfer is necessary,
-!-- because the particle remains on the PE, but the particle coordinate has to
-!-- be adjusted.
-    trlp_count  = 0
-    trlpt_count = 0
-    trrp_count  = 0
-    trrpt_count = 0
-
-    trlp_count_recv   = 0
-    trlpt_count_recv  = 0
-    trrp_count_recv   = 0
-    trrpt_count_recv  = 0
-
-    IF ( pdims(1) /= 1 )  THEN
-!
-!--    First calculate the storage necessary for sending and receiving the data.
-!--    Compute only first (nxl) and last (nxr) loop iterration.
-       DO  ip = nxl, nxr, nxr - nxl
-          DO  jp = nys, nyn
-             DO  kp = nzb+1, nzt
-
-                number_of_particles = prt_count(kp,jp,ip)
-                IF ( number_of_particles <= 0 )  CYCLE
-                particles => grid_particles(kp,jp,ip)%particles(1:number_of_particles)
-                DO  n = 1, number_of_particles
-                   IF ( particles(n)%particle_mask )  THEN
-                      i = ( particles(n)%x + 0.5_wp * dx ) * ddx
-   !
-   !--                Above calculation does not work for indices less than zero
-                      IF ( particles(n)%x < -0.5_wp * dx )  i = -1
-
-                      IF ( i < nxl )  THEN
-                         trlp_count = trlp_count + 1
-                      ELSEIF ( i > nxr )  THEN
-                         trrp_count = trrp_count + 1
-                      ENDIF
-                   ENDIF
-                ENDDO
-
-             ENDDO
-          ENDDO
-       ENDDO
-
-       IF ( trlp_count  == 0 )  trlp_count  = 1
-       IF ( trlpt_count == 0 )  trlpt_count = 1
-       IF ( trrp_count  == 0 )  trrp_count  = 1
-       IF ( trrpt_count == 0 )  trrpt_count = 1
-
-       ALLOCATE( trlp(trlp_count), trrp(trrp_count) )
-
-       trlp = zero_particle
-       trrp = zero_particle
-
-       trlp_count  = 0
-       trlpt_count = 0
-       trrp_count  = 0
-       trrpt_count = 0
-
-    ENDIF
-!
-!-- Compute only first (nxl) and last (nxr) loop iterration
-    DO  ip = nxl, nxr,nxr-nxl
-       DO  jp = nys, nyn
-          DO  kp = nzb+1, nzt
-             number_of_particles = prt_count(kp,jp,ip)
-             IF ( number_of_particles <= 0 ) CYCLE
-             particles => grid_particles(kp,jp,ip)%particles(1:number_of_particles)
-             DO  n = 1, number_of_particles
-!
-!--             Only those particles that have not been marked as 'deleted' may
-!--             be moved.
-                IF ( particles(n)%particle_mask )  THEN
-
-                   i = ( particles(n)%x + 0.5_wp * dx ) * ddx
-   !
-   !--             Above calculation does not work for indices less than zero
-                   IF ( particles(n)%x < - 0.5_wp * dx )  i = -1
-
-                   IF ( i <  nxl )  THEN
-                      IF ( i < 0 )  THEN
-   !
-   !--                   Apply boundary condition along x
-                         IF ( ibc_par_lr == 0 )  THEN
-   !
-   !--                      Cyclic condition
-                            IF ( pdims(1) == 1 )  THEN
-                               particles(n)%x        = ( nx + 1 ) * dx + particles(n)%x
-                               particles(n)%origin_x = ( nx + 1 ) * dx + &
-                               particles(n)%origin_x
-                            ELSE
-                               trlp_count = trlp_count + 1
-                               trlp(trlp_count)   = particles(n)
-                               trlp(trlp_count)%x = ( nx + 1 ) * dx + trlp(trlp_count)%x
-                               trlp(trlp_count)%origin_x = trlp(trlp_count)%origin_x + &
-                               ( nx + 1 ) * dx
-                               particles(n)%particle_mask  = .FALSE.
-                               deleted_particles = deleted_particles + 1
-
-                               IF ( trlp(trlp_count)%x >= (nx + 0.5_wp)* dx - 1.0E-12_wp )  THEN
-                                  trlp(trlp_count)%x = trlp(trlp_count)%x - 1.0E-10_wp
-                                  !++ why is 1 subtracted in next statement???
-                                  trlp(trlp_count)%origin_x = trlp(trlp_count)%origin_x - 1
-                               ENDIF
-
-                            ENDIF
-
-                         ELSEIF ( ibc_par_lr == 1 )  THEN
-   !
-   !--                      Particle absorption
-                            particles(n)%particle_mask = .FALSE.
-                            deleted_particles = deleted_particles + 1
-
-                         ELSEIF ( ibc_par_lr == 2 )  THEN
-   !
-   !--                      Particle reflection
-                            particles(n)%x       = -particles(n)%x
-                            particles(n)%speed_x = -particles(n)%speed_x
-
-                         ENDIF
-                      ELSE
-   !
-   !--                   Store particle data in the transfer array, which will be 
-   !--                   send to the neighbouring PE
-                         trlp_count = trlp_count + 1
-                         trlp(trlp_count) = particles(n)
-                         particles(n)%particle_mask = .FALSE.
-                         deleted_particles = deleted_particles + 1
-
-                      ENDIF
-
-                   ELSEIF ( i > nxr )  THEN
-                      IF ( i > nx )  THEN
-   !
-   !--                   Apply boundary condition along x
-                         IF ( ibc_par_lr == 0 )  THEN
-   !
-   !--                      Cyclic condition
-                            IF ( pdims(1) == 1 )  THEN
-                               particles(n)%x = particles(n)%x - ( nx + 1 ) * dx
-                               particles(n)%origin_x = particles(n)%origin_x - &
-                               ( nx + 1 ) * dx
-                            ELSE
-                               trrp_count = trrp_count + 1
-                               trrp(trrp_count) = particles(n)
-                               trrp(trrp_count)%x = trrp(trrp_count)%x - ( nx + 1 ) * dx
-                               trrp(trrp_count)%origin_x = trrp(trrp_count)%origin_x - &
-                               ( nx + 1 ) * dx
-                               particles(n)%particle_mask = .FALSE.
-                               deleted_particles = deleted_particles + 1
-
-                            ENDIF
-
-                         ELSEIF ( ibc_par_lr == 1 )  THEN
-   !
-   !--                      Particle absorption
-                            particles(n)%particle_mask = .FALSE.
-                            deleted_particles = deleted_particles + 1
-
-                         ELSEIF ( ibc_par_lr == 2 )  THEN
-   !
-   !--                      Particle reflection
-                            particles(n)%x       = 2 * ( nx * dx ) - particles(n)%x
-                            particles(n)%speed_x = -particles(n)%speed_x
-
-                         ENDIF
-                      ELSE
-   !
-   !--                   Store particle data in the transfer array, which will be send
-   !--                   to the neighbouring PE
-                         trrp_count = trrp_count + 1
-                         trrp(trrp_count) = particles(n)
-                         particles(n)%particle_mask = .FALSE.
-                         deleted_particles = deleted_particles + 1
-
-                      ENDIF
-
-                   ENDIF
-                ENDIF
-             ENDDO
-          ENDDO
-       ENDDO
-    ENDDO
-
-!
-!-- Send left boundary, receive right boundary (but first exchange how many
-!-- and check, if particle storage must be extended)
-    IF ( pdims(1) /= 1 )  THEN
-
-       CALL MPI_SENDRECV( trlp_count,      1, MPI_INTEGER, pleft,  0, &
-                          trrp_count_recv, 1, MPI_INTEGER, pright, 0, &
-                          comm2d, status, ierr )
-
-       ALLOCATE(rvrp(MAX(1,trrp_count_recv)))
-
-       CALL MPI_SENDRECV( trlp(1)%radius, max(1,trlp_count), mpi_particle_type,&
-                          pleft, 1, rvrp(1)%radius,                            &
-                          max(1,trrp_count_recv), mpi_particle_type, pright, 1,&
-                          comm2d, status, ierr )
-
-       IF ( trrp_count_recv > 0 )  CALL Add_particles_to_gridcell(rvrp(1:trrp_count_recv))
-
-       DEALLOCATE(rvrp)
-
-!
-!--    Send right boundary, receive left boundary
-       CALL MPI_SENDRECV( trrp_count,      1, MPI_INTEGER, pright, 0, &
-                          trlp_count_recv, 1, MPI_INTEGER, pleft,  0, &
-                          comm2d, status, ierr )
-
-       ALLOCATE(rvlp(MAX(1,trlp_count_recv)))
-
-       CALL MPI_SENDRECV( trrp(1)%radius, max(1,trrp_count), mpi_particle_type,&
-                          pright, 1, rvlp(1)%radius,                           &
-                          max(1,trlp_count_recv), mpi_particle_type, pleft, 1, &
-                          comm2d, status, ierr )
-
-       IF ( trlp_count_recv > 0 )  CALL Add_particles_to_gridcell(rvlp(1:trlp_count_recv))
-
-       DEALLOCATE( rvlp )
-       DEALLOCATE( trlp, trrp )
-
-    ENDIF
-
-
-!
-!-- Check whether particles have crossed the boundaries in y direction. Note 
-!-- that this case can also apply to particles that have just been received
-!-- from the adjacent right or left PE.
-!-- Find out first the number of particles to be transferred and allocate
-!-- temporary arrays needed to store them.
-!-- For a one-dimensional decomposition along x, no transfer is necessary,
-!-- because the particle remains on the PE.
-    trsp_count  = nr_move_south
-    trspt_count = 0
-    trnp_count  = nr_move_north
-    trnpt_count = 0
-
-    trsp_count_recv   = 0
-    trspt_count_recv  = 0
-    trnp_count_recv   = 0
-    trnpt_count_recv  = 0
-
-    IF ( pdims(2) /= 1 )  THEN
-!
-!--    First calculate the storage necessary for sending and receiving the
-!--    data
-       DO  ip = nxl, nxr
-          DO  jp = nys, nyn, nyn-nys                                 !compute only first (nys) and last (nyn) loop iterration
-             DO  kp = nzb+1, nzt
-                number_of_particles = prt_count(kp,jp,ip)
-                IF ( number_of_particles <= 0 )  CYCLE
-                particles => grid_particles(kp,jp,ip)%particles(1:number_of_particles)
-                DO  n = 1, number_of_particles
-                   IF ( particles(n)%particle_mask )  THEN
-                      j = ( particles(n)%y + 0.5_wp * dy ) * ddy
-!
-!--                   Above calculation does not work for indices less than zero
-                      IF ( particles(n)%y < -0.5_wp * dy )  j = -1
-
-                      IF ( j < nys )  THEN
-                         trsp_count = trsp_count + 1
-                      ELSEIF ( j > nyn )  THEN
-                         trnp_count = trnp_count + 1
-                      ENDIF
-                   ENDIF
-                ENDDO
-             ENDDO
-          ENDDO
-       ENDDO
-
-       IF ( trsp_count  == 0 )  trsp_count  = 1
-       IF ( trspt_count == 0 )  trspt_count = 1
-       IF ( trnp_count  == 0 )  trnp_count  = 1
-       IF ( trnpt_count == 0 )  trnpt_count = 1
-
-       ALLOCATE( trsp(trsp_count), trnp(trnp_count) )
-
-       trsp = zero_particle
-       trnp = zero_particle
-
-       trsp_count  = nr_move_south
-       trspt_count = 0
-       trnp_count  = nr_move_north
-       trnpt_count = 0
-
-       trsp(1:nr_move_south) = move_also_south(1:nr_move_south)
-       trnp(1:nr_move_north) = move_also_north(1:nr_move_north)
-
-    ENDIF
-
-    DO  ip = nxl, nxr
-       DO  jp = nys, nyn, nyn-nys ! compute only first (nys) and last (nyn) loop iterration
-          DO  kp = nzb+1, nzt
-             number_of_particles = prt_count(kp,jp,ip)
-             IF ( number_of_particles <= 0 )  CYCLE
-             particles => grid_particles(kp,jp,ip)%particles(1:number_of_particles)
-             DO  n = 1, number_of_particles
-!
-!--             Only those particles that have not been marked as 'deleted' may
-!--             be moved.
-                IF ( particles(n)%particle_mask )  THEN
-                   j = ( particles(n)%y + 0.5_wp * dy ) * ddy
-!
-!--                Above calculation does not work for indices less than zero
-                   IF ( particles(n)%y < -0.5_wp * dy )  j = -1
-
-                   IF ( j < nys )  THEN
-                      IF ( j < 0 )  THEN
-!
-!--                      Apply boundary condition along y
-                         IF ( ibc_par_ns == 0 )  THEN
-!
-!--                         Cyclic condition
-                            IF ( pdims(2) == 1 )  THEN
-                               particles(n)%y = ( ny + 1 ) * dy + particles(n)%y
-                               particles(n)%origin_y = ( ny + 1 ) * dy + &
-                               particles(n)%origin_y
-                            ELSE
-                               trsp_count = trsp_count + 1
-                               trsp(trsp_count) = particles(n)
-                               trsp(trsp_count)%y = ( ny + 1 ) * dy + &
-                               trsp(trsp_count)%y
-                               trsp(trsp_count)%origin_y = trsp(trsp_count)%origin_y &
-                               + ( ny + 1 ) * dy
-                               particles(n)%particle_mask = .FALSE.
-                               deleted_particles = deleted_particles + 1
-
-                               IF ( trsp(trsp_count)%y >= (ny+0.5_wp)* dy - 1.0E-12_wp )  THEN
-                                  trsp(trsp_count)%y = trsp(trsp_count)%y - 1.0E-10_wp
-                                  !++ why is 1 subtracted in next statement???
-                                  trsp(trsp_count)%origin_y =                        &
-                                  trsp(trsp_count)%origin_y - 1
-                               ENDIF
-
-                            ENDIF
-
-                         ELSEIF ( ibc_par_ns == 1 )  THEN
-!
-!--                         Particle absorption
-                            particles(n)%particle_mask = .FALSE.
-                            deleted_particles = deleted_particles + 1
-
-                         ELSEIF ( ibc_par_ns == 2 )  THEN
-!
-!--                         Particle reflection
-                            particles(n)%y       = -particles(n)%y
-                            particles(n)%speed_y = -particles(n)%speed_y
-
-                         ENDIF
-                      ELSE
-!
-!--                      Store particle data in the transfer array, which will 
-!--                      be send to the neighbouring PE
-                         trsp_count = trsp_count + 1
-                         trsp(trsp_count) = particles(n)
-                         particles(n)%particle_mask = .FALSE.
-                         deleted_particles = deleted_particles + 1
-
-                      ENDIF
-
-                   ELSEIF ( j > nyn )  THEN
-                      IF ( j > ny )  THEN
-!
-!--                       Apply boundary condition along x
-                         IF ( ibc_par_ns == 0 )  THEN
-!
-!--                         Cyclic condition
-                            IF ( pdims(2) == 1 )  THEN
-                               particles(n)%y = particles(n)%y - ( ny + 1 ) * dy
-                               particles(n)%origin_y =                         &
-                                  particles(n)%origin_y - ( ny + 1 ) * dy
-                            ELSE
-                               trnp_count = trnp_count + 1
-                               trnp(trnp_count) = particles(n)
-                               trnp(trnp_count)%y =                            &
-                                  trnp(trnp_count)%y - ( ny + 1 ) * dy
-                               trnp(trnp_count)%origin_y =                     &
-                                  trnp(trnp_count)%origin_y - ( ny + 1 ) * dy
-                               particles(n)%particle_mask = .FALSE.
-                               deleted_particles = deleted_particles + 1
-                            ENDIF
-
-                         ELSEIF ( ibc_par_ns == 1 )  THEN
-!
-!--                         Particle absorption
-                            particles(n)%particle_mask = .FALSE.
-                            deleted_particles = deleted_particles + 1
-
-                         ELSEIF ( ibc_par_ns == 2 )  THEN
-!
-!--                         Particle reflection
-                            particles(n)%y       = 2 * ( ny * dy ) - particles(n)%y
-                            particles(n)%speed_y = -particles(n)%speed_y
-
-                         ENDIF
-                      ELSE
-!
-!--                      Store particle data in the transfer array, which will 
-!--                      be send to the neighbouring PE
-                         trnp_count = trnp_count + 1
-                         trnp(trnp_count) = particles(n)
-                         particles(n)%particle_mask = .FALSE.
-                         deleted_particles = deleted_particles + 1
-
-                      ENDIF
-
-                   ENDIF
-                ENDIF
-             ENDDO
-          ENDDO
-       ENDDO
-    ENDDO
-
-!
-!-- Send front boundary, receive back boundary (but first exchange how many
-!-- and check, if particle storage must be extended)
-    IF ( pdims(2) /= 1 )  THEN
-
-       CALL MPI_SENDRECV( trsp_count,      1, MPI_INTEGER, psouth, 0, &
-                          trnp_count_recv, 1, MPI_INTEGER, pnorth, 0, &
-                          comm2d, status, ierr )
-
-       ALLOCATE(rvnp(MAX(1,trnp_count_recv)))
-
-       CALL MPI_SENDRECV( trsp(1)%radius, trsp_count, mpi_particle_type,      &
-                          psouth, 1, rvnp(1)%radius,                             &
-                          trnp_count_recv, mpi_particle_type, pnorth, 1,   &
-                          comm2d, status, ierr )
-
-       IF ( trnp_count_recv  > 0 )  CALL Add_particles_to_gridcell(rvnp(1:trnp_count_recv))
-
-       DEALLOCATE(rvnp)
-
-!
-!--    Send back boundary, receive front boundary
-       CALL MPI_SENDRECV( trnp_count,      1, MPI_INTEGER, pnorth, 0, &
-                          trsp_count_recv, 1, MPI_INTEGER, psouth, 0, &
-                          comm2d, status, ierr )
-
-       ALLOCATE(rvsp(MAX(1,trsp_count_recv)))
-
-       CALL MPI_SENDRECV( trnp(1)%radius, trnp_count, mpi_particle_type,      &
-                          pnorth, 1, rvsp(1)%radius,                          &
-                          trsp_count_recv, mpi_particle_type, psouth, 1,   &
-                          comm2d, status, ierr )
-
-       IF ( trsp_count_recv > 0 )  CALL Add_particles_to_gridcell(rvsp(1:trsp_count_recv))
-
-       DEALLOCATE(rvsp)
-
-       number_of_particles = number_of_particles + trsp_count_recv
-
-       DEALLOCATE( trsp, trnp )
-
-    ENDIF
-
-#else
-
-!
-!-- Apply boundary conditions
-    DO  n = 1, number_of_particles
-
-       IF ( particles(n)%x < -0.5_wp * dx )  THEN
-
-          IF ( ibc_par_lr == 0 )  THEN
-!
-!--          Cyclic boundary. Relevant coordinate has to be changed.
-             particles(n)%x = ( nx + 1 ) * dx + particles(n)%x
-
-          ELSEIF ( ibc_par_lr == 1 )  THEN
-!
-!--          Particle absorption
-             particles(n)%particle_mask = .FALSE.
-             deleted_particles = deleted_particles + 1
-
-          ELSEIF ( ibc_par_lr == 2 )  THEN
-!
-!--          Particle reflection
-             particles(n)%x       = -dx - particles(n)%x
-             particles(n)%speed_x = -particles(n)%speed_x
-          ENDIF
-
-       ELSEIF ( particles(n)%x >= ( nx + 0.5_wp ) * dx )  THEN
-
-          IF ( ibc_par_lr == 0 )  THEN
-!
-!--          Cyclic boundary. Relevant coordinate has to be changed.
-             particles(n)%x = particles(n)%x - ( nx + 1 ) * dx
-
-          ELSEIF ( ibc_par_lr == 1 )  THEN
-!
-!--          Particle absorption
-             particles(n)%particle_mask = .FALSE.
-             deleted_particles = deleted_particles + 1
-
-          ELSEIF ( ibc_par_lr == 2 )  THEN
-!
-!--          Particle reflection
-             particles(n)%x       = ( nx + 1 ) * dx - particles(n)%x
-             particles(n)%speed_x = -particles(n)%speed_x
-          ENDIF
-
-       ENDIF
-
-       IF ( particles(n)%y < -0.5_wp * dy )  THEN
-
-          IF ( ibc_par_ns == 0 )  THEN
-!
-!--          Cyclic boundary. Relevant coordinate has to be changed.
-             particles(n)%y = ( ny + 1 ) * dy + particles(n)%y
-
-          ELSEIF ( ibc_par_ns == 1 )  THEN
-!
-!--          Particle absorption
-             particles(n)%particle_mask = .FALSE.
-             deleted_particles = deleted_particles + 1
-
-          ELSEIF ( ibc_par_ns == 2 )  THEN
-!
-!--          Particle reflection
-             particles(n)%y       = -dy - particles(n)%y
-             particles(n)%speed_y = -particles(n)%speed_y
-          ENDIF
-
-       ELSEIF ( particles(n)%y >= ( ny + 0.5_wp ) * dy )  THEN
-
-          IF ( ibc_par_ns == 0 )  THEN
-!
-!--          Cyclic boundary. Relevant coordinate has to be changed.
-             particles(n)%y = particles(n)%y - ( ny + 1 ) * dy
-
-          ELSEIF ( ibc_par_ns == 1 )  THEN
-!
-!--          Particle absorption
-             particles(n)%particle_mask = .FALSE.
-             deleted_particles = deleted_particles + 1
-
-          ELSEIF ( ibc_par_ns == 2 )  THEN
-!
-!--          Particle reflection
-             particles(n)%y       = ( ny + 1 ) * dy - particles(n)%y
-             particles(n)%speed_y = -particles(n)%speed_y
-          ENDIF
-
-       ENDIF
-    ENDDO
-
-#endif
-
-!
-!-- Accumulate the number of particles transferred between the subdomains
-#if defined( __parallel )
-    trlp_count_sum      = trlp_count_sum      + trlp_count
-    trlp_count_recv_sum = trlp_count_recv_sum + trlp_count_recv
-    trrp_count_sum      = trrp_count_sum      + trrp_count
-    trrp_count_recv_sum = trrp_count_recv_sum + trrp_count_recv
-    trsp_count_sum      = trsp_count_sum      + trsp_count
-    trsp_count_recv_sum = trsp_count_recv_sum + trsp_count_recv
-    trnp_count_sum      = trnp_count_sum      + trnp_count
-    trnp_count_recv_sum = trnp_count_recv_sum + trnp_count_recv
-#endif
-
-    CALL cpu_log( log_point_s(23), 'lpm_exchange_horiz', 'stop' )
-
- END SUBROUTINE lpm_exchange_horiz
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> If a particle moves from one processor to another, this subroutine moves 
-!> the corresponding elements from the particle arrays of the old grid cells 
-!> to the particle arrays of the new grid cells.
-!------------------------------------------------------------------------------!
- SUBROUTINE Add_particles_to_gridcell (particle_array)
-
-    IMPLICIT NONE
-
-    INTEGER(iwp)        ::  ip        !<
-    INTEGER(iwp)        ::  jp        !<
-    INTEGER(iwp)        ::  kp        !<
-    INTEGER(iwp)        ::  n         !<
-    INTEGER(iwp)        ::  pindex    !<
-
-    LOGICAL             ::  pack_done !<
-
-    TYPE(particle_type), DIMENSION(:), INTENT(IN)       :: particle_array
-
-    pack_done     = .FALSE.
-
-    nr_move_north = 0
-    nr_move_south = 0
-
-    DO n = 1, SIZE(particle_array)
-       ip = ( particle_array(n)%x + 0.5_wp * dx ) * ddx
-       jp = ( particle_array(n)%y + 0.5_wp * dy ) * ddy
-       kp = particle_array(n)%z / dz + 1 + offset_ocean_nzt
-
-       IF ( ip >= nxl  .AND.  ip <= nxr  .AND.  jp >= nys  .AND.  jp <= nyn    &
-            .AND.  kp >= nzb+1  .AND.  kp <= nzt)  THEN ! particle stays on processor
-          number_of_particles = prt_count(kp,jp,ip)
-          particles => grid_particles(kp,jp,ip)%particles(1:number_of_particles)
-
-          pindex = prt_count(kp,jp,ip)+1
-          IF( pindex > SIZE(grid_particles(kp,jp,ip)%particles) )  THEN
-             IF ( pack_done )  THEN
-                CALL realloc_particles_array (ip,jp,kp)
-             ELSE
-                CALL lpm_pack_arrays
-                prt_count(kp,jp,ip) = number_of_particles
-                pindex = prt_count(kp,jp,ip)+1
-                IF ( pindex > SIZE(grid_particles(kp,jp,ip)%particles) )  THEN
-                   CALL realloc_particles_array (ip,jp,kp)
-                ENDIF
-                pack_done = .TRUE.
-             ENDIF
-          ENDIF
-          grid_particles(kp,jp,ip)%particles(pindex) = particle_array(n)
-          prt_count(kp,jp,ip) = pindex
-       ELSE
-          IF ( jp == nys - 1 )  THEN
-             nr_move_south = nr_move_south+1
-             move_also_south(nr_move_south) = particle_array(n)
-             IF ( jp == -1 )  THEN
-                move_also_south(nr_move_south)%y =                             &
-                   move_also_south(nr_move_south)%y + ( ny + 1 ) * dy
-                move_also_south(nr_move_south)%origin_y =                      &
-                   move_also_south(nr_move_south)%origin_y + ( ny + 1 ) * dy
-             ENDIF
-          ELSEIF ( jp == nyn+1 )  THEN
-             nr_move_north = nr_move_north+1
-             move_also_north(nr_move_north) = particle_array(n)
-             IF ( jp == ny+1 )  THEN
-                move_also_north(nr_move_north)%y =                             &
-                   move_also_north(nr_move_north)%y - ( ny + 1 ) * dy
-                move_also_north(nr_move_north)%origin_y =                      &
-                   move_also_north(nr_move_north)%origin_y - ( ny + 1 ) * dy
-             ENDIF
-          ELSE
-             WRITE(0,'(a,8i7)') 'particle out of range ',myid,ip,jp,kp,nxl,nxr,nys,nyn
-          ENDIF
-       ENDIF
-    ENDDO
-
-    RETURN
-
- END SUBROUTINE Add_particles_to_gridcell
-
-
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> If a particle moves from one grid cell to another (on the current 
-!> processor!), this subroutine moves the corresponding element from the
-!> particle array of the old grid cell to the particle array of the new grid 
-!> cell.
-!------------------------------------------------------------------------------!
- SUBROUTINE lpm_move_particle
-
-    IMPLICIT NONE
-
-    INTEGER(iwp)        ::  i           !<
-    INTEGER(iwp)        ::  ip          !<
-    INTEGER(iwp)        ::  j           !<
-    INTEGER(iwp)        ::  jp          !<
-    INTEGER(iwp)        ::  k           !<
-    INTEGER(iwp)        ::  kp          !<
-    INTEGER(iwp)        ::  n           !<
-    INTEGER(iwp)        ::  np_old_cell !<
-    INTEGER(iwp)        ::  n_start     !<
-    INTEGER(iwp)        ::  pindex      !<
-
-    LOGICAL             ::  pack_done   !<
-
-    TYPE(particle_type), DIMENSION(:), POINTER  ::  particles_old_cell !<
-
-    CALL cpu_log( log_point_s(41), 'lpm_move_particle', 'start' )
-
-    DO  ip = nxl, nxr
-       DO  jp = nys, nyn
-          DO  kp = nzb+1, nzt
-
-             np_old_cell = prt_count(kp,jp,ip)
-             IF ( np_old_cell <= 0 )  CYCLE
-             particles_old_cell => grid_particles(kp,jp,ip)%particles(1:np_old_cell)
-             n_start = -1
-             
-             DO  n = 1, np_old_cell
-                i = ( particles_old_cell(n)%x + 0.5_wp * dx ) * ddx
-                j = ( particles_old_cell(n)%y + 0.5_wp * dy ) * ddy
-                k = particles_old_cell(n)%z / dz + 1 + offset_ocean_nzt
-!
-!--             Check, if particle has moved to another grid cell.
-                IF ( i /= ip  .OR.  j /= jp  .OR.  k /= kp )  THEN
-!
-!--                The particle has moved to another grid cell. Now check, if 
-!--                particle stays on the same processor.
-                   IF ( i >= nxl  .AND.  i <= nxr  .AND.  j >= nys  .AND.      &
-                        j <= nyn  .AND.  k >= nzb+1  .AND.  k <= nzt)  THEN
-!
-!--                   If the particle stays on the same processor, the particle
-!--                   will be added to the particle array of the new processor.
-                      number_of_particles = prt_count(k,j,i)
-                      particles => grid_particles(k,j,i)%particles(1:number_of_particles)
-
-                      pindex = prt_count(k,j,i)+1
-                      IF (  pindex > SIZE(grid_particles(k,j,i)%particles)  )  &
-                      THEN
-                         n_start = n
-                         EXIT
-                      ENDIF
-
-                      grid_particles(k,j,i)%particles(pindex) = particles_old_cell(n)
-                      prt_count(k,j,i) = pindex
-
-                      particles_old_cell(n)%particle_mask = .FALSE.
-                   ENDIF
-                ENDIF
-             ENDDO
-
-             IF ( n_start >= 0 )  THEN
-                pack_done = .FALSE.
-                DO  n = n_start, np_old_cell
-                   i = ( particles_old_cell(n)%x + 0.5_wp * dx ) * ddx
-                   j = ( particles_old_cell(n)%y + 0.5_wp * dy ) * ddy
-                   k = particles_old_cell(n)%z / dz + 1 + offset_ocean_nzt
-                   IF ( i /= ip  .OR.  j /= jp  .OR.  k /= kp )  THEN
-!
-!--                   Particle is in different box
-                      IF ( i >= nxl  .AND.  i <= nxr  .AND.  j >= nys  .AND.   &
-                           j <= nyn  .AND.  k >= nzb+1  .AND.  k <= nzt)  THEN
-!
-!--                      Particle stays on processor
-                         number_of_particles = prt_count(k,j,i)
-                         particles => grid_particles(k,j,i)%particles(1:number_of_particles)
-
-                         pindex = prt_count(k,j,i)+1
-                         IF ( pindex > SIZE(grid_particles(k,j,i)%particles) ) &
-                         THEN
-                            IF ( pack_done )  THEN
-                               CALL realloc_particles_array(i,j,k)
-                               pindex = prt_count(k,j,i)+1
-                            ELSE
-                               CALL lpm_pack_arrays
-                               prt_count(k,j,i) = number_of_particles
-
-                               pindex = prt_count(k,j,i)+1
-!
-!--                            If number of particles in the new grid box 
-!--                            exceeds its allocated memory, the particle array
-!--                            will be reallocated
-                               IF ( pindex > SIZE(grid_particles(k,j,i)%particles) )  THEN
-                                  CALL realloc_particles_array(i,j,k)
-                                  pindex = prt_count(k,j,i)+1
-                               ENDIF
-
-                               pack_done = .TRUE.
-                            ENDIF
-                         ENDIF
-
-                         grid_particles(k,j,i)%particles(pindex) = particles_old_cell(n)
-                         prt_count(k,j,i) = pindex
-
-                         particles_old_cell(n)%particle_mask = .FALSE.
-                      ENDIF
-                   ENDIF
-                ENDDO
-             ENDIF
-          ENDDO
-       ENDDO
-    ENDDO
-
-    CALL cpu_log( log_point_s(41), 'lpm_move_particle', 'stop' )
-
-    RETURN
-
- END SUBROUTINE lpm_move_particle
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> @todo Missing subroutine description.
-!------------------------------------------------------------------------------!
- SUBROUTINE realloc_particles_array (i,j,k,size_in)
-
-    IMPLICIT NONE
-
-    INTEGER(iwp), INTENT(in)                       ::  i              !<
-    INTEGER(iwp), INTENT(in)                       ::  j              !<
-    INTEGER(iwp), INTENT(in)                       ::  k              !<
-    INTEGER(iwp), INTENT(in), OPTIONAL             ::  size_in        !<
-
-    INTEGER(iwp)                                   :: old_size        !<
-    INTEGER(iwp)                                   :: new_size        !<
-    TYPE(particle_type), DIMENSION(:), ALLOCATABLE :: tmp_particles_d !<
-    TYPE(particle_type), DIMENSION(500)            :: tmp_particles_s !<
-
-
-    old_size = SIZE(grid_particles(k,j,i)%particles)
-
-    IF ( PRESENT(size_in) )   THEN
-       new_size = size_in
-    ELSE
-       new_size = old_size * ( 1.0_wp + alloc_factor / 100.0_wp )
-    ENDIF
-
-    new_size = MAX( new_size, min_nr_particle )
-
-    IF ( old_size <= 500 )  THEN
-
-       tmp_particles_s(1:old_size) = grid_particles(k,j,i)%particles(1:old_size)
-
-       DEALLOCATE(grid_particles(k,j,i)%particles)
-       ALLOCATE(grid_particles(k,j,i)%particles(new_size))
-
-       grid_particles(k,j,i)%particles(1:old_size)          = tmp_particles_s(1:old_size)
-       grid_particles(k,j,i)%particles(old_size+1:new_size) = zero_particle
-
-    ELSE
-
-       ALLOCATE(tmp_particles_d(new_size))
-       tmp_particles_d(1:old_size) = grid_particles(k,j,i)%particles
-
-       DEALLOCATE(grid_particles(k,j,i)%particles)
-       ALLOCATE(grid_particles(k,j,i)%particles(new_size))
-
-       grid_particles(k,j,i)%particles(1:old_size)          = tmp_particles_d(1:old_size)
-       grid_particles(k,j,i)%particles(old_size+1:new_size) = zero_particle
-
-       DEALLOCATE(tmp_particles_d)
-
-    ENDIF
-    particles => grid_particles(k,j,i)%particles(1:number_of_particles)
-
-    RETURN
- END SUBROUTINE realloc_particles_array
-
-END MODULE lpm_exchange_horiz_mod
Index: /palm/trunk/SOURCE/lpm_exchange_horiz_mod.f90
===================================================================
--- /palm/trunk/SOURCE/lpm_exchange_horiz_mod.f90	(revision 1850)
+++ /palm/trunk/SOURCE/lpm_exchange_horiz_mod.f90	(revision 1850)
@@ -0,0 +1,1038 @@
+!> @file lpm_exchange_horiz_mod.f90
+!--------------------------------------------------------------------------------!
+! This file is part of PALM.
+!
+! PALM is free software: you can redistribute it and/or modify it under the terms
+! of the GNU General Public License as published by the Free Software Foundation,
+! either version 3 of the License, or (at your option) any later version.
+!
+! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
+! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
+! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along with
+! PALM. If not, see <http://www.gnu.org/licenses/>.
+!
+! Copyright 1997-2016 Leibniz Universitaet Hannover
+!--------------------------------------------------------------------------------!
+!
+! Current revisions:
+! ------------------
+! Module renamed
+!
+!
+! Former revisions:
+! -----------------
+! $Id$
+!
+! 1822 2016-04-07 07:49:42Z hoffmann
+! Tails removed. Unused variables removed.
+!
+! 1783 2016-03-06 18:36:17Z raasch
+! new netcdf-module included
+!
+! 1691 2015-10-26 16:17:44Z maronga
+! Formatting corrections.
+!
+! 1685 2015-10-08 07:32:13Z raasch
+! bugfix concerning vertical index offset in case of ocean
+!
+! 1682 2015-10-07 23:56:08Z knoop
+! Code annotations made doxygen readable 
+! 
+! 1359 2014-04-11 17:15:14Z hoffmann
+! New particle structure integrated. 
+! Kind definition added to all floating point numbers.
+! 
+! 1327 2014-03-21 11:00:16Z raasch
+! -netcdf output queries
+!
+! 1320 2014-03-20 08:40:49Z raasch
+! ONLY-attribute added to USE-statements,
+! kind-parameters added to all INTEGER and REAL declaration statements,
+! kinds are defined in new module kinds,
+! comment fields (!:) to be used for variable explanations added to
+! all variable declaration statements
+!
+! 1318 2014-03-17 13:35:16Z raasch
+! module interfaces removed
+!
+! 1036 2012-10-22 13:43:42Z raasch
+! code put under GPL (PALM 3.9)
+!
+! 851 2012-03-15 14:32:58Z raasch
+! Bugfix: resetting of particle_mask and tail mask moved from end of this
+! routine to lpm
+!
+! 849 2012-03-15 10:35:09Z raasch
+! initial revision (former part of advec_particles)
+!
+!
+! Description:
+! ------------
+! Exchange of particles between the subdomains.
+!------------------------------------------------------------------------------!
+ MODULE lpm_exchange_horiz_mod
+ 
+
+    USE control_parameters,                                                    &
+        ONLY:  dz, message_string, simulated_time
+
+    USE cpulog,                                                                &
+        ONLY:  cpu_log, log_point_s
+
+    USE grid_variables,                                                        &
+        ONLY:  ddx, ddy, dx, dy
+
+    USE indices,                                                               &
+        ONLY:  nx, nxl, nxr, ny, nyn, nys, nzb, nzt
+
+    USE kinds
+
+    USE lpm_pack_arrays_mod,                                                   &
+        ONLY:  lpm_pack_arrays
+
+    USE netcdf_interface,                                                      &
+        ONLY:  netcdf_data_format
+
+    USE particle_attributes,                                                   &
+        ONLY:  alloc_factor, deleted_particles, grid_particles,                &
+               ibc_par_lr, ibc_par_ns, min_nr_particle,                        &
+               mpi_particle_type, number_of_particles,                         &
+               offset_ocean_nzt, offset_ocean_nzt_m1, particles,               &
+               particle_type, prt_count, trlp_count_sum,                       &
+               trlp_count_recv_sum, trnp_count_sum, trnp_count_recv_sum,       &
+               trrp_count_sum, trrp_count_recv_sum, trsp_count_sum,            &
+               trsp_count_recv_sum, zero_particle
+
+    USE pegrid
+
+    IMPLICIT NONE
+
+    INTEGER(iwp), PARAMETER ::  NR_2_direction_move = 10000 !<
+    INTEGER(iwp)            ::  nr_move_north               !<
+    INTEGER(iwp)            ::  nr_move_south               !<
+
+    TYPE(particle_type), DIMENSION(NR_2_direction_move) ::  move_also_north
+    TYPE(particle_type), DIMENSION(NR_2_direction_move) ::  move_also_south
+
+    SAVE
+
+    PRIVATE
+    PUBLIC lpm_exchange_horiz, lpm_move_particle, realloc_particles_array
+
+    INTERFACE lpm_exchange_horiz
+       MODULE PROCEDURE lpm_exchange_horiz
+    END INTERFACE lpm_exchange_horiz
+
+    INTERFACE lpm_move_particle
+       MODULE PROCEDURE lpm_move_particle
+    END INTERFACE lpm_move_particle
+
+    INTERFACE realloc_particles_array
+       MODULE PROCEDURE realloc_particles_array
+    END INTERFACE realloc_particles_array
+
+CONTAINS
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Exchange between subdomains.
+!> As soon as one particle has moved beyond the boundary of the domain, it
+!> is included in the relevant transfer arrays and marked for subsequent
+!> deletion on this PE.
+!> First sweep for crossings in x direction. Find out first the number of
+!> particles to be transferred and allocate temporary arrays needed to store
+!> them.
+!> For a one-dimensional decomposition along y, no transfer is necessary,
+!> because the particle remains on the PE, but the particle coordinate has to
+!> be adjusted.
+!------------------------------------------------------------------------------!
+ SUBROUTINE lpm_exchange_horiz
+
+    IMPLICIT NONE
+
+    INTEGER(iwp) ::  i                                       !<
+    INTEGER(iwp) ::  ip                                      !<
+    INTEGER(iwp) ::  j                                       !<
+    INTEGER(iwp) ::  jp                                      !<
+    INTEGER(iwp) ::  kp                                      !<
+    INTEGER(iwp) ::  n                                       !<
+    INTEGER(iwp) ::  trlp_count                              !<
+    INTEGER(iwp) ::  trlp_count_recv                         !<
+    INTEGER(iwp) ::  trlpt_count                             !<
+    INTEGER(iwp) ::  trlpt_count_recv                        !<
+    INTEGER(iwp) ::  trnp_count                              !<
+    INTEGER(iwp) ::  trnp_count_recv                         !<
+    INTEGER(iwp) ::  trnpt_count                             !<
+    INTEGER(iwp) ::  trnpt_count_recv                        !<
+    INTEGER(iwp) ::  trrp_count                              !<
+    INTEGER(iwp) ::  trrp_count_recv                         !<
+    INTEGER(iwp) ::  trrpt_count                             !<
+    INTEGER(iwp) ::  trrpt_count_recv                        !<
+    INTEGER(iwp) ::  trsp_count                              !<
+    INTEGER(iwp) ::  trsp_count_recv                         !<
+    INTEGER(iwp) ::  trspt_count                             !<
+    INTEGER(iwp) ::  trspt_count_recv                        !<
+
+    TYPE(particle_type), DIMENSION(:), ALLOCATABLE ::  rvlp  !<
+    TYPE(particle_type), DIMENSION(:), ALLOCATABLE ::  rvnp  !<
+    TYPE(particle_type), DIMENSION(:), ALLOCATABLE ::  rvrp  !<
+    TYPE(particle_type), DIMENSION(:), ALLOCATABLE ::  rvsp  !<
+    TYPE(particle_type), DIMENSION(:), ALLOCATABLE ::  trlp  !<
+    TYPE(particle_type), DIMENSION(:), ALLOCATABLE ::  trnp  !<
+    TYPE(particle_type), DIMENSION(:), ALLOCATABLE ::  trrp  !<
+    TYPE(particle_type), DIMENSION(:), ALLOCATABLE ::  trsp  !<
+
+    CALL cpu_log( log_point_s(23), 'lpm_exchange_horiz', 'start' )
+
+#if defined( __parallel )
+
+!
+!-- Exchange between subdomains.
+!-- As soon as one particle has moved beyond the boundary of the domain, it
+!-- is included in the relevant transfer arrays and marked for subsequent
+!-- deletion on this PE.
+!-- First sweep for crossings in x direction. Find out first the number of
+!-- particles to be transferred and allocate temporary arrays needed to store
+!-- them.
+!-- For a one-dimensional decomposition along y, no transfer is necessary,
+!-- because the particle remains on the PE, but the particle coordinate has to
+!-- be adjusted.
+    trlp_count  = 0
+    trlpt_count = 0
+    trrp_count  = 0
+    trrpt_count = 0
+
+    trlp_count_recv   = 0
+    trlpt_count_recv  = 0
+    trrp_count_recv   = 0
+    trrpt_count_recv  = 0
+
+    IF ( pdims(1) /= 1 )  THEN
+!
+!--    First calculate the storage necessary for sending and receiving the data.
+!--    Compute only first (nxl) and last (nxr) loop iterration.
+       DO  ip = nxl, nxr, nxr - nxl
+          DO  jp = nys, nyn
+             DO  kp = nzb+1, nzt
+
+                number_of_particles = prt_count(kp,jp,ip)
+                IF ( number_of_particles <= 0 )  CYCLE
+                particles => grid_particles(kp,jp,ip)%particles(1:number_of_particles)
+                DO  n = 1, number_of_particles
+                   IF ( particles(n)%particle_mask )  THEN
+                      i = ( particles(n)%x + 0.5_wp * dx ) * ddx
+   !
+   !--                Above calculation does not work for indices less than zero
+                      IF ( particles(n)%x < -0.5_wp * dx )  i = -1
+
+                      IF ( i < nxl )  THEN
+                         trlp_count = trlp_count + 1
+                      ELSEIF ( i > nxr )  THEN
+                         trrp_count = trrp_count + 1
+                      ENDIF
+                   ENDIF
+                ENDDO
+
+             ENDDO
+          ENDDO
+       ENDDO
+
+       IF ( trlp_count  == 0 )  trlp_count  = 1
+       IF ( trlpt_count == 0 )  trlpt_count = 1
+       IF ( trrp_count  == 0 )  trrp_count  = 1
+       IF ( trrpt_count == 0 )  trrpt_count = 1
+
+       ALLOCATE( trlp(trlp_count), trrp(trrp_count) )
+
+       trlp = zero_particle
+       trrp = zero_particle
+
+       trlp_count  = 0
+       trlpt_count = 0
+       trrp_count  = 0
+       trrpt_count = 0
+
+    ENDIF
+!
+!-- Compute only first (nxl) and last (nxr) loop iterration
+    DO  ip = nxl, nxr,nxr-nxl
+       DO  jp = nys, nyn
+          DO  kp = nzb+1, nzt
+             number_of_particles = prt_count(kp,jp,ip)
+             IF ( number_of_particles <= 0 ) CYCLE
+             particles => grid_particles(kp,jp,ip)%particles(1:number_of_particles)
+             DO  n = 1, number_of_particles
+!
+!--             Only those particles that have not been marked as 'deleted' may
+!--             be moved.
+                IF ( particles(n)%particle_mask )  THEN
+
+                   i = ( particles(n)%x + 0.5_wp * dx ) * ddx
+   !
+   !--             Above calculation does not work for indices less than zero
+                   IF ( particles(n)%x < - 0.5_wp * dx )  i = -1
+
+                   IF ( i <  nxl )  THEN
+                      IF ( i < 0 )  THEN
+   !
+   !--                   Apply boundary condition along x
+                         IF ( ibc_par_lr == 0 )  THEN
+   !
+   !--                      Cyclic condition
+                            IF ( pdims(1) == 1 )  THEN
+                               particles(n)%x        = ( nx + 1 ) * dx + particles(n)%x
+                               particles(n)%origin_x = ( nx + 1 ) * dx + &
+                               particles(n)%origin_x
+                            ELSE
+                               trlp_count = trlp_count + 1
+                               trlp(trlp_count)   = particles(n)
+                               trlp(trlp_count)%x = ( nx + 1 ) * dx + trlp(trlp_count)%x
+                               trlp(trlp_count)%origin_x = trlp(trlp_count)%origin_x + &
+                               ( nx + 1 ) * dx
+                               particles(n)%particle_mask  = .FALSE.
+                               deleted_particles = deleted_particles + 1
+
+                               IF ( trlp(trlp_count)%x >= (nx + 0.5_wp)* dx - 1.0E-12_wp )  THEN
+                                  trlp(trlp_count)%x = trlp(trlp_count)%x - 1.0E-10_wp
+                                  !++ why is 1 subtracted in next statement???
+                                  trlp(trlp_count)%origin_x = trlp(trlp_count)%origin_x - 1
+                               ENDIF
+
+                            ENDIF
+
+                         ELSEIF ( ibc_par_lr == 1 )  THEN
+   !
+   !--                      Particle absorption
+                            particles(n)%particle_mask = .FALSE.
+                            deleted_particles = deleted_particles + 1
+
+                         ELSEIF ( ibc_par_lr == 2 )  THEN
+   !
+   !--                      Particle reflection
+                            particles(n)%x       = -particles(n)%x
+                            particles(n)%speed_x = -particles(n)%speed_x
+
+                         ENDIF
+                      ELSE
+   !
+   !--                   Store particle data in the transfer array, which will be 
+   !--                   send to the neighbouring PE
+                         trlp_count = trlp_count + 1
+                         trlp(trlp_count) = particles(n)
+                         particles(n)%particle_mask = .FALSE.
+                         deleted_particles = deleted_particles + 1
+
+                      ENDIF
+
+                   ELSEIF ( i > nxr )  THEN
+                      IF ( i > nx )  THEN
+   !
+   !--                   Apply boundary condition along x
+                         IF ( ibc_par_lr == 0 )  THEN
+   !
+   !--                      Cyclic condition
+                            IF ( pdims(1) == 1 )  THEN
+                               particles(n)%x = particles(n)%x - ( nx + 1 ) * dx
+                               particles(n)%origin_x = particles(n)%origin_x - &
+                               ( nx + 1 ) * dx
+                            ELSE
+                               trrp_count = trrp_count + 1
+                               trrp(trrp_count) = particles(n)
+                               trrp(trrp_count)%x = trrp(trrp_count)%x - ( nx + 1 ) * dx
+                               trrp(trrp_count)%origin_x = trrp(trrp_count)%origin_x - &
+                               ( nx + 1 ) * dx
+                               particles(n)%particle_mask = .FALSE.
+                               deleted_particles = deleted_particles + 1
+
+                            ENDIF
+
+                         ELSEIF ( ibc_par_lr == 1 )  THEN
+   !
+   !--                      Particle absorption
+                            particles(n)%particle_mask = .FALSE.
+                            deleted_particles = deleted_particles + 1
+
+                         ELSEIF ( ibc_par_lr == 2 )  THEN
+   !
+   !--                      Particle reflection
+                            particles(n)%x       = 2 * ( nx * dx ) - particles(n)%x
+                            particles(n)%speed_x = -particles(n)%speed_x
+
+                         ENDIF
+                      ELSE
+   !
+   !--                   Store particle data in the transfer array, which will be send
+   !--                   to the neighbouring PE
+                         trrp_count = trrp_count + 1
+                         trrp(trrp_count) = particles(n)
+                         particles(n)%particle_mask = .FALSE.
+                         deleted_particles = deleted_particles + 1
+
+                      ENDIF
+
+                   ENDIF
+                ENDIF
+             ENDDO
+          ENDDO
+       ENDDO
+    ENDDO
+
+!
+!-- Send left boundary, receive right boundary (but first exchange how many
+!-- and check, if particle storage must be extended)
+    IF ( pdims(1) /= 1 )  THEN
+
+       CALL MPI_SENDRECV( trlp_count,      1, MPI_INTEGER, pleft,  0, &
+                          trrp_count_recv, 1, MPI_INTEGER, pright, 0, &
+                          comm2d, status, ierr )
+
+       ALLOCATE(rvrp(MAX(1,trrp_count_recv)))
+
+       CALL MPI_SENDRECV( trlp(1)%radius, max(1,trlp_count), mpi_particle_type,&
+                          pleft, 1, rvrp(1)%radius,                            &
+                          max(1,trrp_count_recv), mpi_particle_type, pright, 1,&
+                          comm2d, status, ierr )
+
+       IF ( trrp_count_recv > 0 )  CALL Add_particles_to_gridcell(rvrp(1:trrp_count_recv))
+
+       DEALLOCATE(rvrp)
+
+!
+!--    Send right boundary, receive left boundary
+       CALL MPI_SENDRECV( trrp_count,      1, MPI_INTEGER, pright, 0, &
+                          trlp_count_recv, 1, MPI_INTEGER, pleft,  0, &
+                          comm2d, status, ierr )
+
+       ALLOCATE(rvlp(MAX(1,trlp_count_recv)))
+
+       CALL MPI_SENDRECV( trrp(1)%radius, max(1,trrp_count), mpi_particle_type,&
+                          pright, 1, rvlp(1)%radius,                           &
+                          max(1,trlp_count_recv), mpi_particle_type, pleft, 1, &
+                          comm2d, status, ierr )
+
+       IF ( trlp_count_recv > 0 )  CALL Add_particles_to_gridcell(rvlp(1:trlp_count_recv))
+
+       DEALLOCATE( rvlp )
+       DEALLOCATE( trlp, trrp )
+
+    ENDIF
+
+
+!
+!-- Check whether particles have crossed the boundaries in y direction. Note 
+!-- that this case can also apply to particles that have just been received
+!-- from the adjacent right or left PE.
+!-- Find out first the number of particles to be transferred and allocate
+!-- temporary arrays needed to store them.
+!-- For a one-dimensional decomposition along x, no transfer is necessary,
+!-- because the particle remains on the PE.
+    trsp_count  = nr_move_south
+    trspt_count = 0
+    trnp_count  = nr_move_north
+    trnpt_count = 0
+
+    trsp_count_recv   = 0
+    trspt_count_recv  = 0
+    trnp_count_recv   = 0
+    trnpt_count_recv  = 0
+
+    IF ( pdims(2) /= 1 )  THEN
+!
+!--    First calculate the storage necessary for sending and receiving the
+!--    data
+       DO  ip = nxl, nxr
+          DO  jp = nys, nyn, nyn-nys                                 !compute only first (nys) and last (nyn) loop iterration
+             DO  kp = nzb+1, nzt
+                number_of_particles = prt_count(kp,jp,ip)
+                IF ( number_of_particles <= 0 )  CYCLE
+                particles => grid_particles(kp,jp,ip)%particles(1:number_of_particles)
+                DO  n = 1, number_of_particles
+                   IF ( particles(n)%particle_mask )  THEN
+                      j = ( particles(n)%y + 0.5_wp * dy ) * ddy
+!
+!--                   Above calculation does not work for indices less than zero
+                      IF ( particles(n)%y < -0.5_wp * dy )  j = -1
+
+                      IF ( j < nys )  THEN
+                         trsp_count = trsp_count + 1
+                      ELSEIF ( j > nyn )  THEN
+                         trnp_count = trnp_count + 1
+                      ENDIF
+                   ENDIF
+                ENDDO
+             ENDDO
+          ENDDO
+       ENDDO
+
+       IF ( trsp_count  == 0 )  trsp_count  = 1
+       IF ( trspt_count == 0 )  trspt_count = 1
+       IF ( trnp_count  == 0 )  trnp_count  = 1
+       IF ( trnpt_count == 0 )  trnpt_count = 1
+
+       ALLOCATE( trsp(trsp_count), trnp(trnp_count) )
+
+       trsp = zero_particle
+       trnp = zero_particle
+
+       trsp_count  = nr_move_south
+       trspt_count = 0
+       trnp_count  = nr_move_north
+       trnpt_count = 0
+
+       trsp(1:nr_move_south) = move_also_south(1:nr_move_south)
+       trnp(1:nr_move_north) = move_also_north(1:nr_move_north)
+
+    ENDIF
+
+    DO  ip = nxl, nxr
+       DO  jp = nys, nyn, nyn-nys ! compute only first (nys) and last (nyn) loop iterration
+          DO  kp = nzb+1, nzt
+             number_of_particles = prt_count(kp,jp,ip)
+             IF ( number_of_particles <= 0 )  CYCLE
+             particles => grid_particles(kp,jp,ip)%particles(1:number_of_particles)
+             DO  n = 1, number_of_particles
+!
+!--             Only those particles that have not been marked as 'deleted' may
+!--             be moved.
+                IF ( particles(n)%particle_mask )  THEN
+                   j = ( particles(n)%y + 0.5_wp * dy ) * ddy
+!
+!--                Above calculation does not work for indices less than zero
+                   IF ( particles(n)%y < -0.5_wp * dy )  j = -1
+
+                   IF ( j < nys )  THEN
+                      IF ( j < 0 )  THEN
+!
+!--                      Apply boundary condition along y
+                         IF ( ibc_par_ns == 0 )  THEN
+!
+!--                         Cyclic condition
+                            IF ( pdims(2) == 1 )  THEN
+                               particles(n)%y = ( ny + 1 ) * dy + particles(n)%y
+                               particles(n)%origin_y = ( ny + 1 ) * dy + &
+                               particles(n)%origin_y
+                            ELSE
+                               trsp_count = trsp_count + 1
+                               trsp(trsp_count) = particles(n)
+                               trsp(trsp_count)%y = ( ny + 1 ) * dy + &
+                               trsp(trsp_count)%y
+                               trsp(trsp_count)%origin_y = trsp(trsp_count)%origin_y &
+                               + ( ny + 1 ) * dy
+                               particles(n)%particle_mask = .FALSE.
+                               deleted_particles = deleted_particles + 1
+
+                               IF ( trsp(trsp_count)%y >= (ny+0.5_wp)* dy - 1.0E-12_wp )  THEN
+                                  trsp(trsp_count)%y = trsp(trsp_count)%y - 1.0E-10_wp
+                                  !++ why is 1 subtracted in next statement???
+                                  trsp(trsp_count)%origin_y =                        &
+                                  trsp(trsp_count)%origin_y - 1
+                               ENDIF
+
+                            ENDIF
+
+                         ELSEIF ( ibc_par_ns == 1 )  THEN
+!
+!--                         Particle absorption
+                            particles(n)%particle_mask = .FALSE.
+                            deleted_particles = deleted_particles + 1
+
+                         ELSEIF ( ibc_par_ns == 2 )  THEN
+!
+!--                         Particle reflection
+                            particles(n)%y       = -particles(n)%y
+                            particles(n)%speed_y = -particles(n)%speed_y
+
+                         ENDIF
+                      ELSE
+!
+!--                      Store particle data in the transfer array, which will 
+!--                      be send to the neighbouring PE
+                         trsp_count = trsp_count + 1
+                         trsp(trsp_count) = particles(n)
+                         particles(n)%particle_mask = .FALSE.
+                         deleted_particles = deleted_particles + 1
+
+                      ENDIF
+
+                   ELSEIF ( j > nyn )  THEN
+                      IF ( j > ny )  THEN
+!
+!--                       Apply boundary condition along x
+                         IF ( ibc_par_ns == 0 )  THEN
+!
+!--                         Cyclic condition
+                            IF ( pdims(2) == 1 )  THEN
+                               particles(n)%y = particles(n)%y - ( ny + 1 ) * dy
+                               particles(n)%origin_y =                         &
+                                  particles(n)%origin_y - ( ny + 1 ) * dy
+                            ELSE
+                               trnp_count = trnp_count + 1
+                               trnp(trnp_count) = particles(n)
+                               trnp(trnp_count)%y =                            &
+                                  trnp(trnp_count)%y - ( ny + 1 ) * dy
+                               trnp(trnp_count)%origin_y =                     &
+                                  trnp(trnp_count)%origin_y - ( ny + 1 ) * dy
+                               particles(n)%particle_mask = .FALSE.
+                               deleted_particles = deleted_particles + 1
+                            ENDIF
+
+                         ELSEIF ( ibc_par_ns == 1 )  THEN
+!
+!--                         Particle absorption
+                            particles(n)%particle_mask = .FALSE.
+                            deleted_particles = deleted_particles + 1
+
+                         ELSEIF ( ibc_par_ns == 2 )  THEN
+!
+!--                         Particle reflection
+                            particles(n)%y       = 2 * ( ny * dy ) - particles(n)%y
+                            particles(n)%speed_y = -particles(n)%speed_y
+
+                         ENDIF
+                      ELSE
+!
+!--                      Store particle data in the transfer array, which will 
+!--                      be send to the neighbouring PE
+                         trnp_count = trnp_count + 1
+                         trnp(trnp_count) = particles(n)
+                         particles(n)%particle_mask = .FALSE.
+                         deleted_particles = deleted_particles + 1
+
+                      ENDIF
+
+                   ENDIF
+                ENDIF
+             ENDDO
+          ENDDO
+       ENDDO
+    ENDDO
+
+!
+!-- Send front boundary, receive back boundary (but first exchange how many
+!-- and check, if particle storage must be extended)
+    IF ( pdims(2) /= 1 )  THEN
+
+       CALL MPI_SENDRECV( trsp_count,      1, MPI_INTEGER, psouth, 0, &
+                          trnp_count_recv, 1, MPI_INTEGER, pnorth, 0, &
+                          comm2d, status, ierr )
+
+       ALLOCATE(rvnp(MAX(1,trnp_count_recv)))
+
+       CALL MPI_SENDRECV( trsp(1)%radius, trsp_count, mpi_particle_type,      &
+                          psouth, 1, rvnp(1)%radius,                             &
+                          trnp_count_recv, mpi_particle_type, pnorth, 1,   &
+                          comm2d, status, ierr )
+
+       IF ( trnp_count_recv  > 0 )  CALL Add_particles_to_gridcell(rvnp(1:trnp_count_recv))
+
+       DEALLOCATE(rvnp)
+
+!
+!--    Send back boundary, receive front boundary
+       CALL MPI_SENDRECV( trnp_count,      1, MPI_INTEGER, pnorth, 0, &
+                          trsp_count_recv, 1, MPI_INTEGER, psouth, 0, &
+                          comm2d, status, ierr )
+
+       ALLOCATE(rvsp(MAX(1,trsp_count_recv)))
+
+       CALL MPI_SENDRECV( trnp(1)%radius, trnp_count, mpi_particle_type,      &
+                          pnorth, 1, rvsp(1)%radius,                          &
+                          trsp_count_recv, mpi_particle_type, psouth, 1,   &
+                          comm2d, status, ierr )
+
+       IF ( trsp_count_recv > 0 )  CALL Add_particles_to_gridcell(rvsp(1:trsp_count_recv))
+
+       DEALLOCATE(rvsp)
+
+       number_of_particles = number_of_particles + trsp_count_recv
+
+       DEALLOCATE( trsp, trnp )
+
+    ENDIF
+
+#else
+
+!
+!-- Apply boundary conditions
+    DO  n = 1, number_of_particles
+
+       IF ( particles(n)%x < -0.5_wp * dx )  THEN
+
+          IF ( ibc_par_lr == 0 )  THEN
+!
+!--          Cyclic boundary. Relevant coordinate has to be changed.
+             particles(n)%x = ( nx + 1 ) * dx + particles(n)%x
+
+          ELSEIF ( ibc_par_lr == 1 )  THEN
+!
+!--          Particle absorption
+             particles(n)%particle_mask = .FALSE.
+             deleted_particles = deleted_particles + 1
+
+          ELSEIF ( ibc_par_lr == 2 )  THEN
+!
+!--          Particle reflection
+             particles(n)%x       = -dx - particles(n)%x
+             particles(n)%speed_x = -particles(n)%speed_x
+          ENDIF
+
+       ELSEIF ( particles(n)%x >= ( nx + 0.5_wp ) * dx )  THEN
+
+          IF ( ibc_par_lr == 0 )  THEN
+!
+!--          Cyclic boundary. Relevant coordinate has to be changed.
+             particles(n)%x = particles(n)%x - ( nx + 1 ) * dx
+
+          ELSEIF ( ibc_par_lr == 1 )  THEN
+!
+!--          Particle absorption
+             particles(n)%particle_mask = .FALSE.
+             deleted_particles = deleted_particles + 1
+
+          ELSEIF ( ibc_par_lr == 2 )  THEN
+!
+!--          Particle reflection
+             particles(n)%x       = ( nx + 1 ) * dx - particles(n)%x
+             particles(n)%speed_x = -particles(n)%speed_x
+          ENDIF
+
+       ENDIF
+
+       IF ( particles(n)%y < -0.5_wp * dy )  THEN
+
+          IF ( ibc_par_ns == 0 )  THEN
+!
+!--          Cyclic boundary. Relevant coordinate has to be changed.
+             particles(n)%y = ( ny + 1 ) * dy + particles(n)%y
+
+          ELSEIF ( ibc_par_ns == 1 )  THEN
+!
+!--          Particle absorption
+             particles(n)%particle_mask = .FALSE.
+             deleted_particles = deleted_particles + 1
+
+          ELSEIF ( ibc_par_ns == 2 )  THEN
+!
+!--          Particle reflection
+             particles(n)%y       = -dy - particles(n)%y
+             particles(n)%speed_y = -particles(n)%speed_y
+          ENDIF
+
+       ELSEIF ( particles(n)%y >= ( ny + 0.5_wp ) * dy )  THEN
+
+          IF ( ibc_par_ns == 0 )  THEN
+!
+!--          Cyclic boundary. Relevant coordinate has to be changed.
+             particles(n)%y = particles(n)%y - ( ny + 1 ) * dy
+
+          ELSEIF ( ibc_par_ns == 1 )  THEN
+!
+!--          Particle absorption
+             particles(n)%particle_mask = .FALSE.
+             deleted_particles = deleted_particles + 1
+
+          ELSEIF ( ibc_par_ns == 2 )  THEN
+!
+!--          Particle reflection
+             particles(n)%y       = ( ny + 1 ) * dy - particles(n)%y
+             particles(n)%speed_y = -particles(n)%speed_y
+          ENDIF
+
+       ENDIF
+    ENDDO
+
+#endif
+
+!
+!-- Accumulate the number of particles transferred between the subdomains
+#if defined( __parallel )
+    trlp_count_sum      = trlp_count_sum      + trlp_count
+    trlp_count_recv_sum = trlp_count_recv_sum + trlp_count_recv
+    trrp_count_sum      = trrp_count_sum      + trrp_count
+    trrp_count_recv_sum = trrp_count_recv_sum + trrp_count_recv
+    trsp_count_sum      = trsp_count_sum      + trsp_count
+    trsp_count_recv_sum = trsp_count_recv_sum + trsp_count_recv
+    trnp_count_sum      = trnp_count_sum      + trnp_count
+    trnp_count_recv_sum = trnp_count_recv_sum + trnp_count_recv
+#endif
+
+    CALL cpu_log( log_point_s(23), 'lpm_exchange_horiz', 'stop' )
+
+ END SUBROUTINE lpm_exchange_horiz
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> If a particle moves from one processor to another, this subroutine moves 
+!> the corresponding elements from the particle arrays of the old grid cells 
+!> to the particle arrays of the new grid cells.
+!------------------------------------------------------------------------------!
+ SUBROUTINE Add_particles_to_gridcell (particle_array)
+
+    IMPLICIT NONE
+
+    INTEGER(iwp)        ::  ip        !<
+    INTEGER(iwp)        ::  jp        !<
+    INTEGER(iwp)        ::  kp        !<
+    INTEGER(iwp)        ::  n         !<
+    INTEGER(iwp)        ::  pindex    !<
+
+    LOGICAL             ::  pack_done !<
+
+    TYPE(particle_type), DIMENSION(:), INTENT(IN)       :: particle_array
+
+    pack_done     = .FALSE.
+
+    nr_move_north = 0
+    nr_move_south = 0
+
+    DO n = 1, SIZE(particle_array)
+       ip = ( particle_array(n)%x + 0.5_wp * dx ) * ddx
+       jp = ( particle_array(n)%y + 0.5_wp * dy ) * ddy
+       kp = particle_array(n)%z / dz + 1 + offset_ocean_nzt
+
+       IF ( ip >= nxl  .AND.  ip <= nxr  .AND.  jp >= nys  .AND.  jp <= nyn    &
+            .AND.  kp >= nzb+1  .AND.  kp <= nzt)  THEN ! particle stays on processor
+          number_of_particles = prt_count(kp,jp,ip)
+          particles => grid_particles(kp,jp,ip)%particles(1:number_of_particles)
+
+          pindex = prt_count(kp,jp,ip)+1
+          IF( pindex > SIZE(grid_particles(kp,jp,ip)%particles) )  THEN
+             IF ( pack_done )  THEN
+                CALL realloc_particles_array (ip,jp,kp)
+             ELSE
+                CALL lpm_pack_arrays
+                prt_count(kp,jp,ip) = number_of_particles
+                pindex = prt_count(kp,jp,ip)+1
+                IF ( pindex > SIZE(grid_particles(kp,jp,ip)%particles) )  THEN
+                   CALL realloc_particles_array (ip,jp,kp)
+                ENDIF
+                pack_done = .TRUE.
+             ENDIF
+          ENDIF
+          grid_particles(kp,jp,ip)%particles(pindex) = particle_array(n)
+          prt_count(kp,jp,ip) = pindex
+       ELSE
+          IF ( jp == nys - 1 )  THEN
+             nr_move_south = nr_move_south+1
+             move_also_south(nr_move_south) = particle_array(n)
+             IF ( jp == -1 )  THEN
+                move_also_south(nr_move_south)%y =                             &
+                   move_also_south(nr_move_south)%y + ( ny + 1 ) * dy
+                move_also_south(nr_move_south)%origin_y =                      &
+                   move_also_south(nr_move_south)%origin_y + ( ny + 1 ) * dy
+             ENDIF
+          ELSEIF ( jp == nyn+1 )  THEN
+             nr_move_north = nr_move_north+1
+             move_also_north(nr_move_north) = particle_array(n)
+             IF ( jp == ny+1 )  THEN
+                move_also_north(nr_move_north)%y =                             &
+                   move_also_north(nr_move_north)%y - ( ny + 1 ) * dy
+                move_also_north(nr_move_north)%origin_y =                      &
+                   move_also_north(nr_move_north)%origin_y - ( ny + 1 ) * dy
+             ENDIF
+          ELSE
+             WRITE(0,'(a,8i7)') 'particle out of range ',myid,ip,jp,kp,nxl,nxr,nys,nyn
+          ENDIF
+       ENDIF
+    ENDDO
+
+    RETURN
+
+ END SUBROUTINE Add_particles_to_gridcell
+
+
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> If a particle moves from one grid cell to another (on the current 
+!> processor!), this subroutine moves the corresponding element from the
+!> particle array of the old grid cell to the particle array of the new grid 
+!> cell.
+!------------------------------------------------------------------------------!
+ SUBROUTINE lpm_move_particle
+
+    IMPLICIT NONE
+
+    INTEGER(iwp)        ::  i           !<
+    INTEGER(iwp)        ::  ip          !<
+    INTEGER(iwp)        ::  j           !<
+    INTEGER(iwp)        ::  jp          !<
+    INTEGER(iwp)        ::  k           !<
+    INTEGER(iwp)        ::  kp          !<
+    INTEGER(iwp)        ::  n           !<
+    INTEGER(iwp)        ::  np_old_cell !<
+    INTEGER(iwp)        ::  n_start     !<
+    INTEGER(iwp)        ::  pindex      !<
+
+    LOGICAL             ::  pack_done   !<
+
+    TYPE(particle_type), DIMENSION(:), POINTER  ::  particles_old_cell !<
+
+    CALL cpu_log( log_point_s(41), 'lpm_move_particle', 'start' )
+
+    DO  ip = nxl, nxr
+       DO  jp = nys, nyn
+          DO  kp = nzb+1, nzt
+
+             np_old_cell = prt_count(kp,jp,ip)
+             IF ( np_old_cell <= 0 )  CYCLE
+             particles_old_cell => grid_particles(kp,jp,ip)%particles(1:np_old_cell)
+             n_start = -1
+             
+             DO  n = 1, np_old_cell
+                i = ( particles_old_cell(n)%x + 0.5_wp * dx ) * ddx
+                j = ( particles_old_cell(n)%y + 0.5_wp * dy ) * ddy
+                k = particles_old_cell(n)%z / dz + 1 + offset_ocean_nzt
+!
+!--             Check, if particle has moved to another grid cell.
+                IF ( i /= ip  .OR.  j /= jp  .OR.  k /= kp )  THEN
+!
+!--                The particle has moved to another grid cell. Now check, if 
+!--                particle stays on the same processor.
+                   IF ( i >= nxl  .AND.  i <= nxr  .AND.  j >= nys  .AND.      &
+                        j <= nyn  .AND.  k >= nzb+1  .AND.  k <= nzt)  THEN
+!
+!--                   If the particle stays on the same processor, the particle
+!--                   will be added to the particle array of the new processor.
+                      number_of_particles = prt_count(k,j,i)
+                      particles => grid_particles(k,j,i)%particles(1:number_of_particles)
+
+                      pindex = prt_count(k,j,i)+1
+                      IF (  pindex > SIZE(grid_particles(k,j,i)%particles)  )  &
+                      THEN
+                         n_start = n
+                         EXIT
+                      ENDIF
+
+                      grid_particles(k,j,i)%particles(pindex) = particles_old_cell(n)
+                      prt_count(k,j,i) = pindex
+
+                      particles_old_cell(n)%particle_mask = .FALSE.
+                   ENDIF
+                ENDIF
+             ENDDO
+
+             IF ( n_start >= 0 )  THEN
+                pack_done = .FALSE.
+                DO  n = n_start, np_old_cell
+                   i = ( particles_old_cell(n)%x + 0.5_wp * dx ) * ddx
+                   j = ( particles_old_cell(n)%y + 0.5_wp * dy ) * ddy
+                   k = particles_old_cell(n)%z / dz + 1 + offset_ocean_nzt
+                   IF ( i /= ip  .OR.  j /= jp  .OR.  k /= kp )  THEN
+!
+!--                   Particle is in different box
+                      IF ( i >= nxl  .AND.  i <= nxr  .AND.  j >= nys  .AND.   &
+                           j <= nyn  .AND.  k >= nzb+1  .AND.  k <= nzt)  THEN
+!
+!--                      Particle stays on processor
+                         number_of_particles = prt_count(k,j,i)
+                         particles => grid_particles(k,j,i)%particles(1:number_of_particles)
+
+                         pindex = prt_count(k,j,i)+1
+                         IF ( pindex > SIZE(grid_particles(k,j,i)%particles) ) &
+                         THEN
+                            IF ( pack_done )  THEN
+                               CALL realloc_particles_array(i,j,k)
+                               pindex = prt_count(k,j,i)+1
+                            ELSE
+                               CALL lpm_pack_arrays
+                               prt_count(k,j,i) = number_of_particles
+
+                               pindex = prt_count(k,j,i)+1
+!
+!--                            If number of particles in the new grid box 
+!--                            exceeds its allocated memory, the particle array
+!--                            will be reallocated
+                               IF ( pindex > SIZE(grid_particles(k,j,i)%particles) )  THEN
+                                  CALL realloc_particles_array(i,j,k)
+                                  pindex = prt_count(k,j,i)+1
+                               ENDIF
+
+                               pack_done = .TRUE.
+                            ENDIF
+                         ENDIF
+
+                         grid_particles(k,j,i)%particles(pindex) = particles_old_cell(n)
+                         prt_count(k,j,i) = pindex
+
+                         particles_old_cell(n)%particle_mask = .FALSE.
+                      ENDIF
+                   ENDIF
+                ENDDO
+             ENDIF
+          ENDDO
+       ENDDO
+    ENDDO
+
+    CALL cpu_log( log_point_s(41), 'lpm_move_particle', 'stop' )
+
+    RETURN
+
+ END SUBROUTINE lpm_move_particle
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> @todo Missing subroutine description.
+!------------------------------------------------------------------------------!
+ SUBROUTINE realloc_particles_array (i,j,k,size_in)
+
+    IMPLICIT NONE
+
+    INTEGER(iwp), INTENT(in)                       ::  i              !<
+    INTEGER(iwp), INTENT(in)                       ::  j              !<
+    INTEGER(iwp), INTENT(in)                       ::  k              !<
+    INTEGER(iwp), INTENT(in), OPTIONAL             ::  size_in        !<
+
+    INTEGER(iwp)                                   :: old_size        !<
+    INTEGER(iwp)                                   :: new_size        !<
+    TYPE(particle_type), DIMENSION(:), ALLOCATABLE :: tmp_particles_d !<
+    TYPE(particle_type), DIMENSION(500)            :: tmp_particles_s !<
+
+
+    old_size = SIZE(grid_particles(k,j,i)%particles)
+
+    IF ( PRESENT(size_in) )   THEN
+       new_size = size_in
+    ELSE
+       new_size = old_size * ( 1.0_wp + alloc_factor / 100.0_wp )
+    ENDIF
+
+    new_size = MAX( new_size, min_nr_particle )
+
+    IF ( old_size <= 500 )  THEN
+
+       tmp_particles_s(1:old_size) = grid_particles(k,j,i)%particles(1:old_size)
+
+       DEALLOCATE(grid_particles(k,j,i)%particles)
+       ALLOCATE(grid_particles(k,j,i)%particles(new_size))
+
+       grid_particles(k,j,i)%particles(1:old_size)          = tmp_particles_s(1:old_size)
+       grid_particles(k,j,i)%particles(old_size+1:new_size) = zero_particle
+
+    ELSE
+
+       ALLOCATE(tmp_particles_d(new_size))
+       tmp_particles_d(1:old_size) = grid_particles(k,j,i)%particles
+
+       DEALLOCATE(grid_particles(k,j,i)%particles)
+       ALLOCATE(grid_particles(k,j,i)%particles(new_size))
+
+       grid_particles(k,j,i)%particles(1:old_size)          = tmp_particles_d(1:old_size)
+       grid_particles(k,j,i)%particles(old_size+1:new_size) = zero_particle
+
+       DEALLOCATE(tmp_particles_d)
+
+    ENDIF
+    particles => grid_particles(k,j,i)%particles(1:number_of_particles)
+
+    RETURN
+ END SUBROUTINE realloc_particles_array
+
+END MODULE lpm_exchange_horiz_mod
Index: lm/trunk/SOURCE/lpm_init.f90
===================================================================
--- /palm/trunk/SOURCE/lpm_init.f90	(revision 1849)
+++ 	(revision )
@@ -1,757 +1,0 @@
-!> @file lpm_init.f90
-!--------------------------------------------------------------------------------!
-! This file is part of PALM.
-!
-! PALM is free software: you can redistribute it and/or modify it under the terms
-! of the GNU General Public License as published by the Free Software Foundation,
-! either version 3 of the License, or (at your option) any later version.
-!
-! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
-! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
-! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along with
-! PALM. If not, see <http://www.gnu.org/licenses/>.
-!
-! Copyright 1997-2016 Leibniz Universitaet Hannover
-!--------------------------------------------------------------------------------!
-!
-! Current revisions:
-! -----------------
-!
-!
-! Former revisions:
-! -----------------
-! $Id$
-!
-! 1831 2016-04-07 13:15:51Z hoffmann
-! curvature_solution_effects moved to particle_attributes
-!
-! 1822 2016-04-07 07:49:42Z hoffmann
-! Unused variables removed.
-!
-! 1783 2016-03-06 18:36:17Z raasch
-! netcdf module added
-!
-! 1725 2015-11-17 13:01:51Z hoffmann 
-! Bugfix: Processor-dependent seed for random function is generated before it is 
-! used.
-!
-! 1691 2015-10-26 16:17:44Z maronga
-! Renamed prandtl_layer to constant_flux_layer.
-!
-! 1685 2015-10-08 07:32:13Z raasch
-! bugfix concerning vertical index offset in case of ocean
-!
-! 1682 2015-10-07 23:56:08Z knoop
-! Code annotations made doxygen readable 
-!
-! 1575 2015-03-27 09:56:27Z raasch
-! initial vertical particle position is allowed to follow the topography
-!
-! 1359 2014-04-11 17:15:14Z hoffmann
-! New particle structure integrated. 
-! Kind definition added to all floating point numbers.
-! lpm_init changed form a subroutine to a module.
-! 
-! 1327 2014-03-21 11:00:16Z raasch
-! -netcdf_output
-!
-! 1322 2014-03-20 16:38:49Z raasch
-! REAL functions provided with KIND-attribute
-!
-! 1320 2014-03-20 08:40:49Z raasch
-! ONLY-attribute added to USE-statements,
-! kind-parameters added to all INTEGER and REAL declaration statements,
-! kinds are defined in new module kinds,
-! revision history before 2012 removed,
-! comment fields (!:) to be used for variable explanations added to
-! all variable declaration statements
-! bugfix: #if defined( __parallel ) added
-!
-! 1314 2014-03-14 18:25:17Z suehring
-! Vertical logarithmic interpolation of horizontal particle speed for particles 
-! between roughness height and first vertical grid level.
-!
-! 1092 2013-02-02 11:24:22Z raasch
-! unused variables removed
-!
-! 1036 2012-10-22 13:43:42Z raasch
-! code put under GPL (PALM 3.9)
-!
-! 849 2012-03-15 10:35:09Z raasch
-! routine renamed: init_particles -> lpm_init
-! de_dx, de_dy, de_dz are allocated here (instead of automatic arrays in
-! advec_particles),
-! sort_particles renamed lpm_sort_arrays, user_init_particles renamed lpm_init
-!
-! 828 2012-02-21 12:00:36Z raasch
-! call of init_kernels, particle feature color renamed class
-!
-! 824 2012-02-17 09:09:57Z raasch
-! particle attributes speed_x|y|z_sgs renamed rvar1|2|3,
-! array particles implemented as pointer
-!
-! 667 2010-12-23 12:06:00Z suehring/gryschka
-! nxl-1, nxr+1, nys-1, nyn+1 replaced by nxlg, nxrg, nysg, nyng for allocation 
-! of arrays.
-!
-! Revision 1.1  1999/11/25 16:22:38  raasch
-! Initial revision
-!
-!
-! Description:
-! ------------
-!> This routine initializes a set of particles and their attributes (position,
-!> radius, ..) which are used by the Lagrangian particle model (see lpm).
-!------------------------------------------------------------------------------!
- MODULE lpm_init_mod
- 
-
-    USE arrays_3d,                                                             &
-        ONLY:  de_dx, de_dy, de_dz, zu, zw, z0
-
-    USE control_parameters,                                                    &
-        ONLY:  cloud_droplets, constant_flux_layer, current_timestep_number,   &
-               dz, initializing_actions, message_string, ocean, simulated_time
-
-    USE grid_variables,                                                        &
-        ONLY:  ddx, dx, ddy, dy
-
-    USE indices,                                                               &
-        ONLY:  nx, nxl, nxlg, nxrg, nxr, ny, nyn, nys, nyng, nysg, nz, nzb,    &
-               nzb_w_inner, nzt
-
-    USE kinds
-
-    USE lpm_collision_kernels_mod,                                             &
-        ONLY:  init_kernels
-
-    USE netcdf_interface,                                                      &
-        ONLY:  netcdf_data_format
-
-    USE particle_attributes,                                                   &
-        ONLY:   alloc_factor, bc_par_b, bc_par_lr, bc_par_ns, bc_par_t,        &
-                block_offset, block_offset_def, collision_kernel,              &
-                curvature_solution_effects,                                    &
-                density_ratio, grid_particles,                                 &
-                initial_weighting_factor, ibc_par_b, ibc_par_lr, ibc_par_ns,   &
-                ibc_par_t, iran_part, log_z_z0,                                &
-                max_number_of_particle_groups, maximum_number_of_particles,    &
-                min_nr_particle, mpi_particle_type,                            &
-                number_of_particles,                                           &
-                number_of_particle_groups, number_of_sublayers,                &
-                offset_ocean_nzt, offset_ocean_nzt_m1,                         &
-                particles, particle_advection_start, particle_groups,          &
-                particle_groups_type, particles_per_point,                     &
-                particle_type, pdx, pdy, pdz,                                  &
-                prt_count, psb, psl, psn, psr, pss, pst,                       &
-                radius, random_start_position, read_particles_from_restartfile,&
-                seed_follows_topography, sort_count,                           &
-                total_number_of_particles,                                     &
-                use_sgs_for_particles,                                         &
-                write_particle_statistics, uniform_particles, zero_particle,   &
-                z0_av_global
-
-    USE pegrid
-
-    USE random_function_mod,                                                   &
-        ONLY:  random_function
-
-    IMPLICIT NONE
-
-    PRIVATE
-
-    INTEGER(iwp), PARAMETER         :: PHASE_INIT    = 1  !<
-    INTEGER(iwp), PARAMETER, PUBLIC :: PHASE_RELEASE = 2  !<
-
-    INTERFACE lpm_init
-       MODULE PROCEDURE lpm_init
-    END INTERFACE lpm_init
-
-    INTERFACE lpm_create_particle
-       MODULE PROCEDURE lpm_create_particle
-    END INTERFACE lpm_create_particle
-
-    PUBLIC lpm_init, lpm_create_particle
-
-CONTAINS
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> @todo Missing subroutine description.
-!------------------------------------------------------------------------------!
- SUBROUTINE lpm_init
-
-    USE lpm_collision_kernels_mod,                                             &
-        ONLY:  init_kernels
-
-    IMPLICIT NONE
-
-    INTEGER(iwp) ::  i                           !<
-    INTEGER(iwp) ::  j                           !<
-    INTEGER(iwp) ::  k                           !<
-
-#if defined( __parallel )
-    INTEGER(iwp), DIMENSION(3) ::  blocklengths  !<
-    INTEGER(iwp), DIMENSION(3) ::  displacements !<
-    INTEGER(iwp), DIMENSION(3) ::  types         !<
-#endif
-
-    REAL(wp) ::  height_int                      !<
-    REAL(wp) ::  height_p                        !<
-    REAL(wp) ::  z_p                             !<
-    REAL(wp) ::  z0_av_local                     !<
-
-#if defined( __parallel )
-!
-!-- Define MPI derived datatype for FORTRAN datatype particle_type (see module
-!-- particle_attributes). Integer length is 4 byte, Real is 8 byte
-    blocklengths(1)  = 19;  blocklengths(2)  =   6;  blocklengths(3)  =   1
-    displacements(1) =  0;  displacements(2) = 152;  displacements(3) = 176
-
-    types(1) = MPI_REAL
-    types(2) = MPI_INTEGER
-    types(3) = MPI_UB
-    CALL MPI_TYPE_STRUCT( 3, blocklengths, displacements, types, &
-                          mpi_particle_type, ierr )
-    CALL MPI_TYPE_COMMIT( mpi_particle_type, ierr )
-#endif
-
-!
-!-- In case of oceans runs, the vertical index calculations need an offset,
-!-- because otherwise the k indices will become negative
-    IF ( ocean )  THEN
-       offset_ocean_nzt    = nzt
-       offset_ocean_nzt_m1 = nzt - 1
-    ENDIF
-
-!
-!-- Define block offsets for dividing a gridcell in 8 sub cells
-
-    block_offset(0) = block_offset_def (-1,-1,-1)
-    block_offset(1) = block_offset_def (-1,-1, 0)
-    block_offset(2) = block_offset_def (-1, 0,-1)
-    block_offset(3) = block_offset_def (-1, 0, 0)
-    block_offset(4) = block_offset_def ( 0,-1,-1)
-    block_offset(5) = block_offset_def ( 0,-1, 0)
-    block_offset(6) = block_offset_def ( 0, 0,-1)
-    block_offset(7) = block_offset_def ( 0, 0, 0)
-!
-!-- Check the number of particle groups.
-    IF ( number_of_particle_groups > max_number_of_particle_groups )  THEN
-       WRITE( message_string, * ) 'max_number_of_particle_groups =',      &
-                                  max_number_of_particle_groups ,         &
-                                  '&number_of_particle_groups reset to ', &
-                                  max_number_of_particle_groups
-       CALL message( 'lpm_init', 'PA0213', 0, 1, 0, 6, 0 )
-       number_of_particle_groups = max_number_of_particle_groups
-    ENDIF
-
-!
-!-- Set default start positions, if necessary
-    IF ( psl(1) == 9999999.9_wp )  psl(1) = -0.5_wp * dx
-    IF ( psr(1) == 9999999.9_wp )  psr(1) = ( nx + 0.5_wp ) * dx
-    IF ( pss(1) == 9999999.9_wp )  pss(1) = -0.5_wp * dy
-    IF ( psn(1) == 9999999.9_wp )  psn(1) = ( ny + 0.5_wp ) * dy
-    IF ( psb(1) == 9999999.9_wp )  psb(1) = zu(nz/2)
-    IF ( pst(1) == 9999999.9_wp )  pst(1) = psb(1)
-
-    IF ( pdx(1) == 9999999.9_wp  .OR.  pdx(1) == 0.0_wp )  pdx(1) = dx
-    IF ( pdy(1) == 9999999.9_wp  .OR.  pdy(1) == 0.0_wp )  pdy(1) = dy
-    IF ( pdz(1) == 9999999.9_wp  .OR.  pdz(1) == 0.0_wp )  pdz(1) = zu(2) - zu(1)
-
-    DO  j = 2, number_of_particle_groups
-       IF ( psl(j) == 9999999.9_wp )  psl(j) = psl(j-1)
-       IF ( psr(j) == 9999999.9_wp )  psr(j) = psr(j-1)
-       IF ( pss(j) == 9999999.9_wp )  pss(j) = pss(j-1)
-       IF ( psn(j) == 9999999.9_wp )  psn(j) = psn(j-1)
-       IF ( psb(j) == 9999999.9_wp )  psb(j) = psb(j-1)
-       IF ( pst(j) == 9999999.9_wp )  pst(j) = pst(j-1)
-       IF ( pdx(j) == 9999999.9_wp  .OR.  pdx(j) == 0.0_wp )  pdx(j) = pdx(j-1)
-       IF ( pdy(j) == 9999999.9_wp  .OR.  pdy(j) == 0.0_wp )  pdy(j) = pdy(j-1)
-       IF ( pdz(j) == 9999999.9_wp  .OR.  pdz(j) == 0.0_wp )  pdz(j) = pdz(j-1)
-    ENDDO
-
-!
-!-- Allocate arrays required for calculating particle SGS velocities
-    IF ( use_sgs_for_particles  .AND.  .NOT. cloud_droplets )  THEN
-       ALLOCATE( de_dx(nzb:nzt+1,nysg:nyng,nxlg:nxrg), &
-                 de_dy(nzb:nzt+1,nysg:nyng,nxlg:nxrg), &
-                 de_dz(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
-    ENDIF
-
-!
-!-- Allocate array required for logarithmic vertical interpolation of 
-!-- horizontal particle velocities between the surface and the first vertical
-!-- grid level. In order to avoid repeated CPU cost-intensive CALLS of 
-!-- intrinsic FORTRAN procedure LOG(z/z0), LOG(z/z0) is precalculated for 
-!-- several heights. Splitting into 20 sublayers turned out to be sufficient. 
-!-- To obtain exact height levels of particles, linear interpolation is applied
-!-- (see lpm_advec.f90).
-    IF ( constant_flux_layer )  THEN
-       
-       ALLOCATE ( log_z_z0(0:number_of_sublayers) ) 
-       z_p         = zu(nzb+1) - zw(nzb)
-
-!
-!--    Calculate horizontal mean value of z0 used for logartihmic
-!--    interpolation. Note: this is not exact for heterogeneous z0. 
-!--    However, sensitivity studies showed that the effect is 
-!--    negligible. 
-       z0_av_local  = SUM( z0(nys:nyn,nxl:nxr) )
-       z0_av_global = 0.0_wp
-
-#if defined( __parallel )
-       CALL MPI_ALLREDUCE(z0_av_local, z0_av_global, 1, MPI_REAL, MPI_SUM, &
-                          comm2d, ierr )
-#else
-       z0_av_global = z0_av_local
-#endif
-
-       z0_av_global = z0_av_global  / ( ( ny + 1 ) * ( nx + 1 ) )
-!
-!--    Horizontal wind speed is zero below and at z0
-       log_z_z0(0) = 0.0_wp
-!
-!--    Calculate vertical depth of the sublayers
-       height_int  = ( z_p - z0_av_global ) / REAL( number_of_sublayers, KIND=wp )
-!
-!--    Precalculate LOG(z/z0)
-       height_p    = 0.0_wp
-       DO  k = 1, number_of_sublayers
-
-          height_p    = height_p + height_int
-          log_z_z0(k) = LOG( height_p / z0_av_global )
-
-       ENDDO
-
-
-    ENDIF
-
-!
-!-- Check boundary condition and set internal variables
-    SELECT CASE ( bc_par_b )
-    
-       CASE ( 'absorb' )
-          ibc_par_b = 1
-
-       CASE ( 'reflect' )
-          ibc_par_b = 2
-          
-       CASE DEFAULT
-          WRITE( message_string, * )  'unknown boundary condition ',   &
-                                       'bc_par_b = "', TRIM( bc_par_b ), '"'
-          CALL message( 'lpm_init', 'PA0217', 1, 2, 0, 6, 0 )
-          
-    END SELECT
-    SELECT CASE ( bc_par_t )
-    
-       CASE ( 'absorb' )
-          ibc_par_t = 1
-
-       CASE ( 'reflect' )
-          ibc_par_t = 2
-          
-       CASE DEFAULT
-          WRITE( message_string, * ) 'unknown boundary condition ',   &
-                                     'bc_par_t = "', TRIM( bc_par_t ), '"'
-          CALL message( 'lpm_init', 'PA0218', 1, 2, 0, 6, 0 )
-          
-    END SELECT
-    SELECT CASE ( bc_par_lr )
-
-       CASE ( 'cyclic' )
-          ibc_par_lr = 0
-
-       CASE ( 'absorb' )
-          ibc_par_lr = 1
-
-       CASE ( 'reflect' )
-          ibc_par_lr = 2
-          
-       CASE DEFAULT
-          WRITE( message_string, * ) 'unknown boundary condition ',   &
-                                     'bc_par_lr = "', TRIM( bc_par_lr ), '"'
-          CALL message( 'lpm_init', 'PA0219', 1, 2, 0, 6, 0 )
-          
-    END SELECT
-    SELECT CASE ( bc_par_ns )
-
-       CASE ( 'cyclic' )
-          ibc_par_ns = 0
-
-       CASE ( 'absorb' )
-          ibc_par_ns = 1
-
-       CASE ( 'reflect' )
-          ibc_par_ns = 2
-          
-       CASE DEFAULT
-          WRITE( message_string, * ) 'unknown boundary condition ',   &
-                                     'bc_par_ns = "', TRIM( bc_par_ns ), '"'
-          CALL message( 'lpm_init', 'PA0220', 1, 2, 0, 6, 0 )
-          
-    END SELECT
-
-!
-!-- Initialize collision kernels
-    IF ( collision_kernel /= 'none' )  CALL init_kernels
-
-!
-!-- For the first model run of a possible job chain initialize the
-!-- particles, otherwise read the particle data from restart file.
-    IF ( TRIM( initializing_actions ) == 'read_restart_data'  &
-         .AND.  read_particles_from_restartfile )  THEN
-
-       CALL lpm_read_restart_file
-
-    ELSE
-
-!
-!--    Allocate particle arrays and set attributes of the initial set of
-!--    particles, which can be also periodically released at later times.
-       ALLOCATE( prt_count(nzb:nzt+1,nysg:nyng,nxlg:nxrg), &
-                 grid_particles(nzb+1:nzt,nys:nyn,nxl:nxr) )
-
-       maximum_number_of_particles = 0
-       number_of_particles         = 0
-
-       sort_count = 0
-       prt_count  = 0
-
-!
-!--    Initialize all particles with dummy values (otherwise errors may
-!--    occur within restart runs). The reason for this is still not clear
-!--    and may be presumably caused by errors in the respective user-interface.
-       zero_particle = particle_type( 0.0_wp, 0.0_wp, 0.0_wp, 0.0_wp, 0.0_wp,  &
-                                      0.0_wp, 0.0_wp, 0.0_wp, 0.0_wp, 0.0_wp,  &
-                                      0.0_wp, 0.0_wp, 0.0_wp, 0.0_wp, 0.0_wp,  &
-                                      0.0_wp, 0.0_wp, 0.0_wp, 0.0_wp, 0, 0, 0, &
-                                      0, .FALSE., -1)
-
-       particle_groups = particle_groups_type( 0.0_wp, 0.0_wp, 0.0_wp, 0.0_wp )
-
-!
-!--    Set values for the density ratio and radius for all particle
-!--    groups, if necessary
-       IF ( density_ratio(1) == 9999999.9_wp )  density_ratio(1) = 0.0_wp
-       IF ( radius(1)        == 9999999.9_wp )  radius(1) = 0.0_wp
-       DO  i = 2, number_of_particle_groups
-          IF ( density_ratio(i) == 9999999.9_wp )  THEN
-             density_ratio(i) = density_ratio(i-1)
-          ENDIF
-          IF ( radius(i) == 9999999.9_wp )  radius(i) = radius(i-1)
-       ENDDO
-
-       DO  i = 1, number_of_particle_groups
-          IF ( density_ratio(i) /= 0.0_wp  .AND.  radius(i) == 0 )  THEN
-             WRITE( message_string, * ) 'particle group #', i, 'has a', &
-                                        'density ratio /= 0 but radius = 0'
-             CALL message( 'lpm_init', 'PA0215', 1, 2, 0, 6, 0 )
-          ENDIF
-          particle_groups(i)%density_ratio = density_ratio(i)
-          particle_groups(i)%radius        = radius(i)
-       ENDDO
-
-!
-!--    Set a seed value for the random number generator to be exclusively
-!--    used for the particle code. The generated random numbers should be
-!--    different on the different PEs.
-       iran_part = iran_part + myid
-
-       CALL lpm_create_particle (PHASE_INIT)
-
-!
-!--    User modification of initial particles
-       CALL user_lpm_init
-
-!
-!--    Open file for statistical informations about particle conditions
-       IF ( write_particle_statistics )  THEN
-          CALL check_open( 80 )
-          WRITE ( 80, 8000 )  current_timestep_number, simulated_time,         &
-                              number_of_particles,                             &
-                              maximum_number_of_particles
-          CALL close_file( 80 )
-       ENDIF
-
-    ENDIF
-
-!
-!-- To avoid programm abort, assign particles array to the local version of 
-!-- first grid cell
-    number_of_particles = prt_count(nzb+1,nys,nxl)
-    particles => grid_particles(nzb+1,nys,nxl)%particles(1:number_of_particles)
-
-!
-!-- Formats
-8000 FORMAT (I6,1X,F7.2,4X,I10,71X,I10)
-
- END SUBROUTINE lpm_init
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> @todo Missing subroutine description.
-!------------------------------------------------------------------------------!
- SUBROUTINE lpm_create_particle (phase)
-
-    USE lpm_exchange_horiz_mod,                                                &
-        ONLY: lpm_exchange_horiz, lpm_move_particle, realloc_particles_array
-
-    USE lpm_pack_arrays_mod,                                                   &
-        ONLY: lpm_pack_all_arrays
-
-    IMPLICIT  NONE
-
-    INTEGER(iwp)               ::  alloc_size  !<
-    INTEGER(iwp)               ::  i           !<
-    INTEGER(iwp)               ::  ip          !<
-    INTEGER(iwp)               ::  j           !<
-    INTEGER(iwp)               ::  jp          !<
-    INTEGER(iwp)               ::  kp          !<
-    INTEGER(iwp)               ::  loop_stride !<
-    INTEGER(iwp)               ::  n           !<
-    INTEGER(iwp)               ::  new_size    !<
-
-    INTEGER(iwp), INTENT(IN)   ::  phase       !<
-
-    INTEGER(iwp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ::  local_count !<
-    INTEGER(iwp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ::  local_start !<
-
-    LOGICAL                    ::  first_stride !<
-
-    REAL(wp)                   ::  pos_x !<
-    REAL(wp)                   ::  pos_y !<
-    REAL(wp)                   ::  pos_z !<
-
-    TYPE(particle_type),TARGET ::  tmp_particle !<
-
-!
-!-- Calculate particle positions and store particle attributes, if
-!-- particle is situated on this PE
-    DO  loop_stride = 1, 2
-       first_stride = (loop_stride == 1)
-       IF ( first_stride )   THEN
-          local_count = 0           ! count number of particles
-       ELSE
-          local_count = prt_count   ! Start address of new particles
-       ENDIF
-
-       n = 0
-       DO  i = 1, number_of_particle_groups
-
-          pos_z = psb(i)
-
-          DO WHILE ( pos_z <= pst(i) )
-
-             pos_y = pss(i)
-
-             DO WHILE ( pos_y <= psn(i) )
-
-                IF ( pos_y >= ( nys - 0.5_wp ) * dy  .AND.  &
-                     pos_y <  ( nyn + 0.5_wp ) * dy )  THEN
-
-                   pos_x = psl(i)
-
-            xloop: DO WHILE ( pos_x <= psr(i) )
-
-                      IF ( pos_x >= ( nxl - 0.5_wp ) * dx  .AND.  &
-                           pos_x <  ( nxr + 0.5_wp ) * dx )  THEN
-
-                         DO  j = 1, particles_per_point
-
-                            n = n + 1
-                            tmp_particle%x             = pos_x
-                            tmp_particle%y             = pos_y
-                            tmp_particle%z             = pos_z
-                            tmp_particle%age           = 0.0_wp
-                            tmp_particle%age_m         = 0.0_wp
-                            tmp_particle%dt_sum        = 0.0_wp
-                            tmp_particle%dvrp_psize    = 0.0_wp !unused
-                            tmp_particle%e_m           = 0.0_wp
-                            IF ( curvature_solution_effects )  THEN
-!
-!--                            Initial values (internal timesteps, derivative)
-!--                            for Rosenbrock method
-                               tmp_particle%rvar1      = 1.0E-12_wp
-                               tmp_particle%rvar2      = 1.0E-3_wp
-                               tmp_particle%rvar3      = -9999999.9_wp
-                            ELSE
-!
-!--                            Initial values for SGS velocities
-                               tmp_particle%rvar1      = 0.0_wp
-                               tmp_particle%rvar2      = 0.0_wp
-                               tmp_particle%rvar3      = 0.0_wp
-                            ENDIF
-                            tmp_particle%speed_x       = 0.0_wp
-                            tmp_particle%speed_y       = 0.0_wp
-                            tmp_particle%speed_z       = 0.0_wp
-                            tmp_particle%origin_x      = pos_x
-                            tmp_particle%origin_y      = pos_y
-                            tmp_particle%origin_z      = pos_z
-                            tmp_particle%radius        = particle_groups(i)%radius
-                            tmp_particle%weight_factor = initial_weighting_factor
-                            tmp_particle%class         = 1
-                            tmp_particle%group         = i
-                            tmp_particle%tailpoints    = 0     !unused
-                            tmp_particle%particle_mask = .TRUE.
-                            tmp_particle%tail_id       = 0     !unused
-
-!
-!--                         Determine the grid indices of the particle position
-                            ip = ( tmp_particle%x + 0.5_wp * dx ) * ddx
-                            jp = ( tmp_particle%y + 0.5_wp * dy ) * ddy
-                            kp = tmp_particle%z / dz + 1 + offset_ocean_nzt
-
-                            IF ( seed_follows_topography )  THEN
-!
-!--                            Particle height is given relative to topography
-                               kp = kp + nzb_w_inner(jp,ip)
-                               tmp_particle%z = tmp_particle%z + zw(kp)
-                               IF ( kp > nzt )  THEN
-                                  pos_x = pos_x + pdx(i)
-                                  CYCLE xloop
-                               ENDIF
-                            ENDIF
-
-                            local_count(kp,jp,ip) = local_count(kp,jp,ip) + 1
-                            IF ( .NOT. first_stride )  THEN
-                               IF ( ip < nxl  .OR.  jp < nys  .OR.  kp < nzb+1 )  THEN
-                                  write(6,*) 'xl ',ip,jp,kp,nxl,nys,nzb+1
-                               ENDIF
-                               IF ( ip > nxr  .OR.  jp > nyn  .OR.  kp > nzt )  THEN
-                                  write(6,*) 'xu ',ip,jp,kp,nxr,nyn,nzt
-                               ENDIF
-                               grid_particles(kp,jp,ip)%particles(local_count(kp,jp,ip)) = tmp_particle
-                            ENDIF
-                         ENDDO
-
-                      ENDIF
-
-                      pos_x = pos_x + pdx(i)
-
-                   ENDDO xloop
-
-                ENDIF
-
-                pos_y = pos_y + pdy(i)
-
-             ENDDO
-
-             pos_z = pos_z + pdz(i)
-
-          ENDDO
-
-       ENDDO
-
-       IF ( first_stride )  THEN
-          DO  ip = nxl, nxr
-             DO  jp = nys, nyn
-                DO  kp = nzb+1, nzt
-                   IF ( phase == PHASE_INIT )  THEN
-                      IF ( local_count(kp,jp,ip) > 0 )  THEN
-                         alloc_size = MAX( INT( local_count(kp,jp,ip) *        &
-                            ( 1.0_wp + alloc_factor / 100.0_wp ) ),            &
-                            min_nr_particle )
-                      ELSE
-                         alloc_size = min_nr_particle
-                      ENDIF
-                      ALLOCATE(grid_particles(kp,jp,ip)%particles(1:alloc_size))
-                      DO  n = 1, alloc_size
-                         grid_particles(kp,jp,ip)%particles(n) = zero_particle
-                      ENDDO
-                   ELSEIF ( phase == PHASE_RELEASE )  THEN
-                      IF ( local_count(kp,jp,ip) > 0 )  THEN
-                         new_size   = local_count(kp,jp,ip) + prt_count(kp,jp,ip)
-                         alloc_size = MAX( INT( new_size * ( 1.0_wp +          &
-                            alloc_factor / 100.0_wp ) ), min_nr_particle )
-                         IF( alloc_size > SIZE( grid_particles(kp,jp,ip)%particles) )  THEN
-                           CALL realloc_particles_array(ip,jp,kp,alloc_size)
-                         ENDIF
-                      ENDIF
-                   ENDIF
-                ENDDO
-             ENDDO
-          ENDDO
-       ENDIF
-    ENDDO
-
-    local_start = prt_count+1
-    prt_count   = local_count
-!
-!-- Add random fluctuation to particle positions
-    IF ( random_start_position )  THEN
-       DO  ip = nxl, nxr
-          DO  jp = nys, nyn
-             DO  kp = nzb+1, nzt
-                number_of_particles = prt_count(kp,jp,ip)
-                IF ( number_of_particles <= 0 )  CYCLE
-                particles => grid_particles(kp,jp,ip)%particles(1:number_of_particles)
-
-                DO  n = local_start(kp,jp,ip), number_of_particles              !Move only new particles
-                   IF ( psl(particles(n)%group) /= psr(particles(n)%group) )  THEN
-                      particles(n)%x = particles(n)%x +                        &
-                                   ( random_function( iran_part ) - 0.5_wp ) * &
-                                   pdx(particles(n)%group)
-                   ENDIF
-                   IF ( pss(particles(n)%group) /= psn(particles(n)%group) )  THEN
-                      particles(n)%y = particles(n)%y +                        &
-                                   ( random_function( iran_part ) - 0.5_wp ) * &
-                                   pdy(particles(n)%group)
-                   ENDIF
-                   IF ( psb(particles(n)%group) /= pst(particles(n)%group) )  THEN
-                      particles(n)%z = particles(n)%z +                        &
-                                   ( random_function( iran_part ) - 0.5_wp ) * &
-                                   pdz(particles(n)%group)
-                   ENDIF
-                ENDDO
-!
-!--             Identify particles located outside the model domain
-                CALL lpm_boundary_conds( 'bottom/top' )
-             ENDDO
-          ENDDO
-       ENDDO
-!
-!--    Exchange particles between grid cells and processors
-       CALL lpm_move_particle
-       CALL lpm_exchange_horiz
-
-    ENDIF
-!
-!-- In case of random_start_position, delete particles identified by 
-!-- lpm_exchange_horiz and lpm_boundary_conds. Then sort particles into blocks, 
-!-- which is needed for a fast interpolation of the LES fields on the particle 
-!-- position.
-    CALL lpm_pack_all_arrays
-
-!
-!-- Determine maximum number of particles (i.e., all possible particles that 
-!-- have been allocated) and the current number of particles
-    DO  ip = nxl, nxr
-       DO  jp = nys, nyn
-          DO  kp = nzb+1, nzt
-             maximum_number_of_particles = maximum_number_of_particles         &
-                                           + SIZE(grid_particles(kp,jp,ip)%particles)
-             number_of_particles         = number_of_particles                 &
-                                           + prt_count(kp,jp,ip)
-          ENDDO
-       ENDDO
-    ENDDO
-!
-!-- Calculate the number of particles of the total domain
-#if defined( __parallel )
-    IF ( collective_wait )  CALL MPI_BARRIER( comm2d, ierr )
-    CALL MPI_ALLREDUCE( number_of_particles, total_number_of_particles, 1, &
-    MPI_INTEGER, MPI_SUM, comm2d, ierr )
-#else
-    total_number_of_particles = number_of_particles
-#endif
-
-    RETURN
-
- END SUBROUTINE lpm_create_particle
-
-END MODULE lpm_init_mod
Index: /palm/trunk/SOURCE/lpm_init_mod.f90
===================================================================
--- /palm/trunk/SOURCE/lpm_init_mod.f90	(revision 1850)
+++ /palm/trunk/SOURCE/lpm_init_mod.f90	(revision 1850)
@@ -0,0 +1,758 @@
+!> @file lpm_init_mod.f90
+!--------------------------------------------------------------------------------!
+! This file is part of PALM.
+!
+! PALM is free software: you can redistribute it and/or modify it under the terms
+! of the GNU General Public License as published by the Free Software Foundation,
+! either version 3 of the License, or (at your option) any later version.
+!
+! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
+! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
+! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along with
+! PALM. If not, see <http://www.gnu.org/licenses/>.
+!
+! Copyright 1997-2016 Leibniz Universitaet Hannover
+!--------------------------------------------------------------------------------!
+!
+! Current revisions:
+! -----------------
+! Module renamed
+!
+!
+! Former revisions:
+! -----------------
+! $Id$
+!
+! 1831 2016-04-07 13:15:51Z hoffmann
+! curvature_solution_effects moved to particle_attributes
+!
+! 1822 2016-04-07 07:49:42Z hoffmann
+! Unused variables removed.
+!
+! 1783 2016-03-06 18:36:17Z raasch
+! netcdf module added
+!
+! 1725 2015-11-17 13:01:51Z hoffmann 
+! Bugfix: Processor-dependent seed for random function is generated before it is 
+! used.
+!
+! 1691 2015-10-26 16:17:44Z maronga
+! Renamed prandtl_layer to constant_flux_layer.
+!
+! 1685 2015-10-08 07:32:13Z raasch
+! bugfix concerning vertical index offset in case of ocean
+!
+! 1682 2015-10-07 23:56:08Z knoop
+! Code annotations made doxygen readable 
+!
+! 1575 2015-03-27 09:56:27Z raasch
+! initial vertical particle position is allowed to follow the topography
+!
+! 1359 2014-04-11 17:15:14Z hoffmann
+! New particle structure integrated. 
+! Kind definition added to all floating point numbers.
+! lpm_init changed form a subroutine to a module.
+! 
+! 1327 2014-03-21 11:00:16Z raasch
+! -netcdf_output
+!
+! 1322 2014-03-20 16:38:49Z raasch
+! REAL functions provided with KIND-attribute
+!
+! 1320 2014-03-20 08:40:49Z raasch
+! ONLY-attribute added to USE-statements,
+! kind-parameters added to all INTEGER and REAL declaration statements,
+! kinds are defined in new module kinds,
+! revision history before 2012 removed,
+! comment fields (!:) to be used for variable explanations added to
+! all variable declaration statements
+! bugfix: #if defined( __parallel ) added
+!
+! 1314 2014-03-14 18:25:17Z suehring
+! Vertical logarithmic interpolation of horizontal particle speed for particles 
+! between roughness height and first vertical grid level.
+!
+! 1092 2013-02-02 11:24:22Z raasch
+! unused variables removed
+!
+! 1036 2012-10-22 13:43:42Z raasch
+! code put under GPL (PALM 3.9)
+!
+! 849 2012-03-15 10:35:09Z raasch
+! routine renamed: init_particles -> lpm_init
+! de_dx, de_dy, de_dz are allocated here (instead of automatic arrays in
+! advec_particles),
+! sort_particles renamed lpm_sort_arrays, user_init_particles renamed lpm_init
+!
+! 828 2012-02-21 12:00:36Z raasch
+! call of init_kernels, particle feature color renamed class
+!
+! 824 2012-02-17 09:09:57Z raasch
+! particle attributes speed_x|y|z_sgs renamed rvar1|2|3,
+! array particles implemented as pointer
+!
+! 667 2010-12-23 12:06:00Z suehring/gryschka
+! nxl-1, nxr+1, nys-1, nyn+1 replaced by nxlg, nxrg, nysg, nyng for allocation 
+! of arrays.
+!
+! Revision 1.1  1999/11/25 16:22:38  raasch
+! Initial revision
+!
+!
+! Description:
+! ------------
+!> This routine initializes a set of particles and their attributes (position,
+!> radius, ..) which are used by the Lagrangian particle model (see lpm).
+!------------------------------------------------------------------------------!
+ MODULE lpm_init_mod
+ 
+
+    USE arrays_3d,                                                             &
+        ONLY:  de_dx, de_dy, de_dz, zu, zw, z0
+
+    USE control_parameters,                                                    &
+        ONLY:  cloud_droplets, constant_flux_layer, current_timestep_number,   &
+               dz, initializing_actions, message_string, ocean, simulated_time
+
+    USE grid_variables,                                                        &
+        ONLY:  ddx, dx, ddy, dy
+
+    USE indices,                                                               &
+        ONLY:  nx, nxl, nxlg, nxrg, nxr, ny, nyn, nys, nyng, nysg, nz, nzb,    &
+               nzb_w_inner, nzt
+
+    USE kinds
+
+    USE lpm_collision_kernels_mod,                                             &
+        ONLY:  init_kernels
+
+    USE netcdf_interface,                                                      &
+        ONLY:  netcdf_data_format
+
+    USE particle_attributes,                                                   &
+        ONLY:   alloc_factor, bc_par_b, bc_par_lr, bc_par_ns, bc_par_t,        &
+                block_offset, block_offset_def, collision_kernel,              &
+                curvature_solution_effects,                                    &
+                density_ratio, grid_particles,                                 &
+                initial_weighting_factor, ibc_par_b, ibc_par_lr, ibc_par_ns,   &
+                ibc_par_t, iran_part, log_z_z0,                                &
+                max_number_of_particle_groups, maximum_number_of_particles,    &
+                min_nr_particle, mpi_particle_type,                            &
+                number_of_particles,                                           &
+                number_of_particle_groups, number_of_sublayers,                &
+                offset_ocean_nzt, offset_ocean_nzt_m1,                         &
+                particles, particle_advection_start, particle_groups,          &
+                particle_groups_type, particles_per_point,                     &
+                particle_type, pdx, pdy, pdz,                                  &
+                prt_count, psb, psl, psn, psr, pss, pst,                       &
+                radius, random_start_position, read_particles_from_restartfile,&
+                seed_follows_topography, sort_count,                           &
+                total_number_of_particles,                                     &
+                use_sgs_for_particles,                                         &
+                write_particle_statistics, uniform_particles, zero_particle,   &
+                z0_av_global
+
+    USE pegrid
+
+    USE random_function_mod,                                                   &
+        ONLY:  random_function
+
+    IMPLICIT NONE
+
+    PRIVATE
+
+    INTEGER(iwp), PARAMETER         :: PHASE_INIT    = 1  !<
+    INTEGER(iwp), PARAMETER, PUBLIC :: PHASE_RELEASE = 2  !<
+
+    INTERFACE lpm_init
+       MODULE PROCEDURE lpm_init
+    END INTERFACE lpm_init
+
+    INTERFACE lpm_create_particle
+       MODULE PROCEDURE lpm_create_particle
+    END INTERFACE lpm_create_particle
+
+    PUBLIC lpm_init, lpm_create_particle
+
+CONTAINS
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> @todo Missing subroutine description.
+!------------------------------------------------------------------------------!
+ SUBROUTINE lpm_init
+
+    USE lpm_collision_kernels_mod,                                             &
+        ONLY:  init_kernels
+
+    IMPLICIT NONE
+
+    INTEGER(iwp) ::  i                           !<
+    INTEGER(iwp) ::  j                           !<
+    INTEGER(iwp) ::  k                           !<
+
+#if defined( __parallel )
+    INTEGER(iwp), DIMENSION(3) ::  blocklengths  !<
+    INTEGER(iwp), DIMENSION(3) ::  displacements !<
+    INTEGER(iwp), DIMENSION(3) ::  types         !<
+#endif
+
+    REAL(wp) ::  height_int                      !<
+    REAL(wp) ::  height_p                        !<
+    REAL(wp) ::  z_p                             !<
+    REAL(wp) ::  z0_av_local                     !<
+
+#if defined( __parallel )
+!
+!-- Define MPI derived datatype for FORTRAN datatype particle_type (see module
+!-- particle_attributes). Integer length is 4 byte, Real is 8 byte
+    blocklengths(1)  = 19;  blocklengths(2)  =   6;  blocklengths(3)  =   1
+    displacements(1) =  0;  displacements(2) = 152;  displacements(3) = 176
+
+    types(1) = MPI_REAL
+    types(2) = MPI_INTEGER
+    types(3) = MPI_UB
+    CALL MPI_TYPE_STRUCT( 3, blocklengths, displacements, types, &
+                          mpi_particle_type, ierr )
+    CALL MPI_TYPE_COMMIT( mpi_particle_type, ierr )
+#endif
+
+!
+!-- In case of oceans runs, the vertical index calculations need an offset,
+!-- because otherwise the k indices will become negative
+    IF ( ocean )  THEN
+       offset_ocean_nzt    = nzt
+       offset_ocean_nzt_m1 = nzt - 1
+    ENDIF
+
+!
+!-- Define block offsets for dividing a gridcell in 8 sub cells
+
+    block_offset(0) = block_offset_def (-1,-1,-1)
+    block_offset(1) = block_offset_def (-1,-1, 0)
+    block_offset(2) = block_offset_def (-1, 0,-1)
+    block_offset(3) = block_offset_def (-1, 0, 0)
+    block_offset(4) = block_offset_def ( 0,-1,-1)
+    block_offset(5) = block_offset_def ( 0,-1, 0)
+    block_offset(6) = block_offset_def ( 0, 0,-1)
+    block_offset(7) = block_offset_def ( 0, 0, 0)
+!
+!-- Check the number of particle groups.
+    IF ( number_of_particle_groups > max_number_of_particle_groups )  THEN
+       WRITE( message_string, * ) 'max_number_of_particle_groups =',      &
+                                  max_number_of_particle_groups ,         &
+                                  '&number_of_particle_groups reset to ', &
+                                  max_number_of_particle_groups
+       CALL message( 'lpm_init', 'PA0213', 0, 1, 0, 6, 0 )
+       number_of_particle_groups = max_number_of_particle_groups
+    ENDIF
+
+!
+!-- Set default start positions, if necessary
+    IF ( psl(1) == 9999999.9_wp )  psl(1) = -0.5_wp * dx
+    IF ( psr(1) == 9999999.9_wp )  psr(1) = ( nx + 0.5_wp ) * dx
+    IF ( pss(1) == 9999999.9_wp )  pss(1) = -0.5_wp * dy
+    IF ( psn(1) == 9999999.9_wp )  psn(1) = ( ny + 0.5_wp ) * dy
+    IF ( psb(1) == 9999999.9_wp )  psb(1) = zu(nz/2)
+    IF ( pst(1) == 9999999.9_wp )  pst(1) = psb(1)
+
+    IF ( pdx(1) == 9999999.9_wp  .OR.  pdx(1) == 0.0_wp )  pdx(1) = dx
+    IF ( pdy(1) == 9999999.9_wp  .OR.  pdy(1) == 0.0_wp )  pdy(1) = dy
+    IF ( pdz(1) == 9999999.9_wp  .OR.  pdz(1) == 0.0_wp )  pdz(1) = zu(2) - zu(1)
+
+    DO  j = 2, number_of_particle_groups
+       IF ( psl(j) == 9999999.9_wp )  psl(j) = psl(j-1)
+       IF ( psr(j) == 9999999.9_wp )  psr(j) = psr(j-1)
+       IF ( pss(j) == 9999999.9_wp )  pss(j) = pss(j-1)
+       IF ( psn(j) == 9999999.9_wp )  psn(j) = psn(j-1)
+       IF ( psb(j) == 9999999.9_wp )  psb(j) = psb(j-1)
+       IF ( pst(j) == 9999999.9_wp )  pst(j) = pst(j-1)
+       IF ( pdx(j) == 9999999.9_wp  .OR.  pdx(j) == 0.0_wp )  pdx(j) = pdx(j-1)
+       IF ( pdy(j) == 9999999.9_wp  .OR.  pdy(j) == 0.0_wp )  pdy(j) = pdy(j-1)
+       IF ( pdz(j) == 9999999.9_wp  .OR.  pdz(j) == 0.0_wp )  pdz(j) = pdz(j-1)
+    ENDDO
+
+!
+!-- Allocate arrays required for calculating particle SGS velocities
+    IF ( use_sgs_for_particles  .AND.  .NOT. cloud_droplets )  THEN
+       ALLOCATE( de_dx(nzb:nzt+1,nysg:nyng,nxlg:nxrg), &
+                 de_dy(nzb:nzt+1,nysg:nyng,nxlg:nxrg), &
+                 de_dz(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
+    ENDIF
+
+!
+!-- Allocate array required for logarithmic vertical interpolation of 
+!-- horizontal particle velocities between the surface and the first vertical
+!-- grid level. In order to avoid repeated CPU cost-intensive CALLS of 
+!-- intrinsic FORTRAN procedure LOG(z/z0), LOG(z/z0) is precalculated for 
+!-- several heights. Splitting into 20 sublayers turned out to be sufficient. 
+!-- To obtain exact height levels of particles, linear interpolation is applied
+!-- (see lpm_advec.f90).
+    IF ( constant_flux_layer )  THEN
+       
+       ALLOCATE ( log_z_z0(0:number_of_sublayers) ) 
+       z_p         = zu(nzb+1) - zw(nzb)
+
+!
+!--    Calculate horizontal mean value of z0 used for logartihmic
+!--    interpolation. Note: this is not exact for heterogeneous z0. 
+!--    However, sensitivity studies showed that the effect is 
+!--    negligible. 
+       z0_av_local  = SUM( z0(nys:nyn,nxl:nxr) )
+       z0_av_global = 0.0_wp
+
+#if defined( __parallel )
+       CALL MPI_ALLREDUCE(z0_av_local, z0_av_global, 1, MPI_REAL, MPI_SUM, &
+                          comm2d, ierr )
+#else
+       z0_av_global = z0_av_local
+#endif
+
+       z0_av_global = z0_av_global  / ( ( ny + 1 ) * ( nx + 1 ) )
+!
+!--    Horizontal wind speed is zero below and at z0
+       log_z_z0(0) = 0.0_wp
+!
+!--    Calculate vertical depth of the sublayers
+       height_int  = ( z_p - z0_av_global ) / REAL( number_of_sublayers, KIND=wp )
+!
+!--    Precalculate LOG(z/z0)
+       height_p    = 0.0_wp
+       DO  k = 1, number_of_sublayers
+
+          height_p    = height_p + height_int
+          log_z_z0(k) = LOG( height_p / z0_av_global )
+
+       ENDDO
+
+
+    ENDIF
+
+!
+!-- Check boundary condition and set internal variables
+    SELECT CASE ( bc_par_b )
+    
+       CASE ( 'absorb' )
+          ibc_par_b = 1
+
+       CASE ( 'reflect' )
+          ibc_par_b = 2
+          
+       CASE DEFAULT
+          WRITE( message_string, * )  'unknown boundary condition ',   &
+                                       'bc_par_b = "', TRIM( bc_par_b ), '"'
+          CALL message( 'lpm_init', 'PA0217', 1, 2, 0, 6, 0 )
+          
+    END SELECT
+    SELECT CASE ( bc_par_t )
+    
+       CASE ( 'absorb' )
+          ibc_par_t = 1
+
+       CASE ( 'reflect' )
+          ibc_par_t = 2
+          
+       CASE DEFAULT
+          WRITE( message_string, * ) 'unknown boundary condition ',   &
+                                     'bc_par_t = "', TRIM( bc_par_t ), '"'
+          CALL message( 'lpm_init', 'PA0218', 1, 2, 0, 6, 0 )
+          
+    END SELECT
+    SELECT CASE ( bc_par_lr )
+
+       CASE ( 'cyclic' )
+          ibc_par_lr = 0
+
+       CASE ( 'absorb' )
+          ibc_par_lr = 1
+
+       CASE ( 'reflect' )
+          ibc_par_lr = 2
+          
+       CASE DEFAULT
+          WRITE( message_string, * ) 'unknown boundary condition ',   &
+                                     'bc_par_lr = "', TRIM( bc_par_lr ), '"'
+          CALL message( 'lpm_init', 'PA0219', 1, 2, 0, 6, 0 )
+          
+    END SELECT
+    SELECT CASE ( bc_par_ns )
+
+       CASE ( 'cyclic' )
+          ibc_par_ns = 0
+
+       CASE ( 'absorb' )
+          ibc_par_ns = 1
+
+       CASE ( 'reflect' )
+          ibc_par_ns = 2
+          
+       CASE DEFAULT
+          WRITE( message_string, * ) 'unknown boundary condition ',   &
+                                     'bc_par_ns = "', TRIM( bc_par_ns ), '"'
+          CALL message( 'lpm_init', 'PA0220', 1, 2, 0, 6, 0 )
+          
+    END SELECT
+
+!
+!-- Initialize collision kernels
+    IF ( collision_kernel /= 'none' )  CALL init_kernels
+
+!
+!-- For the first model run of a possible job chain initialize the
+!-- particles, otherwise read the particle data from restart file.
+    IF ( TRIM( initializing_actions ) == 'read_restart_data'  &
+         .AND.  read_particles_from_restartfile )  THEN
+
+       CALL lpm_read_restart_file
+
+    ELSE
+
+!
+!--    Allocate particle arrays and set attributes of the initial set of
+!--    particles, which can be also periodically released at later times.
+       ALLOCATE( prt_count(nzb:nzt+1,nysg:nyng,nxlg:nxrg), &
+                 grid_particles(nzb+1:nzt,nys:nyn,nxl:nxr) )
+
+       maximum_number_of_particles = 0
+       number_of_particles         = 0
+
+       sort_count = 0
+       prt_count  = 0
+
+!
+!--    Initialize all particles with dummy values (otherwise errors may
+!--    occur within restart runs). The reason for this is still not clear
+!--    and may be presumably caused by errors in the respective user-interface.
+       zero_particle = particle_type( 0.0_wp, 0.0_wp, 0.0_wp, 0.0_wp, 0.0_wp,  &
+                                      0.0_wp, 0.0_wp, 0.0_wp, 0.0_wp, 0.0_wp,  &
+                                      0.0_wp, 0.0_wp, 0.0_wp, 0.0_wp, 0.0_wp,  &
+                                      0.0_wp, 0.0_wp, 0.0_wp, 0.0_wp, 0, 0, 0, &
+                                      0, .FALSE., -1)
+
+       particle_groups = particle_groups_type( 0.0_wp, 0.0_wp, 0.0_wp, 0.0_wp )
+
+!
+!--    Set values for the density ratio and radius for all particle
+!--    groups, if necessary
+       IF ( density_ratio(1) == 9999999.9_wp )  density_ratio(1) = 0.0_wp
+       IF ( radius(1)        == 9999999.9_wp )  radius(1) = 0.0_wp
+       DO  i = 2, number_of_particle_groups
+          IF ( density_ratio(i) == 9999999.9_wp )  THEN
+             density_ratio(i) = density_ratio(i-1)
+          ENDIF
+          IF ( radius(i) == 9999999.9_wp )  radius(i) = radius(i-1)
+       ENDDO
+
+       DO  i = 1, number_of_particle_groups
+          IF ( density_ratio(i) /= 0.0_wp  .AND.  radius(i) == 0 )  THEN
+             WRITE( message_string, * ) 'particle group #', i, 'has a', &
+                                        'density ratio /= 0 but radius = 0'
+             CALL message( 'lpm_init', 'PA0215', 1, 2, 0, 6, 0 )
+          ENDIF
+          particle_groups(i)%density_ratio = density_ratio(i)
+          particle_groups(i)%radius        = radius(i)
+       ENDDO
+
+!
+!--    Set a seed value for the random number generator to be exclusively
+!--    used for the particle code. The generated random numbers should be
+!--    different on the different PEs.
+       iran_part = iran_part + myid
+
+       CALL lpm_create_particle (PHASE_INIT)
+
+!
+!--    User modification of initial particles
+       CALL user_lpm_init
+
+!
+!--    Open file for statistical informations about particle conditions
+       IF ( write_particle_statistics )  THEN
+          CALL check_open( 80 )
+          WRITE ( 80, 8000 )  current_timestep_number, simulated_time,         &
+                              number_of_particles,                             &
+                              maximum_number_of_particles
+          CALL close_file( 80 )
+       ENDIF
+
+    ENDIF
+
+!
+!-- To avoid programm abort, assign particles array to the local version of 
+!-- first grid cell
+    number_of_particles = prt_count(nzb+1,nys,nxl)
+    particles => grid_particles(nzb+1,nys,nxl)%particles(1:number_of_particles)
+
+!
+!-- Formats
+8000 FORMAT (I6,1X,F7.2,4X,I10,71X,I10)
+
+ END SUBROUTINE lpm_init
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> @todo Missing subroutine description.
+!------------------------------------------------------------------------------!
+ SUBROUTINE lpm_create_particle (phase)
+
+    USE lpm_exchange_horiz_mod,                                                &
+        ONLY: lpm_exchange_horiz, lpm_move_particle, realloc_particles_array
+
+    USE lpm_pack_arrays_mod,                                                   &
+        ONLY: lpm_pack_all_arrays
+
+    IMPLICIT  NONE
+
+    INTEGER(iwp)               ::  alloc_size  !<
+    INTEGER(iwp)               ::  i           !<
+    INTEGER(iwp)               ::  ip          !<
+    INTEGER(iwp)               ::  j           !<
+    INTEGER(iwp)               ::  jp          !<
+    INTEGER(iwp)               ::  kp          !<
+    INTEGER(iwp)               ::  loop_stride !<
+    INTEGER(iwp)               ::  n           !<
+    INTEGER(iwp)               ::  new_size    !<
+
+    INTEGER(iwp), INTENT(IN)   ::  phase       !<
+
+    INTEGER(iwp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ::  local_count !<
+    INTEGER(iwp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ::  local_start !<
+
+    LOGICAL                    ::  first_stride !<
+
+    REAL(wp)                   ::  pos_x !<
+    REAL(wp)                   ::  pos_y !<
+    REAL(wp)                   ::  pos_z !<
+
+    TYPE(particle_type),TARGET ::  tmp_particle !<
+
+!
+!-- Calculate particle positions and store particle attributes, if
+!-- particle is situated on this PE
+    DO  loop_stride = 1, 2
+       first_stride = (loop_stride == 1)
+       IF ( first_stride )   THEN
+          local_count = 0           ! count number of particles
+       ELSE
+          local_count = prt_count   ! Start address of new particles
+       ENDIF
+
+       n = 0
+       DO  i = 1, number_of_particle_groups
+
+          pos_z = psb(i)
+
+          DO WHILE ( pos_z <= pst(i) )
+
+             pos_y = pss(i)
+
+             DO WHILE ( pos_y <= psn(i) )
+
+                IF ( pos_y >= ( nys - 0.5_wp ) * dy  .AND.  &
+                     pos_y <  ( nyn + 0.5_wp ) * dy )  THEN
+
+                   pos_x = psl(i)
+
+            xloop: DO WHILE ( pos_x <= psr(i) )
+
+                      IF ( pos_x >= ( nxl - 0.5_wp ) * dx  .AND.  &
+                           pos_x <  ( nxr + 0.5_wp ) * dx )  THEN
+
+                         DO  j = 1, particles_per_point
+
+                            n = n + 1
+                            tmp_particle%x             = pos_x
+                            tmp_particle%y             = pos_y
+                            tmp_particle%z             = pos_z
+                            tmp_particle%age           = 0.0_wp
+                            tmp_particle%age_m         = 0.0_wp
+                            tmp_particle%dt_sum        = 0.0_wp
+                            tmp_particle%dvrp_psize    = 0.0_wp !unused
+                            tmp_particle%e_m           = 0.0_wp
+                            IF ( curvature_solution_effects )  THEN
+!
+!--                            Initial values (internal timesteps, derivative)
+!--                            for Rosenbrock method
+                               tmp_particle%rvar1      = 1.0E-12_wp
+                               tmp_particle%rvar2      = 1.0E-3_wp
+                               tmp_particle%rvar3      = -9999999.9_wp
+                            ELSE
+!
+!--                            Initial values for SGS velocities
+                               tmp_particle%rvar1      = 0.0_wp
+                               tmp_particle%rvar2      = 0.0_wp
+                               tmp_particle%rvar3      = 0.0_wp
+                            ENDIF
+                            tmp_particle%speed_x       = 0.0_wp
+                            tmp_particle%speed_y       = 0.0_wp
+                            tmp_particle%speed_z       = 0.0_wp
+                            tmp_particle%origin_x      = pos_x
+                            tmp_particle%origin_y      = pos_y
+                            tmp_particle%origin_z      = pos_z
+                            tmp_particle%radius        = particle_groups(i)%radius
+                            tmp_particle%weight_factor = initial_weighting_factor
+                            tmp_particle%class         = 1
+                            tmp_particle%group         = i
+                            tmp_particle%tailpoints    = 0     !unused
+                            tmp_particle%particle_mask = .TRUE.
+                            tmp_particle%tail_id       = 0     !unused
+
+!
+!--                         Determine the grid indices of the particle position
+                            ip = ( tmp_particle%x + 0.5_wp * dx ) * ddx
+                            jp = ( tmp_particle%y + 0.5_wp * dy ) * ddy
+                            kp = tmp_particle%z / dz + 1 + offset_ocean_nzt
+
+                            IF ( seed_follows_topography )  THEN
+!
+!--                            Particle height is given relative to topography
+                               kp = kp + nzb_w_inner(jp,ip)
+                               tmp_particle%z = tmp_particle%z + zw(kp)
+                               IF ( kp > nzt )  THEN
+                                  pos_x = pos_x + pdx(i)
+                                  CYCLE xloop
+                               ENDIF
+                            ENDIF
+
+                            local_count(kp,jp,ip) = local_count(kp,jp,ip) + 1
+                            IF ( .NOT. first_stride )  THEN
+                               IF ( ip < nxl  .OR.  jp < nys  .OR.  kp < nzb+1 )  THEN
+                                  write(6,*) 'xl ',ip,jp,kp,nxl,nys,nzb+1
+                               ENDIF
+                               IF ( ip > nxr  .OR.  jp > nyn  .OR.  kp > nzt )  THEN
+                                  write(6,*) 'xu ',ip,jp,kp,nxr,nyn,nzt
+                               ENDIF
+                               grid_particles(kp,jp,ip)%particles(local_count(kp,jp,ip)) = tmp_particle
+                            ENDIF
+                         ENDDO
+
+                      ENDIF
+
+                      pos_x = pos_x + pdx(i)
+
+                   ENDDO xloop
+
+                ENDIF
+
+                pos_y = pos_y + pdy(i)
+
+             ENDDO
+
+             pos_z = pos_z + pdz(i)
+
+          ENDDO
+
+       ENDDO
+
+       IF ( first_stride )  THEN
+          DO  ip = nxl, nxr
+             DO  jp = nys, nyn
+                DO  kp = nzb+1, nzt
+                   IF ( phase == PHASE_INIT )  THEN
+                      IF ( local_count(kp,jp,ip) > 0 )  THEN
+                         alloc_size = MAX( INT( local_count(kp,jp,ip) *        &
+                            ( 1.0_wp + alloc_factor / 100.0_wp ) ),            &
+                            min_nr_particle )
+                      ELSE
+                         alloc_size = min_nr_particle
+                      ENDIF
+                      ALLOCATE(grid_particles(kp,jp,ip)%particles(1:alloc_size))
+                      DO  n = 1, alloc_size
+                         grid_particles(kp,jp,ip)%particles(n) = zero_particle
+                      ENDDO
+                   ELSEIF ( phase == PHASE_RELEASE )  THEN
+                      IF ( local_count(kp,jp,ip) > 0 )  THEN
+                         new_size   = local_count(kp,jp,ip) + prt_count(kp,jp,ip)
+                         alloc_size = MAX( INT( new_size * ( 1.0_wp +          &
+                            alloc_factor / 100.0_wp ) ), min_nr_particle )
+                         IF( alloc_size > SIZE( grid_particles(kp,jp,ip)%particles) )  THEN
+                           CALL realloc_particles_array(ip,jp,kp,alloc_size)
+                         ENDIF
+                      ENDIF
+                   ENDIF
+                ENDDO
+             ENDDO
+          ENDDO
+       ENDIF
+    ENDDO
+
+    local_start = prt_count+1
+    prt_count   = local_count
+!
+!-- Add random fluctuation to particle positions
+    IF ( random_start_position )  THEN
+       DO  ip = nxl, nxr
+          DO  jp = nys, nyn
+             DO  kp = nzb+1, nzt
+                number_of_particles = prt_count(kp,jp,ip)
+                IF ( number_of_particles <= 0 )  CYCLE
+                particles => grid_particles(kp,jp,ip)%particles(1:number_of_particles)
+
+                DO  n = local_start(kp,jp,ip), number_of_particles              !Move only new particles
+                   IF ( psl(particles(n)%group) /= psr(particles(n)%group) )  THEN
+                      particles(n)%x = particles(n)%x +                        &
+                                   ( random_function( iran_part ) - 0.5_wp ) * &
+                                   pdx(particles(n)%group)
+                   ENDIF
+                   IF ( pss(particles(n)%group) /= psn(particles(n)%group) )  THEN
+                      particles(n)%y = particles(n)%y +                        &
+                                   ( random_function( iran_part ) - 0.5_wp ) * &
+                                   pdy(particles(n)%group)
+                   ENDIF
+                   IF ( psb(particles(n)%group) /= pst(particles(n)%group) )  THEN
+                      particles(n)%z = particles(n)%z +                        &
+                                   ( random_function( iran_part ) - 0.5_wp ) * &
+                                   pdz(particles(n)%group)
+                   ENDIF
+                ENDDO
+!
+!--             Identify particles located outside the model domain
+                CALL lpm_boundary_conds( 'bottom/top' )
+             ENDDO
+          ENDDO
+       ENDDO
+!
+!--    Exchange particles between grid cells and processors
+       CALL lpm_move_particle
+       CALL lpm_exchange_horiz
+
+    ENDIF
+!
+!-- In case of random_start_position, delete particles identified by 
+!-- lpm_exchange_horiz and lpm_boundary_conds. Then sort particles into blocks, 
+!-- which is needed for a fast interpolation of the LES fields on the particle 
+!-- position.
+    CALL lpm_pack_all_arrays
+
+!
+!-- Determine maximum number of particles (i.e., all possible particles that 
+!-- have been allocated) and the current number of particles
+    DO  ip = nxl, nxr
+       DO  jp = nys, nyn
+          DO  kp = nzb+1, nzt
+             maximum_number_of_particles = maximum_number_of_particles         &
+                                           + SIZE(grid_particles(kp,jp,ip)%particles)
+             number_of_particles         = number_of_particles                 &
+                                           + prt_count(kp,jp,ip)
+          ENDDO
+       ENDDO
+    ENDDO
+!
+!-- Calculate the number of particles of the total domain
+#if defined( __parallel )
+    IF ( collective_wait )  CALL MPI_BARRIER( comm2d, ierr )
+    CALL MPI_ALLREDUCE( number_of_particles, total_number_of_particles, 1, &
+    MPI_INTEGER, MPI_SUM, comm2d, ierr )
+#else
+    total_number_of_particles = number_of_particles
+#endif
+
+    RETURN
+
+ END SUBROUTINE lpm_create_particle
+
+END MODULE lpm_init_mod
Index: lm/trunk/SOURCE/ls_forcing.f90
===================================================================
--- /palm/trunk/SOURCE/ls_forcing.f90	(revision 1849)
+++ 	(revision )
@@ -1,639 +1,0 @@
-!> @file ls_forcing.f90
-!--------------------------------------------------------------------------------!
-! This file is part of PALM.
-!
-! PALM is free software: you can redistribute it and/or modify it under the terms
-! of the GNU General Public License as published by the Free Software Foundation,
-! either version 3 of the License, or (at your option) any later version.
-!
-! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
-! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
-! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along with
-! PALM. If not, see <http://www.gnu.org/licenses/>.
-!
-! Copyright 1997-2016 Leibniz Universitaet Hannover
-!--------------------------------------------------------------------------------!
-!
-! Current revisions:
-! ------------------
-! 
-! 
-! Former revisions:
-! -----------------
-! $Id$
-!
-! 1682 2015-10-07 23:56:08Z knoop
-! Code annotations made doxygen readable
-! 
-! 1602 2015-06-22 07:50:56Z heinze 
-! PA0370 changed to PA0363
-!
-! 1382 2014-04-30 12:15:41Z boeske
-! Renamed variables which store large scale forcing tendencies
-! pt_lsa -> td_lsa_lpt, pt_subs -> td_sub_lpt, 
-! q_lsa  -> td_lsa_q,   q_subs  -> td_sub_q,
-! high|lowpt_lsa -> high|low_td_lsa_lpt, ...
-! 
-! 1365 2014-04-22 15:03:56Z boeske
-! Usage of large scale forcing for pt and q enabled:
-! Added new subroutine ls_advec for horizontal large scale advection and large 
-! scale subsidence, 
-! error message in init_ls_forcing specified,
-! variable t renamed nt
-! 
-! 1353 2014-04-08 15:21:23Z heinze
-! REAL constants provided with KIND-attribute
-!
-! 1320 2014-03-20 08:40:49Z raasch
-! ONLY-attribute added to USE-statements,
-! kind-parameters added to all INTEGER and REAL declaration statements,
-! kinds are defined in new module kinds,
-! comment fields (!:) to be used for variable explanations added to
-! all variable declaration statements
-!
-! 1318 2014-03-17 13:35:16Z raasch
-! module interfaces removed
-!
-! 1299 2014-03-06 13:15:21Z heinze
-! Ensure a zero large scale vertical velocity at the surface
-! Bugfix: typo in case of boundary condition in if-clause
-!
-! 1276 2014-01-15 13:40:41Z heinze
-! Use LSF_DATA also in case of Dirichlet bottom boundary condition for scalars
-!
-! 1249 2013-11-06 10:45:47Z heinze
-! remove call of user module
-! reformatting
-!
-! 1241 2013-10-30 11:36:58Z heinze
-! Initial revision
-!
-! Description:
-! ------------
-!> Calculates large scale forcings (geostrophic wind and subsidence velocity) as 
-!> well as surfaces fluxes dependent on time given in an external file (LSF_DATA).
-!> Code is based in parts on DALES and UCLA-LES.
-!--------------------------------------------------------------------------------!
- MODULE ls_forcing_mod
- 
-
-    PRIVATE
-    PUBLIC init_ls_forcing, ls_forcing_surf, ls_forcing_vert, ls_advec
-    SAVE
-
-    INTERFACE ls_advec
-       MODULE PROCEDURE ls_advec
-       MODULE PROCEDURE ls_advec_ij
-    END INTERFACE ls_advec
-
- CONTAINS
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> @todo Missing subroutine description.
-!------------------------------------------------------------------------------!
-    SUBROUTINE init_ls_forcing
-
-       USE arrays_3d,                                                          &
-           ONLY:  p_surf, pt_surf, q_surf, qsws_surf, shf_surf, td_lsa_lpt,    &
-                  td_lsa_q, td_sub_lpt, td_sub_q, time_surf, time_vert,        &
-                  ug_vert, vg_vert, wsubs_vert, zu
-
-       USE control_parameters,                                                 &
-           ONLY:  end_time, lsf_surf, lsf_vert, message_string, nlsf
-
-       USE indices,                                                            &
-           ONLY:  ngp_sums_ls, nzb, nz, nzt
-
-       USE kinds
-
-       USE statistics,                                                         &
-           ONLY:  sums_ls_l
-
-
-       IMPLICIT NONE
-
-       CHARACTER(100) ::  chmess      !<
-       CHARACTER(1)   ::  hash        !<
-
-       INTEGER(iwp) ::  ierrn         !<
-       INTEGER(iwp) ::  finput = 90   !<
-       INTEGER(iwp) ::  k             !<
-       INTEGER(iwp) ::  nt             !<
-
-       REAL(wp) ::  fac               !<
-       REAL(wp) ::  highheight        !<
-       REAL(wp) ::  highug_vert       !<
-       REAL(wp) ::  highvg_vert       !<
-       REAL(wp) ::  highwsubs_vert    !<
-       REAL(wp) ::  lowheight         !<
-       REAL(wp) ::  lowug_vert        !<
-       REAL(wp) ::  lowvg_vert        !<
-       REAL(wp) ::  lowwsubs_vert     !<
-       REAL(wp) ::  high_td_lsa_lpt   !<
-       REAL(wp) ::  low_td_lsa_lpt    !<
-       REAL(wp) ::  high_td_lsa_q     !<
-       REAL(wp) ::  low_td_lsa_q      !<
-       REAL(wp) ::  high_td_sub_lpt   !<
-       REAL(wp) ::  low_td_sub_lpt    !<
-       REAL(wp) ::  high_td_sub_q     !<
-       REAL(wp) ::  low_td_sub_q      !<
-       REAL(wp) ::  r_dummy           !<
-
-       ALLOCATE( p_surf(0:nlsf), pt_surf(0:nlsf), q_surf(0:nlsf),              &
-                 qsws_surf(0:nlsf), shf_surf(0:nlsf),                          &
-                 td_lsa_lpt(nzb:nzt+1,0:nlsf), td_lsa_q(nzb:nzt+1,0:nlsf),     &
-                 td_sub_lpt(nzb:nzt+1,0:nlsf), td_sub_q(nzb:nzt+1,0:nlsf),     &
-                 time_vert(0:nlsf), time_surf(0:nlsf),                         &
-                 ug_vert(nzb:nzt+1,0:nlsf), vg_vert(nzb:nzt+1,0:nlsf),         &
-                 wsubs_vert(nzb:nzt+1,0:nlsf) )
-
-       p_surf = 0.0_wp; pt_surf = 0.0_wp; q_surf = 0.0_wp; qsws_surf = 0.0_wp
-       shf_surf = 0.0_wp; time_vert = 0.0_wp; td_lsa_lpt = 0.0_wp
-       td_lsa_q = 0.0_wp; td_sub_lpt = 0.0_wp; td_sub_q = 0.0_wp
-       time_surf = 0.0_wp; ug_vert = 0.0_wp; vg_vert = 0.0_wp
-       wsubs_vert = 0.0_wp
-
-!
-!--    Array for storing large scale forcing and nudging tendencies at each 
-!--    timestep for data output
-       ALLOCATE( sums_ls_l(nzb:nzt+1,0:7) )
-       sums_ls_l = 0.0_wp
-
-       ngp_sums_ls = (nz+2)*6
-
-       OPEN ( finput, FILE='LSF_DATA', STATUS='OLD', &
-              FORM='FORMATTED', IOSTAT=ierrn )
-
-       IF ( ierrn /= 0 )  THEN
-          message_string = 'file LSF_DATA does not exist'
-          CALL message( 'ls_forcing', 'PA0368', 1, 2, 0, 6, 0 )
-       ENDIF
-
-       ierrn = 0
-!
-!--    First three lines of LSF_DATA contain header
-       READ ( finput, FMT='(a100)', IOSTAT=ierrn ) chmess
-       READ ( finput, FMT='(a100)', IOSTAT=ierrn ) chmess
-       READ ( finput, FMT='(a100)', IOSTAT=ierrn ) chmess
-
-       IF ( ierrn /= 0 )  THEN
-          message_string = 'errors in file LSF_DATA'
-          CALL message( 'ls_forcing', 'PA0369', 1, 2, 0, 6, 0 )
-       ENDIF
-
-!
-!--    Surface values are read in
-       nt     = 0
-       ierrn = 0
-
-       DO WHILE ( time_surf(nt) < end_time )
-          nt = nt + 1
-          READ ( finput, *, IOSTAT = ierrn ) time_surf(nt), shf_surf(nt),      &
-                                             qsws_surf(nt), pt_surf(nt),       &
-                                             q_surf(nt), p_surf(nt)
-
-          IF ( ierrn < 0 )  THEN
-            WRITE ( message_string, * ) 'No time dependent surface variables ',&
-                              'in&LSF_DATA for end of run found'
-
-             CALL message( 'ls_forcing', 'PA0363', 1, 2, 0, 6, 0 )
-          ENDIF
-       ENDDO
-
-
-       IF ( time_surf(1) > end_time )  THEN
-          WRITE ( message_string, * ) 'No time dependent surface variables in ',&
-                                     '&LSF_DATA for end of run found - ',      &
-                                     'lsf_surf is set to FALSE'
-          CALL message( 'ls_forcing', 'PA0371', 0, 0, 0, 6, 0 )
-          lsf_surf = .FALSE.
-       ENDIF
-
-!
-!--    Go to the end of the list with surface variables
-       DO WHILE ( ierrn == 0 )
-          READ ( finput, *, IOSTAT = ierrn ) r_dummy
-       ENDDO
-
-!
-!--    Profiles of ug, vg and w_subs are read in (large scale forcing)
-
-       nt = 0
-       DO WHILE ( time_vert(nt) < end_time )
-          nt = nt + 1
-          hash = "#"
-          ierrn = 1 ! not zero
-!
-!--       Search for the next line consisting of "# time", 
-!--       from there onwards the profiles will be read
-          DO WHILE ( .NOT. ( hash == "#" .AND. ierrn == 0 ) ) 
-             READ ( finput, *, IOSTAT=ierrn ) hash, time_vert(nt)
-             IF ( ierrn < 0 )  THEN 
-                WRITE( message_string, * ) 'No time dependent vertical profiles',&
-                                 ' in&LSF_DATA for end of run found'
-                CALL message( 'ls_forcing', 'PA0372', 1, 2, 0, 6, 0 )
-             ENDIF
-          ENDDO
-
-          IF ( nt == 1 .AND. time_vert(nt) > end_time ) EXIT
-
-          READ ( finput, *, IOSTAT=ierrn ) lowheight, lowug_vert, lowvg_vert,  &
-                                           lowwsubs_vert, low_td_lsa_lpt,      &
-                                           low_td_lsa_q, low_td_sub_lpt,       &
-                                           low_td_sub_q
-          IF ( ierrn /= 0 )  THEN
-             message_string = 'errors in file LSF_DATA'
-             CALL message( 'ls_forcing', 'PA0369', 1, 2, 0, 6, 0 )
-          ENDIF
-
-          READ ( finput, *, IOSTAT=ierrn ) highheight, highug_vert,            &
-                                           highvg_vert, highwsubs_vert,        &
-                                           high_td_lsa_lpt, high_td_lsa_q,     &
-                                           high_td_sub_lpt, high_td_sub_q
-      
-          IF ( ierrn /= 0 )  THEN
-             message_string = 'errors in file LSF_DATA'
-             CALL message( 'ls_forcing', 'PA0369', 1, 2, 0, 6, 0 )
-          ENDIF
-
-
-          DO  k = nzb, nzt+1
-             IF ( highheight < zu(k) )  THEN
-                lowheight      = highheight
-                lowug_vert     = highug_vert
-                lowvg_vert     = highvg_vert
-                lowwsubs_vert  = highwsubs_vert
-                low_td_lsa_lpt = high_td_lsa_lpt
-                low_td_lsa_q   = high_td_lsa_q
-                low_td_sub_lpt = high_td_sub_lpt
-                low_td_sub_q   = high_td_sub_q
-
-                ierrn = 0
-                READ ( finput, *, IOSTAT=ierrn ) highheight, highug_vert,      &
-                                                 highvg_vert, highwsubs_vert,  &
-                                                 high_td_lsa_lpt,              &
-                                                 high_td_lsa_q,                &
-                                                 high_td_sub_lpt, high_td_sub_q
-
-                IF ( ierrn /= 0 )  THEN
-                   WRITE( message_string, * ) 'zu(nzt+1) = ', zu(nzt+1), 'm ', &
-                        'is higher than the maximum height in LSF_DATA which ',&
-                        'is ', lowheight, 'm. Interpolation on PALM ',         &
-                        'grid is not possible.'
-                   CALL message( 'ls_forcing', 'PA0395', 1, 2, 0, 6, 0 )
-                ENDIF
-
-             ENDIF
-
-!
-!--          Interpolation of prescribed profiles in space 
-             fac = (highheight-zu(k))/(highheight - lowheight)
-
-             ug_vert(k,nt)    = fac * lowug_vert                               &
-                                + ( 1.0_wp - fac ) * highug_vert
-             vg_vert(k,nt)    = fac * lowvg_vert                               &
-                                + ( 1.0_wp - fac ) * highvg_vert
-             wsubs_vert(k,nt) = fac * lowwsubs_vert                            &
-                                + ( 1.0_wp - fac ) * highwsubs_vert
-
-             td_lsa_lpt(k,nt) = fac * low_td_lsa_lpt                           &
-                                + ( 1.0_wp - fac ) * high_td_lsa_lpt
-             td_lsa_q(k,nt)   = fac * low_td_lsa_q                             &
-                                + ( 1.0_wp - fac ) * high_td_lsa_q
-             td_sub_lpt(k,nt) = fac * low_td_sub_lpt                           &
-                                + ( 1.0_wp - fac ) * high_td_sub_lpt
-             td_sub_q(k,nt)   = fac * low_td_sub_q                             &
-                                + ( 1.0_wp - fac ) * high_td_sub_q
-
-          ENDDO
-
-       ENDDO 
-
-!
-!--    Large scale vertical velocity has to be zero at the surface
-       wsubs_vert(nzb,:) = 0.0_wp
- 
-       IF ( time_vert(1) > end_time )  THEN
-          WRITE ( message_string, * ) 'Time dependent large scale profile ',   &
-                             'forcing from&LSF_DATA sets in after end of ' ,   &
-                             'simulation - lsf_vert is set to FALSE'
-          CALL message( 'ls_forcing', 'PA0373', 0, 0, 0, 6, 0 )
-          lsf_vert = .FALSE.
-       ENDIF
-
-       CLOSE( finput )
-
-
-    END SUBROUTINE init_ls_forcing 
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> @todo Missing subroutine description.
-!------------------------------------------------------------------------------!
-    SUBROUTINE ls_forcing_surf ( time )
-
-       USE arrays_3d,                                                          &
-           ONLY:  p_surf, pt_surf, q_surf, qsws, qsws_surf, shf, shf_surf,     &
-                  time_surf, time_vert, ug, ug_vert, vg, vg_vert
-
-       USE control_parameters,                                                 &
-           ONLY:  bc_q_b, ibc_pt_b, ibc_q_b, pt_surface, q_surface,            &
-                  surface_pressure
-
-       USE kinds
-
-       IMPLICIT NONE
-
-       INTEGER(iwp) ::  nt                     !<
-
-       REAL(wp)             :: fac            !<
-       REAL(wp), INTENT(in) :: time           !<
-
-!
-!--    Interpolation in time of LSF_DATA at the surface
-       nt = 1
-       DO WHILE ( time > time_surf(nt) )
-          nt = nt + 1
-       ENDDO
-       IF ( time /= time_surf(nt) )  THEN
-         nt = nt - 1
-       ENDIF
-
-       fac = ( time -time_surf(nt) ) / ( time_surf(nt+1) - time_surf(nt) )
-
-       IF ( ibc_pt_b == 0 )  THEN
-!
-!--       In case of Dirichlet boundary condition shf must not 
-!--       be set - it is calculated via MOST in prandtl_fluxes
-          pt_surface = pt_surf(nt) + fac * ( pt_surf(nt+1) - pt_surf(nt) )
-
-       ELSEIF ( ibc_pt_b == 1 )  THEN
-!
-!--       In case of Neumann boundary condition pt_surface is needed for 
-!--       calculation of reference density
-          shf        = shf_surf(nt) + fac * ( shf_surf(nt+1) - shf_surf(nt) )
-          pt_surface = pt_surf(nt) + fac * ( pt_surf(nt+1) - pt_surf(nt) )
-
-       ENDIF
-
-       IF ( ibc_q_b == 0 )  THEN
-!
-!--       In case of Dirichlet boundary condition qsws must not 
-!--       be set - it is calculated via MOST in prandtl_fluxes
-          q_surface = q_surf(nt) + fac * ( q_surf(nt+1) - q_surf(nt) )
-
-       ELSEIF ( ibc_q_b == 1 )  THEN
-
-          qsws = qsws_surf(nt) + fac * ( qsws_surf(nt+1) - qsws_surf(nt) )
-
-       ENDIF
-
-       surface_pressure = p_surf(nt) + fac * ( p_surf(nt+1) - p_surf(nt) )
-
-    END SUBROUTINE ls_forcing_surf 
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> @todo Missing subroutine description.
-!------------------------------------------------------------------------------!
-    SUBROUTINE ls_forcing_vert ( time )
-
-       USE arrays_3d,                                                          &
-           ONLY:  time_vert, ug, ug_vert, vg, vg_vert, w_subs, wsubs_vert
-
-       USE control_parameters,                                                 &
-           ONLY:  large_scale_subsidence
-
-       USE kinds
-
-       IMPLICIT NONE
-
-       INTEGER(iwp) ::  nt                     !<
-
-       REAL(wp)             ::  fac           !<
-       REAL(wp), INTENT(in) ::  time          !<
-
-!
-!--    Interpolation in time of LSF_DATA for ug, vg and w_subs
-       nt = 1
-       DO WHILE ( time > time_vert(nt) )
-          nt = nt + 1
-       ENDDO
-       IF ( time /= time_vert(nt) )  THEN
-         nt = nt - 1
-       ENDIF
-
-       fac = ( time-time_vert(nt) ) / ( time_vert(nt+1)-time_vert(nt) )
-
-       ug     = ug_vert(:,nt) + fac * ( ug_vert(:,nt+1) - ug_vert(:,nt) )
-       vg     = vg_vert(:,nt) + fac * ( vg_vert(:,nt+1) - vg_vert(:,nt) )
-
-       IF ( large_scale_subsidence )  THEN
-          w_subs = wsubs_vert(:,nt)                                            &
-                   + fac * ( wsubs_vert(:,nt+1) - wsubs_vert(:,nt) )
-       ENDIF
-
-    END SUBROUTINE ls_forcing_vert
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Call for all grid points
-!------------------------------------------------------------------------------!
-    SUBROUTINE ls_advec ( time, prog_var )
-
-       USE arrays_3d,                                                          &
-           ONLY:  td_lsa_lpt, td_lsa_q, td_sub_lpt, td_sub_q, tend, time_vert        
-       
-       USE control_parameters,                                                 &
-           ONLY:  large_scale_subsidence, use_subsidence_tendencies
-       
-       USE indices
-       
-       USE kinds
-
-       IMPLICIT NONE
-
-       CHARACTER (LEN=*) ::  prog_var   !< 
-
-       REAL(wp), INTENT(in)  :: time    !< 
-       REAL(wp) :: fac                  !<  
-
-       INTEGER(iwp) ::  i               !< 
-       INTEGER(iwp) ::  j               !< 
-       INTEGER(iwp) ::  k               !< 
-       INTEGER(iwp) ::  nt               !< 
-
-!
-!--    Interpolation in time of LSF_DATA 
-       nt = 1
-       DO WHILE ( time > time_vert(nt) )
-          nt = nt + 1
-       ENDDO
-       IF ( time /= time_vert(nt) )  THEN
-         nt = nt - 1
-       ENDIF
-
-       fac = ( time-time_vert(nt) ) / ( time_vert(nt+1)-time_vert(nt) )
-
-!
-!--    Add horizontal large scale advection tendencies of pt and q 
-       SELECT CASE ( prog_var )
-
-          CASE ( 'pt' )
-
-             DO  i = nxl, nxr
-                DO  j = nys, nyn
-                   DO  k = nzb_u_inner(j,i)+1, nzt
-                      tend(k,j,i) = tend(k,j,i) + td_lsa_lpt(k,nt) + fac *     &
-                                    ( td_lsa_lpt(k,nt+1) - td_lsa_lpt(k,nt) )
-                   ENDDO
-                ENDDO
-             ENDDO
-
-          CASE ( 'q' )
-
-             DO  i = nxl, nxr
-                DO  j = nys, nyn
-                   DO  k = nzb_u_inner(j,i)+1, nzt
-                      tend(k,j,i) = tend(k,j,i) + td_lsa_q(k,nt) + fac *       &
-                                    ( td_lsa_q(k,nt+1) - td_lsa_q(k,nt) )
-                   ENDDO
-                ENDDO
-             ENDDO
-
-       END SELECT
-
-!
-!--    Subsidence of pt and q with prescribed subsidence tendencies
-       IF ( large_scale_subsidence .AND. use_subsidence_tendencies )  THEN
-
-          SELECT CASE ( prog_var )
-
-             CASE ( 'pt' )
-
-                DO  i = nxl, nxr
-                   DO  j = nys, nyn
-                      DO  k = nzb_u_inner(j,i)+1, nzt
-                         tend(k,j,i) = tend(k,j,i) + td_sub_lpt(k,nt) + fac *  &
-                                       ( td_sub_lpt(k,nt+1) - td_sub_lpt(k,nt) )
-                      ENDDO
-                   ENDDO
-                ENDDO
-  
-             CASE ( 'q' )
-
-                DO  i = nxl, nxr
-                   DO  j = nys, nyn
-                      DO  k = nzb_u_inner(j,i)+1, nzt
-                         tend(k,j,i) = tend(k,j,i) + td_sub_q(k,nt) + fac *    &
-                                       ( td_sub_q(k,nt+1) - td_sub_q(k,nt) )
-                      ENDDO
-                   ENDDO
-                ENDDO
-
-          END SELECT
-
-       ENDIF
-
-    END SUBROUTINE ls_advec
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Call for grid point i,j
-!------------------------------------------------------------------------------!
-    SUBROUTINE ls_advec_ij ( i, j, time, prog_var )
-
-       USE arrays_3d,                                                          &
-           ONLY:  td_lsa_lpt, td_lsa_q, td_sub_lpt, td_sub_q, tend, time_vert        
-       
-       USE control_parameters,                                                 &
-           ONLY:  large_scale_subsidence, use_subsidence_tendencies
-       
-       USE indices
-       
-       USE kinds
-
-       IMPLICIT NONE
-
-       CHARACTER (LEN=*) ::  prog_var   !< 
-
-       REAL(wp), INTENT(in)  :: time    !< 
-       REAL(wp) :: fac                  !< 
-
-       INTEGER(iwp) ::  i               !< 
-       INTEGER(iwp) ::  j               !< 
-       INTEGER(iwp) ::  k               !< 
-       INTEGER(iwp) ::  nt               !< 
-
-!
-!--    Interpolation in time of LSF_DATA 
-       nt = 1
-       DO WHILE ( time > time_vert(nt) )
-          nt = nt + 1
-       ENDDO
-       IF ( time /= time_vert(nt) )  THEN
-         nt = nt - 1
-       ENDIF
-
-       fac = ( time-time_vert(nt) ) / ( time_vert(nt+1)-time_vert(nt) )
-
-!
-!--    Add horizontal large scale advection tendencies of pt and q 
-       SELECT CASE ( prog_var )
-
-          CASE ( 'pt' )
-
-             DO  k = nzb_u_inner(j,i)+1, nzt
-                tend(k,j,i) = tend(k,j,i) + td_lsa_lpt(k,nt)                   &
-                              + fac * ( td_lsa_lpt(k,nt+1) - td_lsa_lpt(k,nt) )
-             ENDDO
-
-          CASE ( 'q' )
-
-             DO  k = nzb_u_inner(j,i)+1, nzt
-                tend(k,j,i) = tend(k,j,i) + td_lsa_q(k,nt)                     &
-                              + fac * ( td_lsa_q(k,nt+1) - td_lsa_q(k,nt) )
-             ENDDO
-
-       END SELECT
-
-!
-!--    Subsidence of pt and q with prescribed profiles
-       IF ( large_scale_subsidence .AND. use_subsidence_tendencies )  THEN
-
-          SELECT CASE ( prog_var )
-
-             CASE ( 'pt' )
-
-                DO  k = nzb_u_inner(j,i)+1, nzt
-                   tend(k,j,i) = tend(k,j,i) + td_sub_lpt(k,nt) + fac *        &
-                                 ( td_sub_lpt(k,nt+1) - td_sub_lpt(k,nt) )
-                ENDDO
-  
-             CASE ( 'q' )
-
-                DO  k = nzb_u_inner(j,i)+1, nzt
-                   tend(k,j,i) = tend(k,j,i) + td_sub_q(k,nt) + fac *          &
-                                 ( td_sub_q(k,nt+1) - td_sub_q(k,nt) )
-                ENDDO
-
-          END SELECT
-
-       ENDIF
-
-    END SUBROUTINE ls_advec_ij
-
-
- END MODULE ls_forcing_mod
Index: /palm/trunk/SOURCE/ls_forcing_mod.f90
===================================================================
--- /palm/trunk/SOURCE/ls_forcing_mod.f90	(revision 1850)
+++ /palm/trunk/SOURCE/ls_forcing_mod.f90	(revision 1850)
@@ -0,0 +1,640 @@
+!> @file ls_forcing_mod.f90
+!--------------------------------------------------------------------------------!
+! This file is part of PALM.
+!
+! PALM is free software: you can redistribute it and/or modify it under the terms
+! of the GNU General Public License as published by the Free Software Foundation,
+! either version 3 of the License, or (at your option) any later version.
+!
+! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
+! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
+! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along with
+! PALM. If not, see <http://www.gnu.org/licenses/>.
+!
+! Copyright 1997-2016 Leibniz Universitaet Hannover
+!--------------------------------------------------------------------------------!
+!
+! Current revisions:
+! ------------------
+! Module renamed
+! 
+! 
+! Former revisions:
+! -----------------
+! $Id$
+!
+! 1682 2015-10-07 23:56:08Z knoop
+! Code annotations made doxygen readable
+! 
+! 1602 2015-06-22 07:50:56Z heinze 
+! PA0370 changed to PA0363
+!
+! 1382 2014-04-30 12:15:41Z boeske
+! Renamed variables which store large scale forcing tendencies
+! pt_lsa -> td_lsa_lpt, pt_subs -> td_sub_lpt, 
+! q_lsa  -> td_lsa_q,   q_subs  -> td_sub_q,
+! high|lowpt_lsa -> high|low_td_lsa_lpt, ...
+! 
+! 1365 2014-04-22 15:03:56Z boeske
+! Usage of large scale forcing for pt and q enabled:
+! Added new subroutine ls_advec for horizontal large scale advection and large 
+! scale subsidence, 
+! error message in init_ls_forcing specified,
+! variable t renamed nt
+! 
+! 1353 2014-04-08 15:21:23Z heinze
+! REAL constants provided with KIND-attribute
+!
+! 1320 2014-03-20 08:40:49Z raasch
+! ONLY-attribute added to USE-statements,
+! kind-parameters added to all INTEGER and REAL declaration statements,
+! kinds are defined in new module kinds,
+! comment fields (!:) to be used for variable explanations added to
+! all variable declaration statements
+!
+! 1318 2014-03-17 13:35:16Z raasch
+! module interfaces removed
+!
+! 1299 2014-03-06 13:15:21Z heinze
+! Ensure a zero large scale vertical velocity at the surface
+! Bugfix: typo in case of boundary condition in if-clause
+!
+! 1276 2014-01-15 13:40:41Z heinze
+! Use LSF_DATA also in case of Dirichlet bottom boundary condition for scalars
+!
+! 1249 2013-11-06 10:45:47Z heinze
+! remove call of user module
+! reformatting
+!
+! 1241 2013-10-30 11:36:58Z heinze
+! Initial revision
+!
+! Description:
+! ------------
+!> Calculates large scale forcings (geostrophic wind and subsidence velocity) as 
+!> well as surfaces fluxes dependent on time given in an external file (LSF_DATA).
+!> Code is based in parts on DALES and UCLA-LES.
+!--------------------------------------------------------------------------------!
+ MODULE ls_forcing_mod
+ 
+
+    PRIVATE
+    PUBLIC init_ls_forcing, ls_forcing_surf, ls_forcing_vert, ls_advec
+    SAVE
+
+    INTERFACE ls_advec
+       MODULE PROCEDURE ls_advec
+       MODULE PROCEDURE ls_advec_ij
+    END INTERFACE ls_advec
+
+ CONTAINS
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> @todo Missing subroutine description.
+!------------------------------------------------------------------------------!
+    SUBROUTINE init_ls_forcing
+
+       USE arrays_3d,                                                          &
+           ONLY:  p_surf, pt_surf, q_surf, qsws_surf, shf_surf, td_lsa_lpt,    &
+                  td_lsa_q, td_sub_lpt, td_sub_q, time_surf, time_vert,        &
+                  ug_vert, vg_vert, wsubs_vert, zu
+
+       USE control_parameters,                                                 &
+           ONLY:  end_time, lsf_surf, lsf_vert, message_string, nlsf
+
+       USE indices,                                                            &
+           ONLY:  ngp_sums_ls, nzb, nz, nzt
+
+       USE kinds
+
+       USE statistics,                                                         &
+           ONLY:  sums_ls_l
+
+
+       IMPLICIT NONE
+
+       CHARACTER(100) ::  chmess      !<
+       CHARACTER(1)   ::  hash        !<
+
+       INTEGER(iwp) ::  ierrn         !<
+       INTEGER(iwp) ::  finput = 90   !<
+       INTEGER(iwp) ::  k             !<
+       INTEGER(iwp) ::  nt             !<
+
+       REAL(wp) ::  fac               !<
+       REAL(wp) ::  highheight        !<
+       REAL(wp) ::  highug_vert       !<
+       REAL(wp) ::  highvg_vert       !<
+       REAL(wp) ::  highwsubs_vert    !<
+       REAL(wp) ::  lowheight         !<
+       REAL(wp) ::  lowug_vert        !<
+       REAL(wp) ::  lowvg_vert        !<
+       REAL(wp) ::  lowwsubs_vert     !<
+       REAL(wp) ::  high_td_lsa_lpt   !<
+       REAL(wp) ::  low_td_lsa_lpt    !<
+       REAL(wp) ::  high_td_lsa_q     !<
+       REAL(wp) ::  low_td_lsa_q      !<
+       REAL(wp) ::  high_td_sub_lpt   !<
+       REAL(wp) ::  low_td_sub_lpt    !<
+       REAL(wp) ::  high_td_sub_q     !<
+       REAL(wp) ::  low_td_sub_q      !<
+       REAL(wp) ::  r_dummy           !<
+
+       ALLOCATE( p_surf(0:nlsf), pt_surf(0:nlsf), q_surf(0:nlsf),              &
+                 qsws_surf(0:nlsf), shf_surf(0:nlsf),                          &
+                 td_lsa_lpt(nzb:nzt+1,0:nlsf), td_lsa_q(nzb:nzt+1,0:nlsf),     &
+                 td_sub_lpt(nzb:nzt+1,0:nlsf), td_sub_q(nzb:nzt+1,0:nlsf),     &
+                 time_vert(0:nlsf), time_surf(0:nlsf),                         &
+                 ug_vert(nzb:nzt+1,0:nlsf), vg_vert(nzb:nzt+1,0:nlsf),         &
+                 wsubs_vert(nzb:nzt+1,0:nlsf) )
+
+       p_surf = 0.0_wp; pt_surf = 0.0_wp; q_surf = 0.0_wp; qsws_surf = 0.0_wp
+       shf_surf = 0.0_wp; time_vert = 0.0_wp; td_lsa_lpt = 0.0_wp
+       td_lsa_q = 0.0_wp; td_sub_lpt = 0.0_wp; td_sub_q = 0.0_wp
+       time_surf = 0.0_wp; ug_vert = 0.0_wp; vg_vert = 0.0_wp
+       wsubs_vert = 0.0_wp
+
+!
+!--    Array for storing large scale forcing and nudging tendencies at each 
+!--    timestep for data output
+       ALLOCATE( sums_ls_l(nzb:nzt+1,0:7) )
+       sums_ls_l = 0.0_wp
+
+       ngp_sums_ls = (nz+2)*6
+
+       OPEN ( finput, FILE='LSF_DATA', STATUS='OLD', &
+              FORM='FORMATTED', IOSTAT=ierrn )
+
+       IF ( ierrn /= 0 )  THEN
+          message_string = 'file LSF_DATA does not exist'
+          CALL message( 'ls_forcing', 'PA0368', 1, 2, 0, 6, 0 )
+       ENDIF
+
+       ierrn = 0
+!
+!--    First three lines of LSF_DATA contain header
+       READ ( finput, FMT='(a100)', IOSTAT=ierrn ) chmess
+       READ ( finput, FMT='(a100)', IOSTAT=ierrn ) chmess
+       READ ( finput, FMT='(a100)', IOSTAT=ierrn ) chmess
+
+       IF ( ierrn /= 0 )  THEN
+          message_string = 'errors in file LSF_DATA'
+          CALL message( 'ls_forcing', 'PA0369', 1, 2, 0, 6, 0 )
+       ENDIF
+
+!
+!--    Surface values are read in
+       nt     = 0
+       ierrn = 0
+
+       DO WHILE ( time_surf(nt) < end_time )
+          nt = nt + 1
+          READ ( finput, *, IOSTAT = ierrn ) time_surf(nt), shf_surf(nt),      &
+                                             qsws_surf(nt), pt_surf(nt),       &
+                                             q_surf(nt), p_surf(nt)
+
+          IF ( ierrn < 0 )  THEN
+            WRITE ( message_string, * ) 'No time dependent surface variables ',&
+                              'in&LSF_DATA for end of run found'
+
+             CALL message( 'ls_forcing', 'PA0363', 1, 2, 0, 6, 0 )
+          ENDIF
+       ENDDO
+
+
+       IF ( time_surf(1) > end_time )  THEN
+          WRITE ( message_string, * ) 'No time dependent surface variables in ',&
+                                     '&LSF_DATA for end of run found - ',      &
+                                     'lsf_surf is set to FALSE'
+          CALL message( 'ls_forcing', 'PA0371', 0, 0, 0, 6, 0 )
+          lsf_surf = .FALSE.
+       ENDIF
+
+!
+!--    Go to the end of the list with surface variables
+       DO WHILE ( ierrn == 0 )
+          READ ( finput, *, IOSTAT = ierrn ) r_dummy
+       ENDDO
+
+!
+!--    Profiles of ug, vg and w_subs are read in (large scale forcing)
+
+       nt = 0
+       DO WHILE ( time_vert(nt) < end_time )
+          nt = nt + 1
+          hash = "#"
+          ierrn = 1 ! not zero
+!
+!--       Search for the next line consisting of "# time", 
+!--       from there onwards the profiles will be read
+          DO WHILE ( .NOT. ( hash == "#" .AND. ierrn == 0 ) ) 
+             READ ( finput, *, IOSTAT=ierrn ) hash, time_vert(nt)
+             IF ( ierrn < 0 )  THEN 
+                WRITE( message_string, * ) 'No time dependent vertical profiles',&
+                                 ' in&LSF_DATA for end of run found'
+                CALL message( 'ls_forcing', 'PA0372', 1, 2, 0, 6, 0 )
+             ENDIF
+          ENDDO
+
+          IF ( nt == 1 .AND. time_vert(nt) > end_time ) EXIT
+
+          READ ( finput, *, IOSTAT=ierrn ) lowheight, lowug_vert, lowvg_vert,  &
+                                           lowwsubs_vert, low_td_lsa_lpt,      &
+                                           low_td_lsa_q, low_td_sub_lpt,       &
+                                           low_td_sub_q
+          IF ( ierrn /= 0 )  THEN
+             message_string = 'errors in file LSF_DATA'
+             CALL message( 'ls_forcing', 'PA0369', 1, 2, 0, 6, 0 )
+          ENDIF
+
+          READ ( finput, *, IOSTAT=ierrn ) highheight, highug_vert,            &
+                                           highvg_vert, highwsubs_vert,        &
+                                           high_td_lsa_lpt, high_td_lsa_q,     &
+                                           high_td_sub_lpt, high_td_sub_q
+      
+          IF ( ierrn /= 0 )  THEN
+             message_string = 'errors in file LSF_DATA'
+             CALL message( 'ls_forcing', 'PA0369', 1, 2, 0, 6, 0 )
+          ENDIF
+
+
+          DO  k = nzb, nzt+1
+             IF ( highheight < zu(k) )  THEN
+                lowheight      = highheight
+                lowug_vert     = highug_vert
+                lowvg_vert     = highvg_vert
+                lowwsubs_vert  = highwsubs_vert
+                low_td_lsa_lpt = high_td_lsa_lpt
+                low_td_lsa_q   = high_td_lsa_q
+                low_td_sub_lpt = high_td_sub_lpt
+                low_td_sub_q   = high_td_sub_q
+
+                ierrn = 0
+                READ ( finput, *, IOSTAT=ierrn ) highheight, highug_vert,      &
+                                                 highvg_vert, highwsubs_vert,  &
+                                                 high_td_lsa_lpt,              &
+                                                 high_td_lsa_q,                &
+                                                 high_td_sub_lpt, high_td_sub_q
+
+                IF ( ierrn /= 0 )  THEN
+                   WRITE( message_string, * ) 'zu(nzt+1) = ', zu(nzt+1), 'm ', &
+                        'is higher than the maximum height in LSF_DATA which ',&
+                        'is ', lowheight, 'm. Interpolation on PALM ',         &
+                        'grid is not possible.'
+                   CALL message( 'ls_forcing', 'PA0395', 1, 2, 0, 6, 0 )
+                ENDIF
+
+             ENDIF
+
+!
+!--          Interpolation of prescribed profiles in space 
+             fac = (highheight-zu(k))/(highheight - lowheight)
+
+             ug_vert(k,nt)    = fac * lowug_vert                               &
+                                + ( 1.0_wp - fac ) * highug_vert
+             vg_vert(k,nt)    = fac * lowvg_vert                               &
+                                + ( 1.0_wp - fac ) * highvg_vert
+             wsubs_vert(k,nt) = fac * lowwsubs_vert                            &
+                                + ( 1.0_wp - fac ) * highwsubs_vert
+
+             td_lsa_lpt(k,nt) = fac * low_td_lsa_lpt                           &
+                                + ( 1.0_wp - fac ) * high_td_lsa_lpt
+             td_lsa_q(k,nt)   = fac * low_td_lsa_q                             &
+                                + ( 1.0_wp - fac ) * high_td_lsa_q
+             td_sub_lpt(k,nt) = fac * low_td_sub_lpt                           &
+                                + ( 1.0_wp - fac ) * high_td_sub_lpt
+             td_sub_q(k,nt)   = fac * low_td_sub_q                             &
+                                + ( 1.0_wp - fac ) * high_td_sub_q
+
+          ENDDO
+
+       ENDDO 
+
+!
+!--    Large scale vertical velocity has to be zero at the surface
+       wsubs_vert(nzb,:) = 0.0_wp
+ 
+       IF ( time_vert(1) > end_time )  THEN
+          WRITE ( message_string, * ) 'Time dependent large scale profile ',   &
+                             'forcing from&LSF_DATA sets in after end of ' ,   &
+                             'simulation - lsf_vert is set to FALSE'
+          CALL message( 'ls_forcing', 'PA0373', 0, 0, 0, 6, 0 )
+          lsf_vert = .FALSE.
+       ENDIF
+
+       CLOSE( finput )
+
+
+    END SUBROUTINE init_ls_forcing 
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> @todo Missing subroutine description.
+!------------------------------------------------------------------------------!
+    SUBROUTINE ls_forcing_surf ( time )
+
+       USE arrays_3d,                                                          &
+           ONLY:  p_surf, pt_surf, q_surf, qsws, qsws_surf, shf, shf_surf,     &
+                  time_surf, time_vert, ug, ug_vert, vg, vg_vert
+
+       USE control_parameters,                                                 &
+           ONLY:  bc_q_b, ibc_pt_b, ibc_q_b, pt_surface, q_surface,            &
+                  surface_pressure
+
+       USE kinds
+
+       IMPLICIT NONE
+
+       INTEGER(iwp) ::  nt                     !<
+
+       REAL(wp)             :: fac            !<
+       REAL(wp), INTENT(in) :: time           !<
+
+!
+!--    Interpolation in time of LSF_DATA at the surface
+       nt = 1
+       DO WHILE ( time > time_surf(nt) )
+          nt = nt + 1
+       ENDDO
+       IF ( time /= time_surf(nt) )  THEN
+         nt = nt - 1
+       ENDIF
+
+       fac = ( time -time_surf(nt) ) / ( time_surf(nt+1) - time_surf(nt) )
+
+       IF ( ibc_pt_b == 0 )  THEN
+!
+!--       In case of Dirichlet boundary condition shf must not 
+!--       be set - it is calculated via MOST in prandtl_fluxes
+          pt_surface = pt_surf(nt) + fac * ( pt_surf(nt+1) - pt_surf(nt) )
+
+       ELSEIF ( ibc_pt_b == 1 )  THEN
+!
+!--       In case of Neumann boundary condition pt_surface is needed for 
+!--       calculation of reference density
+          shf        = shf_surf(nt) + fac * ( shf_surf(nt+1) - shf_surf(nt) )
+          pt_surface = pt_surf(nt) + fac * ( pt_surf(nt+1) - pt_surf(nt) )
+
+       ENDIF
+
+       IF ( ibc_q_b == 0 )  THEN
+!
+!--       In case of Dirichlet boundary condition qsws must not 
+!--       be set - it is calculated via MOST in prandtl_fluxes
+          q_surface = q_surf(nt) + fac * ( q_surf(nt+1) - q_surf(nt) )
+
+       ELSEIF ( ibc_q_b == 1 )  THEN
+
+          qsws = qsws_surf(nt) + fac * ( qsws_surf(nt+1) - qsws_surf(nt) )
+
+       ENDIF
+
+       surface_pressure = p_surf(nt) + fac * ( p_surf(nt+1) - p_surf(nt) )
+
+    END SUBROUTINE ls_forcing_surf 
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> @todo Missing subroutine description.
+!------------------------------------------------------------------------------!
+    SUBROUTINE ls_forcing_vert ( time )
+
+       USE arrays_3d,                                                          &
+           ONLY:  time_vert, ug, ug_vert, vg, vg_vert, w_subs, wsubs_vert
+
+       USE control_parameters,                                                 &
+           ONLY:  large_scale_subsidence
+
+       USE kinds
+
+       IMPLICIT NONE
+
+       INTEGER(iwp) ::  nt                     !<
+
+       REAL(wp)             ::  fac           !<
+       REAL(wp), INTENT(in) ::  time          !<
+
+!
+!--    Interpolation in time of LSF_DATA for ug, vg and w_subs
+       nt = 1
+       DO WHILE ( time > time_vert(nt) )
+          nt = nt + 1
+       ENDDO
+       IF ( time /= time_vert(nt) )  THEN
+         nt = nt - 1
+       ENDIF
+
+       fac = ( time-time_vert(nt) ) / ( time_vert(nt+1)-time_vert(nt) )
+
+       ug     = ug_vert(:,nt) + fac * ( ug_vert(:,nt+1) - ug_vert(:,nt) )
+       vg     = vg_vert(:,nt) + fac * ( vg_vert(:,nt+1) - vg_vert(:,nt) )
+
+       IF ( large_scale_subsidence )  THEN
+          w_subs = wsubs_vert(:,nt)                                            &
+                   + fac * ( wsubs_vert(:,nt+1) - wsubs_vert(:,nt) )
+       ENDIF
+
+    END SUBROUTINE ls_forcing_vert
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Call for all grid points
+!------------------------------------------------------------------------------!
+    SUBROUTINE ls_advec ( time, prog_var )
+
+       USE arrays_3d,                                                          &
+           ONLY:  td_lsa_lpt, td_lsa_q, td_sub_lpt, td_sub_q, tend, time_vert        
+       
+       USE control_parameters,                                                 &
+           ONLY:  large_scale_subsidence, use_subsidence_tendencies
+       
+       USE indices
+       
+       USE kinds
+
+       IMPLICIT NONE
+
+       CHARACTER (LEN=*) ::  prog_var   !< 
+
+       REAL(wp), INTENT(in)  :: time    !< 
+       REAL(wp) :: fac                  !<  
+
+       INTEGER(iwp) ::  i               !< 
+       INTEGER(iwp) ::  j               !< 
+       INTEGER(iwp) ::  k               !< 
+       INTEGER(iwp) ::  nt               !< 
+
+!
+!--    Interpolation in time of LSF_DATA 
+       nt = 1
+       DO WHILE ( time > time_vert(nt) )
+          nt = nt + 1
+       ENDDO
+       IF ( time /= time_vert(nt) )  THEN
+         nt = nt - 1
+       ENDIF
+
+       fac = ( time-time_vert(nt) ) / ( time_vert(nt+1)-time_vert(nt) )
+
+!
+!--    Add horizontal large scale advection tendencies of pt and q 
+       SELECT CASE ( prog_var )
+
+          CASE ( 'pt' )
+
+             DO  i = nxl, nxr
+                DO  j = nys, nyn
+                   DO  k = nzb_u_inner(j,i)+1, nzt
+                      tend(k,j,i) = tend(k,j,i) + td_lsa_lpt(k,nt) + fac *     &
+                                    ( td_lsa_lpt(k,nt+1) - td_lsa_lpt(k,nt) )
+                   ENDDO
+                ENDDO
+             ENDDO
+
+          CASE ( 'q' )
+
+             DO  i = nxl, nxr
+                DO  j = nys, nyn
+                   DO  k = nzb_u_inner(j,i)+1, nzt
+                      tend(k,j,i) = tend(k,j,i) + td_lsa_q(k,nt) + fac *       &
+                                    ( td_lsa_q(k,nt+1) - td_lsa_q(k,nt) )
+                   ENDDO
+                ENDDO
+             ENDDO
+
+       END SELECT
+
+!
+!--    Subsidence of pt and q with prescribed subsidence tendencies
+       IF ( large_scale_subsidence .AND. use_subsidence_tendencies )  THEN
+
+          SELECT CASE ( prog_var )
+
+             CASE ( 'pt' )
+
+                DO  i = nxl, nxr
+                   DO  j = nys, nyn
+                      DO  k = nzb_u_inner(j,i)+1, nzt
+                         tend(k,j,i) = tend(k,j,i) + td_sub_lpt(k,nt) + fac *  &
+                                       ( td_sub_lpt(k,nt+1) - td_sub_lpt(k,nt) )
+                      ENDDO
+                   ENDDO
+                ENDDO
+  
+             CASE ( 'q' )
+
+                DO  i = nxl, nxr
+                   DO  j = nys, nyn
+                      DO  k = nzb_u_inner(j,i)+1, nzt
+                         tend(k,j,i) = tend(k,j,i) + td_sub_q(k,nt) + fac *    &
+                                       ( td_sub_q(k,nt+1) - td_sub_q(k,nt) )
+                      ENDDO
+                   ENDDO
+                ENDDO
+
+          END SELECT
+
+       ENDIF
+
+    END SUBROUTINE ls_advec
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Call for grid point i,j
+!------------------------------------------------------------------------------!
+    SUBROUTINE ls_advec_ij ( i, j, time, prog_var )
+
+       USE arrays_3d,                                                          &
+           ONLY:  td_lsa_lpt, td_lsa_q, td_sub_lpt, td_sub_q, tend, time_vert        
+       
+       USE control_parameters,                                                 &
+           ONLY:  large_scale_subsidence, use_subsidence_tendencies
+       
+       USE indices
+       
+       USE kinds
+
+       IMPLICIT NONE
+
+       CHARACTER (LEN=*) ::  prog_var   !< 
+
+       REAL(wp), INTENT(in)  :: time    !< 
+       REAL(wp) :: fac                  !< 
+
+       INTEGER(iwp) ::  i               !< 
+       INTEGER(iwp) ::  j               !< 
+       INTEGER(iwp) ::  k               !< 
+       INTEGER(iwp) ::  nt               !< 
+
+!
+!--    Interpolation in time of LSF_DATA 
+       nt = 1
+       DO WHILE ( time > time_vert(nt) )
+          nt = nt + 1
+       ENDDO
+       IF ( time /= time_vert(nt) )  THEN
+         nt = nt - 1
+       ENDIF
+
+       fac = ( time-time_vert(nt) ) / ( time_vert(nt+1)-time_vert(nt) )
+
+!
+!--    Add horizontal large scale advection tendencies of pt and q 
+       SELECT CASE ( prog_var )
+
+          CASE ( 'pt' )
+
+             DO  k = nzb_u_inner(j,i)+1, nzt
+                tend(k,j,i) = tend(k,j,i) + td_lsa_lpt(k,nt)                   &
+                              + fac * ( td_lsa_lpt(k,nt+1) - td_lsa_lpt(k,nt) )
+             ENDDO
+
+          CASE ( 'q' )
+
+             DO  k = nzb_u_inner(j,i)+1, nzt
+                tend(k,j,i) = tend(k,j,i) + td_lsa_q(k,nt)                     &
+                              + fac * ( td_lsa_q(k,nt+1) - td_lsa_q(k,nt) )
+             ENDDO
+
+       END SELECT
+
+!
+!--    Subsidence of pt and q with prescribed profiles
+       IF ( large_scale_subsidence .AND. use_subsidence_tendencies )  THEN
+
+          SELECT CASE ( prog_var )
+
+             CASE ( 'pt' )
+
+                DO  k = nzb_u_inner(j,i)+1, nzt
+                   tend(k,j,i) = tend(k,j,i) + td_sub_lpt(k,nt) + fac *        &
+                                 ( td_sub_lpt(k,nt+1) - td_sub_lpt(k,nt) )
+                ENDDO
+  
+             CASE ( 'q' )
+
+                DO  k = nzb_u_inner(j,i)+1, nzt
+                   tend(k,j,i) = tend(k,j,i) + td_sub_q(k,nt) + fac *          &
+                                 ( td_sub_q(k,nt+1) - td_sub_q(k,nt) )
+                ENDDO
+
+          END SELECT
+
+       ENDIF
+
+    END SUBROUTINE ls_advec_ij
+
+
+ END MODULE ls_forcing_mod
Index: lm/trunk/SOURCE/microphysics.f90
===================================================================
--- /palm/trunk/SOURCE/microphysics.f90	(revision 1849)
+++ 	(revision )
@@ -1,2224 +1,0 @@
-!> @file microphysics.f90
-!--------------------------------------------------------------------------------!
-! This file is part of PALM.
-!
-! PALM is free software: you can redistribute it and/or modify it under the terms
-! of the GNU General Public License as published by the Free Software Foundation,
-! either version 3 of the License, or (at your option) any later version.
-!
-! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
-! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
-! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along with
-! PALM. If not, see <http://www.gnu.org/licenses/>.
-!
-! Copyright 1997-2016 Leibniz Universitaet Hannover
-!--------------------------------------------------------------------------------!
-!
-! Current revisions:
-! ------------------
-! Adapted for modularization of microphysics.
-!
-! Former revisions:
-! -----------------
-! $Id$
-!
-! 1845 2016-04-08 08:29:13Z raasch
-! nzb_2d replaced by nzb_s_inner, Kessler precipitation is stored at surface
-! point (instead of one point above surface)
-!
-! 1831 2016-04-07 13:15:51Z hoffmann
-! turbulence renamed collision_turbulence,
-! drizzle renamed cloud_water_sedimentation. cloud_water_sedimentation also
-! avaialble for microphysics_kessler.
-!
-! 1822 2016-04-07 07:49:42Z hoffmann
-! Unused variables removed.
-! Kessler scheme integrated.
-!
-! 1691 2015-10-26 16:17:44Z maronga
-! Added new routine calc_precipitation_amount. The routine now allows to account
-! for precipitation due to sedimenation of cloud (fog) droplets
-! 
-! 1682 2015-10-07 23:56:08Z knoop
-! Code annotations made doxygen readable 
-!
-! 1646 2015-09-02 16:00:10Z hoffmann
-! Bugfix: Wrong computation of d_mean.
-!
-! 1361 2014-04-16 15:17:48Z hoffmann
-! Bugfix in sedimentation_rain: Index corrected.
-! Vectorized version of adjust_cloud added.
-! Little reformatting of the code.
-! 
-! 1353 2014-04-08 15:21:23Z heinze
-! REAL constants provided with KIND-attribute
-! 
-! 1346 2014-03-27 13:18:20Z heinze
-! Bugfix: REAL constants provided with KIND-attribute especially in call of 
-! intrinsic function like MAX, MIN, SIGN
-! 
-! 1334 2014-03-25 12:21:40Z heinze
-! Bugfix: REAL constants provided with KIND-attribute
-!
-! 1322 2014-03-20 16:38:49Z raasch
-! REAL constants defined as wp-kind
-!
-! 1320 2014-03-20 08:40:49Z raasch
-! ONLY-attribute added to USE-statements,
-! kind-parameters added to all INTEGER and REAL declaration statements,
-! kinds are defined in new module kinds,
-! comment fields (!:) to be used for variable explanations added to
-! all variable declaration statements
-!
-! 1241 2013-10-30 11:36:58Z heinze
-! hyp and rho have to be calculated at each time step if data from external
-! file LSF_DATA are used
-!
-! 1115 2013-03-26 18:16:16Z hoffmann
-! microphyical tendencies are calculated in microphysics_control in an optimized
-! way; unrealistic values are prevented; bugfix in evaporation; some reformatting
-!
-! 1106 2013-03-04 05:31:38Z raasch
-! small changes in code formatting
-!
-! 1092 2013-02-02 11:24:22Z raasch
-! unused variables removed
-! file put under GPL
-!
-! 1065 2012-11-22 17:42:36Z hoffmann
-! Sedimentation process implemented according to Stevens and Seifert (2008).
-! Turbulence effects on autoconversion and accretion added (Seifert, Nuijens
-! and Stevens, 2010).
-!
-! 1053 2012-11-13 17:11:03Z hoffmann
-! initial revision
-! 
-! Description:
-! ------------
-!> Calculate bilk cloud microphysics.
-!------------------------------------------------------------------------------!
- MODULE microphysics_mod
-
-    USE  kinds
-
-    IMPLICIT NONE
-
-    LOGICAL ::  cloud_water_sedimentation = .FALSE.  !< cloud water sedimentation
-    LOGICAL ::  limiter_sedimentation = .TRUE.       !< sedimentation limiter
-    LOGICAL ::  collision_turbulence = .FALSE.       !< turbulence effects
-    LOGICAL ::  ventilation_effect = .TRUE.          !< ventilation effect
-
-    REAL(wp) ::  a_1 = 8.69E-4_wp          !< coef. in turb. parametrization (cm-2 s3)
-    REAL(wp) ::  a_2 = -7.38E-5_wp         !< coef. in turb. parametrization (cm-2 s3)
-    REAL(wp) ::  a_3 = -1.40E-2_wp         !< coef. in turb. parametrization
-    REAL(wp) ::  a_term = 9.65_wp          !< coef. for terminal velocity (m s-1)
-    REAL(wp) ::  a_vent = 0.78_wp          !< coef. for ventilation effect
-    REAL(wp) ::  b_1 = 11.45E-6_wp         !< coef. in turb. parametrization (m)
-    REAL(wp) ::  b_2 = 9.68E-6_wp          !< coef. in turb. parametrization (m)
-    REAL(wp) ::  b_3 = 0.62_wp             !< coef. in turb. parametrization
-    REAL(wp) ::  b_term = 9.8_wp           !< coef. for terminal velocity (m s-1)
-    REAL(wp) ::  b_vent = 0.308_wp         !< coef. for ventilation effect
-    REAL(wp) ::  beta_cc = 3.09E-4_wp      !< coef. in turb. parametrization (cm-2 s3)
-    REAL(wp) ::  c_1 = 4.82E-6_wp          !< coef. in turb. parametrization (m)
-    REAL(wp) ::  c_2 = 4.8E-6_wp           !< coef. in turb. parametrization (m)
-    REAL(wp) ::  c_3 = 0.76_wp             !< coef. in turb. parametrization
-    REAL(wp) ::  c_const = 0.93_wp         !< const. in Taylor-microscale Reynolds number
-    REAL(wp) ::  c_evap = 0.7_wp           !< constant in evaporation
-    REAL(wp) ::  c_term = 600.0_wp         !< coef. for terminal velocity (m-1)
-    REAL(wp) ::  diff_coeff_l = 0.23E-4_wp  !< diffusivity of water vapor (m2 s-1)
-    REAL(wp) ::  eps_sb = 1.0E-20_wp       !< threshold in two-moments scheme
-    REAL(wp) ::  k_cc = 9.44E09_wp         !< const. cloud-cloud kernel (m3 kg-2 s-1)
-    REAL(wp) ::  k_cr0 = 4.33_wp           !< const. cloud-rain kernel (m3 kg-1 s-1)
-    REAL(wp) ::  k_rr = 7.12_wp            !< const. rain-rain kernel (m3 kg-1 s-1)
-    REAL(wp) ::  k_br = 1000.0_wp          !< const. in breakup parametrization (m-1)
-    REAL(wp) ::  k_st = 1.2E8_wp           !< const. in drizzle parametrization (m-1 s-1)
-    REAL(wp) ::  kappa_rr = 60.7_wp        !< const. in collision kernel (kg-1/3)
-    REAL(wp) ::  kin_vis_air = 1.4086E-5_wp  !< kin. viscosity of air (m2 s-1)
-    REAL(wp) ::  prec_time_const = 0.001_wp  !< coef. in Kessler scheme (s-1)
-    REAL(wp) ::  ql_crit = 0.0005_wp       !< coef. in Kessler scheme (kg kg-1)
-    REAL(wp) ::  schmidt_p_1d3=0.8921121_wp  !< Schmidt number**0.33333, 0.71**0.33333
-    REAL(wp) ::  sigma_gc = 1.3_wp         !< geometric standard deviation cloud droplets
-    REAL(wp) ::  thermal_conductivity_l = 2.43E-2_wp  !< therm. cond. air (J m-1 s-1 K-1)
-    REAL(wp) ::  w_precipitation = 9.65_wp  !< maximum terminal velocity (m s-1)
-    REAL(wp) ::  x0 = 2.6E-10_wp           !< separating drop mass (kg)
-    REAL(wp) ::  xrmin = 2.6E-10_wp        !< minimum rain drop size (kg)
-    REAL(wp) ::  xrmax = 5.0E-6_wp         !< maximum rain drop site (kg)
-
-    REAL(wp) ::  c_sedimentation = 2.0_wp  !< Courant number of sedimentation process
-    REAL(wp) ::  dpirho_l                  !< 6.0 / ( pi * rho_l )
-    REAL(wp) ::  dt_micro                  !< microphysics time step
-    REAL(wp) ::  nc_const = 70.0E6_wp      !< cloud droplet concentration
-    REAL(wp) ::  dt_precipitation = 100.0_wp !< timestep precipitation (s)
-    REAL(wp) ::  sed_qc_const              !< const. for sedimentation of cloud water
-    REAL(wp) ::  pirho_l                   !< pi * rho_l / 6.0;
-
-    REAL(wp), DIMENSION(:), ALLOCATABLE ::  nc_1d  !<
-    REAL(wp), DIMENSION(:), ALLOCATABLE ::  nr_1d  !<
-    REAL(wp), DIMENSION(:), ALLOCATABLE ::  pt_1d  !<
-    REAL(wp), DIMENSION(:), ALLOCATABLE ::  qc_1d  !<
-    REAL(wp), DIMENSION(:), ALLOCATABLE ::  qr_1d  !<
-    REAL(wp), DIMENSION(:), ALLOCATABLE ::  q_1d   !<
-
-    SAVE
-
-    PRIVATE
-    PUBLIC microphysics_control, microphysics_init
-
-    PUBLIC cloud_water_sedimentation, collision_turbulence, c_sedimentation,   &
-           dt_precipitation, limiter_sedimentation, nc_const, sigma_gc,        &
-           ventilation_effect
-
-    INTERFACE microphysics_control
-       MODULE PROCEDURE microphysics_control
-       MODULE PROCEDURE microphysics_control_ij
-    END INTERFACE microphysics_control
-
-    INTERFACE adjust_cloud
-       MODULE PROCEDURE adjust_cloud
-       MODULE PROCEDURE adjust_cloud_ij
-    END INTERFACE adjust_cloud
-
-    INTERFACE autoconversion
-       MODULE PROCEDURE autoconversion
-       MODULE PROCEDURE autoconversion_ij
-    END INTERFACE autoconversion
-
-    INTERFACE autoconversion_kessler
-       MODULE PROCEDURE autoconversion_kessler
-       MODULE PROCEDURE autoconversion_kessler_ij
-    END INTERFACE autoconversion_kessler
-
-    INTERFACE accretion
-       MODULE PROCEDURE accretion
-       MODULE PROCEDURE accretion_ij
-    END INTERFACE accretion
-
-    INTERFACE selfcollection_breakup
-       MODULE PROCEDURE selfcollection_breakup
-       MODULE PROCEDURE selfcollection_breakup_ij
-    END INTERFACE selfcollection_breakup
-
-    INTERFACE evaporation_rain
-       MODULE PROCEDURE evaporation_rain
-       MODULE PROCEDURE evaporation_rain_ij
-    END INTERFACE evaporation_rain
-
-    INTERFACE sedimentation_cloud
-       MODULE PROCEDURE sedimentation_cloud
-       MODULE PROCEDURE sedimentation_cloud_ij
-    END INTERFACE sedimentation_cloud
- 
-    INTERFACE sedimentation_rain
-       MODULE PROCEDURE sedimentation_rain
-       MODULE PROCEDURE sedimentation_rain_ij
-    END INTERFACE sedimentation_rain
-
-    INTERFACE calc_precipitation_amount
-       MODULE PROCEDURE calc_precipitation_amount
-       MODULE PROCEDURE calc_precipitation_amount_ij
-    END INTERFACE calc_precipitation_amount
-
- CONTAINS
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Initialization of bulk microphysics
-!------------------------------------------------------------------------------!
-    SUBROUTINE microphysics_init
-
-       USE arrays_3d,                                                          &
-           ONLY:  dzu
-
-       USE constants,                                                          &
-           ONLY:  pi
-
-       USE cloud_parameters,                                                   &
-           ONLY:  rho_l
-
-       USE control_parameters,                                                 &
-           ONLY:  microphysics_seifert
-
-       USE indices,                                                            &
-           ONLY:  nzb, nzt
-
-       IMPLICIT NONE
-
-!
-!--    constant for the sedimentation of cloud water (2-moment cloud physics)
-       sed_qc_const = k_st * ( 3.0_wp / ( 4.0_wp * pi * rho_l )                &
-                          )**( 2.0_wp / 3.0_wp ) *                             &
-                      EXP( 5.0_wp * LOG( sigma_gc )**2 )
-
-!
-!--    Calculate timestep according to precipitation
-       IF ( microphysics_seifert )  THEN
-          dt_precipitation = c_sedimentation * MINVAL( dzu(nzb+2:nzt) ) /      &
-                             w_precipitation
-       ENDIF
-
-!
-!--    Pre-calculate frequently calculated fractions of pi and rho_l
-       pirho_l  = pi * rho_l / 6.0_wp
-       dpirho_l = 1.0_wp / pirho_l
-
-!
-!--    Allocate 1D microphysics arrays
-       ALLOCATE ( nc_1d(nzb:nzt+1), pt_1d(nzb:nzt+1), q_1d(nzb:nzt+1),         &
-                  qc_1d(nzb:nzt+1) )
-
-       IF ( microphysics_seifert )  THEN
-          ALLOCATE ( nr_1d(nzb:nzt+1), qr_1d(nzb:nzt+1) )
-       ENDIF
-
-!
-!--    Initialze nc_1d with nc_const
-       nc_1d = nc_const
-
-    END SUBROUTINE microphysics_init
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Control of microphysics for all grid points
-!------------------------------------------------------------------------------!
-    SUBROUTINE microphysics_control
-
-       USE arrays_3d,                                                          &
-           ONLY:  hyp, pt_init, prr, zu
-
-       USE cloud_parameters,                                                   &
-           ONLY:  cp, hyrho, pt_d_t, r_d, t_d_pt
-
-       USE control_parameters,                                                 &
-           ONLY:  call_microphysics_at_all_substeps, dt_3d, g,                 &
-                  intermediate_timestep_count, large_scale_forcing,            &
-                  lsf_surf, microphysics_kessler, microphysics_seifert,        &
-                  pt_surface, rho_surface,surface_pressure
-
-       USE indices,                                                            &
-           ONLY:  nzb, nzt
-
-       USE kinds
-
-       USE statistics,                                                         &
-           ONLY:  weight_pres
-
-       IMPLICIT NONE
-
-       INTEGER(iwp) ::  k                 !<
-
-       REAL(wp)     ::  t_surface         !<
-
-       IF ( large_scale_forcing  .AND.  lsf_surf ) THEN
-!
-!--       Calculate:
-!--       pt / t : ratio of potential and actual temperature (pt_d_t)
-!--       t / pt : ratio of actual and potential temperature (t_d_pt)
-!--       p_0(z) : vertical profile of the hydrostatic pressure (hyp)
-          t_surface = pt_surface * ( surface_pressure / 1000.0_wp )**0.286_wp
-          DO  k = nzb, nzt+1
-             hyp(k)    = surface_pressure * 100.0_wp * &
-                         ( ( t_surface - g / cp * zu(k) ) /                    &
-                         t_surface )**(1.0_wp / 0.286_wp)
-             pt_d_t(k) = ( 100000.0_wp / hyp(k) )**0.286_wp
-             t_d_pt(k) = 1.0_wp / pt_d_t(k)
-             hyrho(k)  = hyp(k) / ( r_d * t_d_pt(k) * pt_init(k) )       
-          ENDDO
-
-!
-!--       Compute reference density
-          rho_surface = surface_pressure * 100.0_wp / ( r_d * t_surface )
-       ENDIF
-
-!
-!--    Compute length of time step 
-       IF ( call_microphysics_at_all_substeps )  THEN
-          dt_micro = dt_3d * weight_pres(intermediate_timestep_count)
-       ELSE
-          dt_micro = dt_3d
-       ENDIF
-
-!
-!--    Reset precipitation rate
-       IF ( intermediate_timestep_count == 1 )  prr = 0.0_wp
-
-!
-!--    Compute cloud physics
-       IF ( microphysics_kessler )  THEN
-
-          CALL autoconversion_kessler
-          IF ( cloud_water_sedimentation )  CALL sedimentation_cloud
-
-       ELSEIF ( microphysics_seifert )  THEN
-
-          CALL adjust_cloud
-          CALL autoconversion
-          CALL accretion
-          CALL selfcollection_breakup
-          CALL evaporation_rain
-          CALL sedimentation_rain
-          IF ( cloud_water_sedimentation )  CALL sedimentation_cloud
-
-       ENDIF
-
-       CALL calc_precipitation_amount
-
-    END SUBROUTINE microphysics_control
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Adjust number of raindrops to avoid nonlinear effects in sedimentation and 
-!> evaporation of rain drops due to too small or too big weights 
-!> of rain drops (Stevens and Seifert, 2008).
-!------------------------------------------------------------------------------!
-    SUBROUTINE adjust_cloud
-
-       USE arrays_3d,                                                          &
-           ONLY:  qr, nr
-
-       USE cloud_parameters,                                                   &
-           ONLY:  hyrho
-
-       USE cpulog,                                                             &
-           ONLY:  cpu_log, log_point_s
-
-       USE indices,                                                            &
-           ONLY:  nxl, nxr, nys, nyn, nzb_s_inner, nzt
-
-       USE kinds
-
-       IMPLICIT NONE
-
-       INTEGER(iwp) ::  i                 !<
-       INTEGER(iwp) ::  j                 !<
-       INTEGER(iwp) ::  k                 !<
-
-       CALL cpu_log( log_point_s(54), 'adjust_cloud', 'start' )
-
-       DO  i = nxl, nxr
-          DO  j = nys, nyn
-             DO  k = nzb_s_inner(j,i)+1, nzt
-                IF ( qr(k,j,i) <= eps_sb )  THEN
-                   qr(k,j,i) = 0.0_wp
-                   nr(k,j,i) = 0.0_wp
-                ELSE
-                   IF ( nr(k,j,i) * xrmin > qr(k,j,i) * hyrho(k) )  THEN
-                      nr(k,j,i) = qr(k,j,i) * hyrho(k) / xrmin
-                   ELSEIF ( nr(k,j,i) * xrmax < qr(k,j,i) * hyrho(k) )  THEN
-                      nr(k,j,i) = qr(k,j,i) * hyrho(k) / xrmax
-                   ENDIF
-                ENDIF
-             ENDDO
-          ENDDO
-       ENDDO
-
-       CALL cpu_log( log_point_s(54), 'adjust_cloud', 'stop' )
-
-    END SUBROUTINE adjust_cloud
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Autoconversion rate (Seifert and Beheng, 2006).
-!------------------------------------------------------------------------------!
-    SUBROUTINE autoconversion
-
-       USE arrays_3d,                                                          &
-           ONLY:  diss, dzu, nr, qc, qr
-
-       USE cloud_parameters,                                                   &
-           ONLY:  hyrho
-
-       USE control_parameters,                                                 &
-           ONLY:  rho_surface
-
-       USE cpulog,                                                             &
-           ONLY:  cpu_log, log_point_s
-
-       USE grid_variables,                                                     &
-           ONLY:  dx, dy
-
-       USE indices,                                                            &
-           ONLY:  nxl, nxr, nys, nyn, nzb_s_inner, nzt
-
-       USE kinds
-
-       IMPLICIT NONE
-
-       INTEGER(iwp) ::  i                 !<
-       INTEGER(iwp) ::  j                 !<
-       INTEGER(iwp) ::  k                 !<
-
-       REAL(wp)     ::  alpha_cc          !<                   
-       REAL(wp)     ::  autocon           !<
-       REAL(wp)     ::  dissipation       !<
-       REAL(wp)     ::  k_au              !<
-       REAL(wp)     ::  l_mix             !<
-       REAL(wp)     ::  nu_c              !<
-       REAL(wp)     ::  phi_au            !<
-       REAL(wp)     ::  r_cc              !<
-       REAL(wp)     ::  rc                !<
-       REAL(wp)     ::  re_lambda         !<
-       REAL(wp)     ::  sigma_cc          !<
-       REAL(wp)     ::  tau_cloud         !<
-       REAL(wp)     ::  xc                !<
-
-       CALL cpu_log( log_point_s(55), 'autoconversion', 'start' )
-
-       DO  i = nxl, nxr
-          DO  j = nys, nyn
-             DO  k = nzb_s_inner(j,i)+1, nzt
-
-                IF ( qc(k,j,i) > eps_sb )  THEN
-
-                   k_au = k_cc / ( 20.0_wp * x0 )
-!
-!--                Intern time scale of coagulation (Seifert and Beheng, 2006):
-!--                (1.0_wp - qc(k,j,i) / ( qc(k,j,i) + qr(k,j,i) ))
-                   tau_cloud = 1.0_wp - qc(k,j,i) / ( qr(k,j,i) + qc(k,j,i) )
-!
-!--                Universal function for autoconversion process 
-!--                (Seifert and Beheng, 2006):
-                   phi_au = 600.0_wp * tau_cloud**0.68_wp *                    &
-                            ( 1.0_wp - tau_cloud**0.68_wp )**3
-!
-!--                Shape parameter of gamma distribution (Geoffroy et al., 2010):
-!--                (Use constant nu_c = 1.0_wp instead?)
-                   nu_c = 1.0_wp !MAX( 0.0_wp, 1580.0_wp * hyrho(k) * qc(k,j,i) - 0.28_wp )
-!
-!--                Mean weight of cloud droplets:
-                   xc = hyrho(k) * qc(k,j,i) / nc_const
-!
-!--                Parameterized turbulence effects on autoconversion (Seifert, 
-!--                Nuijens and Stevens, 2010)
-                   IF ( collision_turbulence )  THEN
-!
-!--                   Weight averaged radius of cloud droplets:
-                      rc = 0.5_wp * ( xc * dpirho_l )**( 1.0_wp / 3.0_wp )
-
-                      alpha_cc = ( a_1 + a_2 * nu_c ) / ( 1.0_wp + a_3 * nu_c )
-                      r_cc     = ( b_1 + b_2 * nu_c ) / ( 1.0_wp + b_3 * nu_c )
-                      sigma_cc = ( c_1 + c_2 * nu_c ) / ( 1.0_wp + c_3 * nu_c )
-!
-!--                   Mixing length (neglecting distance to ground and 
-!--                   stratification)
-                      l_mix = ( dx * dy * dzu(k) )**( 1.0_wp / 3.0_wp )
-!
-!--                   Limit dissipation rate according to Seifert, Nuijens and 
-!--                   Stevens (2010)
-                      dissipation = MIN( 0.06_wp, diss(k,j,i) )
-!
-!--                   Compute Taylor-microscale Reynolds number:
-                      re_lambda = 6.0_wp / 11.0_wp *                           &
-                                  ( l_mix / c_const )**( 2.0_wp / 3.0_wp ) *   &
-                                  SQRT( 15.0_wp / kin_vis_air ) *              &
-                                  dissipation**( 1.0_wp / 6.0_wp )
-!
-!--                   The factor of 1.0E4 is needed to convert the dissipation 
-!--                   rate from m2 s-3 to cm2 s-3.
-                      k_au = k_au * ( 1.0_wp +                                 &
-                                      dissipation * 1.0E4_wp *                 &
-                                      ( re_lambda * 1.0E-3_wp )**0.25_wp *     &
-                                      ( alpha_cc * EXP( -1.0_wp * ( ( rc -     &      
-                                                                      r_cc ) / &
-                                                        sigma_cc )**2          &
-                                                      ) + beta_cc              &
-                                      )                                        &
-                                    )
-                   ENDIF
-!
-!--                Autoconversion rate (Seifert and Beheng, 2006):
-                   autocon = k_au * ( nu_c + 2.0_wp ) * ( nu_c + 4.0_wp ) /    &
-                             ( nu_c + 1.0_wp )**2 * qc(k,j,i)**2 * xc**2 *     &
-                             ( 1.0_wp + phi_au / ( 1.0_wp - tau_cloud )**2 ) * &
-                             rho_surface
-                   autocon = MIN( autocon, qc(k,j,i) / dt_micro )
-
-                   qr(k,j,i) = qr(k,j,i) + autocon * dt_micro
-                   qc(k,j,i) = qc(k,j,i) - autocon * dt_micro 
-                   nr(k,j,i) = nr(k,j,i) + autocon / x0 * hyrho(k) * dt_micro
-
-                ENDIF
-
-             ENDDO
-          ENDDO
-       ENDDO
-
-       CALL cpu_log( log_point_s(55), 'autoconversion', 'stop' )
-
-    END SUBROUTINE autoconversion
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Autoconversion process (Kessler, 1969).
-!------------------------------------------------------------------------------!
-    SUBROUTINE autoconversion_kessler
-
-       USE arrays_3d,                                                          &
-           ONLY:  dzw, pt, prr, q, qc
-
-       USE cloud_parameters,                                                   &
-           ONLY:  l_d_cp, pt_d_t
-
-       USE indices,                                                            &
-           ONLY:  nxl, nxr, nyn, nys, nzb_s_inner, nzt
-
-       USE kinds
-
-
-       IMPLICIT NONE
-
-       INTEGER(iwp) ::  i !<
-       INTEGER(iwp) ::  j !<
-       INTEGER(iwp) ::  k !<
-
-       REAL(wp)    ::  dqdt_precip !<
-
-       DO  i = nxl, nxr
-          DO  j = nys, nyn
-             DO  k = nzb_s_inner(j,i)+1, nzt
-
-                IF ( qc(k,j,i) > ql_crit )  THEN
-                   dqdt_precip = prec_time_const * ( qc(k,j,i) - ql_crit )
-                ELSE
-                   dqdt_precip = 0.0_wp
-                ENDIF
-
-                qc(k,j,i) = qc(k,j,i) - dqdt_precip * dt_micro
-                q(k,j,i)  = q(k,j,i)  - dqdt_precip * dt_micro
-                pt(k,j,i) = pt(k,j,i) + dqdt_precip * dt_micro * l_d_cp *      &
-                                        pt_d_t(k)
-
-!
-!--             Compute the rain rate (stored on surface grid point)
-                prr(nzb_s_inner(j,i),j,i) = prr(nzb_s_inner(j,i),j,i) +        &
-                                            dqdt_precip * dzw(k)
-
-             ENDDO
-          ENDDO
-       ENDDO
-
-   END SUBROUTINE autoconversion_kessler
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Accretion rate (Seifert and Beheng, 2006).
-!------------------------------------------------------------------------------!
-    SUBROUTINE accretion
-
-       USE arrays_3d,                                                          &
-           ONLY:  diss, qc, qr
-
-       USE cloud_parameters,                                                   &
-           ONLY:  hyrho
-
-       USE control_parameters,                                                 &
-           ONLY:  rho_surface
-
-       USE cpulog,                                                             &
-           ONLY:  cpu_log, log_point_s
-
-       USE indices,                                                            &
-           ONLY:  nxl, nxr, nys, nyn, nzb_s_inner, nzt
-
-       USE kinds
-
-       IMPLICIT NONE
-
-       INTEGER(iwp) ::  i                 !<
-       INTEGER(iwp) ::  j                 !<
-       INTEGER(iwp) ::  k                 !<
-
-       REAL(wp)     ::  accr              !<
-       REAL(wp)     ::  k_cr              !<
-       REAL(wp)     ::  phi_ac            !<
-       REAL(wp)     ::  tau_cloud         !<
-
-       CALL cpu_log( log_point_s(56), 'accretion', 'start' )
-
-       DO  i = nxl, nxr
-          DO  j = nys, nyn
-             DO  k = nzb_s_inner(j,i)+1, nzt
-
-                IF ( ( qc(k,j,i) > eps_sb )  .AND.  ( qr(k,j,i) > eps_sb ) )  THEN
-!
-!--                Intern time scale of coagulation (Seifert and Beheng, 2006):
-                   tau_cloud = 1.0_wp - qc(k,j,i) / ( qc(k,j,i) + qr(k,j,i) ) 
-!
-!--                Universal function for accretion process (Seifert and 
-!--                Beheng, 2001):
-                   phi_ac = ( tau_cloud / ( tau_cloud + 5.0E-5_wp ) )**4
-!
-!--                Parameterized turbulence effects on autoconversion (Seifert, 
-!--                Nuijens and Stevens, 2010). The factor of 1.0E4 is needed to 
-!--                convert the dissipation rate (diss) from m2 s-3 to cm2 s-3.
-                   IF ( collision_turbulence )  THEN
-                      k_cr = k_cr0 * ( 1.0_wp + 0.05_wp *                      &
-                                       MIN( 600.0_wp,                          &
-                                            diss(k,j,i) * 1.0E4_wp )**0.25_wp  &
-                                     )
-                   ELSE
-                      k_cr = k_cr0                       
-                   ENDIF
-!
-!--                Accretion rate (Seifert and Beheng, 2006):
-                   accr = k_cr * qc(k,j,i) * qr(k,j,i) * phi_ac *              &
-                          SQRT( rho_surface * hyrho(k) )
-                   accr = MIN( accr, qc(k,j,i) / dt_micro )
-
-                   qr(k,j,i) = qr(k,j,i) + accr * dt_micro 
-                   qc(k,j,i) = qc(k,j,i) - accr * dt_micro
-
-                ENDIF
-
-             ENDDO
-          ENDDO
-       ENDDO
-
-       CALL cpu_log( log_point_s(56), 'accretion', 'stop' )
-
-    END SUBROUTINE accretion
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Collisional breakup rate (Seifert, 2008).
-!------------------------------------------------------------------------------!
-    SUBROUTINE selfcollection_breakup
-
-       USE arrays_3d,                                                          &
-           ONLY:  nr, qr
-
-       USE cloud_parameters,                                                   &
-           ONLY:  hyrho
-
-       USE control_parameters,                                                 &
-           ONLY:  rho_surface
-
-       USE cpulog,                                                             &
-           ONLY:  cpu_log, log_point_s
-
-       USE indices,                                                            &
-           ONLY:  nxl, nxr, nys, nyn, nzb_s_inner, nzt
-
-       USE kinds
-   
-       IMPLICIT NONE
-
-       INTEGER(iwp) ::  i                 !<
-       INTEGER(iwp) ::  j                 !<
-       INTEGER(iwp) ::  k                 !<
-
-       REAL(wp)     ::  breakup           !<
-       REAL(wp)     ::  dr                !<
-       REAL(wp)     ::  phi_br            !<
-       REAL(wp)     ::  selfcoll          !<
-
-       CALL cpu_log( log_point_s(57), 'selfcollection', 'start' )
-
-       DO  i = nxl, nxr
-          DO  j = nys, nyn
-             DO  k = nzb_s_inner(j,i)+1, nzt
-                IF ( qr(k,j,i) > eps_sb )  THEN
-!
-!--                Selfcollection rate (Seifert and Beheng, 2001):
-                   selfcoll = k_rr * nr(k,j,i) * qr(k,j,i) *                   &
-                              SQRT( hyrho(k) * rho_surface )
-!
-!--                Weight averaged diameter of rain drops:
-                   dr = ( hyrho(k) * qr(k,j,i) /                               &
-                          nr(k,j,i) * dpirho_l )**( 1.0_wp / 3.0_wp )
-!
-!--                Collisional breakup rate (Seifert, 2008):
-                   IF ( dr >= 0.3E-3_wp )  THEN
-                      phi_br  = k_br * ( dr - 1.1E-3_wp )
-                      breakup = selfcoll * ( phi_br + 1.0_wp )
-                   ELSE
-                      breakup = 0.0_wp
-                   ENDIF
-
-                   selfcoll = MAX( breakup - selfcoll, -nr(k,j,i) / dt_micro )
-                   nr(k,j,i) = nr(k,j,i) + selfcoll * dt_micro
-
-                ENDIF          
-             ENDDO
-          ENDDO
-       ENDDO
-
-       CALL cpu_log( log_point_s(57), 'selfcollection', 'stop' )
-
-    END SUBROUTINE selfcollection_breakup
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Evaporation of precipitable water. Condensation is neglected for 
-!> precipitable water.
-!------------------------------------------------------------------------------!
-    SUBROUTINE evaporation_rain
-
-       USE arrays_3d,                                                          &
-           ONLY:  hyp, nr, pt, q,  qc, qr
-
-       USE cloud_parameters,                                                   &
-           ONLY:  hyrho, l_d_cp, l_d_r, l_v, r_v, t_d_pt
-
-       USE constants,                                                          &
-           ONLY:  pi
-
-       USE cpulog,                                                             &
-           ONLY:  cpu_log, log_point_s
-
-       USE indices,                                                            &
-           ONLY:  nxl, nxr, nys, nyn, nzb_s_inner, nzt
-
-       USE kinds
-
-       IMPLICIT NONE
-
-       INTEGER(iwp) ::  i                 !<
-       INTEGER(iwp) ::  j                 !<
-       INTEGER(iwp) ::  k                 !<
-
-       REAL(wp)     ::  alpha             !<
-       REAL(wp)     ::  dr                !<
-       REAL(wp)     ::  e_s               !<
-       REAL(wp)     ::  evap              !<
-       REAL(wp)     ::  evap_nr           !<
-       REAL(wp)     ::  f_vent            !<
-       REAL(wp)     ::  g_evap            !<
-       REAL(wp)     ::  lambda_r          !<
-       REAL(wp)     ::  mu_r              !<
-       REAL(wp)     ::  mu_r_2            !<
-       REAL(wp)     ::  mu_r_5d2          !<
-       REAL(wp)     ::  nr_0              !<
-       REAL(wp)     ::  q_s               !<
-       REAL(wp)     ::  sat               !<
-       REAL(wp)     ::  t_l               !<
-       REAL(wp)     ::  temp              !<
-       REAL(wp)     ::  xr                !<
-
-       CALL cpu_log( log_point_s(58), 'evaporation', 'start' )
-
-       DO  i = nxl, nxr
-          DO  j = nys, nyn
-             DO  k = nzb_s_inner(j,i)+1, nzt
-                IF ( qr(k,j,i) > eps_sb )  THEN
-!
-!--                Actual liquid water temperature:
-                   t_l = t_d_pt(k) * pt(k,j,i)
-!
-!--                Saturation vapor pressure at t_l:
-                   e_s = 610.78_wp * EXP( 17.269_wp * ( t_l - 273.16_wp ) /    &
-                                          ( t_l - 35.86_wp )                   &
-                                        )
-!
-!--                Computation of saturation humidity:
-                   q_s   = 0.622_wp * e_s / ( hyp(k) - 0.378_wp * e_s )
-                   alpha = 0.622_wp * l_d_r * l_d_cp / ( t_l * t_l )
-                   q_s   = q_s * ( 1.0_wp + alpha * q(k,j,i) ) /               &
-                           ( 1.0_wp + alpha * q_s )
-!
-!--                Supersaturation:
-                   sat   = ( q(k,j,i) - qr(k,j,i) - qc(k,j,i) ) / q_s - 1.0_wp
-!
-!--                Evaporation needs only to be calculated in subsaturated regions
-                   IF ( sat < 0.0_wp )  THEN
-!
-!--                   Actual temperature:
-                      temp = t_l + l_d_cp * ( qc(k,j,i) + qr(k,j,i) )
-             
-                      g_evap = 1.0_wp / ( ( l_v / ( r_v * temp ) - 1.0_wp ) *     &
-                                          l_v / ( thermal_conductivity_l * temp ) &
-                                          + r_v * temp / ( diff_coeff_l * e_s )   &
-                                        )
-!
-!--                   Mean weight of rain drops
-                      xr = hyrho(k) * qr(k,j,i) / nr(k,j,i)
-!
-!--                   Weight averaged diameter of rain drops:
-                      dr = ( xr * dpirho_l )**( 1.0_wp / 3.0_wp )
-!
-!--                   Compute ventilation factor and intercept parameter 
-!--                   (Seifert and Beheng, 2006; Seifert, 2008):
-                      IF ( ventilation_effect )  THEN
-!
-!--                      Shape parameter of gamma distribution (Milbrandt and Yau, 
-!--                      2005; Stevens and Seifert, 2008):
-                         mu_r = 10.0_wp * ( 1.0_wp + TANH( 1.2E3_wp *          &
-                                                          ( dr - 1.4E-3_wp ) ) )
-!
-!--                      Slope parameter of gamma distribution (Seifert, 2008):
-                         lambda_r = ( ( mu_r + 3.0_wp ) * ( mu_r + 2.0_wp ) *  &
-                                      ( mu_r + 1.0_wp )                        &
-                                    )**( 1.0_wp / 3.0_wp ) / dr
-
-                         mu_r_2   = mu_r + 2.0_wp
-                         mu_r_5d2 = mu_r + 2.5_wp 
-
-                         f_vent = a_vent * gamm( mu_r_2 ) *                     &
-                                  lambda_r**( -mu_r_2 ) + b_vent *              &
-                                  schmidt_p_1d3 * SQRT( a_term / kin_vis_air ) *&
-                                  gamm( mu_r_5d2 ) * lambda_r**( -mu_r_5d2 ) *  &
-                                  ( 1.0_wp -                                    &
-                                    0.5_wp * ( b_term / a_term ) *              &
-                                    ( lambda_r / ( c_term + lambda_r )          &
-                                    )**mu_r_5d2 -                               &
-                                    0.125_wp * ( b_term / a_term )**2 *         &
-                                    ( lambda_r / ( 2.0_wp * c_term + lambda_r ) &
-                                    )**mu_r_5d2 -                               &
-                                    0.0625_wp * ( b_term / a_term )**3 *        &
-                                    ( lambda_r / ( 3.0_wp * c_term + lambda_r ) &
-                                    )**mu_r_5d2 -                               &
-                                    0.0390625_wp * ( b_term / a_term )**4 *     & 
-                                    ( lambda_r / ( 4.0_wp * c_term + lambda_r ) &
-                                    )**mu_r_5d2                                 &
-                                  )
-
-                         nr_0   = nr(k,j,i) * lambda_r**( mu_r + 1.0_wp ) /    &
-                                  gamm( mu_r + 1.0_wp ) 
-                      ELSE
-                         f_vent = 1.0_wp
-                         nr_0   = nr(k,j,i) * dr
-                      ENDIF
-   !
-   !--                Evaporation rate of rain water content (Seifert and 
-   !--                Beheng, 2006):
-                      evap    = 2.0_wp * pi * nr_0 * g_evap * f_vent * sat /   &
-                                hyrho(k)
-                      evap    = MAX( evap, -qr(k,j,i) / dt_micro )
-                      evap_nr = MAX( c_evap * evap / xr * hyrho(k),            &
-                                     -nr(k,j,i) / dt_micro )
-
-                      qr(k,j,i) = qr(k,j,i) + evap    * dt_micro
-                      nr(k,j,i) = nr(k,j,i) + evap_nr * dt_micro
-
-                   ENDIF
-                ENDIF          
-
-             ENDDO
-          ENDDO
-       ENDDO
-
-       CALL cpu_log( log_point_s(58), 'evaporation', 'stop' )
-
-    END SUBROUTINE evaporation_rain
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Sedimentation of cloud droplets (Ackermann et al., 2009, MWR).
-!------------------------------------------------------------------------------!
-    SUBROUTINE sedimentation_cloud
-
-       USE arrays_3d,                                                          &
-           ONLY:  ddzu, dzu, pt, prr, q, qc
-
-       USE cloud_parameters,                                                   &
-           ONLY:  hyrho, l_d_cp, pt_d_t
-
-       USE control_parameters,                                                 &
-           ONLY:  call_microphysics_at_all_substeps, intermediate_timestep_count
-
-       USE cpulog,                                                             &
-           ONLY:  cpu_log, log_point_s
-
-       USE indices,                                                            &
-           ONLY:  nxl, nxr, nys, nyn, nzb, nzb_s_inner, nzt
-
-       USE kinds
-
-       USE statistics,                                                         &
-           ONLY:  weight_substep
-    
-
-       IMPLICIT NONE
-
-       INTEGER(iwp) ::  i             !<
-       INTEGER(iwp) ::  j             !<
-       INTEGER(iwp) ::  k             !<
-
-       REAL(wp), DIMENSION(nzb:nzt+1) :: sed_qc !<
-
-       CALL cpu_log( log_point_s(59), 'sed_cloud', 'start' )
-
-       sed_qc(nzt+1) = 0.0_wp
-
-       DO  i = nxl, nxr
-          DO  j = nys, nyn
-             DO  k = nzt, nzb_s_inner(j,i)+1, -1
-
-                IF ( qc(k,j,i) > eps_sb )  THEN
-                   sed_qc(k) = sed_qc_const * nc_const**( -2.0_wp / 3.0_wp ) * &
-                               ( qc(k,j,i) * hyrho(k) )**( 5.0_wp / 3.0_wp )
-                ELSE
-                   sed_qc(k) = 0.0_wp
-                ENDIF
-
-                sed_qc(k) = MIN( sed_qc(k), hyrho(k) * dzu(k+1) * q(k,j,i) /   &
-                                            dt_micro + sed_qc(k+1)             &
-                               )
-
-                q(k,j,i)  = q(k,j,i)  + ( sed_qc(k+1) - sed_qc(k) ) *          &
-                                        ddzu(k+1) / hyrho(k) * dt_micro
-                qc(k,j,i) = qc(k,j,i) + ( sed_qc(k+1) - sed_qc(k) ) *          &
-                                        ddzu(k+1) / hyrho(k) * dt_micro
-                pt(k,j,i) = pt(k,j,i) - ( sed_qc(k+1) - sed_qc(k) ) *          &
-                                        ddzu(k+1) / hyrho(k) * l_d_cp *        &
-                                        pt_d_t(k) * dt_micro
-
-!
-!--             Compute the precipitation rate due to cloud (fog) droplets
-                IF ( call_microphysics_at_all_substeps )  THEN
-                   prr(k,j,i) = prr(k,j,i) +  sed_qc(k) / hyrho(k)             &
-                                * weight_substep(intermediate_timestep_count)
-                ELSE
-                   prr(k,j,i) = prr(k,j,i) + sed_qc(k) / hyrho(k)
-                ENDIF
-
-             ENDDO
-          ENDDO
-       ENDDO
-
-       CALL cpu_log( log_point_s(59), 'sed_cloud', 'stop' )
-
-    END SUBROUTINE sedimentation_cloud
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Computation of sedimentation flux. Implementation according to Stevens
-!> and Seifert (2008). Code is based on UCLA-LES.
-!------------------------------------------------------------------------------!
-    SUBROUTINE sedimentation_rain
-
-       USE arrays_3d,                                                          &
-           ONLY:  ddzu, dzu, nr, pt, prr, q, qr
-
-       USE cloud_parameters,                                                   &
-           ONLY:  hyrho, l_d_cp, pt_d_t
-
-       USE control_parameters,                                                 &
-           ONLY:  call_microphysics_at_all_substeps, intermediate_timestep_count
-       USE cpulog,                                                             &
-           ONLY:  cpu_log, log_point_s
-
-       USE indices,                                                            &
-           ONLY:  nxl, nxr, nys, nyn, nzb, nzb_s_inner, nzt
-
-       USE kinds
-
-       USE statistics,                                                         &
-           ONLY:  weight_substep
-       
-       IMPLICIT NONE
-
-       INTEGER(iwp) ::  i                          !<
-       INTEGER(iwp) ::  j                          !<
-       INTEGER(iwp) ::  k                          !<
-       INTEGER(iwp) ::  k_run                      !<
-
-       REAL(wp)     ::  c_run                      !<
-       REAL(wp)     ::  d_max                      !<
-       REAL(wp)     ::  d_mean                     !<
-       REAL(wp)     ::  d_min                      !<
-       REAL(wp)     ::  dr                         !<
-       REAL(wp)     ::  flux                       !<
-       REAL(wp)     ::  lambda_r                   !<
-       REAL(wp)     ::  mu_r                       !<
-       REAL(wp)     ::  z_run                      !<
-
-       REAL(wp), DIMENSION(nzb:nzt+1) ::  c_nr     !<
-       REAL(wp), DIMENSION(nzb:nzt+1) ::  c_qr     !<
-       REAL(wp), DIMENSION(nzb:nzt+1) ::  nr_slope !<
-       REAL(wp), DIMENSION(nzb:nzt+1) ::  qr_slope !<
-       REAL(wp), DIMENSION(nzb:nzt+1) ::  sed_nr   !<
-       REAL(wp), DIMENSION(nzb:nzt+1) ::  sed_qr   !<
-       REAL(wp), DIMENSION(nzb:nzt+1) ::  w_nr     !<
-       REAL(wp), DIMENSION(nzb:nzt+1) ::  w_qr     !<
-
-       CALL cpu_log( log_point_s(60), 'sed_rain', 'start' )
-
-!
-!--    Compute velocities 
-       DO  i = nxl, nxr
-          DO  j = nys, nyn
-             DO  k = nzb_s_inner(j,i)+1, nzt
-                IF ( qr(k,j,i) > eps_sb )  THEN
-!
-!--                Weight averaged diameter of rain drops:
-                   dr = ( hyrho(k) * qr(k,j,i) /                               &
-                          nr(k,j,i) * dpirho_l )**( 1.0_wp / 3.0_wp )
-!
-!--                Shape parameter of gamma distribution (Milbrandt and Yau, 2005;
-!--                Stevens and Seifert, 2008):
-                   mu_r = 10.0_wp * ( 1.0_wp + TANH( 1.2E3_wp *                &
-                                                     ( dr - 1.4E-3_wp ) ) )
-!
-!--                Slope parameter of gamma distribution (Seifert, 2008):
-                   lambda_r = ( ( mu_r + 3.0_wp ) * ( mu_r + 2.0_wp ) *        &
-                                ( mu_r + 1.0_wp ) )**( 1.0_wp / 3.0_wp ) / dr
-
-                   w_nr(k) = MAX( 0.1_wp, MIN( 20.0_wp,                        &
-                                               a_term - b_term * ( 1.0_wp +    &
-                                                  c_term /                     &
-                                                  lambda_r )**( -1.0_wp *      &
-                                                  ( mu_r + 1.0_wp ) )          &
-                                              )                                &
-                                )
-
-                   w_qr(k) = MAX( 0.1_wp, MIN( 20.0_wp,                        &
-                                               a_term - b_term * ( 1.0_wp +    &
-                                                  c_term /                     &
-                                                  lambda_r )**( -1.0_wp *      &
-                                                  ( mu_r + 4.0_wp ) )          &
-                                             )                                 &
-                                )
-                ELSE
-                   w_nr(k) = 0.0_wp
-                   w_qr(k) = 0.0_wp
-                ENDIF
-             ENDDO
-!
-!--          Adjust boundary values
-             w_nr(nzb_s_inner(j,i)) = w_nr(nzb_s_inner(j,i)+1)
-             w_qr(nzb_s_inner(j,i)) = w_qr(nzb_s_inner(j,i)+1)
-             w_nr(nzt+1) = 0.0_wp
-             w_qr(nzt+1) = 0.0_wp
-!
-!--          Compute Courant number
-             DO  k = nzb_s_inner(j,i)+1, nzt
-                c_nr(k) = 0.25_wp * ( w_nr(k-1) +                              &
-                                      2.0_wp * w_nr(k) + w_nr(k+1) ) *         &
-                          dt_micro * ddzu(k)
-                c_qr(k) = 0.25_wp * ( w_qr(k-1) +                              &
-                                      2.0_wp * w_qr(k) + w_qr(k+1) ) *         &
-                          dt_micro * ddzu(k)
-             ENDDO     
-!
-!--          Limit slopes with monotonized centered (MC) limiter (van Leer, 1977):
-             IF ( limiter_sedimentation )  THEN
-
-                DO k = nzb_s_inner(j,i)+1, nzt
-                   d_mean = 0.5_wp * ( qr(k+1,j,i) - qr(k-1,j,i) )
-                   d_min  = qr(k,j,i) - MIN( qr(k+1,j,i), qr(k,j,i), qr(k-1,j,i) )
-                   d_max  = MAX( qr(k+1,j,i), qr(k,j,i), qr(k-1,j,i) ) - qr(k,j,i)
-
-                   qr_slope(k) = SIGN(1.0_wp, d_mean) * MIN ( 2.0_wp * d_min,  &
-                                                              2.0_wp * d_max,  &
-                                                              ABS( d_mean ) )
-
-                   d_mean = 0.5_wp * ( nr(k+1,j,i) - nr(k-1,j,i) )
-                   d_min  = nr(k,j,i) - MIN( nr(k+1,j,i), nr(k,j,i), nr(k-1,j,i) )
-                   d_max  = MAX( nr(k+1,j,i), nr(k,j,i), nr(k-1,j,i) ) - nr(k,j,i)
-
-                   nr_slope(k) = SIGN(1.0_wp, d_mean) * MIN ( 2.0_wp * d_min,  &
-                                                              2.0_wp * d_max,  &
-                                                              ABS( d_mean ) )
-                ENDDO
-
-             ELSE
-
-                nr_slope = 0.0_wp
-                qr_slope = 0.0_wp
-
-             ENDIF
-
-             sed_nr(nzt+1) = 0.0_wp
-             sed_qr(nzt+1) = 0.0_wp
-!
-!--          Compute sedimentation flux
-             DO  k = nzt, nzb_s_inner(j,i)+1, -1
-!
-!--             Sum up all rain drop number densities which contribute to the flux 
-!--             through k-1/2
-                flux  = 0.0_wp
-                z_run = 0.0_wp ! height above z(k)
-                k_run = k
-                c_run = MIN( 1.0_wp, c_nr(k) )
-                DO WHILE ( c_run > 0.0_wp  .AND.  k_run <= nzt )
-                   flux  = flux + hyrho(k_run) *                               &
-                           ( nr(k_run,j,i) + nr_slope(k_run) *                 &
-                           ( 1.0_wp - c_run ) * 0.5_wp ) * c_run * dzu(k_run)
-                   z_run = z_run + dzu(k_run)
-                   k_run = k_run + 1
-                   c_run = MIN( 1.0_wp, c_nr(k_run) - z_run * ddzu(k_run) )
-                ENDDO
-!
-!--             It is not allowed to sediment more rain drop number density than 
-!--             available
-                flux = MIN( flux,                                              &
-                            hyrho(k) * dzu(k+1) * nr(k,j,i) + sed_nr(k+1) *    &
-                            dt_micro                                           &
-                          )
-
-                sed_nr(k) = flux / dt_micro
-                nr(k,j,i) = nr(k,j,i) + ( sed_nr(k+1) - sed_nr(k) ) *          &
-                                        ddzu(k+1) / hyrho(k) * dt_micro
-!
-!--             Sum up all rain water content which contributes to the flux 
-!--             through k-1/2
-                flux  = 0.0_wp
-                z_run = 0.0_wp ! height above z(k)
-                k_run = k
-                c_run = MIN( 1.0_wp, c_qr(k) )
-
-                DO WHILE ( c_run > 0.0_wp  .AND.  k_run <= nzt )
-
-                   flux  = flux + hyrho(k_run) * ( qr(k_run,j,i) +             &
-                                  qr_slope(k_run) * ( 1.0_wp - c_run ) *       &
-                                  0.5_wp ) * c_run * dzu(k_run)
-                   z_run = z_run + dzu(k_run)
-                   k_run = k_run + 1
-                   c_run = MIN( 1.0_wp, c_qr(k_run) - z_run * ddzu(k_run) )
-
-                ENDDO
-!
-!--             It is not allowed to sediment more rain water content than 
-!--             available
-                flux = MIN( flux,                                              &
-                            hyrho(k) * dzu(k) * qr(k,j,i) + sed_qr(k+1) *      &
-                            dt_micro                                           &
-                          )
-
-                sed_qr(k) = flux / dt_micro
-
-                qr(k,j,i) = qr(k,j,i) + ( sed_qr(k+1) - sed_qr(k) ) *          &
-                                        ddzu(k+1) / hyrho(k) * dt_micro
-                q(k,j,i)  = q(k,j,i)  + ( sed_qr(k+1) - sed_qr(k) ) *          &
-                                        ddzu(k+1) / hyrho(k) * dt_micro 
-                pt(k,j,i) = pt(k,j,i) - ( sed_qr(k+1) - sed_qr(k) ) *          &
-                                        ddzu(k+1) / hyrho(k) * l_d_cp *        &
-                                        pt_d_t(k) * dt_micro
-!
-!--             Compute the rain rate
-                IF ( call_microphysics_at_all_substeps )  THEN
-                   prr(k,j,i) = prr(k,j,i) + sed_qr(k) / hyrho(k)             &
-                                * weight_substep(intermediate_timestep_count)
-                ELSE
-                   prr(k,j,i) = prr(k,j,i) + sed_qr(k) / hyrho(k)
-                ENDIF
-
-             ENDDO
-          ENDDO
-       ENDDO
-
-       CALL cpu_log( log_point_s(60), 'sed_rain', 'stop' )
-
-    END SUBROUTINE sedimentation_rain
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Computation of the precipitation amount due to gravitational settling of
-!> rain and cloud (fog) droplets
-!------------------------------------------------------------------------------!
-    SUBROUTINE calc_precipitation_amount
-
-       USE arrays_3d,                                                          &
-           ONLY:  precipitation_amount, prr
-
-       USE cloud_parameters,                                                   &
-           ONLY:  hyrho
-
-       USE control_parameters,                                                 &
-           ONLY:  call_microphysics_at_all_substeps, dt_do2d_xy, dt_3d,        &
-                  intermediate_timestep_count, intermediate_timestep_count_max,&
-                  precipitation_amount_interval, time_do2d_xy
-
-       USE indices,                                                            &
-           ONLY:  nxl, nxr, nys, nyn, nzb_s_inner
-
-       USE kinds
-
-       IMPLICIT NONE
-
-       INTEGER(iwp) ::  i                          !:
-       INTEGER(iwp) ::  j                          !:
-
-
-       IF ( ( dt_do2d_xy - time_do2d_xy ) < precipitation_amount_interval .AND.&
-            ( .NOT. call_microphysics_at_all_substeps .OR.                     &
-            intermediate_timestep_count == intermediate_timestep_count_max ) ) &
-       THEN
-
-          DO  i = nxl, nxr
-             DO  j = nys, nyn
-
-                precipitation_amount(j,i) = precipitation_amount(j,i) +        &
-                                            prr(nzb_s_inner(j,i)+1,j,i) *      &
-                                            hyrho(nzb_s_inner(j,i)+1) * dt_3d
-
-             ENDDO
-          ENDDO
-       ENDIF
-
-    END SUBROUTINE calc_precipitation_amount
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Control of microphysics for grid points i,j
-!------------------------------------------------------------------------------!
-
-    SUBROUTINE microphysics_control_ij( i, j )
-
-       USE arrays_3d,                                                          &
-           ONLY:  hyp, nr, pt, pt_init, prr, q, qc, qr, zu
-
-       USE cloud_parameters,                                                   &
-           ONLY:  cp, hyrho, pt_d_t, r_d, t_d_pt
-
-       USE control_parameters,                                                 &
-           ONLY:  call_microphysics_at_all_substeps, dt_3d, g,                 &
-                  intermediate_timestep_count, large_scale_forcing,            &
-                  lsf_surf, microphysics_seifert, microphysics_kessler,        &
-                  pt_surface, rho_surface, surface_pressure
-
-       USE indices,                                                            &
-           ONLY:  nzb, nzt
-
-       USE kinds
-
-       USE statistics,                                                         &
-           ONLY:  weight_pres
-
-       IMPLICIT NONE
-
-       INTEGER(iwp) ::  i                 !<
-       INTEGER(iwp) ::  j                 !<
-       INTEGER(iwp) ::  k                 !<
-
-       REAL(wp)     ::  t_surface         !<
-
-       IF ( large_scale_forcing  .AND.  lsf_surf ) THEN
-!
-!--       Calculate:
-!--       pt / t : ratio of potential and actual temperature (pt_d_t)
-!--       t / pt : ratio of actual and potential temperature (t_d_pt)
-!--       p_0(z) : vertical profile of the hydrostatic pressure (hyp)
-          t_surface = pt_surface * ( surface_pressure / 1000.0_wp )**0.286_wp
-          DO  k = nzb, nzt+1
-             hyp(k)    = surface_pressure * 100.0_wp * &
-                         ( ( t_surface - g / cp * zu(k) ) / t_surface )**(1.0_wp / 0.286_wp)
-             pt_d_t(k) = ( 100000.0_wp / hyp(k) )**0.286_wp
-             t_d_pt(k) = 1.0_wp / pt_d_t(k)
-             hyrho(k)  = hyp(k) / ( r_d * t_d_pt(k) * pt_init(k) )       
-          ENDDO
-!
-!--       Compute reference density
-          rho_surface = surface_pressure * 100.0_wp / ( r_d * t_surface )
-       ENDIF
-
-!
-!--    Compute length of time step 
-       IF ( call_microphysics_at_all_substeps )  THEN
-          dt_micro = dt_3d * weight_pres(intermediate_timestep_count)
-       ELSE
-          dt_micro = dt_3d
-       ENDIF
-
-!
-!--    Use 1d arrays
-       q_1d(:)  = q(:,j,i)
-       pt_1d(:) = pt(:,j,i)
-       qc_1d(:) = qc(:,j,i)
-       nc_1d(:) = nc_const
-       IF ( microphysics_seifert )  THEN
-          qr_1d(:) = qr(:,j,i)
-          nr_1d(:) = nr(:,j,i)
-       ENDIF
-
-!
-!--    Reset precipitation rate
-       IF ( intermediate_timestep_count == 1 )  prr(:,j,i) = 0.0_wp
-
-!
-!--    Compute cloud physics
-       IF( microphysics_kessler )  THEN
-
-          CALL autoconversion_kessler( i,j )
-          IF ( cloud_water_sedimentation )  CALL sedimentation_cloud( i,j )
-
-       ELSEIF ( microphysics_seifert )  THEN
-
-          CALL adjust_cloud( i,j )
-          CALL autoconversion( i,j )
-          CALL accretion( i,j )
-          CALL selfcollection_breakup( i,j )
-          CALL evaporation_rain( i,j )
-          CALL sedimentation_rain( i,j )
-          IF ( cloud_water_sedimentation )  CALL sedimentation_cloud( i,j )
-
-       ENDIF
-
-       CALL calc_precipitation_amount( i,j )
-
-!
-!--    Store results on the 3d arrays
-       q(:,j,i)  = q_1d(:)
-       pt(:,j,i) = pt_1d(:)
-       IF ( microphysics_seifert )  THEN
-          qr(:,j,i) = qr_1d(:)
-          nr(:,j,i) = nr_1d(:)
-       ENDIF
-
-    END SUBROUTINE microphysics_control_ij
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Adjust number of raindrops to avoid nonlinear effects in 
-!> sedimentation and evaporation of rain drops due to too small or
-!> too big weights of rain drops (Stevens and Seifert, 2008).
-!> The same procedure is applied to cloud droplets if they are determined
-!> prognostically. Call for grid point i,j
-!------------------------------------------------------------------------------!
-    SUBROUTINE adjust_cloud_ij( i, j )
-
-       USE cloud_parameters,                                                   &
-           ONLY:  hyrho
-
-       USE indices,                                                            &
-           ONLY:  nzb_s_inner, nzt
-
-       USE kinds
-
-       IMPLICIT NONE
-
-       INTEGER(iwp) ::  i                 !<
-       INTEGER(iwp) ::  j                 !<
-       INTEGER(iwp) ::  k                 !<
-
-       DO  k = nzb_s_inner(j,i)+1, nzt
-
-          IF ( qr_1d(k) <= eps_sb )  THEN
-             qr_1d(k) = 0.0_wp
-             nr_1d(k) = 0.0_wp
-          ELSE
-!
-!--          Adjust number of raindrops to avoid nonlinear effects in 
-!--          sedimentation and evaporation of rain drops due to too small or
-!--          too big weights of rain drops (Stevens and Seifert, 2008).
-             IF ( nr_1d(k) * xrmin > qr_1d(k) * hyrho(k) )  THEN
-                nr_1d(k) = qr_1d(k) * hyrho(k) / xrmin
-             ELSEIF ( nr_1d(k) * xrmax < qr_1d(k) * hyrho(k) )  THEN
-                nr_1d(k) = qr_1d(k) * hyrho(k) / xrmax
-             ENDIF
-
-          ENDIF
-
-       ENDDO
-
-    END SUBROUTINE adjust_cloud_ij
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Autoconversion rate (Seifert and Beheng, 2006). Call for grid point i,j
-!------------------------------------------------------------------------------!
-    SUBROUTINE autoconversion_ij( i, j )
-
-       USE arrays_3d,                                                          &
-           ONLY:  diss, dzu
-
-       USE cloud_parameters,                                                   &
-           ONLY:  hyrho
-
-       USE control_parameters,                                                 &
-           ONLY:  rho_surface
-
-       USE grid_variables,                                                     &
-           ONLY:  dx, dy
-
-       USE indices,                                                            &
-           ONLY:  nzb_s_inner, nzt
-
-       USE kinds
-
-       IMPLICIT NONE
-
-       INTEGER(iwp) ::  i                 !<
-       INTEGER(iwp) ::  j                 !<
-       INTEGER(iwp) ::  k                 !<
-
-       REAL(wp)     ::  alpha_cc          !<                   
-       REAL(wp)     ::  autocon           !<
-       REAL(wp)     ::  dissipation       !<
-       REAL(wp)     ::  k_au              !<
-       REAL(wp)     ::  l_mix             !<
-       REAL(wp)     ::  nu_c              !<
-       REAL(wp)     ::  phi_au            !<
-       REAL(wp)     ::  r_cc              !<
-       REAL(wp)     ::  rc                !<
-       REAL(wp)     ::  re_lambda         !<
-       REAL(wp)     ::  sigma_cc          !<
-       REAL(wp)     ::  tau_cloud         !<
-       REAL(wp)     ::  xc                !<
-
-       DO  k = nzb_s_inner(j,i)+1, nzt
-
-          IF ( qc_1d(k) > eps_sb )  THEN
-
-             k_au = k_cc / ( 20.0_wp * x0 )
-!
-!--          Intern time scale of coagulation (Seifert and Beheng, 2006):
-!--          (1.0_wp - qc(k,j,i) / ( qc(k,j,i) + qr_1d(k) ))
-             tau_cloud = 1.0_wp - qc_1d(k) / ( qr_1d(k) + qc_1d(k) )
-!
-!--          Universal function for autoconversion process 
-!--          (Seifert and Beheng, 2006):
-             phi_au = 600.0_wp * tau_cloud**0.68_wp * ( 1.0_wp - tau_cloud**0.68_wp )**3
-!
-!--          Shape parameter of gamma distribution (Geoffroy et al., 2010):
-!--          (Use constant nu_c = 1.0_wp instead?)
-             nu_c = 1.0_wp !MAX( 0.0_wp, 1580.0_wp * hyrho(k) * qc_1d(k) - 0.28_wp )
-!
-!--          Mean weight of cloud droplets:
-             xc = hyrho(k) * qc_1d(k) / nc_1d(k)
-!
-!--          Parameterized turbulence effects on autoconversion (Seifert, 
-!--          Nuijens and Stevens, 2010)
-             IF ( collision_turbulence )  THEN
-!
-!--             Weight averaged radius of cloud droplets:
-                rc = 0.5_wp * ( xc * dpirho_l )**( 1.0_wp / 3.0_wp )
-
-                alpha_cc = ( a_1 + a_2 * nu_c ) / ( 1.0_wp + a_3 * nu_c )
-                r_cc     = ( b_1 + b_2 * nu_c ) / ( 1.0_wp + b_3 * nu_c )
-                sigma_cc = ( c_1 + c_2 * nu_c ) / ( 1.0_wp + c_3 * nu_c )
-!
-!--             Mixing length (neglecting distance to ground and stratification)
-                l_mix = ( dx * dy * dzu(k) )**( 1.0_wp / 3.0_wp )
-!
-!--             Limit dissipation rate according to Seifert, Nuijens and 
-!--             Stevens (2010)
-                dissipation = MIN( 0.06_wp, diss(k,j,i) )
-!
-!--             Compute Taylor-microscale Reynolds number:
-                re_lambda = 6.0_wp / 11.0_wp *                                 &
-                            ( l_mix / c_const )**( 2.0_wp / 3.0_wp ) *         &
-                            SQRT( 15.0_wp / kin_vis_air ) *                    &
-                            dissipation**( 1.0_wp / 6.0_wp )
-!
-!--             The factor of 1.0E4 is needed to convert the dissipation rate
-!--             from m2 s-3 to cm2 s-3.
-                k_au = k_au * ( 1.0_wp +                                       &
-                                dissipation * 1.0E4_wp *                       &
-                                ( re_lambda * 1.0E-3_wp )**0.25_wp *           &
-                                ( alpha_cc * EXP( -1.0_wp * ( ( rc - r_cc ) /  &
-                                                  sigma_cc )**2                &
-                                                ) + beta_cc                    &
-                                )                                              &
-                              )
-             ENDIF
-!
-!--          Autoconversion rate (Seifert and Beheng, 2006):
-             autocon = k_au * ( nu_c + 2.0_wp ) * ( nu_c + 4.0_wp ) /          &
-                       ( nu_c + 1.0_wp )**2 * qc_1d(k)**2 * xc**2 *            &
-                       ( 1.0_wp + phi_au / ( 1.0_wp - tau_cloud )**2 ) *       &
-                       rho_surface
-             autocon = MIN( autocon, qc_1d(k) / dt_micro )
-
-             qr_1d(k) = qr_1d(k) + autocon * dt_micro
-             qc_1d(k) = qc_1d(k) - autocon * dt_micro 
-             nr_1d(k) = nr_1d(k) + autocon / x0 * hyrho(k) * dt_micro
-
-          ENDIF
-
-       ENDDO
-
-    END SUBROUTINE autoconversion_ij
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Autoconversion process (Kessler, 1969).
-!------------------------------------------------------------------------------!
-    SUBROUTINE autoconversion_kessler_ij( i, j )
-
-       USE arrays_3d,                                                          &
-           ONLY:  dzw, prr
-
-       USE cloud_parameters,                                                   &
-           ONLY:  l_d_cp, pt_d_t
-
-       USE indices,                                                            &
-           ONLY:  nzb_s_inner, nzt
-
-       USE kinds
-
-
-       IMPLICIT NONE
-
-       INTEGER(iwp) ::  i !<
-       INTEGER(iwp) ::  j !<
-       INTEGER(iwp) ::  k !<
-
-       REAL(wp)    ::  dqdt_precip !<
-
-       DO  k = nzb_s_inner(j,i)+1, nzt
-
-          IF ( qc_1d(k) > ql_crit )  THEN
-             dqdt_precip = prec_time_const * ( qc_1d(k) - ql_crit )
-          ELSE
-             dqdt_precip = 0.0_wp
-          ENDIF
-
-          qc_1d(k) = qc_1d(k) - dqdt_precip * dt_micro
-          q_1d(k)  = q_1d(k)  - dqdt_precip * dt_micro
-          pt_1d(k) = pt_1d(k) + dqdt_precip * dt_micro * l_d_cp * pt_d_t(k)
-
-!
-!--       Compute the rain rate (stored on surface grid point)
-          prr(nzb_s_inner(j,i),j,i) = prr(nzb_s_inner(j,i),j,i) +              &
-                                      dqdt_precip * dzw(k)
-
-       ENDDO
-
-    END SUBROUTINE autoconversion_kessler_ij
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Accretion rate (Seifert and Beheng, 2006). Call for grid point i,j
-!------------------------------------------------------------------------------!
-    SUBROUTINE accretion_ij( i, j )
-
-       USE arrays_3d,                                                          &
-           ONLY:  diss
-
-       USE cloud_parameters,                                                   &
-           ONLY:  hyrho
-
-       USE control_parameters,                                                 &
-           ONLY:  rho_surface
-
-       USE indices,                                                            &
-           ONLY:  nzb_s_inner, nzt
-
-       USE kinds
-
-       IMPLICIT NONE
-
-       INTEGER(iwp) ::  i                 !<
-       INTEGER(iwp) ::  j                 !<
-       INTEGER(iwp) ::  k                 !<
-
-       REAL(wp)     ::  accr              !<
-       REAL(wp)     ::  k_cr              !<
-       REAL(wp)     ::  phi_ac            !<
-       REAL(wp)     ::  tau_cloud         !<
-
-       DO  k = nzb_s_inner(j,i)+1, nzt
-          IF ( ( qc_1d(k) > eps_sb )  .AND.  ( qr_1d(k) > eps_sb ) )  THEN
-!
-!--          Intern time scale of coagulation (Seifert and Beheng, 2006):
-             tau_cloud = 1.0_wp - qc_1d(k) / ( qc_1d(k) + qr_1d(k) ) 
-!
-!--          Universal function for accretion process 
-!--          (Seifert and Beheng, 2001):
-             phi_ac = ( tau_cloud / ( tau_cloud + 5.0E-5_wp ) )**4
-!
-!--          Parameterized turbulence effects on autoconversion (Seifert, 
-!--          Nuijens and Stevens, 2010). The factor of 1.0E4 is needed to 
-!--          convert the dissipation rate (diss) from m2 s-3 to cm2 s-3.
-             IF ( collision_turbulence )  THEN
-                k_cr = k_cr0 * ( 1.0_wp + 0.05_wp *                            &
-                                 MIN( 600.0_wp,                                &
-                                      diss(k,j,i) * 1.0E4_wp )**0.25_wp        &
-                               )
-             ELSE
-                k_cr = k_cr0                       
-             ENDIF
-!
-!--          Accretion rate (Seifert and Beheng, 2006):
-             accr = k_cr * qc_1d(k) * qr_1d(k) * phi_ac * SQRT( rho_surface * hyrho(k) )
-             accr = MIN( accr, qc_1d(k) / dt_micro )
-
-             qr_1d(k) = qr_1d(k) + accr * dt_micro 
-             qc_1d(k) = qc_1d(k) - accr * dt_micro
-
-          ENDIF
-
-       ENDDO
-
-    END SUBROUTINE accretion_ij
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Collisional breakup rate (Seifert, 2008). Call for grid point i,j
-!------------------------------------------------------------------------------!
-    SUBROUTINE selfcollection_breakup_ij( i, j )
-
-       USE cloud_parameters,                                                   &
-           ONLY:  hyrho
-
-       USE control_parameters,                                                 &
-           ONLY:  rho_surface
-
-       USE indices,                                                            &
-           ONLY:  nzb_s_inner, nzt
-
-       USE kinds
-   
-       IMPLICIT NONE
-
-       INTEGER(iwp) ::  i                 !<
-       INTEGER(iwp) ::  j                 !<
-       INTEGER(iwp) ::  k                 !<
-
-       REAL(wp)     ::  breakup           !<
-       REAL(wp)     ::  dr                !<
-       REAL(wp)     ::  phi_br            !<
-       REAL(wp)     ::  selfcoll          !<
-
-       DO  k = nzb_s_inner(j,i)+1, nzt
-          IF ( qr_1d(k) > eps_sb )  THEN
-!
-!--          Selfcollection rate (Seifert and Beheng, 2001):
-             selfcoll = k_rr * nr_1d(k) * qr_1d(k) * SQRT( hyrho(k) * rho_surface )
-!
-!--          Weight averaged diameter of rain drops:
-             dr = ( hyrho(k) * qr_1d(k) / nr_1d(k) * dpirho_l )**( 1.0_wp / 3.0_wp )
-!
-!--          Collisional breakup rate (Seifert, 2008):
-             IF ( dr >= 0.3E-3_wp )  THEN
-                phi_br  = k_br * ( dr - 1.1E-3_wp )
-                breakup = selfcoll * ( phi_br + 1.0_wp )
-             ELSE
-                breakup = 0.0_wp
-             ENDIF
-
-             selfcoll = MAX( breakup - selfcoll, -nr_1d(k) / dt_micro )
-             nr_1d(k) = nr_1d(k) + selfcoll * dt_micro
-
-          ENDIF          
-       ENDDO
-
-    END SUBROUTINE selfcollection_breakup_ij
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Evaporation of precipitable water. Condensation is neglected for 
-!> precipitable water. Call for grid point i,j
-!------------------------------------------------------------------------------!
-    SUBROUTINE evaporation_rain_ij( i, j )
-
-       USE arrays_3d,                                                          &
-           ONLY:  hyp
-
-       USE cloud_parameters,                                                   &
-           ONLY:  hyrho, l_d_cp, l_d_r, l_v, r_v, t_d_pt
-
-       USE constants,                                                          &
-           ONLY:  pi
-
-       USE indices,                                                            &
-           ONLY:  nzb_s_inner, nzt
-
-       USE kinds
-
-       IMPLICIT NONE
-
-       INTEGER(iwp) ::  i                 !<
-       INTEGER(iwp) ::  j                 !<
-       INTEGER(iwp) ::  k                 !<
-
-       REAL(wp)     ::  alpha             !<
-       REAL(wp)     ::  dr                !<
-       REAL(wp)     ::  e_s               !<
-       REAL(wp)     ::  evap              !<
-       REAL(wp)     ::  evap_nr           !<
-       REAL(wp)     ::  f_vent            !<
-       REAL(wp)     ::  g_evap            !<
-       REAL(wp)     ::  lambda_r          !<
-       REAL(wp)     ::  mu_r              !<
-       REAL(wp)     ::  mu_r_2            !<
-       REAL(wp)     ::  mu_r_5d2          !<
-       REAL(wp)     ::  nr_0              !<
-       REAL(wp)     ::  q_s               !<
-       REAL(wp)     ::  sat               !<
-       REAL(wp)     ::  t_l               !<
-       REAL(wp)     ::  temp              !<
-       REAL(wp)     ::  xr                !<
-
-       DO  k = nzb_s_inner(j,i)+1, nzt
-          IF ( qr_1d(k) > eps_sb )  THEN
-!
-!--          Actual liquid water temperature:
-             t_l = t_d_pt(k) * pt_1d(k)
-!
-!--          Saturation vapor pressure at t_l:
-             e_s = 610.78_wp * EXP( 17.269_wp * ( t_l - 273.16_wp ) /          &
-                                    ( t_l - 35.86_wp )                         &
-                                  )
-!
-!--          Computation of saturation humidity:
-             q_s   = 0.622_wp * e_s / ( hyp(k) - 0.378_wp * e_s )
-             alpha = 0.622_wp * l_d_r * l_d_cp / ( t_l * t_l )
-             q_s   = q_s * ( 1.0_wp + alpha * q_1d(k) ) / ( 1.0_wp + alpha * q_s )
-!
-!--          Supersaturation:
-             sat   = ( q_1d(k) - qr_1d(k) - qc_1d(k) ) / q_s - 1.0_wp
-!
-!--          Evaporation needs only to be calculated in subsaturated regions
-             IF ( sat < 0.0_wp )  THEN
-!
-!--             Actual temperature:
-                temp = t_l + l_d_cp * ( qc_1d(k) + qr_1d(k) )
-       
-                g_evap = 1.0_wp / ( ( l_v / ( r_v * temp ) - 1.0_wp ) * l_v /  &
-                                    ( thermal_conductivity_l * temp ) +        &
-                                    r_v * temp / ( diff_coeff_l * e_s )        &
-                                  )
-!
-!--             Mean weight of rain drops
-                xr = hyrho(k) * qr_1d(k) / nr_1d(k)
-!
-!--             Weight averaged diameter of rain drops:
-                dr = ( xr * dpirho_l )**( 1.0_wp / 3.0_wp )
-!
-!--             Compute ventilation factor and intercept parameter 
-!--             (Seifert and Beheng, 2006; Seifert, 2008):
-                IF ( ventilation_effect )  THEN
-!
-!--                Shape parameter of gamma distribution (Milbrandt and Yau, 2005;
-!--                Stevens and Seifert, 2008):
-                   mu_r = 10.0_wp * ( 1.0_wp + TANH( 1.2E3_wp * ( dr - 1.4E-3_wp ) ) )
-!
-!--                Slope parameter of gamma distribution (Seifert, 2008):
-                   lambda_r = ( ( mu_r + 3.0_wp ) * ( mu_r + 2.0_wp ) *        &
-                                ( mu_r + 1.0_wp )                              &
-                              )**( 1.0_wp / 3.0_wp ) / dr
-
-                   mu_r_2   = mu_r + 2.0_wp
-                   mu_r_5d2 = mu_r + 2.5_wp 
-
-                   f_vent = a_vent * gamm( mu_r_2 ) * lambda_r**( -mu_r_2 ) +  & 
-                            b_vent * schmidt_p_1d3 *                           &
-                            SQRT( a_term / kin_vis_air ) * gamm( mu_r_5d2 ) *  &
-                            lambda_r**( -mu_r_5d2 ) *                          &
-                            ( 1.0_wp -                                         &
-                              0.5_wp * ( b_term / a_term ) *                   &
-                              ( lambda_r / ( c_term + lambda_r )               &
-                              )**mu_r_5d2 -                                    &
-                              0.125_wp * ( b_term / a_term )**2 *              &
-                              ( lambda_r / ( 2.0_wp * c_term + lambda_r )      &
-                              )**mu_r_5d2 -                                    &
-                              0.0625_wp * ( b_term / a_term )**3 *             &
-                              ( lambda_r / ( 3.0_wp * c_term + lambda_r )      &
-                              )**mu_r_5d2 -                                    &
-                              0.0390625_wp * ( b_term / a_term )**4 *          & 
-                              ( lambda_r / ( 4.0_wp * c_term + lambda_r )      &
-                              )**mu_r_5d2                                      &
-                            )
-
-                   nr_0   = nr_1d(k) * lambda_r**( mu_r + 1.0_wp ) /           &
-                            gamm( mu_r + 1.0_wp ) 
-                ELSE
-                   f_vent = 1.0_wp
-                   nr_0   = nr_1d(k) * dr
-                ENDIF
-!
-!--             Evaporation rate of rain water content (Seifert and Beheng, 2006):
-                evap    = 2.0_wp * pi * nr_0 * g_evap * f_vent * sat / hyrho(k)
-                evap    = MAX( evap, -qr_1d(k) / dt_micro )
-                evap_nr = MAX( c_evap * evap / xr * hyrho(k),                  &
-                               -nr_1d(k) / dt_micro )
-
-                qr_1d(k) = qr_1d(k) + evap    * dt_micro
-                nr_1d(k) = nr_1d(k) + evap_nr * dt_micro
-
-             ENDIF
-          ENDIF          
-
-       ENDDO
-
-    END SUBROUTINE evaporation_rain_ij
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Sedimentation of cloud droplets (Ackermann et al., 2009, MWR). 
-!> Call for grid point i,j
-!------------------------------------------------------------------------------!
-    SUBROUTINE sedimentation_cloud_ij( i, j )
-
-       USE arrays_3d,                                                          &
-           ONLY:  ddzu, dzu, prr
-
-       USE cloud_parameters,                                                   &
-           ONLY:  hyrho, l_d_cp, pt_d_t
-
-       USE control_parameters,                                                 &
-           ONLY:  call_microphysics_at_all_substeps, intermediate_timestep_count
-
-       USE indices,                                                            &
-           ONLY:  nzb, nzb_s_inner, nzt
-
-       USE kinds
-       
-       USE statistics,                                                         &
-           ONLY:  weight_substep
-
-       IMPLICIT NONE
-
-       INTEGER(iwp) ::  i             !<
-       INTEGER(iwp) ::  j             !<
-       INTEGER(iwp) ::  k             !<
-
-       REAL(wp), DIMENSION(nzb:nzt+1) :: sed_qc  !<
-
-       sed_qc(nzt+1) = 0.0_wp
-
-       DO  k = nzt, nzb_s_inner(j,i)+1, -1
-          IF ( qc_1d(k) > eps_sb )  THEN
-             sed_qc(k) = sed_qc_const * nc_1d(k)**( -2.0_wp / 3.0_wp ) *       &
-                         ( qc_1d(k) * hyrho(k) )**( 5.0_wp / 3.0_wp )
-          ELSE
-             sed_qc(k) = 0.0_wp
-          ENDIF
-
-          sed_qc(k) = MIN( sed_qc(k), hyrho(k) * dzu(k+1) * q_1d(k) /          &
-                                      dt_micro + sed_qc(k+1)                   &
-                         )
-
-          q_1d(k)  = q_1d(k)  + ( sed_qc(k+1) - sed_qc(k) ) * ddzu(k+1) /      &
-                                hyrho(k) * dt_micro
-          qc_1d(k) = qc_1d(k) + ( sed_qc(k+1) - sed_qc(k) ) * ddzu(k+1) /      & 
-                                hyrho(k) * dt_micro
-          pt_1d(k) = pt_1d(k) - ( sed_qc(k+1) - sed_qc(k) ) * ddzu(k+1) /      &
-                                hyrho(k) * l_d_cp * pt_d_t(k) * dt_micro
-
-!
-!--       Compute the precipitation rate of cloud (fog) droplets
-          IF ( call_microphysics_at_all_substeps )  THEN
-             prr(k,j,i) = prr(k,j,i) + sed_qc(k) / hyrho(k) *               &
-                             weight_substep(intermediate_timestep_count)
-          ELSE
-             prr(k,j,i) = prr(k,j,i) + sed_qc(k) / hyrho(k)
-          ENDIF
-
-       ENDDO
-
-    END SUBROUTINE sedimentation_cloud_ij
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Computation of sedimentation flux. Implementation according to Stevens
-!> and Seifert (2008). Code is based on UCLA-LES. Call for grid point i,j
-!------------------------------------------------------------------------------!
-    SUBROUTINE sedimentation_rain_ij( i, j )
-
-       USE arrays_3d,                                                          &
-           ONLY:  ddzu, dzu, prr
-
-       USE cloud_parameters,                                                   &
-           ONLY:  hyrho, l_d_cp, pt_d_t
-
-       USE control_parameters,                                                 &
-           ONLY:  call_microphysics_at_all_substeps, intermediate_timestep_count
-
-       USE indices,                                                            &
-           ONLY:  nzb, nzb_s_inner, nzt
-
-       USE kinds
-
-       USE statistics,                                                         &
-           ONLY:  weight_substep
-       
-       IMPLICIT NONE
-
-       INTEGER(iwp) ::  i                          !<
-       INTEGER(iwp) ::  j                          !<
-       INTEGER(iwp) ::  k                          !<
-       INTEGER(iwp) ::  k_run                      !<
-
-       REAL(wp)     ::  c_run                      !<
-       REAL(wp)     ::  d_max                      !<
-       REAL(wp)     ::  d_mean                     !<
-       REAL(wp)     ::  d_min                      !<
-       REAL(wp)     ::  dr                         !<
-       REAL(wp)     ::  flux                       !<
-       REAL(wp)     ::  lambda_r                   !<
-       REAL(wp)     ::  mu_r                       !<
-       REAL(wp)     ::  z_run                      !<
-
-       REAL(wp), DIMENSION(nzb:nzt+1) ::  c_nr     !<
-       REAL(wp), DIMENSION(nzb:nzt+1) ::  c_qr     !<
-       REAL(wp), DIMENSION(nzb:nzt+1) ::  nr_slope !<
-       REAL(wp), DIMENSION(nzb:nzt+1) ::  qr_slope !<
-       REAL(wp), DIMENSION(nzb:nzt+1) ::  sed_nr   !<
-       REAL(wp), DIMENSION(nzb:nzt+1) ::  sed_qr   !<
-       REAL(wp), DIMENSION(nzb:nzt+1) ::  w_nr     !<
-       REAL(wp), DIMENSION(nzb:nzt+1) ::  w_qr     !<
-
-!
-!--    Compute velocities 
-       DO  k = nzb_s_inner(j,i)+1, nzt
-          IF ( qr_1d(k) > eps_sb )  THEN
-!
-!--          Weight averaged diameter of rain drops:
-             dr = ( hyrho(k) * qr_1d(k) / nr_1d(k) * dpirho_l )**( 1.0_wp / 3.0_wp )
-!
-!--          Shape parameter of gamma distribution (Milbrandt and Yau, 2005;
-!--          Stevens and Seifert, 2008):
-             mu_r = 10.0_wp * ( 1.0_wp + TANH( 1.2E3_wp * ( dr - 1.4E-3_wp ) ) )
-!
-!--          Slope parameter of gamma distribution (Seifert, 2008):
-             lambda_r = ( ( mu_r + 3.0_wp ) * ( mu_r + 2.0_wp ) *              &
-                          ( mu_r + 1.0_wp ) )**( 1.0_wp / 3.0_wp ) / dr
-
-             w_nr(k) = MAX( 0.1_wp, MIN( 20.0_wp,                              &
-                                         a_term - b_term * ( 1.0_wp +          &
-                                            c_term / lambda_r )**( -1.0_wp *   &
-                                            ( mu_r + 1.0_wp ) )                &
-                                        )                                      &
-                          )
-             w_qr(k) = MAX( 0.1_wp, MIN( 20.0_wp,                              &
-                                         a_term - b_term * ( 1.0_wp +          &
-                                            c_term / lambda_r )**( -1.0_wp *   &
-                                            ( mu_r + 4.0_wp ) )                &
-                                       )                                       &
-                          )
-          ELSE
-             w_nr(k) = 0.0_wp
-             w_qr(k) = 0.0_wp
-          ENDIF
-       ENDDO
-!
-!--    Adjust boundary values
-       w_nr(nzb_s_inner(j,i)) = w_nr(nzb_s_inner(j,i)+1)
-       w_qr(nzb_s_inner(j,i)) = w_qr(nzb_s_inner(j,i)+1)
-       w_nr(nzt+1) = 0.0_wp
-       w_qr(nzt+1) = 0.0_wp
-!
-!--    Compute Courant number
-       DO  k = nzb_s_inner(j,i)+1, nzt
-          c_nr(k) = 0.25_wp * ( w_nr(k-1) + 2.0_wp * w_nr(k) + w_nr(k+1) ) *   &
-                    dt_micro * ddzu(k)
-          c_qr(k) = 0.25_wp * ( w_qr(k-1) + 2.0_wp * w_qr(k) + w_qr(k+1) ) *   &
-                    dt_micro * ddzu(k)
-       ENDDO     
-!
-!--    Limit slopes with monotonized centered (MC) limiter (van Leer, 1977):
-       IF ( limiter_sedimentation )  THEN
-
-          DO k = nzb_s_inner(j,i)+1, nzt
-             d_mean = 0.5_wp * ( qr_1d(k+1) - qr_1d(k-1) )
-             d_min  = qr_1d(k) - MIN( qr_1d(k+1), qr_1d(k), qr_1d(k-1) )
-             d_max  = MAX( qr_1d(k+1), qr_1d(k), qr_1d(k-1) ) - qr_1d(k)
-
-             qr_slope(k) = SIGN(1.0_wp, d_mean) * MIN ( 2.0_wp * d_min,        &
-                                                        2.0_wp * d_max,        &
-                                                        ABS( d_mean ) )
-
-             d_mean = 0.5_wp * ( nr_1d(k+1) - nr_1d(k-1) )
-             d_min  = nr_1d(k) - MIN( nr_1d(k+1), nr_1d(k), nr_1d(k-1) )
-             d_max  = MAX( nr_1d(k+1), nr_1d(k), nr_1d(k-1) ) - nr_1d(k)
-
-             nr_slope(k) = SIGN(1.0_wp, d_mean) * MIN ( 2.0_wp * d_min,        &
-                                                        2.0_wp * d_max,        &
-                                                        ABS( d_mean ) )
-          ENDDO
-
-       ELSE
-
-          nr_slope = 0.0_wp
-          qr_slope = 0.0_wp
-
-       ENDIF
-
-       sed_nr(nzt+1) = 0.0_wp
-       sed_qr(nzt+1) = 0.0_wp
-!
-!--    Compute sedimentation flux
-       DO  k = nzt, nzb_s_inner(j,i)+1, -1
-!
-!--       Sum up all rain drop number densities which contribute to the flux 
-!--       through k-1/2
-          flux  = 0.0_wp
-          z_run = 0.0_wp ! height above z(k)
-          k_run = k
-          c_run = MIN( 1.0_wp, c_nr(k) )
-          DO WHILE ( c_run > 0.0_wp  .AND.  k_run <= nzt )
-             flux  = flux + hyrho(k_run) *                                     &
-                     ( nr_1d(k_run) + nr_slope(k_run) * ( 1.0_wp - c_run ) *   &
-                     0.5_wp ) * c_run * dzu(k_run)
-             z_run = z_run + dzu(k_run)
-             k_run = k_run + 1
-             c_run = MIN( 1.0_wp, c_nr(k_run) - z_run * ddzu(k_run) )
-          ENDDO
-!
-!--       It is not allowed to sediment more rain drop number density than 
-!--       available
-          flux = MIN( flux,                                                    &
-                      hyrho(k) * dzu(k+1) * nr_1d(k) + sed_nr(k+1) * dt_micro )
-
-          sed_nr(k) = flux / dt_micro
-          nr_1d(k)  = nr_1d(k) + ( sed_nr(k+1) - sed_nr(k) ) * ddzu(k+1) /     &
-                                    hyrho(k) * dt_micro
-!
-!--       Sum up all rain water content which contributes to the flux 
-!--       through k-1/2
-          flux  = 0.0_wp
-          z_run = 0.0_wp ! height above z(k)
-          k_run = k
-          c_run = MIN( 1.0_wp, c_qr(k) )
-
-          DO WHILE ( c_run > 0.0_wp  .AND.  k_run <= nzt )
-
-             flux  = flux + hyrho(k_run) *                                     &
-                     ( qr_1d(k_run) + qr_slope(k_run) * ( 1.0_wp - c_run ) *   &
-                     0.5_wp ) * c_run * dzu(k_run)
-             z_run = z_run + dzu(k_run)
-             k_run = k_run + 1
-             c_run = MIN( 1.0_wp, c_qr(k_run) - z_run * ddzu(k_run) )
-
-          ENDDO
-!
-!--       It is not allowed to sediment more rain water content than available
-          flux = MIN( flux,                                                    &
-                      hyrho(k) * dzu(k) * qr_1d(k) + sed_qr(k+1) * dt_micro )
-
-          sed_qr(k) = flux / dt_micro
-
-          qr_1d(k) = qr_1d(k) + ( sed_qr(k+1) - sed_qr(k) ) * ddzu(k+1) /      &
-                                hyrho(k) * dt_micro
-          q_1d(k)  = q_1d(k)  + ( sed_qr(k+1) - sed_qr(k) ) * ddzu(k+1) /      &
-                                hyrho(k) * dt_micro 
-          pt_1d(k) = pt_1d(k) - ( sed_qr(k+1) - sed_qr(k) ) * ddzu(k+1) /      &
-                                hyrho(k) * l_d_cp * pt_d_t(k) * dt_micro
-!
-!--       Compute the rain rate
-          IF ( call_microphysics_at_all_substeps )  THEN
-             prr(k,j,i) = prr(k,j,i) + sed_qr(k) / hyrho(k)                    &
-                          * weight_substep(intermediate_timestep_count)
-          ELSE
-             prr(k,j,i) = prr(k,j,i) + sed_qr(k) / hyrho(k)
-          ENDIF
-
-       ENDDO
-
-    END SUBROUTINE sedimentation_rain_ij
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> This subroutine computes the precipitation amount due to gravitational
-!> settling of rain and cloud (fog) droplets
-!------------------------------------------------------------------------------!
-    SUBROUTINE calc_precipitation_amount_ij( i, j )
-
-       USE arrays_3d,                                                          &
-           ONLY:  precipitation_amount, prr
-
-       USE cloud_parameters,                                                   &
-           ONLY:  hyrho
-
-       USE control_parameters,                                                 &
-           ONLY:  call_microphysics_at_all_substeps, dt_do2d_xy, dt_3d,        &
-                  intermediate_timestep_count, intermediate_timestep_count_max,&
-                  precipitation_amount_interval, time_do2d_xy
-
-       USE indices,                                                            &
-           ONLY:  nzb_s_inner
-
-       USE kinds
-
-       IMPLICIT NONE
-
-       INTEGER(iwp) ::  i                          !:
-       INTEGER(iwp) ::  j                          !:
-
-
-       IF ( ( dt_do2d_xy - time_do2d_xy ) < precipitation_amount_interval .AND.&
-            ( .NOT. call_microphysics_at_all_substeps .OR.                     &
-            intermediate_timestep_count == intermediate_timestep_count_max ) ) &
-       THEN
-
-          precipitation_amount(j,i) = precipitation_amount(j,i) +              &
-                                      prr(nzb_s_inner(j,i)+1,j,i) *            &
-                                      hyrho(nzb_s_inner(j,i)+1) * dt_3d
-       ENDIF
-
-    END SUBROUTINE calc_precipitation_amount_ij
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> This function computes the gamma function (Press et al., 1992).
-!> The gamma function is needed for the calculation of the evaporation 
-!> of rain drops.
-!------------------------------------------------------------------------------!
-    FUNCTION gamm( xx ) 
-
-       USE kinds
-
-       IMPLICIT NONE 
-
-       INTEGER(iwp) ::  j            !<
-
-       REAL(wp)     ::  gamm         !<
-       REAL(wp)     ::  ser          !<
-       REAL(wp)     ::  tmp          !<
-       REAL(wp)     ::  x_gamm       !<
-       REAL(wp)     ::  xx           !<
-       REAL(wp)     ::  y_gamm       !<
-
-
-       REAL(wp), PARAMETER  ::  stp = 2.5066282746310005_wp               !<
-       REAL(wp), PARAMETER  ::  cof(6) = (/ 76.18009172947146_wp,      &
-                                           -86.50532032941677_wp,      &
-                                            24.01409824083091_wp,      &
-                                            -1.231739572450155_wp,     &
-                                             0.1208650973866179E-2_wp, &
-                                            -0.5395239384953E-5_wp /)     !<
-
-       x_gamm = xx
-       y_gamm = x_gamm
-       tmp = x_gamm + 5.5_wp
-       tmp = ( x_gamm + 0.5_wp ) * LOG( tmp ) - tmp
-       ser = 1.000000000190015_wp
-
-       DO  j = 1, 6 
-          y_gamm = y_gamm + 1.0_wp 
-          ser    = ser + cof( j ) / y_gamm 
-       ENDDO
-
-! 
-!--    Until this point the algorithm computes the logarithm of the gamma 
-!--    function. Hence, the exponential function is used.  
-!       gamm = EXP( tmp + LOG( stp * ser / x_gamm ) ) 
-       gamm = EXP( tmp ) * stp * ser / x_gamm 
-
-       RETURN 
- 
-    END FUNCTION gamm 
-
- END MODULE microphysics_mod
Index: /palm/trunk/SOURCE/microphysics_mod.f90
===================================================================
--- /palm/trunk/SOURCE/microphysics_mod.f90	(revision 1850)
+++ /palm/trunk/SOURCE/microphysics_mod.f90	(revision 1850)
@@ -0,0 +1,2225 @@
+!> @file microphysics_mod.f90
+!--------------------------------------------------------------------------------!
+! This file is part of PALM.
+!
+! PALM is free software: you can redistribute it and/or modify it under the terms
+! of the GNU General Public License as published by the Free Software Foundation,
+! either version 3 of the License, or (at your option) any later version.
+!
+! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
+! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
+! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along with
+! PALM. If not, see <http://www.gnu.org/licenses/>.
+!
+! Copyright 1997-2016 Leibniz Universitaet Hannover
+!--------------------------------------------------------------------------------!
+!
+! Current revisions:
+! ------------------
+! Module renamed
+! Adapted for modularization of microphysics.
+!
+! Former revisions:
+! -----------------
+! $Id$
+!
+! 1845 2016-04-08 08:29:13Z raasch
+! nzb_2d replaced by nzb_s_inner, Kessler precipitation is stored at surface
+! point (instead of one point above surface)
+!
+! 1831 2016-04-07 13:15:51Z hoffmann
+! turbulence renamed collision_turbulence,
+! drizzle renamed cloud_water_sedimentation. cloud_water_sedimentation also
+! avaialble for microphysics_kessler.
+!
+! 1822 2016-04-07 07:49:42Z hoffmann
+! Unused variables removed.
+! Kessler scheme integrated.
+!
+! 1691 2015-10-26 16:17:44Z maronga
+! Added new routine calc_precipitation_amount. The routine now allows to account
+! for precipitation due to sedimenation of cloud (fog) droplets
+! 
+! 1682 2015-10-07 23:56:08Z knoop
+! Code annotations made doxygen readable 
+!
+! 1646 2015-09-02 16:00:10Z hoffmann
+! Bugfix: Wrong computation of d_mean.
+!
+! 1361 2014-04-16 15:17:48Z hoffmann
+! Bugfix in sedimentation_rain: Index corrected.
+! Vectorized version of adjust_cloud added.
+! Little reformatting of the code.
+! 
+! 1353 2014-04-08 15:21:23Z heinze
+! REAL constants provided with KIND-attribute
+! 
+! 1346 2014-03-27 13:18:20Z heinze
+! Bugfix: REAL constants provided with KIND-attribute especially in call of 
+! intrinsic function like MAX, MIN, SIGN
+! 
+! 1334 2014-03-25 12:21:40Z heinze
+! Bugfix: REAL constants provided with KIND-attribute
+!
+! 1322 2014-03-20 16:38:49Z raasch
+! REAL constants defined as wp-kind
+!
+! 1320 2014-03-20 08:40:49Z raasch
+! ONLY-attribute added to USE-statements,
+! kind-parameters added to all INTEGER and REAL declaration statements,
+! kinds are defined in new module kinds,
+! comment fields (!:) to be used for variable explanations added to
+! all variable declaration statements
+!
+! 1241 2013-10-30 11:36:58Z heinze
+! hyp and rho have to be calculated at each time step if data from external
+! file LSF_DATA are used
+!
+! 1115 2013-03-26 18:16:16Z hoffmann
+! microphyical tendencies are calculated in microphysics_control in an optimized
+! way; unrealistic values are prevented; bugfix in evaporation; some reformatting
+!
+! 1106 2013-03-04 05:31:38Z raasch
+! small changes in code formatting
+!
+! 1092 2013-02-02 11:24:22Z raasch
+! unused variables removed
+! file put under GPL
+!
+! 1065 2012-11-22 17:42:36Z hoffmann
+! Sedimentation process implemented according to Stevens and Seifert (2008).
+! Turbulence effects on autoconversion and accretion added (Seifert, Nuijens
+! and Stevens, 2010).
+!
+! 1053 2012-11-13 17:11:03Z hoffmann
+! initial revision
+! 
+! Description:
+! ------------
+!> Calculate bilk cloud microphysics.
+!------------------------------------------------------------------------------!
+ MODULE microphysics_mod
+
+    USE  kinds
+
+    IMPLICIT NONE
+
+    LOGICAL ::  cloud_water_sedimentation = .FALSE.  !< cloud water sedimentation
+    LOGICAL ::  limiter_sedimentation = .TRUE.       !< sedimentation limiter
+    LOGICAL ::  collision_turbulence = .FALSE.       !< turbulence effects
+    LOGICAL ::  ventilation_effect = .TRUE.          !< ventilation effect
+
+    REAL(wp) ::  a_1 = 8.69E-4_wp          !< coef. in turb. parametrization (cm-2 s3)
+    REAL(wp) ::  a_2 = -7.38E-5_wp         !< coef. in turb. parametrization (cm-2 s3)
+    REAL(wp) ::  a_3 = -1.40E-2_wp         !< coef. in turb. parametrization
+    REAL(wp) ::  a_term = 9.65_wp          !< coef. for terminal velocity (m s-1)
+    REAL(wp) ::  a_vent = 0.78_wp          !< coef. for ventilation effect
+    REAL(wp) ::  b_1 = 11.45E-6_wp         !< coef. in turb. parametrization (m)
+    REAL(wp) ::  b_2 = 9.68E-6_wp          !< coef. in turb. parametrization (m)
+    REAL(wp) ::  b_3 = 0.62_wp             !< coef. in turb. parametrization
+    REAL(wp) ::  b_term = 9.8_wp           !< coef. for terminal velocity (m s-1)
+    REAL(wp) ::  b_vent = 0.308_wp         !< coef. for ventilation effect
+    REAL(wp) ::  beta_cc = 3.09E-4_wp      !< coef. in turb. parametrization (cm-2 s3)
+    REAL(wp) ::  c_1 = 4.82E-6_wp          !< coef. in turb. parametrization (m)
+    REAL(wp) ::  c_2 = 4.8E-6_wp           !< coef. in turb. parametrization (m)
+    REAL(wp) ::  c_3 = 0.76_wp             !< coef. in turb. parametrization
+    REAL(wp) ::  c_const = 0.93_wp         !< const. in Taylor-microscale Reynolds number
+    REAL(wp) ::  c_evap = 0.7_wp           !< constant in evaporation
+    REAL(wp) ::  c_term = 600.0_wp         !< coef. for terminal velocity (m-1)
+    REAL(wp) ::  diff_coeff_l = 0.23E-4_wp  !< diffusivity of water vapor (m2 s-1)
+    REAL(wp) ::  eps_sb = 1.0E-20_wp       !< threshold in two-moments scheme
+    REAL(wp) ::  k_cc = 9.44E09_wp         !< const. cloud-cloud kernel (m3 kg-2 s-1)
+    REAL(wp) ::  k_cr0 = 4.33_wp           !< const. cloud-rain kernel (m3 kg-1 s-1)
+    REAL(wp) ::  k_rr = 7.12_wp            !< const. rain-rain kernel (m3 kg-1 s-1)
+    REAL(wp) ::  k_br = 1000.0_wp          !< const. in breakup parametrization (m-1)
+    REAL(wp) ::  k_st = 1.2E8_wp           !< const. in drizzle parametrization (m-1 s-1)
+    REAL(wp) ::  kappa_rr = 60.7_wp        !< const. in collision kernel (kg-1/3)
+    REAL(wp) ::  kin_vis_air = 1.4086E-5_wp  !< kin. viscosity of air (m2 s-1)
+    REAL(wp) ::  prec_time_const = 0.001_wp  !< coef. in Kessler scheme (s-1)
+    REAL(wp) ::  ql_crit = 0.0005_wp       !< coef. in Kessler scheme (kg kg-1)
+    REAL(wp) ::  schmidt_p_1d3=0.8921121_wp  !< Schmidt number**0.33333, 0.71**0.33333
+    REAL(wp) ::  sigma_gc = 1.3_wp         !< geometric standard deviation cloud droplets
+    REAL(wp) ::  thermal_conductivity_l = 2.43E-2_wp  !< therm. cond. air (J m-1 s-1 K-1)
+    REAL(wp) ::  w_precipitation = 9.65_wp  !< maximum terminal velocity (m s-1)
+    REAL(wp) ::  x0 = 2.6E-10_wp           !< separating drop mass (kg)
+    REAL(wp) ::  xrmin = 2.6E-10_wp        !< minimum rain drop size (kg)
+    REAL(wp) ::  xrmax = 5.0E-6_wp         !< maximum rain drop site (kg)
+
+    REAL(wp) ::  c_sedimentation = 2.0_wp  !< Courant number of sedimentation process
+    REAL(wp) ::  dpirho_l                  !< 6.0 / ( pi * rho_l )
+    REAL(wp) ::  dt_micro                  !< microphysics time step
+    REAL(wp) ::  nc_const = 70.0E6_wp      !< cloud droplet concentration
+    REAL(wp) ::  dt_precipitation = 100.0_wp !< timestep precipitation (s)
+    REAL(wp) ::  sed_qc_const              !< const. for sedimentation of cloud water
+    REAL(wp) ::  pirho_l                   !< pi * rho_l / 6.0;
+
+    REAL(wp), DIMENSION(:), ALLOCATABLE ::  nc_1d  !<
+    REAL(wp), DIMENSION(:), ALLOCATABLE ::  nr_1d  !<
+    REAL(wp), DIMENSION(:), ALLOCATABLE ::  pt_1d  !<
+    REAL(wp), DIMENSION(:), ALLOCATABLE ::  qc_1d  !<
+    REAL(wp), DIMENSION(:), ALLOCATABLE ::  qr_1d  !<
+    REAL(wp), DIMENSION(:), ALLOCATABLE ::  q_1d   !<
+
+    SAVE
+
+    PRIVATE
+    PUBLIC microphysics_control, microphysics_init
+
+    PUBLIC cloud_water_sedimentation, collision_turbulence, c_sedimentation,   &
+           dt_precipitation, limiter_sedimentation, nc_const, sigma_gc,        &
+           ventilation_effect
+
+    INTERFACE microphysics_control
+       MODULE PROCEDURE microphysics_control
+       MODULE PROCEDURE microphysics_control_ij
+    END INTERFACE microphysics_control
+
+    INTERFACE adjust_cloud
+       MODULE PROCEDURE adjust_cloud
+       MODULE PROCEDURE adjust_cloud_ij
+    END INTERFACE adjust_cloud
+
+    INTERFACE autoconversion
+       MODULE PROCEDURE autoconversion
+       MODULE PROCEDURE autoconversion_ij
+    END INTERFACE autoconversion
+
+    INTERFACE autoconversion_kessler
+       MODULE PROCEDURE autoconversion_kessler
+       MODULE PROCEDURE autoconversion_kessler_ij
+    END INTERFACE autoconversion_kessler
+
+    INTERFACE accretion
+       MODULE PROCEDURE accretion
+       MODULE PROCEDURE accretion_ij
+    END INTERFACE accretion
+
+    INTERFACE selfcollection_breakup
+       MODULE PROCEDURE selfcollection_breakup
+       MODULE PROCEDURE selfcollection_breakup_ij
+    END INTERFACE selfcollection_breakup
+
+    INTERFACE evaporation_rain
+       MODULE PROCEDURE evaporation_rain
+       MODULE PROCEDURE evaporation_rain_ij
+    END INTERFACE evaporation_rain
+
+    INTERFACE sedimentation_cloud
+       MODULE PROCEDURE sedimentation_cloud
+       MODULE PROCEDURE sedimentation_cloud_ij
+    END INTERFACE sedimentation_cloud
+ 
+    INTERFACE sedimentation_rain
+       MODULE PROCEDURE sedimentation_rain
+       MODULE PROCEDURE sedimentation_rain_ij
+    END INTERFACE sedimentation_rain
+
+    INTERFACE calc_precipitation_amount
+       MODULE PROCEDURE calc_precipitation_amount
+       MODULE PROCEDURE calc_precipitation_amount_ij
+    END INTERFACE calc_precipitation_amount
+
+ CONTAINS
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Initialization of bulk microphysics
+!------------------------------------------------------------------------------!
+    SUBROUTINE microphysics_init
+
+       USE arrays_3d,                                                          &
+           ONLY:  dzu
+
+       USE constants,                                                          &
+           ONLY:  pi
+
+       USE cloud_parameters,                                                   &
+           ONLY:  rho_l
+
+       USE control_parameters,                                                 &
+           ONLY:  microphysics_seifert
+
+       USE indices,                                                            &
+           ONLY:  nzb, nzt
+
+       IMPLICIT NONE
+
+!
+!--    constant for the sedimentation of cloud water (2-moment cloud physics)
+       sed_qc_const = k_st * ( 3.0_wp / ( 4.0_wp * pi * rho_l )                &
+                          )**( 2.0_wp / 3.0_wp ) *                             &
+                      EXP( 5.0_wp * LOG( sigma_gc )**2 )
+
+!
+!--    Calculate timestep according to precipitation
+       IF ( microphysics_seifert )  THEN
+          dt_precipitation = c_sedimentation * MINVAL( dzu(nzb+2:nzt) ) /      &
+                             w_precipitation
+       ENDIF
+
+!
+!--    Pre-calculate frequently calculated fractions of pi and rho_l
+       pirho_l  = pi * rho_l / 6.0_wp
+       dpirho_l = 1.0_wp / pirho_l
+
+!
+!--    Allocate 1D microphysics arrays
+       ALLOCATE ( nc_1d(nzb:nzt+1), pt_1d(nzb:nzt+1), q_1d(nzb:nzt+1),         &
+                  qc_1d(nzb:nzt+1) )
+
+       IF ( microphysics_seifert )  THEN
+          ALLOCATE ( nr_1d(nzb:nzt+1), qr_1d(nzb:nzt+1) )
+       ENDIF
+
+!
+!--    Initialze nc_1d with nc_const
+       nc_1d = nc_const
+
+    END SUBROUTINE microphysics_init
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Control of microphysics for all grid points
+!------------------------------------------------------------------------------!
+    SUBROUTINE microphysics_control
+
+       USE arrays_3d,                                                          &
+           ONLY:  hyp, pt_init, prr, zu
+
+       USE cloud_parameters,                                                   &
+           ONLY:  cp, hyrho, pt_d_t, r_d, t_d_pt
+
+       USE control_parameters,                                                 &
+           ONLY:  call_microphysics_at_all_substeps, dt_3d, g,                 &
+                  intermediate_timestep_count, large_scale_forcing,            &
+                  lsf_surf, microphysics_kessler, microphysics_seifert,        &
+                  pt_surface, rho_surface,surface_pressure
+
+       USE indices,                                                            &
+           ONLY:  nzb, nzt
+
+       USE kinds
+
+       USE statistics,                                                         &
+           ONLY:  weight_pres
+
+       IMPLICIT NONE
+
+       INTEGER(iwp) ::  k                 !<
+
+       REAL(wp)     ::  t_surface         !<
+
+       IF ( large_scale_forcing  .AND.  lsf_surf ) THEN
+!
+!--       Calculate:
+!--       pt / t : ratio of potential and actual temperature (pt_d_t)
+!--       t / pt : ratio of actual and potential temperature (t_d_pt)
+!--       p_0(z) : vertical profile of the hydrostatic pressure (hyp)
+          t_surface = pt_surface * ( surface_pressure / 1000.0_wp )**0.286_wp
+          DO  k = nzb, nzt+1
+             hyp(k)    = surface_pressure * 100.0_wp * &
+                         ( ( t_surface - g / cp * zu(k) ) /                    &
+                         t_surface )**(1.0_wp / 0.286_wp)
+             pt_d_t(k) = ( 100000.0_wp / hyp(k) )**0.286_wp
+             t_d_pt(k) = 1.0_wp / pt_d_t(k)
+             hyrho(k)  = hyp(k) / ( r_d * t_d_pt(k) * pt_init(k) )       
+          ENDDO
+
+!
+!--       Compute reference density
+          rho_surface = surface_pressure * 100.0_wp / ( r_d * t_surface )
+       ENDIF
+
+!
+!--    Compute length of time step 
+       IF ( call_microphysics_at_all_substeps )  THEN
+          dt_micro = dt_3d * weight_pres(intermediate_timestep_count)
+       ELSE
+          dt_micro = dt_3d
+       ENDIF
+
+!
+!--    Reset precipitation rate
+       IF ( intermediate_timestep_count == 1 )  prr = 0.0_wp
+
+!
+!--    Compute cloud physics
+       IF ( microphysics_kessler )  THEN
+
+          CALL autoconversion_kessler
+          IF ( cloud_water_sedimentation )  CALL sedimentation_cloud
+
+       ELSEIF ( microphysics_seifert )  THEN
+
+          CALL adjust_cloud
+          CALL autoconversion
+          CALL accretion
+          CALL selfcollection_breakup
+          CALL evaporation_rain
+          CALL sedimentation_rain
+          IF ( cloud_water_sedimentation )  CALL sedimentation_cloud
+
+       ENDIF
+
+       CALL calc_precipitation_amount
+
+    END SUBROUTINE microphysics_control
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Adjust number of raindrops to avoid nonlinear effects in sedimentation and 
+!> evaporation of rain drops due to too small or too big weights 
+!> of rain drops (Stevens and Seifert, 2008).
+!------------------------------------------------------------------------------!
+    SUBROUTINE adjust_cloud
+
+       USE arrays_3d,                                                          &
+           ONLY:  qr, nr
+
+       USE cloud_parameters,                                                   &
+           ONLY:  hyrho
+
+       USE cpulog,                                                             &
+           ONLY:  cpu_log, log_point_s
+
+       USE indices,                                                            &
+           ONLY:  nxl, nxr, nys, nyn, nzb_s_inner, nzt
+
+       USE kinds
+
+       IMPLICIT NONE
+
+       INTEGER(iwp) ::  i                 !<
+       INTEGER(iwp) ::  j                 !<
+       INTEGER(iwp) ::  k                 !<
+
+       CALL cpu_log( log_point_s(54), 'adjust_cloud', 'start' )
+
+       DO  i = nxl, nxr
+          DO  j = nys, nyn
+             DO  k = nzb_s_inner(j,i)+1, nzt
+                IF ( qr(k,j,i) <= eps_sb )  THEN
+                   qr(k,j,i) = 0.0_wp
+                   nr(k,j,i) = 0.0_wp
+                ELSE
+                   IF ( nr(k,j,i) * xrmin > qr(k,j,i) * hyrho(k) )  THEN
+                      nr(k,j,i) = qr(k,j,i) * hyrho(k) / xrmin
+                   ELSEIF ( nr(k,j,i) * xrmax < qr(k,j,i) * hyrho(k) )  THEN
+                      nr(k,j,i) = qr(k,j,i) * hyrho(k) / xrmax
+                   ENDIF
+                ENDIF
+             ENDDO
+          ENDDO
+       ENDDO
+
+       CALL cpu_log( log_point_s(54), 'adjust_cloud', 'stop' )
+
+    END SUBROUTINE adjust_cloud
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Autoconversion rate (Seifert and Beheng, 2006).
+!------------------------------------------------------------------------------!
+    SUBROUTINE autoconversion
+
+       USE arrays_3d,                                                          &
+           ONLY:  diss, dzu, nr, qc, qr
+
+       USE cloud_parameters,                                                   &
+           ONLY:  hyrho
+
+       USE control_parameters,                                                 &
+           ONLY:  rho_surface
+
+       USE cpulog,                                                             &
+           ONLY:  cpu_log, log_point_s
+
+       USE grid_variables,                                                     &
+           ONLY:  dx, dy
+
+       USE indices,                                                            &
+           ONLY:  nxl, nxr, nys, nyn, nzb_s_inner, nzt
+
+       USE kinds
+
+       IMPLICIT NONE
+
+       INTEGER(iwp) ::  i                 !<
+       INTEGER(iwp) ::  j                 !<
+       INTEGER(iwp) ::  k                 !<
+
+       REAL(wp)     ::  alpha_cc          !<                   
+       REAL(wp)     ::  autocon           !<
+       REAL(wp)     ::  dissipation       !<
+       REAL(wp)     ::  k_au              !<
+       REAL(wp)     ::  l_mix             !<
+       REAL(wp)     ::  nu_c              !<
+       REAL(wp)     ::  phi_au            !<
+       REAL(wp)     ::  r_cc              !<
+       REAL(wp)     ::  rc                !<
+       REAL(wp)     ::  re_lambda         !<
+       REAL(wp)     ::  sigma_cc          !<
+       REAL(wp)     ::  tau_cloud         !<
+       REAL(wp)     ::  xc                !<
+
+       CALL cpu_log( log_point_s(55), 'autoconversion', 'start' )
+
+       DO  i = nxl, nxr
+          DO  j = nys, nyn
+             DO  k = nzb_s_inner(j,i)+1, nzt
+
+                IF ( qc(k,j,i) > eps_sb )  THEN
+
+                   k_au = k_cc / ( 20.0_wp * x0 )
+!
+!--                Intern time scale of coagulation (Seifert and Beheng, 2006):
+!--                (1.0_wp - qc(k,j,i) / ( qc(k,j,i) + qr(k,j,i) ))
+                   tau_cloud = 1.0_wp - qc(k,j,i) / ( qr(k,j,i) + qc(k,j,i) )
+!
+!--                Universal function for autoconversion process 
+!--                (Seifert and Beheng, 2006):
+                   phi_au = 600.0_wp * tau_cloud**0.68_wp *                    &
+                            ( 1.0_wp - tau_cloud**0.68_wp )**3
+!
+!--                Shape parameter of gamma distribution (Geoffroy et al., 2010):
+!--                (Use constant nu_c = 1.0_wp instead?)
+                   nu_c = 1.0_wp !MAX( 0.0_wp, 1580.0_wp * hyrho(k) * qc(k,j,i) - 0.28_wp )
+!
+!--                Mean weight of cloud droplets:
+                   xc = hyrho(k) * qc(k,j,i) / nc_const
+!
+!--                Parameterized turbulence effects on autoconversion (Seifert, 
+!--                Nuijens and Stevens, 2010)
+                   IF ( collision_turbulence )  THEN
+!
+!--                   Weight averaged radius of cloud droplets:
+                      rc = 0.5_wp * ( xc * dpirho_l )**( 1.0_wp / 3.0_wp )
+
+                      alpha_cc = ( a_1 + a_2 * nu_c ) / ( 1.0_wp + a_3 * nu_c )
+                      r_cc     = ( b_1 + b_2 * nu_c ) / ( 1.0_wp + b_3 * nu_c )
+                      sigma_cc = ( c_1 + c_2 * nu_c ) / ( 1.0_wp + c_3 * nu_c )
+!
+!--                   Mixing length (neglecting distance to ground and 
+!--                   stratification)
+                      l_mix = ( dx * dy * dzu(k) )**( 1.0_wp / 3.0_wp )
+!
+!--                   Limit dissipation rate according to Seifert, Nuijens and 
+!--                   Stevens (2010)
+                      dissipation = MIN( 0.06_wp, diss(k,j,i) )
+!
+!--                   Compute Taylor-microscale Reynolds number:
+                      re_lambda = 6.0_wp / 11.0_wp *                           &
+                                  ( l_mix / c_const )**( 2.0_wp / 3.0_wp ) *   &
+                                  SQRT( 15.0_wp / kin_vis_air ) *              &
+                                  dissipation**( 1.0_wp / 6.0_wp )
+!
+!--                   The factor of 1.0E4 is needed to convert the dissipation 
+!--                   rate from m2 s-3 to cm2 s-3.
+                      k_au = k_au * ( 1.0_wp +                                 &
+                                      dissipation * 1.0E4_wp *                 &
+                                      ( re_lambda * 1.0E-3_wp )**0.25_wp *     &
+                                      ( alpha_cc * EXP( -1.0_wp * ( ( rc -     &      
+                                                                      r_cc ) / &
+                                                        sigma_cc )**2          &
+                                                      ) + beta_cc              &
+                                      )                                        &
+                                    )
+                   ENDIF
+!
+!--                Autoconversion rate (Seifert and Beheng, 2006):
+                   autocon = k_au * ( nu_c + 2.0_wp ) * ( nu_c + 4.0_wp ) /    &
+                             ( nu_c + 1.0_wp )**2 * qc(k,j,i)**2 * xc**2 *     &
+                             ( 1.0_wp + phi_au / ( 1.0_wp - tau_cloud )**2 ) * &
+                             rho_surface
+                   autocon = MIN( autocon, qc(k,j,i) / dt_micro )
+
+                   qr(k,j,i) = qr(k,j,i) + autocon * dt_micro
+                   qc(k,j,i) = qc(k,j,i) - autocon * dt_micro 
+                   nr(k,j,i) = nr(k,j,i) + autocon / x0 * hyrho(k) * dt_micro
+
+                ENDIF
+
+             ENDDO
+          ENDDO
+       ENDDO
+
+       CALL cpu_log( log_point_s(55), 'autoconversion', 'stop' )
+
+    END SUBROUTINE autoconversion
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Autoconversion process (Kessler, 1969).
+!------------------------------------------------------------------------------!
+    SUBROUTINE autoconversion_kessler
+
+       USE arrays_3d,                                                          &
+           ONLY:  dzw, pt, prr, q, qc
+
+       USE cloud_parameters,                                                   &
+           ONLY:  l_d_cp, pt_d_t
+
+       USE indices,                                                            &
+           ONLY:  nxl, nxr, nyn, nys, nzb_s_inner, nzt
+
+       USE kinds
+
+
+       IMPLICIT NONE
+
+       INTEGER(iwp) ::  i !<
+       INTEGER(iwp) ::  j !<
+       INTEGER(iwp) ::  k !<
+
+       REAL(wp)    ::  dqdt_precip !<
+
+       DO  i = nxl, nxr
+          DO  j = nys, nyn
+             DO  k = nzb_s_inner(j,i)+1, nzt
+
+                IF ( qc(k,j,i) > ql_crit )  THEN
+                   dqdt_precip = prec_time_const * ( qc(k,j,i) - ql_crit )
+                ELSE
+                   dqdt_precip = 0.0_wp
+                ENDIF
+
+                qc(k,j,i) = qc(k,j,i) - dqdt_precip * dt_micro
+                q(k,j,i)  = q(k,j,i)  - dqdt_precip * dt_micro
+                pt(k,j,i) = pt(k,j,i) + dqdt_precip * dt_micro * l_d_cp *      &
+                                        pt_d_t(k)
+
+!
+!--             Compute the rain rate (stored on surface grid point)
+                prr(nzb_s_inner(j,i),j,i) = prr(nzb_s_inner(j,i),j,i) +        &
+                                            dqdt_precip * dzw(k)
+
+             ENDDO
+          ENDDO
+       ENDDO
+
+   END SUBROUTINE autoconversion_kessler
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Accretion rate (Seifert and Beheng, 2006).
+!------------------------------------------------------------------------------!
+    SUBROUTINE accretion
+
+       USE arrays_3d,                                                          &
+           ONLY:  diss, qc, qr
+
+       USE cloud_parameters,                                                   &
+           ONLY:  hyrho
+
+       USE control_parameters,                                                 &
+           ONLY:  rho_surface
+
+       USE cpulog,                                                             &
+           ONLY:  cpu_log, log_point_s
+
+       USE indices,                                                            &
+           ONLY:  nxl, nxr, nys, nyn, nzb_s_inner, nzt
+
+       USE kinds
+
+       IMPLICIT NONE
+
+       INTEGER(iwp) ::  i                 !<
+       INTEGER(iwp) ::  j                 !<
+       INTEGER(iwp) ::  k                 !<
+
+       REAL(wp)     ::  accr              !<
+       REAL(wp)     ::  k_cr              !<
+       REAL(wp)     ::  phi_ac            !<
+       REAL(wp)     ::  tau_cloud         !<
+
+       CALL cpu_log( log_point_s(56), 'accretion', 'start' )
+
+       DO  i = nxl, nxr
+          DO  j = nys, nyn
+             DO  k = nzb_s_inner(j,i)+1, nzt
+
+                IF ( ( qc(k,j,i) > eps_sb )  .AND.  ( qr(k,j,i) > eps_sb ) )  THEN
+!
+!--                Intern time scale of coagulation (Seifert and Beheng, 2006):
+                   tau_cloud = 1.0_wp - qc(k,j,i) / ( qc(k,j,i) + qr(k,j,i) ) 
+!
+!--                Universal function for accretion process (Seifert and 
+!--                Beheng, 2001):
+                   phi_ac = ( tau_cloud / ( tau_cloud + 5.0E-5_wp ) )**4
+!
+!--                Parameterized turbulence effects on autoconversion (Seifert, 
+!--                Nuijens and Stevens, 2010). The factor of 1.0E4 is needed to 
+!--                convert the dissipation rate (diss) from m2 s-3 to cm2 s-3.
+                   IF ( collision_turbulence )  THEN
+                      k_cr = k_cr0 * ( 1.0_wp + 0.05_wp *                      &
+                                       MIN( 600.0_wp,                          &
+                                            diss(k,j,i) * 1.0E4_wp )**0.25_wp  &
+                                     )
+                   ELSE
+                      k_cr = k_cr0                       
+                   ENDIF
+!
+!--                Accretion rate (Seifert and Beheng, 2006):
+                   accr = k_cr * qc(k,j,i) * qr(k,j,i) * phi_ac *              &
+                          SQRT( rho_surface * hyrho(k) )
+                   accr = MIN( accr, qc(k,j,i) / dt_micro )
+
+                   qr(k,j,i) = qr(k,j,i) + accr * dt_micro 
+                   qc(k,j,i) = qc(k,j,i) - accr * dt_micro
+
+                ENDIF
+
+             ENDDO
+          ENDDO
+       ENDDO
+
+       CALL cpu_log( log_point_s(56), 'accretion', 'stop' )
+
+    END SUBROUTINE accretion
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Collisional breakup rate (Seifert, 2008).
+!------------------------------------------------------------------------------!
+    SUBROUTINE selfcollection_breakup
+
+       USE arrays_3d,                                                          &
+           ONLY:  nr, qr
+
+       USE cloud_parameters,                                                   &
+           ONLY:  hyrho
+
+       USE control_parameters,                                                 &
+           ONLY:  rho_surface
+
+       USE cpulog,                                                             &
+           ONLY:  cpu_log, log_point_s
+
+       USE indices,                                                            &
+           ONLY:  nxl, nxr, nys, nyn, nzb_s_inner, nzt
+
+       USE kinds
+   
+       IMPLICIT NONE
+
+       INTEGER(iwp) ::  i                 !<
+       INTEGER(iwp) ::  j                 !<
+       INTEGER(iwp) ::  k                 !<
+
+       REAL(wp)     ::  breakup           !<
+       REAL(wp)     ::  dr                !<
+       REAL(wp)     ::  phi_br            !<
+       REAL(wp)     ::  selfcoll          !<
+
+       CALL cpu_log( log_point_s(57), 'selfcollection', 'start' )
+
+       DO  i = nxl, nxr
+          DO  j = nys, nyn
+             DO  k = nzb_s_inner(j,i)+1, nzt
+                IF ( qr(k,j,i) > eps_sb )  THEN
+!
+!--                Selfcollection rate (Seifert and Beheng, 2001):
+                   selfcoll = k_rr * nr(k,j,i) * qr(k,j,i) *                   &
+                              SQRT( hyrho(k) * rho_surface )
+!
+!--                Weight averaged diameter of rain drops:
+                   dr = ( hyrho(k) * qr(k,j,i) /                               &
+                          nr(k,j,i) * dpirho_l )**( 1.0_wp / 3.0_wp )
+!
+!--                Collisional breakup rate (Seifert, 2008):
+                   IF ( dr >= 0.3E-3_wp )  THEN
+                      phi_br  = k_br * ( dr - 1.1E-3_wp )
+                      breakup = selfcoll * ( phi_br + 1.0_wp )
+                   ELSE
+                      breakup = 0.0_wp
+                   ENDIF
+
+                   selfcoll = MAX( breakup - selfcoll, -nr(k,j,i) / dt_micro )
+                   nr(k,j,i) = nr(k,j,i) + selfcoll * dt_micro
+
+                ENDIF          
+             ENDDO
+          ENDDO
+       ENDDO
+
+       CALL cpu_log( log_point_s(57), 'selfcollection', 'stop' )
+
+    END SUBROUTINE selfcollection_breakup
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Evaporation of precipitable water. Condensation is neglected for 
+!> precipitable water.
+!------------------------------------------------------------------------------!
+    SUBROUTINE evaporation_rain
+
+       USE arrays_3d,                                                          &
+           ONLY:  hyp, nr, pt, q,  qc, qr
+
+       USE cloud_parameters,                                                   &
+           ONLY:  hyrho, l_d_cp, l_d_r, l_v, r_v, t_d_pt
+
+       USE constants,                                                          &
+           ONLY:  pi
+
+       USE cpulog,                                                             &
+           ONLY:  cpu_log, log_point_s
+
+       USE indices,                                                            &
+           ONLY:  nxl, nxr, nys, nyn, nzb_s_inner, nzt
+
+       USE kinds
+
+       IMPLICIT NONE
+
+       INTEGER(iwp) ::  i                 !<
+       INTEGER(iwp) ::  j                 !<
+       INTEGER(iwp) ::  k                 !<
+
+       REAL(wp)     ::  alpha             !<
+       REAL(wp)     ::  dr                !<
+       REAL(wp)     ::  e_s               !<
+       REAL(wp)     ::  evap              !<
+       REAL(wp)     ::  evap_nr           !<
+       REAL(wp)     ::  f_vent            !<
+       REAL(wp)     ::  g_evap            !<
+       REAL(wp)     ::  lambda_r          !<
+       REAL(wp)     ::  mu_r              !<
+       REAL(wp)     ::  mu_r_2            !<
+       REAL(wp)     ::  mu_r_5d2          !<
+       REAL(wp)     ::  nr_0              !<
+       REAL(wp)     ::  q_s               !<
+       REAL(wp)     ::  sat               !<
+       REAL(wp)     ::  t_l               !<
+       REAL(wp)     ::  temp              !<
+       REAL(wp)     ::  xr                !<
+
+       CALL cpu_log( log_point_s(58), 'evaporation', 'start' )
+
+       DO  i = nxl, nxr
+          DO  j = nys, nyn
+             DO  k = nzb_s_inner(j,i)+1, nzt
+                IF ( qr(k,j,i) > eps_sb )  THEN
+!
+!--                Actual liquid water temperature:
+                   t_l = t_d_pt(k) * pt(k,j,i)
+!
+!--                Saturation vapor pressure at t_l:
+                   e_s = 610.78_wp * EXP( 17.269_wp * ( t_l - 273.16_wp ) /    &
+                                          ( t_l - 35.86_wp )                   &
+                                        )
+!
+!--                Computation of saturation humidity:
+                   q_s   = 0.622_wp * e_s / ( hyp(k) - 0.378_wp * e_s )
+                   alpha = 0.622_wp * l_d_r * l_d_cp / ( t_l * t_l )
+                   q_s   = q_s * ( 1.0_wp + alpha * q(k,j,i) ) /               &
+                           ( 1.0_wp + alpha * q_s )
+!
+!--                Supersaturation:
+                   sat   = ( q(k,j,i) - qr(k,j,i) - qc(k,j,i) ) / q_s - 1.0_wp
+!
+!--                Evaporation needs only to be calculated in subsaturated regions
+                   IF ( sat < 0.0_wp )  THEN
+!
+!--                   Actual temperature:
+                      temp = t_l + l_d_cp * ( qc(k,j,i) + qr(k,j,i) )
+             
+                      g_evap = 1.0_wp / ( ( l_v / ( r_v * temp ) - 1.0_wp ) *     &
+                                          l_v / ( thermal_conductivity_l * temp ) &
+                                          + r_v * temp / ( diff_coeff_l * e_s )   &
+                                        )
+!
+!--                   Mean weight of rain drops
+                      xr = hyrho(k) * qr(k,j,i) / nr(k,j,i)
+!
+!--                   Weight averaged diameter of rain drops:
+                      dr = ( xr * dpirho_l )**( 1.0_wp / 3.0_wp )
+!
+!--                   Compute ventilation factor and intercept parameter 
+!--                   (Seifert and Beheng, 2006; Seifert, 2008):
+                      IF ( ventilation_effect )  THEN
+!
+!--                      Shape parameter of gamma distribution (Milbrandt and Yau, 
+!--                      2005; Stevens and Seifert, 2008):
+                         mu_r = 10.0_wp * ( 1.0_wp + TANH( 1.2E3_wp *          &
+                                                          ( dr - 1.4E-3_wp ) ) )
+!
+!--                      Slope parameter of gamma distribution (Seifert, 2008):
+                         lambda_r = ( ( mu_r + 3.0_wp ) * ( mu_r + 2.0_wp ) *  &
+                                      ( mu_r + 1.0_wp )                        &
+                                    )**( 1.0_wp / 3.0_wp ) / dr
+
+                         mu_r_2   = mu_r + 2.0_wp
+                         mu_r_5d2 = mu_r + 2.5_wp 
+
+                         f_vent = a_vent * gamm( mu_r_2 ) *                     &
+                                  lambda_r**( -mu_r_2 ) + b_vent *              &
+                                  schmidt_p_1d3 * SQRT( a_term / kin_vis_air ) *&
+                                  gamm( mu_r_5d2 ) * lambda_r**( -mu_r_5d2 ) *  &
+                                  ( 1.0_wp -                                    &
+                                    0.5_wp * ( b_term / a_term ) *              &
+                                    ( lambda_r / ( c_term + lambda_r )          &
+                                    )**mu_r_5d2 -                               &
+                                    0.125_wp * ( b_term / a_term )**2 *         &
+                                    ( lambda_r / ( 2.0_wp * c_term + lambda_r ) &
+                                    )**mu_r_5d2 -                               &
+                                    0.0625_wp * ( b_term / a_term )**3 *        &
+                                    ( lambda_r / ( 3.0_wp * c_term + lambda_r ) &
+                                    )**mu_r_5d2 -                               &
+                                    0.0390625_wp * ( b_term / a_term )**4 *     & 
+                                    ( lambda_r / ( 4.0_wp * c_term + lambda_r ) &
+                                    )**mu_r_5d2                                 &
+                                  )
+
+                         nr_0   = nr(k,j,i) * lambda_r**( mu_r + 1.0_wp ) /    &
+                                  gamm( mu_r + 1.0_wp ) 
+                      ELSE
+                         f_vent = 1.0_wp
+                         nr_0   = nr(k,j,i) * dr
+                      ENDIF
+   !
+   !--                Evaporation rate of rain water content (Seifert and 
+   !--                Beheng, 2006):
+                      evap    = 2.0_wp * pi * nr_0 * g_evap * f_vent * sat /   &
+                                hyrho(k)
+                      evap    = MAX( evap, -qr(k,j,i) / dt_micro )
+                      evap_nr = MAX( c_evap * evap / xr * hyrho(k),            &
+                                     -nr(k,j,i) / dt_micro )
+
+                      qr(k,j,i) = qr(k,j,i) + evap    * dt_micro
+                      nr(k,j,i) = nr(k,j,i) + evap_nr * dt_micro
+
+                   ENDIF
+                ENDIF          
+
+             ENDDO
+          ENDDO
+       ENDDO
+
+       CALL cpu_log( log_point_s(58), 'evaporation', 'stop' )
+
+    END SUBROUTINE evaporation_rain
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Sedimentation of cloud droplets (Ackermann et al., 2009, MWR).
+!------------------------------------------------------------------------------!
+    SUBROUTINE sedimentation_cloud
+
+       USE arrays_3d,                                                          &
+           ONLY:  ddzu, dzu, pt, prr, q, qc
+
+       USE cloud_parameters,                                                   &
+           ONLY:  hyrho, l_d_cp, pt_d_t
+
+       USE control_parameters,                                                 &
+           ONLY:  call_microphysics_at_all_substeps, intermediate_timestep_count
+
+       USE cpulog,                                                             &
+           ONLY:  cpu_log, log_point_s
+
+       USE indices,                                                            &
+           ONLY:  nxl, nxr, nys, nyn, nzb, nzb_s_inner, nzt
+
+       USE kinds
+
+       USE statistics,                                                         &
+           ONLY:  weight_substep
+    
+
+       IMPLICIT NONE
+
+       INTEGER(iwp) ::  i             !<
+       INTEGER(iwp) ::  j             !<
+       INTEGER(iwp) ::  k             !<
+
+       REAL(wp), DIMENSION(nzb:nzt+1) :: sed_qc !<
+
+       CALL cpu_log( log_point_s(59), 'sed_cloud', 'start' )
+
+       sed_qc(nzt+1) = 0.0_wp
+
+       DO  i = nxl, nxr
+          DO  j = nys, nyn
+             DO  k = nzt, nzb_s_inner(j,i)+1, -1
+
+                IF ( qc(k,j,i) > eps_sb )  THEN
+                   sed_qc(k) = sed_qc_const * nc_const**( -2.0_wp / 3.0_wp ) * &
+                               ( qc(k,j,i) * hyrho(k) )**( 5.0_wp / 3.0_wp )
+                ELSE
+                   sed_qc(k) = 0.0_wp
+                ENDIF
+
+                sed_qc(k) = MIN( sed_qc(k), hyrho(k) * dzu(k+1) * q(k,j,i) /   &
+                                            dt_micro + sed_qc(k+1)             &
+                               )
+
+                q(k,j,i)  = q(k,j,i)  + ( sed_qc(k+1) - sed_qc(k) ) *          &
+                                        ddzu(k+1) / hyrho(k) * dt_micro
+                qc(k,j,i) = qc(k,j,i) + ( sed_qc(k+1) - sed_qc(k) ) *          &
+                                        ddzu(k+1) / hyrho(k) * dt_micro
+                pt(k,j,i) = pt(k,j,i) - ( sed_qc(k+1) - sed_qc(k) ) *          &
+                                        ddzu(k+1) / hyrho(k) * l_d_cp *        &
+                                        pt_d_t(k) * dt_micro
+
+!
+!--             Compute the precipitation rate due to cloud (fog) droplets
+                IF ( call_microphysics_at_all_substeps )  THEN
+                   prr(k,j,i) = prr(k,j,i) +  sed_qc(k) / hyrho(k)             &
+                                * weight_substep(intermediate_timestep_count)
+                ELSE
+                   prr(k,j,i) = prr(k,j,i) + sed_qc(k) / hyrho(k)
+                ENDIF
+
+             ENDDO
+          ENDDO
+       ENDDO
+
+       CALL cpu_log( log_point_s(59), 'sed_cloud', 'stop' )
+
+    END SUBROUTINE sedimentation_cloud
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Computation of sedimentation flux. Implementation according to Stevens
+!> and Seifert (2008). Code is based on UCLA-LES.
+!------------------------------------------------------------------------------!
+    SUBROUTINE sedimentation_rain
+
+       USE arrays_3d,                                                          &
+           ONLY:  ddzu, dzu, nr, pt, prr, q, qr
+
+       USE cloud_parameters,                                                   &
+           ONLY:  hyrho, l_d_cp, pt_d_t
+
+       USE control_parameters,                                                 &
+           ONLY:  call_microphysics_at_all_substeps, intermediate_timestep_count
+       USE cpulog,                                                             &
+           ONLY:  cpu_log, log_point_s
+
+       USE indices,                                                            &
+           ONLY:  nxl, nxr, nys, nyn, nzb, nzb_s_inner, nzt
+
+       USE kinds
+
+       USE statistics,                                                         &
+           ONLY:  weight_substep
+       
+       IMPLICIT NONE
+
+       INTEGER(iwp) ::  i                          !<
+       INTEGER(iwp) ::  j                          !<
+       INTEGER(iwp) ::  k                          !<
+       INTEGER(iwp) ::  k_run                      !<
+
+       REAL(wp)     ::  c_run                      !<
+       REAL(wp)     ::  d_max                      !<
+       REAL(wp)     ::  d_mean                     !<
+       REAL(wp)     ::  d_min                      !<
+       REAL(wp)     ::  dr                         !<
+       REAL(wp)     ::  flux                       !<
+       REAL(wp)     ::  lambda_r                   !<
+       REAL(wp)     ::  mu_r                       !<
+       REAL(wp)     ::  z_run                      !<
+
+       REAL(wp), DIMENSION(nzb:nzt+1) ::  c_nr     !<
+       REAL(wp), DIMENSION(nzb:nzt+1) ::  c_qr     !<
+       REAL(wp), DIMENSION(nzb:nzt+1) ::  nr_slope !<
+       REAL(wp), DIMENSION(nzb:nzt+1) ::  qr_slope !<
+       REAL(wp), DIMENSION(nzb:nzt+1) ::  sed_nr   !<
+       REAL(wp), DIMENSION(nzb:nzt+1) ::  sed_qr   !<
+       REAL(wp), DIMENSION(nzb:nzt+1) ::  w_nr     !<
+       REAL(wp), DIMENSION(nzb:nzt+1) ::  w_qr     !<
+
+       CALL cpu_log( log_point_s(60), 'sed_rain', 'start' )
+
+!
+!--    Compute velocities 
+       DO  i = nxl, nxr
+          DO  j = nys, nyn
+             DO  k = nzb_s_inner(j,i)+1, nzt
+                IF ( qr(k,j,i) > eps_sb )  THEN
+!
+!--                Weight averaged diameter of rain drops:
+                   dr = ( hyrho(k) * qr(k,j,i) /                               &
+                          nr(k,j,i) * dpirho_l )**( 1.0_wp / 3.0_wp )
+!
+!--                Shape parameter of gamma distribution (Milbrandt and Yau, 2005;
+!--                Stevens and Seifert, 2008):
+                   mu_r = 10.0_wp * ( 1.0_wp + TANH( 1.2E3_wp *                &
+                                                     ( dr - 1.4E-3_wp ) ) )
+!
+!--                Slope parameter of gamma distribution (Seifert, 2008):
+                   lambda_r = ( ( mu_r + 3.0_wp ) * ( mu_r + 2.0_wp ) *        &
+                                ( mu_r + 1.0_wp ) )**( 1.0_wp / 3.0_wp ) / dr
+
+                   w_nr(k) = MAX( 0.1_wp, MIN( 20.0_wp,                        &
+                                               a_term - b_term * ( 1.0_wp +    &
+                                                  c_term /                     &
+                                                  lambda_r )**( -1.0_wp *      &
+                                                  ( mu_r + 1.0_wp ) )          &
+                                              )                                &
+                                )
+
+                   w_qr(k) = MAX( 0.1_wp, MIN( 20.0_wp,                        &
+                                               a_term - b_term * ( 1.0_wp +    &
+                                                  c_term /                     &
+                                                  lambda_r )**( -1.0_wp *      &
+                                                  ( mu_r + 4.0_wp ) )          &
+                                             )                                 &
+                                )
+                ELSE
+                   w_nr(k) = 0.0_wp
+                   w_qr(k) = 0.0_wp
+                ENDIF
+             ENDDO
+!
+!--          Adjust boundary values
+             w_nr(nzb_s_inner(j,i)) = w_nr(nzb_s_inner(j,i)+1)
+             w_qr(nzb_s_inner(j,i)) = w_qr(nzb_s_inner(j,i)+1)
+             w_nr(nzt+1) = 0.0_wp
+             w_qr(nzt+1) = 0.0_wp
+!
+!--          Compute Courant number
+             DO  k = nzb_s_inner(j,i)+1, nzt
+                c_nr(k) = 0.25_wp * ( w_nr(k-1) +                              &
+                                      2.0_wp * w_nr(k) + w_nr(k+1) ) *         &
+                          dt_micro * ddzu(k)
+                c_qr(k) = 0.25_wp * ( w_qr(k-1) +                              &
+                                      2.0_wp * w_qr(k) + w_qr(k+1) ) *         &
+                          dt_micro * ddzu(k)
+             ENDDO     
+!
+!--          Limit slopes with monotonized centered (MC) limiter (van Leer, 1977):
+             IF ( limiter_sedimentation )  THEN
+
+                DO k = nzb_s_inner(j,i)+1, nzt
+                   d_mean = 0.5_wp * ( qr(k+1,j,i) - qr(k-1,j,i) )
+                   d_min  = qr(k,j,i) - MIN( qr(k+1,j,i), qr(k,j,i), qr(k-1,j,i) )
+                   d_max  = MAX( qr(k+1,j,i), qr(k,j,i), qr(k-1,j,i) ) - qr(k,j,i)
+
+                   qr_slope(k) = SIGN(1.0_wp, d_mean) * MIN ( 2.0_wp * d_min,  &
+                                                              2.0_wp * d_max,  &
+                                                              ABS( d_mean ) )
+
+                   d_mean = 0.5_wp * ( nr(k+1,j,i) - nr(k-1,j,i) )
+                   d_min  = nr(k,j,i) - MIN( nr(k+1,j,i), nr(k,j,i), nr(k-1,j,i) )
+                   d_max  = MAX( nr(k+1,j,i), nr(k,j,i), nr(k-1,j,i) ) - nr(k,j,i)
+
+                   nr_slope(k) = SIGN(1.0_wp, d_mean) * MIN ( 2.0_wp * d_min,  &
+                                                              2.0_wp * d_max,  &
+                                                              ABS( d_mean ) )
+                ENDDO
+
+             ELSE
+
+                nr_slope = 0.0_wp
+                qr_slope = 0.0_wp
+
+             ENDIF
+
+             sed_nr(nzt+1) = 0.0_wp
+             sed_qr(nzt+1) = 0.0_wp
+!
+!--          Compute sedimentation flux
+             DO  k = nzt, nzb_s_inner(j,i)+1, -1
+!
+!--             Sum up all rain drop number densities which contribute to the flux 
+!--             through k-1/2
+                flux  = 0.0_wp
+                z_run = 0.0_wp ! height above z(k)
+                k_run = k
+                c_run = MIN( 1.0_wp, c_nr(k) )
+                DO WHILE ( c_run > 0.0_wp  .AND.  k_run <= nzt )
+                   flux  = flux + hyrho(k_run) *                               &
+                           ( nr(k_run,j,i) + nr_slope(k_run) *                 &
+                           ( 1.0_wp - c_run ) * 0.5_wp ) * c_run * dzu(k_run)
+                   z_run = z_run + dzu(k_run)
+                   k_run = k_run + 1
+                   c_run = MIN( 1.0_wp, c_nr(k_run) - z_run * ddzu(k_run) )
+                ENDDO
+!
+!--             It is not allowed to sediment more rain drop number density than 
+!--             available
+                flux = MIN( flux,                                              &
+                            hyrho(k) * dzu(k+1) * nr(k,j,i) + sed_nr(k+1) *    &
+                            dt_micro                                           &
+                          )
+
+                sed_nr(k) = flux / dt_micro
+                nr(k,j,i) = nr(k,j,i) + ( sed_nr(k+1) - sed_nr(k) ) *          &
+                                        ddzu(k+1) / hyrho(k) * dt_micro
+!
+!--             Sum up all rain water content which contributes to the flux 
+!--             through k-1/2
+                flux  = 0.0_wp
+                z_run = 0.0_wp ! height above z(k)
+                k_run = k
+                c_run = MIN( 1.0_wp, c_qr(k) )
+
+                DO WHILE ( c_run > 0.0_wp  .AND.  k_run <= nzt )
+
+                   flux  = flux + hyrho(k_run) * ( qr(k_run,j,i) +             &
+                                  qr_slope(k_run) * ( 1.0_wp - c_run ) *       &
+                                  0.5_wp ) * c_run * dzu(k_run)
+                   z_run = z_run + dzu(k_run)
+                   k_run = k_run + 1
+                   c_run = MIN( 1.0_wp, c_qr(k_run) - z_run * ddzu(k_run) )
+
+                ENDDO
+!
+!--             It is not allowed to sediment more rain water content than 
+!--             available
+                flux = MIN( flux,                                              &
+                            hyrho(k) * dzu(k) * qr(k,j,i) + sed_qr(k+1) *      &
+                            dt_micro                                           &
+                          )
+
+                sed_qr(k) = flux / dt_micro
+
+                qr(k,j,i) = qr(k,j,i) + ( sed_qr(k+1) - sed_qr(k) ) *          &
+                                        ddzu(k+1) / hyrho(k) * dt_micro
+                q(k,j,i)  = q(k,j,i)  + ( sed_qr(k+1) - sed_qr(k) ) *          &
+                                        ddzu(k+1) / hyrho(k) * dt_micro 
+                pt(k,j,i) = pt(k,j,i) - ( sed_qr(k+1) - sed_qr(k) ) *          &
+                                        ddzu(k+1) / hyrho(k) * l_d_cp *        &
+                                        pt_d_t(k) * dt_micro
+!
+!--             Compute the rain rate
+                IF ( call_microphysics_at_all_substeps )  THEN
+                   prr(k,j,i) = prr(k,j,i) + sed_qr(k) / hyrho(k)             &
+                                * weight_substep(intermediate_timestep_count)
+                ELSE
+                   prr(k,j,i) = prr(k,j,i) + sed_qr(k) / hyrho(k)
+                ENDIF
+
+             ENDDO
+          ENDDO
+       ENDDO
+
+       CALL cpu_log( log_point_s(60), 'sed_rain', 'stop' )
+
+    END SUBROUTINE sedimentation_rain
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Computation of the precipitation amount due to gravitational settling of
+!> rain and cloud (fog) droplets
+!------------------------------------------------------------------------------!
+    SUBROUTINE calc_precipitation_amount
+
+       USE arrays_3d,                                                          &
+           ONLY:  precipitation_amount, prr
+
+       USE cloud_parameters,                                                   &
+           ONLY:  hyrho
+
+       USE control_parameters,                                                 &
+           ONLY:  call_microphysics_at_all_substeps, dt_do2d_xy, dt_3d,        &
+                  intermediate_timestep_count, intermediate_timestep_count_max,&
+                  precipitation_amount_interval, time_do2d_xy
+
+       USE indices,                                                            &
+           ONLY:  nxl, nxr, nys, nyn, nzb_s_inner
+
+       USE kinds
+
+       IMPLICIT NONE
+
+       INTEGER(iwp) ::  i                          !:
+       INTEGER(iwp) ::  j                          !:
+
+
+       IF ( ( dt_do2d_xy - time_do2d_xy ) < precipitation_amount_interval .AND.&
+            ( .NOT. call_microphysics_at_all_substeps .OR.                     &
+            intermediate_timestep_count == intermediate_timestep_count_max ) ) &
+       THEN
+
+          DO  i = nxl, nxr
+             DO  j = nys, nyn
+
+                precipitation_amount(j,i) = precipitation_amount(j,i) +        &
+                                            prr(nzb_s_inner(j,i)+1,j,i) *      &
+                                            hyrho(nzb_s_inner(j,i)+1) * dt_3d
+
+             ENDDO
+          ENDDO
+       ENDIF
+
+    END SUBROUTINE calc_precipitation_amount
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Control of microphysics for grid points i,j
+!------------------------------------------------------------------------------!
+
+    SUBROUTINE microphysics_control_ij( i, j )
+
+       USE arrays_3d,                                                          &
+           ONLY:  hyp, nr, pt, pt_init, prr, q, qc, qr, zu
+
+       USE cloud_parameters,                                                   &
+           ONLY:  cp, hyrho, pt_d_t, r_d, t_d_pt
+
+       USE control_parameters,                                                 &
+           ONLY:  call_microphysics_at_all_substeps, dt_3d, g,                 &
+                  intermediate_timestep_count, large_scale_forcing,            &
+                  lsf_surf, microphysics_seifert, microphysics_kessler,        &
+                  pt_surface, rho_surface, surface_pressure
+
+       USE indices,                                                            &
+           ONLY:  nzb, nzt
+
+       USE kinds
+
+       USE statistics,                                                         &
+           ONLY:  weight_pres
+
+       IMPLICIT NONE
+
+       INTEGER(iwp) ::  i                 !<
+       INTEGER(iwp) ::  j                 !<
+       INTEGER(iwp) ::  k                 !<
+
+       REAL(wp)     ::  t_surface         !<
+
+       IF ( large_scale_forcing  .AND.  lsf_surf ) THEN
+!
+!--       Calculate:
+!--       pt / t : ratio of potential and actual temperature (pt_d_t)
+!--       t / pt : ratio of actual and potential temperature (t_d_pt)
+!--       p_0(z) : vertical profile of the hydrostatic pressure (hyp)
+          t_surface = pt_surface * ( surface_pressure / 1000.0_wp )**0.286_wp
+          DO  k = nzb, nzt+1
+             hyp(k)    = surface_pressure * 100.0_wp * &
+                         ( ( t_surface - g / cp * zu(k) ) / t_surface )**(1.0_wp / 0.286_wp)
+             pt_d_t(k) = ( 100000.0_wp / hyp(k) )**0.286_wp
+             t_d_pt(k) = 1.0_wp / pt_d_t(k)
+             hyrho(k)  = hyp(k) / ( r_d * t_d_pt(k) * pt_init(k) )       
+          ENDDO
+!
+!--       Compute reference density
+          rho_surface = surface_pressure * 100.0_wp / ( r_d * t_surface )
+       ENDIF
+
+!
+!--    Compute length of time step 
+       IF ( call_microphysics_at_all_substeps )  THEN
+          dt_micro = dt_3d * weight_pres(intermediate_timestep_count)
+       ELSE
+          dt_micro = dt_3d
+       ENDIF
+
+!
+!--    Use 1d arrays
+       q_1d(:)  = q(:,j,i)
+       pt_1d(:) = pt(:,j,i)
+       qc_1d(:) = qc(:,j,i)
+       nc_1d(:) = nc_const
+       IF ( microphysics_seifert )  THEN
+          qr_1d(:) = qr(:,j,i)
+          nr_1d(:) = nr(:,j,i)
+       ENDIF
+
+!
+!--    Reset precipitation rate
+       IF ( intermediate_timestep_count == 1 )  prr(:,j,i) = 0.0_wp
+
+!
+!--    Compute cloud physics
+       IF( microphysics_kessler )  THEN
+
+          CALL autoconversion_kessler( i,j )
+          IF ( cloud_water_sedimentation )  CALL sedimentation_cloud( i,j )
+
+       ELSEIF ( microphysics_seifert )  THEN
+
+          CALL adjust_cloud( i,j )
+          CALL autoconversion( i,j )
+          CALL accretion( i,j )
+          CALL selfcollection_breakup( i,j )
+          CALL evaporation_rain( i,j )
+          CALL sedimentation_rain( i,j )
+          IF ( cloud_water_sedimentation )  CALL sedimentation_cloud( i,j )
+
+       ENDIF
+
+       CALL calc_precipitation_amount( i,j )
+
+!
+!--    Store results on the 3d arrays
+       q(:,j,i)  = q_1d(:)
+       pt(:,j,i) = pt_1d(:)
+       IF ( microphysics_seifert )  THEN
+          qr(:,j,i) = qr_1d(:)
+          nr(:,j,i) = nr_1d(:)
+       ENDIF
+
+    END SUBROUTINE microphysics_control_ij
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Adjust number of raindrops to avoid nonlinear effects in 
+!> sedimentation and evaporation of rain drops due to too small or
+!> too big weights of rain drops (Stevens and Seifert, 2008).
+!> The same procedure is applied to cloud droplets if they are determined
+!> prognostically. Call for grid point i,j
+!------------------------------------------------------------------------------!
+    SUBROUTINE adjust_cloud_ij( i, j )
+
+       USE cloud_parameters,                                                   &
+           ONLY:  hyrho
+
+       USE indices,                                                            &
+           ONLY:  nzb_s_inner, nzt
+
+       USE kinds
+
+       IMPLICIT NONE
+
+       INTEGER(iwp) ::  i                 !<
+       INTEGER(iwp) ::  j                 !<
+       INTEGER(iwp) ::  k                 !<
+
+       DO  k = nzb_s_inner(j,i)+1, nzt
+
+          IF ( qr_1d(k) <= eps_sb )  THEN
+             qr_1d(k) = 0.0_wp
+             nr_1d(k) = 0.0_wp
+          ELSE
+!
+!--          Adjust number of raindrops to avoid nonlinear effects in 
+!--          sedimentation and evaporation of rain drops due to too small or
+!--          too big weights of rain drops (Stevens and Seifert, 2008).
+             IF ( nr_1d(k) * xrmin > qr_1d(k) * hyrho(k) )  THEN
+                nr_1d(k) = qr_1d(k) * hyrho(k) / xrmin
+             ELSEIF ( nr_1d(k) * xrmax < qr_1d(k) * hyrho(k) )  THEN
+                nr_1d(k) = qr_1d(k) * hyrho(k) / xrmax
+             ENDIF
+
+          ENDIF
+
+       ENDDO
+
+    END SUBROUTINE adjust_cloud_ij
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Autoconversion rate (Seifert and Beheng, 2006). Call for grid point i,j
+!------------------------------------------------------------------------------!
+    SUBROUTINE autoconversion_ij( i, j )
+
+       USE arrays_3d,                                                          &
+           ONLY:  diss, dzu
+
+       USE cloud_parameters,                                                   &
+           ONLY:  hyrho
+
+       USE control_parameters,                                                 &
+           ONLY:  rho_surface
+
+       USE grid_variables,                                                     &
+           ONLY:  dx, dy
+
+       USE indices,                                                            &
+           ONLY:  nzb_s_inner, nzt
+
+       USE kinds
+
+       IMPLICIT NONE
+
+       INTEGER(iwp) ::  i                 !<
+       INTEGER(iwp) ::  j                 !<
+       INTEGER(iwp) ::  k                 !<
+
+       REAL(wp)     ::  alpha_cc          !<                   
+       REAL(wp)     ::  autocon           !<
+       REAL(wp)     ::  dissipation       !<
+       REAL(wp)     ::  k_au              !<
+       REAL(wp)     ::  l_mix             !<
+       REAL(wp)     ::  nu_c              !<
+       REAL(wp)     ::  phi_au            !<
+       REAL(wp)     ::  r_cc              !<
+       REAL(wp)     ::  rc                !<
+       REAL(wp)     ::  re_lambda         !<
+       REAL(wp)     ::  sigma_cc          !<
+       REAL(wp)     ::  tau_cloud         !<
+       REAL(wp)     ::  xc                !<
+
+       DO  k = nzb_s_inner(j,i)+1, nzt
+
+          IF ( qc_1d(k) > eps_sb )  THEN
+
+             k_au = k_cc / ( 20.0_wp * x0 )
+!
+!--          Intern time scale of coagulation (Seifert and Beheng, 2006):
+!--          (1.0_wp - qc(k,j,i) / ( qc(k,j,i) + qr_1d(k) ))
+             tau_cloud = 1.0_wp - qc_1d(k) / ( qr_1d(k) + qc_1d(k) )
+!
+!--          Universal function for autoconversion process 
+!--          (Seifert and Beheng, 2006):
+             phi_au = 600.0_wp * tau_cloud**0.68_wp * ( 1.0_wp - tau_cloud**0.68_wp )**3
+!
+!--          Shape parameter of gamma distribution (Geoffroy et al., 2010):
+!--          (Use constant nu_c = 1.0_wp instead?)
+             nu_c = 1.0_wp !MAX( 0.0_wp, 1580.0_wp * hyrho(k) * qc_1d(k) - 0.28_wp )
+!
+!--          Mean weight of cloud droplets:
+             xc = hyrho(k) * qc_1d(k) / nc_1d(k)
+!
+!--          Parameterized turbulence effects on autoconversion (Seifert, 
+!--          Nuijens and Stevens, 2010)
+             IF ( collision_turbulence )  THEN
+!
+!--             Weight averaged radius of cloud droplets:
+                rc = 0.5_wp * ( xc * dpirho_l )**( 1.0_wp / 3.0_wp )
+
+                alpha_cc = ( a_1 + a_2 * nu_c ) / ( 1.0_wp + a_3 * nu_c )
+                r_cc     = ( b_1 + b_2 * nu_c ) / ( 1.0_wp + b_3 * nu_c )
+                sigma_cc = ( c_1 + c_2 * nu_c ) / ( 1.0_wp + c_3 * nu_c )
+!
+!--             Mixing length (neglecting distance to ground and stratification)
+                l_mix = ( dx * dy * dzu(k) )**( 1.0_wp / 3.0_wp )
+!
+!--             Limit dissipation rate according to Seifert, Nuijens and 
+!--             Stevens (2010)
+                dissipation = MIN( 0.06_wp, diss(k,j,i) )
+!
+!--             Compute Taylor-microscale Reynolds number:
+                re_lambda = 6.0_wp / 11.0_wp *                                 &
+                            ( l_mix / c_const )**( 2.0_wp / 3.0_wp ) *         &
+                            SQRT( 15.0_wp / kin_vis_air ) *                    &
+                            dissipation**( 1.0_wp / 6.0_wp )
+!
+!--             The factor of 1.0E4 is needed to convert the dissipation rate
+!--             from m2 s-3 to cm2 s-3.
+                k_au = k_au * ( 1.0_wp +                                       &
+                                dissipation * 1.0E4_wp *                       &
+                                ( re_lambda * 1.0E-3_wp )**0.25_wp *           &
+                                ( alpha_cc * EXP( -1.0_wp * ( ( rc - r_cc ) /  &
+                                                  sigma_cc )**2                &
+                                                ) + beta_cc                    &
+                                )                                              &
+                              )
+             ENDIF
+!
+!--          Autoconversion rate (Seifert and Beheng, 2006):
+             autocon = k_au * ( nu_c + 2.0_wp ) * ( nu_c + 4.0_wp ) /          &
+                       ( nu_c + 1.0_wp )**2 * qc_1d(k)**2 * xc**2 *            &
+                       ( 1.0_wp + phi_au / ( 1.0_wp - tau_cloud )**2 ) *       &
+                       rho_surface
+             autocon = MIN( autocon, qc_1d(k) / dt_micro )
+
+             qr_1d(k) = qr_1d(k) + autocon * dt_micro
+             qc_1d(k) = qc_1d(k) - autocon * dt_micro 
+             nr_1d(k) = nr_1d(k) + autocon / x0 * hyrho(k) * dt_micro
+
+          ENDIF
+
+       ENDDO
+
+    END SUBROUTINE autoconversion_ij
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Autoconversion process (Kessler, 1969).
+!------------------------------------------------------------------------------!
+    SUBROUTINE autoconversion_kessler_ij( i, j )
+
+       USE arrays_3d,                                                          &
+           ONLY:  dzw, prr
+
+       USE cloud_parameters,                                                   &
+           ONLY:  l_d_cp, pt_d_t
+
+       USE indices,                                                            &
+           ONLY:  nzb_s_inner, nzt
+
+       USE kinds
+
+
+       IMPLICIT NONE
+
+       INTEGER(iwp) ::  i !<
+       INTEGER(iwp) ::  j !<
+       INTEGER(iwp) ::  k !<
+
+       REAL(wp)    ::  dqdt_precip !<
+
+       DO  k = nzb_s_inner(j,i)+1, nzt
+
+          IF ( qc_1d(k) > ql_crit )  THEN
+             dqdt_precip = prec_time_const * ( qc_1d(k) - ql_crit )
+          ELSE
+             dqdt_precip = 0.0_wp
+          ENDIF
+
+          qc_1d(k) = qc_1d(k) - dqdt_precip * dt_micro
+          q_1d(k)  = q_1d(k)  - dqdt_precip * dt_micro
+          pt_1d(k) = pt_1d(k) + dqdt_precip * dt_micro * l_d_cp * pt_d_t(k)
+
+!
+!--       Compute the rain rate (stored on surface grid point)
+          prr(nzb_s_inner(j,i),j,i) = prr(nzb_s_inner(j,i),j,i) +              &
+                                      dqdt_precip * dzw(k)
+
+       ENDDO
+
+    END SUBROUTINE autoconversion_kessler_ij
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Accretion rate (Seifert and Beheng, 2006). Call for grid point i,j
+!------------------------------------------------------------------------------!
+    SUBROUTINE accretion_ij( i, j )
+
+       USE arrays_3d,                                                          &
+           ONLY:  diss
+
+       USE cloud_parameters,                                                   &
+           ONLY:  hyrho
+
+       USE control_parameters,                                                 &
+           ONLY:  rho_surface
+
+       USE indices,                                                            &
+           ONLY:  nzb_s_inner, nzt
+
+       USE kinds
+
+       IMPLICIT NONE
+
+       INTEGER(iwp) ::  i                 !<
+       INTEGER(iwp) ::  j                 !<
+       INTEGER(iwp) ::  k                 !<
+
+       REAL(wp)     ::  accr              !<
+       REAL(wp)     ::  k_cr              !<
+       REAL(wp)     ::  phi_ac            !<
+       REAL(wp)     ::  tau_cloud         !<
+
+       DO  k = nzb_s_inner(j,i)+1, nzt
+          IF ( ( qc_1d(k) > eps_sb )  .AND.  ( qr_1d(k) > eps_sb ) )  THEN
+!
+!--          Intern time scale of coagulation (Seifert and Beheng, 2006):
+             tau_cloud = 1.0_wp - qc_1d(k) / ( qc_1d(k) + qr_1d(k) ) 
+!
+!--          Universal function for accretion process 
+!--          (Seifert and Beheng, 2001):
+             phi_ac = ( tau_cloud / ( tau_cloud + 5.0E-5_wp ) )**4
+!
+!--          Parameterized turbulence effects on autoconversion (Seifert, 
+!--          Nuijens and Stevens, 2010). The factor of 1.0E4 is needed to 
+!--          convert the dissipation rate (diss) from m2 s-3 to cm2 s-3.
+             IF ( collision_turbulence )  THEN
+                k_cr = k_cr0 * ( 1.0_wp + 0.05_wp *                            &
+                                 MIN( 600.0_wp,                                &
+                                      diss(k,j,i) * 1.0E4_wp )**0.25_wp        &
+                               )
+             ELSE
+                k_cr = k_cr0                       
+             ENDIF
+!
+!--          Accretion rate (Seifert and Beheng, 2006):
+             accr = k_cr * qc_1d(k) * qr_1d(k) * phi_ac * SQRT( rho_surface * hyrho(k) )
+             accr = MIN( accr, qc_1d(k) / dt_micro )
+
+             qr_1d(k) = qr_1d(k) + accr * dt_micro 
+             qc_1d(k) = qc_1d(k) - accr * dt_micro
+
+          ENDIF
+
+       ENDDO
+
+    END SUBROUTINE accretion_ij
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Collisional breakup rate (Seifert, 2008). Call for grid point i,j
+!------------------------------------------------------------------------------!
+    SUBROUTINE selfcollection_breakup_ij( i, j )
+
+       USE cloud_parameters,                                                   &
+           ONLY:  hyrho
+
+       USE control_parameters,                                                 &
+           ONLY:  rho_surface
+
+       USE indices,                                                            &
+           ONLY:  nzb_s_inner, nzt
+
+       USE kinds
+   
+       IMPLICIT NONE
+
+       INTEGER(iwp) ::  i                 !<
+       INTEGER(iwp) ::  j                 !<
+       INTEGER(iwp) ::  k                 !<
+
+       REAL(wp)     ::  breakup           !<
+       REAL(wp)     ::  dr                !<
+       REAL(wp)     ::  phi_br            !<
+       REAL(wp)     ::  selfcoll          !<
+
+       DO  k = nzb_s_inner(j,i)+1, nzt
+          IF ( qr_1d(k) > eps_sb )  THEN
+!
+!--          Selfcollection rate (Seifert and Beheng, 2001):
+             selfcoll = k_rr * nr_1d(k) * qr_1d(k) * SQRT( hyrho(k) * rho_surface )
+!
+!--          Weight averaged diameter of rain drops:
+             dr = ( hyrho(k) * qr_1d(k) / nr_1d(k) * dpirho_l )**( 1.0_wp / 3.0_wp )
+!
+!--          Collisional breakup rate (Seifert, 2008):
+             IF ( dr >= 0.3E-3_wp )  THEN
+                phi_br  = k_br * ( dr - 1.1E-3_wp )
+                breakup = selfcoll * ( phi_br + 1.0_wp )
+             ELSE
+                breakup = 0.0_wp
+             ENDIF
+
+             selfcoll = MAX( breakup - selfcoll, -nr_1d(k) / dt_micro )
+             nr_1d(k) = nr_1d(k) + selfcoll * dt_micro
+
+          ENDIF          
+       ENDDO
+
+    END SUBROUTINE selfcollection_breakup_ij
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Evaporation of precipitable water. Condensation is neglected for 
+!> precipitable water. Call for grid point i,j
+!------------------------------------------------------------------------------!
+    SUBROUTINE evaporation_rain_ij( i, j )
+
+       USE arrays_3d,                                                          &
+           ONLY:  hyp
+
+       USE cloud_parameters,                                                   &
+           ONLY:  hyrho, l_d_cp, l_d_r, l_v, r_v, t_d_pt
+
+       USE constants,                                                          &
+           ONLY:  pi
+
+       USE indices,                                                            &
+           ONLY:  nzb_s_inner, nzt
+
+       USE kinds
+
+       IMPLICIT NONE
+
+       INTEGER(iwp) ::  i                 !<
+       INTEGER(iwp) ::  j                 !<
+       INTEGER(iwp) ::  k                 !<
+
+       REAL(wp)     ::  alpha             !<
+       REAL(wp)     ::  dr                !<
+       REAL(wp)     ::  e_s               !<
+       REAL(wp)     ::  evap              !<
+       REAL(wp)     ::  evap_nr           !<
+       REAL(wp)     ::  f_vent            !<
+       REAL(wp)     ::  g_evap            !<
+       REAL(wp)     ::  lambda_r          !<
+       REAL(wp)     ::  mu_r              !<
+       REAL(wp)     ::  mu_r_2            !<
+       REAL(wp)     ::  mu_r_5d2          !<
+       REAL(wp)     ::  nr_0              !<
+       REAL(wp)     ::  q_s               !<
+       REAL(wp)     ::  sat               !<
+       REAL(wp)     ::  t_l               !<
+       REAL(wp)     ::  temp              !<
+       REAL(wp)     ::  xr                !<
+
+       DO  k = nzb_s_inner(j,i)+1, nzt
+          IF ( qr_1d(k) > eps_sb )  THEN
+!
+!--          Actual liquid water temperature:
+             t_l = t_d_pt(k) * pt_1d(k)
+!
+!--          Saturation vapor pressure at t_l:
+             e_s = 610.78_wp * EXP( 17.269_wp * ( t_l - 273.16_wp ) /          &
+                                    ( t_l - 35.86_wp )                         &
+                                  )
+!
+!--          Computation of saturation humidity:
+             q_s   = 0.622_wp * e_s / ( hyp(k) - 0.378_wp * e_s )
+             alpha = 0.622_wp * l_d_r * l_d_cp / ( t_l * t_l )
+             q_s   = q_s * ( 1.0_wp + alpha * q_1d(k) ) / ( 1.0_wp + alpha * q_s )
+!
+!--          Supersaturation:
+             sat   = ( q_1d(k) - qr_1d(k) - qc_1d(k) ) / q_s - 1.0_wp
+!
+!--          Evaporation needs only to be calculated in subsaturated regions
+             IF ( sat < 0.0_wp )  THEN
+!
+!--             Actual temperature:
+                temp = t_l + l_d_cp * ( qc_1d(k) + qr_1d(k) )
+       
+                g_evap = 1.0_wp / ( ( l_v / ( r_v * temp ) - 1.0_wp ) * l_v /  &
+                                    ( thermal_conductivity_l * temp ) +        &
+                                    r_v * temp / ( diff_coeff_l * e_s )        &
+                                  )
+!
+!--             Mean weight of rain drops
+                xr = hyrho(k) * qr_1d(k) / nr_1d(k)
+!
+!--             Weight averaged diameter of rain drops:
+                dr = ( xr * dpirho_l )**( 1.0_wp / 3.0_wp )
+!
+!--             Compute ventilation factor and intercept parameter 
+!--             (Seifert and Beheng, 2006; Seifert, 2008):
+                IF ( ventilation_effect )  THEN
+!
+!--                Shape parameter of gamma distribution (Milbrandt and Yau, 2005;
+!--                Stevens and Seifert, 2008):
+                   mu_r = 10.0_wp * ( 1.0_wp + TANH( 1.2E3_wp * ( dr - 1.4E-3_wp ) ) )
+!
+!--                Slope parameter of gamma distribution (Seifert, 2008):
+                   lambda_r = ( ( mu_r + 3.0_wp ) * ( mu_r + 2.0_wp ) *        &
+                                ( mu_r + 1.0_wp )                              &
+                              )**( 1.0_wp / 3.0_wp ) / dr
+
+                   mu_r_2   = mu_r + 2.0_wp
+                   mu_r_5d2 = mu_r + 2.5_wp 
+
+                   f_vent = a_vent * gamm( mu_r_2 ) * lambda_r**( -mu_r_2 ) +  & 
+                            b_vent * schmidt_p_1d3 *                           &
+                            SQRT( a_term / kin_vis_air ) * gamm( mu_r_5d2 ) *  &
+                            lambda_r**( -mu_r_5d2 ) *                          &
+                            ( 1.0_wp -                                         &
+                              0.5_wp * ( b_term / a_term ) *                   &
+                              ( lambda_r / ( c_term + lambda_r )               &
+                              )**mu_r_5d2 -                                    &
+                              0.125_wp * ( b_term / a_term )**2 *              &
+                              ( lambda_r / ( 2.0_wp * c_term + lambda_r )      &
+                              )**mu_r_5d2 -                                    &
+                              0.0625_wp * ( b_term / a_term )**3 *             &
+                              ( lambda_r / ( 3.0_wp * c_term + lambda_r )      &
+                              )**mu_r_5d2 -                                    &
+                              0.0390625_wp * ( b_term / a_term )**4 *          & 
+                              ( lambda_r / ( 4.0_wp * c_term + lambda_r )      &
+                              )**mu_r_5d2                                      &
+                            )
+
+                   nr_0   = nr_1d(k) * lambda_r**( mu_r + 1.0_wp ) /           &
+                            gamm( mu_r + 1.0_wp ) 
+                ELSE
+                   f_vent = 1.0_wp
+                   nr_0   = nr_1d(k) * dr
+                ENDIF
+!
+!--             Evaporation rate of rain water content (Seifert and Beheng, 2006):
+                evap    = 2.0_wp * pi * nr_0 * g_evap * f_vent * sat / hyrho(k)
+                evap    = MAX( evap, -qr_1d(k) / dt_micro )
+                evap_nr = MAX( c_evap * evap / xr * hyrho(k),                  &
+                               -nr_1d(k) / dt_micro )
+
+                qr_1d(k) = qr_1d(k) + evap    * dt_micro
+                nr_1d(k) = nr_1d(k) + evap_nr * dt_micro
+
+             ENDIF
+          ENDIF          
+
+       ENDDO
+
+    END SUBROUTINE evaporation_rain_ij
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Sedimentation of cloud droplets (Ackermann et al., 2009, MWR). 
+!> Call for grid point i,j
+!------------------------------------------------------------------------------!
+    SUBROUTINE sedimentation_cloud_ij( i, j )
+
+       USE arrays_3d,                                                          &
+           ONLY:  ddzu, dzu, prr
+
+       USE cloud_parameters,                                                   &
+           ONLY:  hyrho, l_d_cp, pt_d_t
+
+       USE control_parameters,                                                 &
+           ONLY:  call_microphysics_at_all_substeps, intermediate_timestep_count
+
+       USE indices,                                                            &
+           ONLY:  nzb, nzb_s_inner, nzt
+
+       USE kinds
+       
+       USE statistics,                                                         &
+           ONLY:  weight_substep
+
+       IMPLICIT NONE
+
+       INTEGER(iwp) ::  i             !<
+       INTEGER(iwp) ::  j             !<
+       INTEGER(iwp) ::  k             !<
+
+       REAL(wp), DIMENSION(nzb:nzt+1) :: sed_qc  !<
+
+       sed_qc(nzt+1) = 0.0_wp
+
+       DO  k = nzt, nzb_s_inner(j,i)+1, -1
+          IF ( qc_1d(k) > eps_sb )  THEN
+             sed_qc(k) = sed_qc_const * nc_1d(k)**( -2.0_wp / 3.0_wp ) *       &
+                         ( qc_1d(k) * hyrho(k) )**( 5.0_wp / 3.0_wp )
+          ELSE
+             sed_qc(k) = 0.0_wp
+          ENDIF
+
+          sed_qc(k) = MIN( sed_qc(k), hyrho(k) * dzu(k+1) * q_1d(k) /          &
+                                      dt_micro + sed_qc(k+1)                   &
+                         )
+
+          q_1d(k)  = q_1d(k)  + ( sed_qc(k+1) - sed_qc(k) ) * ddzu(k+1) /      &
+                                hyrho(k) * dt_micro
+          qc_1d(k) = qc_1d(k) + ( sed_qc(k+1) - sed_qc(k) ) * ddzu(k+1) /      & 
+                                hyrho(k) * dt_micro
+          pt_1d(k) = pt_1d(k) - ( sed_qc(k+1) - sed_qc(k) ) * ddzu(k+1) /      &
+                                hyrho(k) * l_d_cp * pt_d_t(k) * dt_micro
+
+!
+!--       Compute the precipitation rate of cloud (fog) droplets
+          IF ( call_microphysics_at_all_substeps )  THEN
+             prr(k,j,i) = prr(k,j,i) + sed_qc(k) / hyrho(k) *               &
+                             weight_substep(intermediate_timestep_count)
+          ELSE
+             prr(k,j,i) = prr(k,j,i) + sed_qc(k) / hyrho(k)
+          ENDIF
+
+       ENDDO
+
+    END SUBROUTINE sedimentation_cloud_ij
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Computation of sedimentation flux. Implementation according to Stevens
+!> and Seifert (2008). Code is based on UCLA-LES. Call for grid point i,j
+!------------------------------------------------------------------------------!
+    SUBROUTINE sedimentation_rain_ij( i, j )
+
+       USE arrays_3d,                                                          &
+           ONLY:  ddzu, dzu, prr
+
+       USE cloud_parameters,                                                   &
+           ONLY:  hyrho, l_d_cp, pt_d_t
+
+       USE control_parameters,                                                 &
+           ONLY:  call_microphysics_at_all_substeps, intermediate_timestep_count
+
+       USE indices,                                                            &
+           ONLY:  nzb, nzb_s_inner, nzt
+
+       USE kinds
+
+       USE statistics,                                                         &
+           ONLY:  weight_substep
+       
+       IMPLICIT NONE
+
+       INTEGER(iwp) ::  i                          !<
+       INTEGER(iwp) ::  j                          !<
+       INTEGER(iwp) ::  k                          !<
+       INTEGER(iwp) ::  k_run                      !<
+
+       REAL(wp)     ::  c_run                      !<
+       REAL(wp)     ::  d_max                      !<
+       REAL(wp)     ::  d_mean                     !<
+       REAL(wp)     ::  d_min                      !<
+       REAL(wp)     ::  dr                         !<
+       REAL(wp)     ::  flux                       !<
+       REAL(wp)     ::  lambda_r                   !<
+       REAL(wp)     ::  mu_r                       !<
+       REAL(wp)     ::  z_run                      !<
+
+       REAL(wp), DIMENSION(nzb:nzt+1) ::  c_nr     !<
+       REAL(wp), DIMENSION(nzb:nzt+1) ::  c_qr     !<
+       REAL(wp), DIMENSION(nzb:nzt+1) ::  nr_slope !<
+       REAL(wp), DIMENSION(nzb:nzt+1) ::  qr_slope !<
+       REAL(wp), DIMENSION(nzb:nzt+1) ::  sed_nr   !<
+       REAL(wp), DIMENSION(nzb:nzt+1) ::  sed_qr   !<
+       REAL(wp), DIMENSION(nzb:nzt+1) ::  w_nr     !<
+       REAL(wp), DIMENSION(nzb:nzt+1) ::  w_qr     !<
+
+!
+!--    Compute velocities 
+       DO  k = nzb_s_inner(j,i)+1, nzt
+          IF ( qr_1d(k) > eps_sb )  THEN
+!
+!--          Weight averaged diameter of rain drops:
+             dr = ( hyrho(k) * qr_1d(k) / nr_1d(k) * dpirho_l )**( 1.0_wp / 3.0_wp )
+!
+!--          Shape parameter of gamma distribution (Milbrandt and Yau, 2005;
+!--          Stevens and Seifert, 2008):
+             mu_r = 10.0_wp * ( 1.0_wp + TANH( 1.2E3_wp * ( dr - 1.4E-3_wp ) ) )
+!
+!--          Slope parameter of gamma distribution (Seifert, 2008):
+             lambda_r = ( ( mu_r + 3.0_wp ) * ( mu_r + 2.0_wp ) *              &
+                          ( mu_r + 1.0_wp ) )**( 1.0_wp / 3.0_wp ) / dr
+
+             w_nr(k) = MAX( 0.1_wp, MIN( 20.0_wp,                              &
+                                         a_term - b_term * ( 1.0_wp +          &
+                                            c_term / lambda_r )**( -1.0_wp *   &
+                                            ( mu_r + 1.0_wp ) )                &
+                                        )                                      &
+                          )
+             w_qr(k) = MAX( 0.1_wp, MIN( 20.0_wp,                              &
+                                         a_term - b_term * ( 1.0_wp +          &
+                                            c_term / lambda_r )**( -1.0_wp *   &
+                                            ( mu_r + 4.0_wp ) )                &
+                                       )                                       &
+                          )
+          ELSE
+             w_nr(k) = 0.0_wp
+             w_qr(k) = 0.0_wp
+          ENDIF
+       ENDDO
+!
+!--    Adjust boundary values
+       w_nr(nzb_s_inner(j,i)) = w_nr(nzb_s_inner(j,i)+1)
+       w_qr(nzb_s_inner(j,i)) = w_qr(nzb_s_inner(j,i)+1)
+       w_nr(nzt+1) = 0.0_wp
+       w_qr(nzt+1) = 0.0_wp
+!
+!--    Compute Courant number
+       DO  k = nzb_s_inner(j,i)+1, nzt
+          c_nr(k) = 0.25_wp * ( w_nr(k-1) + 2.0_wp * w_nr(k) + w_nr(k+1) ) *   &
+                    dt_micro * ddzu(k)
+          c_qr(k) = 0.25_wp * ( w_qr(k-1) + 2.0_wp * w_qr(k) + w_qr(k+1) ) *   &
+                    dt_micro * ddzu(k)
+       ENDDO     
+!
+!--    Limit slopes with monotonized centered (MC) limiter (van Leer, 1977):
+       IF ( limiter_sedimentation )  THEN
+
+          DO k = nzb_s_inner(j,i)+1, nzt
+             d_mean = 0.5_wp * ( qr_1d(k+1) - qr_1d(k-1) )
+             d_min  = qr_1d(k) - MIN( qr_1d(k+1), qr_1d(k), qr_1d(k-1) )
+             d_max  = MAX( qr_1d(k+1), qr_1d(k), qr_1d(k-1) ) - qr_1d(k)
+
+             qr_slope(k) = SIGN(1.0_wp, d_mean) * MIN ( 2.0_wp * d_min,        &
+                                                        2.0_wp * d_max,        &
+                                                        ABS( d_mean ) )
+
+             d_mean = 0.5_wp * ( nr_1d(k+1) - nr_1d(k-1) )
+             d_min  = nr_1d(k) - MIN( nr_1d(k+1), nr_1d(k), nr_1d(k-1) )
+             d_max  = MAX( nr_1d(k+1), nr_1d(k), nr_1d(k-1) ) - nr_1d(k)
+
+             nr_slope(k) = SIGN(1.0_wp, d_mean) * MIN ( 2.0_wp * d_min,        &
+                                                        2.0_wp * d_max,        &
+                                                        ABS( d_mean ) )
+          ENDDO
+
+       ELSE
+
+          nr_slope = 0.0_wp
+          qr_slope = 0.0_wp
+
+       ENDIF
+
+       sed_nr(nzt+1) = 0.0_wp
+       sed_qr(nzt+1) = 0.0_wp
+!
+!--    Compute sedimentation flux
+       DO  k = nzt, nzb_s_inner(j,i)+1, -1
+!
+!--       Sum up all rain drop number densities which contribute to the flux 
+!--       through k-1/2
+          flux  = 0.0_wp
+          z_run = 0.0_wp ! height above z(k)
+          k_run = k
+          c_run = MIN( 1.0_wp, c_nr(k) )
+          DO WHILE ( c_run > 0.0_wp  .AND.  k_run <= nzt )
+             flux  = flux + hyrho(k_run) *                                     &
+                     ( nr_1d(k_run) + nr_slope(k_run) * ( 1.0_wp - c_run ) *   &
+                     0.5_wp ) * c_run * dzu(k_run)
+             z_run = z_run + dzu(k_run)
+             k_run = k_run + 1
+             c_run = MIN( 1.0_wp, c_nr(k_run) - z_run * ddzu(k_run) )
+          ENDDO
+!
+!--       It is not allowed to sediment more rain drop number density than 
+!--       available
+          flux = MIN( flux,                                                    &
+                      hyrho(k) * dzu(k+1) * nr_1d(k) + sed_nr(k+1) * dt_micro )
+
+          sed_nr(k) = flux / dt_micro
+          nr_1d(k)  = nr_1d(k) + ( sed_nr(k+1) - sed_nr(k) ) * ddzu(k+1) /     &
+                                    hyrho(k) * dt_micro
+!
+!--       Sum up all rain water content which contributes to the flux 
+!--       through k-1/2
+          flux  = 0.0_wp
+          z_run = 0.0_wp ! height above z(k)
+          k_run = k
+          c_run = MIN( 1.0_wp, c_qr(k) )
+
+          DO WHILE ( c_run > 0.0_wp  .AND.  k_run <= nzt )
+
+             flux  = flux + hyrho(k_run) *                                     &
+                     ( qr_1d(k_run) + qr_slope(k_run) * ( 1.0_wp - c_run ) *   &
+                     0.5_wp ) * c_run * dzu(k_run)
+             z_run = z_run + dzu(k_run)
+             k_run = k_run + 1
+             c_run = MIN( 1.0_wp, c_qr(k_run) - z_run * ddzu(k_run) )
+
+          ENDDO
+!
+!--       It is not allowed to sediment more rain water content than available
+          flux = MIN( flux,                                                    &
+                      hyrho(k) * dzu(k) * qr_1d(k) + sed_qr(k+1) * dt_micro )
+
+          sed_qr(k) = flux / dt_micro
+
+          qr_1d(k) = qr_1d(k) + ( sed_qr(k+1) - sed_qr(k) ) * ddzu(k+1) /      &
+                                hyrho(k) * dt_micro
+          q_1d(k)  = q_1d(k)  + ( sed_qr(k+1) - sed_qr(k) ) * ddzu(k+1) /      &
+                                hyrho(k) * dt_micro 
+          pt_1d(k) = pt_1d(k) - ( sed_qr(k+1) - sed_qr(k) ) * ddzu(k+1) /      &
+                                hyrho(k) * l_d_cp * pt_d_t(k) * dt_micro
+!
+!--       Compute the rain rate
+          IF ( call_microphysics_at_all_substeps )  THEN
+             prr(k,j,i) = prr(k,j,i) + sed_qr(k) / hyrho(k)                    &
+                          * weight_substep(intermediate_timestep_count)
+          ELSE
+             prr(k,j,i) = prr(k,j,i) + sed_qr(k) / hyrho(k)
+          ENDIF
+
+       ENDDO
+
+    END SUBROUTINE sedimentation_rain_ij
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> This subroutine computes the precipitation amount due to gravitational
+!> settling of rain and cloud (fog) droplets
+!------------------------------------------------------------------------------!
+    SUBROUTINE calc_precipitation_amount_ij( i, j )
+
+       USE arrays_3d,                                                          &
+           ONLY:  precipitation_amount, prr
+
+       USE cloud_parameters,                                                   &
+           ONLY:  hyrho
+
+       USE control_parameters,                                                 &
+           ONLY:  call_microphysics_at_all_substeps, dt_do2d_xy, dt_3d,        &
+                  intermediate_timestep_count, intermediate_timestep_count_max,&
+                  precipitation_amount_interval, time_do2d_xy
+
+       USE indices,                                                            &
+           ONLY:  nzb_s_inner
+
+       USE kinds
+
+       IMPLICIT NONE
+
+       INTEGER(iwp) ::  i                          !:
+       INTEGER(iwp) ::  j                          !:
+
+
+       IF ( ( dt_do2d_xy - time_do2d_xy ) < precipitation_amount_interval .AND.&
+            ( .NOT. call_microphysics_at_all_substeps .OR.                     &
+            intermediate_timestep_count == intermediate_timestep_count_max ) ) &
+       THEN
+
+          precipitation_amount(j,i) = precipitation_amount(j,i) +              &
+                                      prr(nzb_s_inner(j,i)+1,j,i) *            &
+                                      hyrho(nzb_s_inner(j,i)+1) * dt_3d
+       ENDIF
+
+    END SUBROUTINE calc_precipitation_amount_ij
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> This function computes the gamma function (Press et al., 1992).
+!> The gamma function is needed for the calculation of the evaporation 
+!> of rain drops.
+!------------------------------------------------------------------------------!
+    FUNCTION gamm( xx ) 
+
+       USE kinds
+
+       IMPLICIT NONE 
+
+       INTEGER(iwp) ::  j            !<
+
+       REAL(wp)     ::  gamm         !<
+       REAL(wp)     ::  ser          !<
+       REAL(wp)     ::  tmp          !<
+       REAL(wp)     ::  x_gamm       !<
+       REAL(wp)     ::  xx           !<
+       REAL(wp)     ::  y_gamm       !<
+
+
+       REAL(wp), PARAMETER  ::  stp = 2.5066282746310005_wp               !<
+       REAL(wp), PARAMETER  ::  cof(6) = (/ 76.18009172947146_wp,      &
+                                           -86.50532032941677_wp,      &
+                                            24.01409824083091_wp,      &
+                                            -1.231739572450155_wp,     &
+                                             0.1208650973866179E-2_wp, &
+                                            -0.5395239384953E-5_wp /)     !<
+
+       x_gamm = xx
+       y_gamm = x_gamm
+       tmp = x_gamm + 5.5_wp
+       tmp = ( x_gamm + 0.5_wp ) * LOG( tmp ) - tmp
+       ser = 1.000000000190015_wp
+
+       DO  j = 1, 6 
+          y_gamm = y_gamm + 1.0_wp 
+          ser    = ser + cof( j ) / y_gamm 
+       ENDDO
+
+! 
+!--    Until this point the algorithm computes the logarithm of the gamma 
+!--    function. Hence, the exponential function is used.  
+!       gamm = EXP( tmp + LOG( stp * ser / x_gamm ) ) 
+       gamm = EXP( tmp ) * stp * ser / x_gamm 
+
+       RETURN 
+ 
+    END FUNCTION gamm 
+
+ END MODULE microphysics_mod
Index: lm/trunk/SOURCE/netcdf_interface.f90
===================================================================
--- /palm/trunk/SOURCE/netcdf_interface.f90	(revision 1849)
+++ 	(revision )
@@ -1,5129 +1,0 @@
-!> @file netcdf_interface.f90
-!--------------------------------------------------------------------------------!
-! This file is part of PALM.
-!
-! PALM is free software: you can redistribute it and/or modify it under the terms
-! of the GNU General Public License as published by the Free Software Foundation,
-! either version 3 of the License, or (at your option) any later version.
-!
-! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
-! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
-! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along with
-! PALM. If not, see <http://www.gnu.org/licenses/>.
-!
-! Copyright 1997-2016 Leibniz Universitaet Hannover
-!--------------------------------------------------------------------------------!
-!
-! Current revisions:
-! ------------------
-! 
-! 
-! Former revisions:
-! -----------------
-! $Id$
-!
-! 1833 2016-04-07 14:23:03Z raasch
-! spectrum renamed spectra_mod
-!
-! 1786 2016-03-08 05:49:27Z raasch
-! Bugfix: id_var_time_sp made public
-!
-! 1783 2016-03-06 18:36:17Z raasch
-! netcdf interface has been modularized, former file netcdf renamed to
-! netcdf_interface, creation of netcdf-dimensions and -variables moved to
-! specific new subroutines create_netcdf_dim and create_netcdf_var,
-! compression (deflation) of variables implemented,
-! ibmy special cpp directive removed
-!
-! 1745 2016-02-05 13:06:51Z gronemeier
-! Bugfix: recalculating ntdim_3d, ntdim_2d_xy/xz/yz when checking the
-!         extensibility of an existing file (only when using parallel NetCDF). 
-! 
-! 1691 2015-10-26 16:17:44Z maronga
-! Added output of radiative heating rates for RRTMG. Corrected output of 
-! radiative fluxes
-! 
-! 1682 2015-10-07 23:56:08Z knoop
-! Code annotations made doxygen readable 
-! 
-! 1596 2015-05-21 09:34:28Z gronemeier
-! Bugfix in masked data output. Read 'zu_3d' when trying to extend masked data
-! 
-! 1551 2015-03-03 14:18:16Z maronga
-! Added support for land surface model and radiation model output. In the course
-! of this action a new vertical grid zs (soil) was introduced.
-! 
-! 1353 2014-04-08 15:21:23Z heinze
-! REAL constants provided with KIND-attribute
-!
-! 1322 2014-03-20 16:38:49Z raasch
-! Forgotten ONLY-attribute added to USE-statements
-!
-! 1320 2014-03-20 08:40:49Z raasch
-! ONLY-attribute added to USE-statements,
-! kind-parameters added to all INTEGER and REAL declaration statements,
-! kinds are defined in new module kinds,
-! revision history before 2012 removed,
-! comment fields (!:) to be used for variable explanations added to
-! all variable declaration statements
-!
-! 1308 2014-03-13 14:58:42Z fricke
-! +ntime_count, oldmode
-! Adjust NF90_CREATE and NF90_OPEN statement for parallel output
-! To increase the performance for parallel output, the following is done:
-! - Limit time dimension
-! - Values of axis data are only written by PE0
-! - No fill is set for all variables
-! Check the number of output time levels for restart jobs
-!
-! 1206 2013-07-18 12:49:16Z witha
-! Bugfix: typo in preprocessor directive in subroutine open_write_netcdf_file
-!
-! 1092 2013-02-02 11:24:22Z raasch
-! unused variables removed
-!
-! 1053 2012-11-13 17:11:03Z hoffmann
-! +qr, nr, prr
-!
-! 1036 2012-10-22 13:43:42Z raasch
-! code put under GPL (PALM 3.9)
-!
-! 1031 2012-10-19 14:35:30Z raasch
-! netCDF4 without parallel file support implemented, new routines
-! create_netcdf_file and open_write_netcdf_file at end
-!
-! 992 2012-09-05 15:08:26Z hoffmann
-! Removal of the informative messages PA0352 and PA0353.
-!  
-! 983 2012-08-21 14:17:57Z hoffmann
-! Bugfix in cross_profiles.
-!
-! 964 2012-07-26 09:14:24Z raasch
-! rev 951 and 959 reformatted
-!
-! 959 2012-07-24 13:13:41Z hoffmann
-! Bugfix in cross_profiles. It is not allowed to arrange more than 100
-! profiles with cross_profiles. 
-!
-! 951 2012-07-19 14:22:52Z hoffmann
-! cross_profiles, profile_rows, profile_columns are written to netCDF header
-!
-! Revision 1.1  2005/05/18 15:37:16  raasch
-! Initial revision
-!
-!
-! Description:
-! ------------
-!> In case of extend = .FALSE.:
-!> Define all necessary dimensions, axes and variables for the different
-!> netCDF datasets. This subroutine is called from check_open after a new
-!> dataset is created. It leaves the open netCDF files ready to write.
-!>
-!> In case of extend = .TRUE.:
-!> Find out if dimensions and variables of an existing file match the values
-!> of the actual run. If so, get all necessary information (ids, etc.) from
-!> this file.
-!>
-!> Parameter av can assume values 0 (non-averaged data) and 1 (time averaged
-!> data)
-!>
-!> @todo calculation of output time levels for parallel NetCDF still does not
-!>       cover every exception (change of dt_do, end_time in restart)
-!------------------------------------------------------------------------------!
- MODULE netcdf_interface
-
-    USE control_parameters, ONLY: max_masks
-    USE kinds
-#if defined( __netcdf )
-    USE NETCDF
-#endif
-
-    PRIVATE
-
-    INTEGER(iwp), PARAMETER ::  dopr_norm_num = 7, dopts_num = 29, dots_max = 100
-
-    CHARACTER (LEN=6), DIMENSION(dopr_norm_num) ::  dopr_norm_names =          &
-         (/ 'wpt0  ', 'ws2   ', 'tsw2  ', 'ws3   ', 'ws2tsw', 'wstsw2',        &
-            'z_i   ' /)
-
-    CHARACTER (LEN=6), DIMENSION(dopr_norm_num) ::  dopr_norm_longnames =      &
-         (/ 'wpt0  ', 'w*2   ', 't*w2  ', 'w*3   ', 'w*2t*w', 'w*t*w2',        &
-            'z_i   ' /)
-
-    CHARACTER (LEN=7), DIMENSION(dopts_num) :: dopts_label =                   &
-          (/ 'tnpt   ', 'x_     ', 'y_     ', 'z_     ', 'z_abs  ', 'u      ', &
-             'v      ', 'w      ', 'u"     ', 'v"     ', 'w"     ', 'npt_up ', &
-             'w_up   ', 'w_down ', 'radius ', 'r_min  ', 'r_max  ', 'npt_max', &
-             'npt_min', 'x*2    ', 'y*2    ', 'z*2    ', 'u*2    ', 'v*2    ', &
-             'w*2    ', 'u"2    ', 'v"2    ', 'w"2    ', 'npt*2  ' /)
-
-    CHARACTER (LEN=7), DIMENSION(dopts_num) :: dopts_unit =                    &
-          (/ 'number ', 'm      ', 'm      ', 'm      ', 'm      ', 'm/s    ', &
-             'm/s    ', 'm/s    ', 'm/s    ', 'm/s    ', 'm/s    ', 'number ', &
-             'm/s    ', 'm/s    ', 'm      ', 'm      ', 'm      ', 'number ', &
-             'number ', 'm2     ', 'm2     ', 'm2     ', 'm2/s2  ', 'm2/s2  ', &
-             'm2/s2  ', 'm2/s2  ', 'm2/s2  ', 'm2/s2  ', 'number2' /)
-
-    INTEGER(iwp) ::  dots_num  = 31  !< number of timeseries defined by default
-    INTEGER(iwp) ::  dots_soil = 24  !< starting index for soil-timeseries
-    INTEGER(iwp) ::  dots_rad  = 32  !< starting index for radiation-timeseries
-
-    CHARACTER (LEN=13), DIMENSION(dots_max) :: dots_label =                    &
-          (/ 'E            ', 'E*           ', 'dt           ',                &
-             'u*           ', 'th*          ', 'umax         ',                &
-             'vmax         ', 'wmax         ', 'div_new      ',                &
-             'div_old      ', 'z_i_wpt      ', 'z_i_pt       ',                &
-             'w*           ', 'w"pt"0       ', 'w"pt"        ',                &
-             'wpt          ', 'pt(0)        ', 'pt(z_mo)     ',                &
-             'w"u"0        ', 'w"v"0        ', 'w"q"0        ',                &
-             'ol           ', 'q*           ', 'ghf_eb       ',                &
-             'shf_eb       ', 'qsws_eb      ', 'qsws_liq_eb  ',                &
-             'qsws_soil_eb ', 'qsws_veg_eb  ', 'r_a          ',                &
-             'r_s          ', 'rad_net      ', 'rad_lw_in    ',                &
-             'rad_lw_out   ', 'rad_sw_in    ', 'rad_sw_out   ',                &
-             'rrtm_aldif   ', 'rrtm_aldir   ', 'rrtm_asdif   ',                &
-             'rrtm_asdir   ',                                                  &
-             ( 'unknown      ', i9 = 1, dots_max-40 ) /)
-
-    CHARACTER (LEN=13), DIMENSION(dots_max) :: dots_unit =                     &
-          (/ 'm2/s2        ', 'm2/s2        ', 's            ',                &
-             'm/s          ', 'K            ', 'm/s          ',                &
-             'm/s          ', 'm/s          ', 's-1          ',                &
-             's-1          ', 'm            ', 'm            ',                &
-             'm/s          ', 'K m/s        ', 'K m/s        ',                &
-             'K m/s        ', 'K            ', 'K            ',                &
-             'm2/s2        ', 'm2/s2        ', 'kg m/s       ',                &
-             'm            ', 'kg/kg        ', '             ',                &
-             '             ', '             ', '             ',                &
-             '             ', 'W/m2         ', 's/m          ',                &
-             '             ', 'W/m2         ', 'W/m2         ',                &
-             'W/m2         ', 'W/m2         ', 'W/m2         ',                &
-             '             ', '             ', '             ',                &
-             '             ',                                                  &
-             ( 'unknown      ', i9 = 1, dots_max-40 ) /)
-
-    CHARACTER (LEN=9), DIMENSION(300) ::  dopr_unit = 'unknown'
-
-    CHARACTER (LEN=7), DIMENSION(0:1,100) ::  do2d_unit, do3d_unit
-
-    CHARACTER (LEN=16), DIMENSION(25) ::  prt_var_names = &
-          (/ 'pt_age          ', 'pt_dvrp_size    ', 'pt_origin_x     ', &
-             'pt_origin_y     ', 'pt_origin_z     ', 'pt_radius       ', &
-             'pt_speed_x      ', 'pt_speed_y      ', 'pt_speed_z      ', &
-             'pt_weight_factor', 'pt_x            ', 'pt_y            ', &
-             'pt_z            ', 'pt_color        ', 'pt_group        ', &
-             'pt_tailpoints   ', 'pt_tail_id      ', 'pt_density_ratio', &
-             'pt_exp_arg      ', 'pt_exp_term     ', 'not_used        ', &
-             'not_used        ', 'not_used        ', 'not_used        ', &
-             'not_used        ' /)
-
-    CHARACTER (LEN=16), DIMENSION(25) ::  prt_var_units = &
-          (/ 'seconds         ', 'meters          ', 'meters          ', &
-             'meters          ', 'meters          ', 'meters          ', &
-             'm/s             ', 'm/s             ', 'm/s             ', &
-             'factor          ', 'meters          ', 'meters          ', &
-             'meters          ', 'none            ', 'none            ', &
-             'none            ', 'none            ', 'ratio           ', &
-             'none            ', 'none            ', 'not_used        ', &
-             'not_used        ', 'not_used        ', 'not_used        ', &
-             'not_used        ' /)
-
-    CHARACTER(LEN=20), DIMENSION(11) ::  netcdf_precision = ' '
-    CHARACTER(LEN=40) ::  netcdf_data_format_string
-
-    INTEGER(iwp) ::  id_dim_prtnum, id_dim_time_pr, id_dim_time_prt, &
-                     id_dim_time_pts, id_dim_time_sp, id_dim_time_ts, id_dim_x_sp, &
-                     id_dim_y_sp, id_dim_zu_sp, id_dim_zw_sp, id_set_pr, &
-                     id_set_prt, id_set_pts, id_set_sp, id_set_ts, id_var_prtnum, &
-                     id_var_rnop_prt, id_var_time_pr, id_var_time_prt, &
-                     id_var_time_pts, id_var_time_sp, id_var_time_ts, id_var_x_sp, &
-                     id_var_y_sp, id_var_zu_sp, id_var_zw_sp, nc_stat
-
-    INTEGER(iwp), DIMENSION(0:1) ::  id_dim_time_xy, id_dim_time_xz, &
-                    id_dim_time_yz, id_dim_time_3d, id_dim_x_xy, id_dim_xu_xy, &
-                    id_dim_x_xz, id_dim_xu_xz, id_dim_x_yz, id_dim_xu_yz, &
-                    id_dim_x_3d, id_dim_xu_3d, id_dim_y_xy, id_dim_yv_xy, &
-                    id_dim_y_xz, id_dim_yv_xz, id_dim_y_yz, id_dim_yv_yz, &
-                    id_dim_y_3d, id_dim_yv_3d, id_dim_zs_xy, id_dim_zs_xz, &
-                    id_dim_zs_yz, id_dim_zs_3d, id_dim_zu_xy, id_dim_zu1_xy, &
-                    id_dim_zu_xz, id_dim_zu_yz, id_dim_zu_3d, id_dim_zw_xy, &
-                    id_dim_zw_xz, id_dim_zw_yz, id_dim_zw_3d, id_set_xy, &
-                    id_set_xz, id_set_yz, id_set_3d, id_var_ind_x_yz, &
-                    id_var_ind_y_xz, id_var_ind_z_xy, id_var_time_xy, &
-                    id_var_time_xz, id_var_time_yz, id_var_time_3d, id_var_x_xy, &
-                    id_var_xu_xy, id_var_x_xz, id_var_xu_xz, id_var_x_yz, &
-                    id_var_xu_yz, id_var_x_3d, id_var_xu_3d, id_var_y_xy, &
-                    id_var_yv_xy, id_var_y_xz, id_var_yv_xz, id_var_y_yz, &
-                    id_var_yv_yz, id_var_y_3d, id_var_yv_3d, id_var_zs_xy, &
-                    id_var_zs_xz, id_var_zs_yz, id_var_zs_3d, id_var_zusi_xy, &
-                    id_var_zusi_3d, id_var_zu_xy, id_var_zu1_xy, id_var_zu_xz, &
-                    id_var_zu_yz, id_var_zu_3d, id_var_zwwi_xy, id_var_zwwi_3d, &
-                    id_var_zw_xy, id_var_zw_xz, id_var_zw_yz, id_var_zw_3d
-
-    INTEGER ::  netcdf_data_format = 2  !< NetCDF3 64bit offset format
-    INTEGER ::  netcdf_deflate = 0      !< NetCDF compression, default: no
-                                        !< compression
-
-    INTEGER(iwp), DIMENSION(10)  ::  id_var_dospx, id_var_dospy
-    INTEGER(iwp), DIMENSION(20)  ::  id_var_prt
-    INTEGER(iwp), DIMENSION(11)  ::  nc_precision
-    INTEGER(iwp), DIMENSION(dopr_norm_num) ::  id_var_norm_dopr
-
-    INTEGER(iwp), DIMENSION(dopts_num,0:10) ::  id_var_dopts
-    INTEGER(iwp), DIMENSION(0:1,100)        ::  id_var_do2d, id_var_do3d
-    INTEGER(iwp), DIMENSION(100,0:9)        ::  id_dim_z_pr, id_var_dopr, &
-                                                id_var_z_pr
-    INTEGER(iwp), DIMENSION(dots_max,0:9)   ::  id_var_dots
-
-!
-!-- Masked output
-    CHARACTER (LEN=7), DIMENSION(max_masks,0:1,100) ::  domask_unit
-
-    LOGICAL ::  output_for_t0 = .FALSE.
-
-    INTEGER(iwp), DIMENSION(1:max_masks,0:1) ::  id_dim_time_mask, id_dim_x_mask, &
-                   id_dim_xu_mask, id_dim_y_mask, id_dim_yv_mask, id_dim_zs_mask, &
-                   id_dim_zu_mask, id_dim_zw_mask, &
-                   id_set_mask, &
-                   id_var_time_mask, id_var_x_mask, id_var_xu_mask, &
-                   id_var_y_mask, id_var_yv_mask, id_var_zs_mask, &
-                   id_var_zu_mask, id_var_zw_mask, &
-                   id_var_zusi_mask, id_var_zwwi_mask
-
-    INTEGER(iwp), DIMENSION(1:max_masks,0:1,100) ::  id_var_domask
-
-
-    PUBLIC  domask_unit, dopr_unit, dopts_num, dots_label, dots_max, dots_num, &
-            dots_rad, dots_soil, dots_unit, do2d_unit, do3d_unit, id_set_mask, &
-            id_set_pr, id_set_prt, id_set_pts, id_set_sp, id_set_ts,           &
-            id_set_xy, id_set_xz, id_set_yz, id_set_3d, id_var_domask,         &
-            id_var_dopr, id_var_dopts, id_var_dospx, id_var_dospy,             &
-            id_var_dots, id_var_do2d, id_var_do3d, id_var_norm_dopr,           &
-            id_var_time_mask, id_var_time_pr, id_var_time_pts, id_var_time_sp, &
-            id_var_time_ts, id_var_time_xy, id_var_time_xz, id_var_time_yz,    &
-            id_var_time_3d, nc_stat, netcdf_data_format,                       &
-            netcdf_data_format_string, netcdf_deflate, netcdf_precision,       &
-            output_for_t0
-
-    SAVE
-
-    INTERFACE netcdf_create_dim
-       MODULE PROCEDURE netcdf_create_dim
-    END INTERFACE netcdf_create_dim
-
-    INTERFACE netcdf_create_file
-       MODULE PROCEDURE netcdf_create_file
-    END INTERFACE netcdf_create_file
-
-    INTERFACE netcdf_create_var
-       MODULE PROCEDURE netcdf_create_var
-    END INTERFACE netcdf_create_var
-
-    INTERFACE netcdf_define_header
-       MODULE PROCEDURE netcdf_define_header
-    END INTERFACE netcdf_define_header
-
-    INTERFACE netcdf_handle_error
-       MODULE PROCEDURE netcdf_handle_error
-    END INTERFACE netcdf_handle_error
-
-    INTERFACE netcdf_open_write_file
-       MODULE PROCEDURE netcdf_open_write_file
-    END INTERFACE netcdf_open_write_file
-
-    PUBLIC netcdf_create_file, netcdf_define_header, netcdf_handle_error,      &
-           netcdf_open_write_file
-
- CONTAINS
-
- SUBROUTINE netcdf_define_header( callmode, extend, av )
- 
-#if defined( __netcdf )
-
-    USE arrays_3d,                                                             &
-        ONLY:  zu, zw
-
-    USE constants,                                                             &
-        ONLY:  pi
-
-    USE control_parameters,                                                    &
-        ONLY:  averaging_interval, averaging_interval_pr,                      &
-               data_output_pr,  domask,  dopr_n,        &
-               dopr_time_count, dopts_time_count, dots_time_count,             &
-               do2d, do2d_xz_time_count, do3d,                &
-               do2d_yz_time_count, dt_data_output_av, dt_do2d_xy, dt_do2d_xz,  &
-               dt_do2d_yz, dt_do3d, mask_size, do2d_xy_time_count,             &
-               do3d_time_count, domask_time_count, end_time, mask_i_global,    &
-               mask_j_global, mask_k_global, message_string, mid, ntdim_2d_xy, &
-               ntdim_2d_xz, ntdim_2d_yz, ntdim_3d, nz_do3d, prt_time_count,    &
-               run_description_header, section, simulated_time,                &
-               simulated_time_at_begin, skip_time_data_output_av,              &
-               skip_time_do2d_xy, skip_time_do2d_xz, skip_time_do2d_yz,        &
-               skip_time_do3d, topography
-
-    USE grid_variables,                                                        &
-        ONLY:  dx, dy, zu_s_inner, zw_w_inner
-
-    USE indices,                                                               &
-        ONLY:  nx, ny, nz ,nzb, nzt
-
-    USE kinds
-
-    USE land_surface_model_mod,                                                &
-        ONLY: land_surface, nzb_soil, nzt_soil, nzs, zs
-
-    USE pegrid
-
-    USE particle_attributes,                                                   &
-        ONLY:  maximum_number_of_particles, number_of_particle_groups
-
-    USE profil_parameter,                                                      &
-        ONLY:  crmax, cross_profiles, dopr_index, profile_columns, profile_rows
-
-    USE spectra_mod,                                                           &
-        ONLY:  averaging_interval_sp, comp_spectra_level, data_output_sp, dosp_time_count, spectra_direction
-
-    USE statistics,                                                            &
-        ONLY:  hom, statistic_regions
-
-
-    IMPLICIT NONE
-
-    CHARACTER (LEN=2)              ::  suffix                !<
-    CHARACTER (LEN=2), INTENT (IN) ::  callmode              !<
-    CHARACTER (LEN=3)              ::  suffix1               !<
-    CHARACTER (LEN=4)              ::  grid_x                !<
-    CHARACTER (LEN=4)              ::  grid_y                !<
-    CHARACTER (LEN=4)              ::  grid_z                !<
-    CHARACTER (LEN=6)              ::  mode                  !<
-    CHARACTER (LEN=10)             ::  netcdf_var_name       !<
-    CHARACTER (LEN=10)             ::  precision             !<
-    CHARACTER (LEN=10)             ::  var                   !<
-    CHARACTER (LEN=80)             ::  time_average_text     !<
-    CHARACTER (LEN=2000)           ::  char_cross_profiles   !<
-    CHARACTER (LEN=2000)           ::  var_list              !<
-    CHARACTER (LEN=2000)           ::  var_list_old          !<
-
-    CHARACTER (LEN=100), DIMENSION(1:crmax) ::  cross_profiles_adj   !<
-    CHARACTER (LEN=100), DIMENSION(1:crmax) ::  cross_profiles_char  !<
-
-    INTEGER(iwp) ::  av                                      !<
-    INTEGER(iwp) ::  cross_profiles_count                    !<
-    INTEGER(iwp) ::  cross_profiles_maxi                     !<
-    INTEGER(iwp) ::  delim                                   !<
-    INTEGER(iwp) ::  delim_old                               !<
-    INTEGER(iwp) ::  file_id                                 !<
-    INTEGER(iwp) ::  i                                       !<
-    INTEGER(iwp) ::  id_last                                 !<
-    INTEGER(iwp) ::  id_x                                    !<
-    INTEGER(iwp) ::  id_y                                    !<
-    INTEGER(iwp) ::  id_z                                    !<
-    INTEGER(iwp) ::  j                                       !<
-    INTEGER(iwp) ::  k                                       !<
-    INTEGER(iwp) ::  kk                                      !<
-    INTEGER(iwp) ::  ns                                      !<
-    INTEGER(iwp) ::  ns_do                                   !< actual value of ns for soil model data
-    INTEGER(iwp) ::  ns_old                                  !<
-    INTEGER(iwp) ::  ntime_count                             !< number of time levels found in file
-    INTEGER(iwp) ::  nz_old                                  !<
-
-    INTEGER(iwp), SAVE ::  oldmode                           !<
-
-    INTEGER(iwp), DIMENSION(1) ::  id_dim_time_old           !<
-    INTEGER(iwp), DIMENSION(1) ::  id_dim_x_yz_old           !<
-    INTEGER(iwp), DIMENSION(1) ::  id_dim_y_xz_old           !<
-    INTEGER(iwp), DIMENSION(1) ::  id_dim_zu_sp_old          !<
-    INTEGER(iwp), DIMENSION(1) ::  id_dim_zu_xy_old          !<
-    INTEGER(iwp), DIMENSION(1) ::  id_dim_zu_3d_old          !<
-    INTEGER(iwp), DIMENSION(1) ::  id_dim_zu_mask_old        !<
-
-
-    INTEGER(iwp), DIMENSION(1:crmax) ::  cross_profiles_numb !<
-
-    LOGICAL ::  found                                        !<
-
-    LOGICAL, INTENT (INOUT) ::  extend                       !<
-
-    LOGICAL, SAVE ::  init_netcdf = .FALSE.                  !<
-
-    REAL(wp), DIMENSION(1) ::  last_time_coordinate          !< last time value in file
-
-    REAL(wp), DIMENSION(:), ALLOCATABLE   ::  netcdf_data    !<
-    REAL(wp), DIMENSION(:,:), ALLOCATABLE ::  netcdf_data_2d !<
-
-!
-!-- Initializing actions
-    IF ( .NOT. init_netcdf )  THEN
-!
-!--    Check and set accuracy for netCDF output. First set default value
-       nc_precision = NF90_REAL4
-
-       i = 1
-       DO  WHILE ( netcdf_precision(i) /= ' ' )
-          j = INDEX( netcdf_precision(i), '_' )
-          IF ( j == 0 )  THEN
-             WRITE ( message_string, * ) 'netcdf_precision must contain a ', &
-                                         '"_"netcdf_precision(', i, ')="',   &
-                                         TRIM( netcdf_precision(i) ),'"'
-             CALL message( 'netcdf_define_header', 'PA0241', 2, 2, 0, 6, 0 )
-          ENDIF
-
-          var       = netcdf_precision(i)(1:j-1)
-          precision = netcdf_precision(i)(j+1:)
-
-          IF ( precision == 'NF90_REAL4' )  THEN
-             j = NF90_REAL4
-          ELSEIF ( precision == 'NF90_REAL8' )  THEN
-             j = NF90_REAL8
-          ELSE
-             WRITE ( message_string, * ) 'illegal netcdf precision: ',  &
-                                         'netcdf_precision(', i, ')="', &
-                                         TRIM( netcdf_precision(i) ),'"'
-             CALL message( 'netcdf_define_header', 'PA0242', 1, 2, 0, 6, 0 )
-          ENDIF
-
-          SELECT CASE ( var )
-             CASE ( 'xy' )
-                nc_precision(1) = j
-             CASE ( 'xz' )
-                nc_precision(2) = j
-             CASE ( 'yz' )
-                nc_precision(3) = j
-             CASE ( '2d' )
-                nc_precision(1:3) = j
-             CASE ( '3d' )
-                nc_precision(4) = j
-             CASE ( 'pr' )
-                nc_precision(5) = j
-             CASE ( 'ts' )
-                nc_precision(6) = j
-             CASE ( 'sp' )
-                nc_precision(7) = j
-             CASE ( 'prt' )
-                nc_precision(8) = j
-             CASE ( 'masks' )
-                nc_precision(11) = j
-             CASE ( 'all' )
-                nc_precision    = j
-
-             CASE DEFAULT
-                WRITE ( message_string, * ) 'unknown variable in inipar ',    & 
-                                  'assignment: netcdf_precision(', i, ')="',  &
-                                            TRIM( netcdf_precision(i) ),'"'
-                CALL message( 'netcdf_define_header', 'PA0243', 1, 2, 0, 6, 0 )
-
-          END SELECT
-
-          i = i + 1
-          IF ( i > 50 )  EXIT
-       ENDDO
-
-!
-!--    Check for allowed parameter range
-       IF ( netcdf_deflate < 0  .OR.  netcdf_deflate > 9 )  THEN
-          WRITE ( message_string, '(A,I3,A)' ) 'netcdf_deflate out of ' //     &
-                                      'range & given value: ', netcdf_deflate, &
-                                      ', allowed range: 0-9'
-          CALL message( 'netcdf_define_header', 'PA0355', 2, 2, 0, 6, 0 )
-       ENDIF
-!
-!--    Data compression does not work with parallel NetCDF/HDF5
-       IF ( netcdf_deflate > 0  .AND.  netcdf_data_format /= 3 )  THEN
-          message_string = 'netcdf_deflate reset to 0'
-          CALL message( 'netcdf_define_header', 'PA0356', 0, 1, 0, 6, 0 )
-
-          netcdf_deflate = 0
-       ENDIF
-
-       init_netcdf = .TRUE.
-
-    ENDIF
-
-!
-!-- Determine the mode to be processed
-    IF ( extend )  THEN
-       mode = callmode // '_ext'
-    ELSE
-       mode = callmode // '_new'
-    ENDIF
-
-!
-!-- Select the mode to be processed. Possibilities are 3d, mask, xy, xz, yz, 
-!-- pr and ts.
-    SELECT CASE ( mode )
-
-       CASE ( 'ma_new' )
-
-!
-!--       decompose actual parameter file_id (=formal parameter av) into 
-!--       mid and av
-          file_id = av
-          IF ( file_id <= 200+max_masks )  THEN
-             mid = file_id - 200
-             av = 0
-          ELSE
-             mid = file_id - (200+max_masks)
-             av = 1
-          ENDIF
-
-!
-!--       Define some global attributes of the dataset
-          nc_stat = NF90_PUT_ATT( id_set_mask(mid,av), NF90_GLOBAL, &
-                                  'Conventions', 'COARDS' )
-          CALL netcdf_handle_error( 'netcdf_define_header', 464 )
-
-          IF ( av == 0 )  THEN
-             time_average_text = ' '
-          ELSE
-             WRITE (time_average_text, '('', '',F7.1,'' s average'')') &
-                                                            averaging_interval
-          ENDIF
-          nc_stat = NF90_PUT_ATT( id_set_mask(mid,av), NF90_GLOBAL, 'title', &
-                                  TRIM( run_description_header ) //    &
-                                  TRIM( time_average_text ) )
-          CALL netcdf_handle_error( 'netcdf_define_header', 465 )
-          IF ( av == 1 )  THEN
-             WRITE ( time_average_text,'(F7.1,'' s avg'')' )  averaging_interval
-             nc_stat = NF90_PUT_ATT( id_set_mask(mid,av), NF90_GLOBAL, &
-                                     'time_avg', TRIM( time_average_text ) )
-             CALL netcdf_handle_error( 'netcdf_define_header', 466 )
-          ENDIF
-
-!
-!--       Define time coordinate for volume data (unlimited dimension)
-          CALL netcdf_create_dim( id_set_mask(mid,av), 'time', NF90_UNLIMITED, &
-                                  id_dim_time_mask(mid,av), 467 )
-          CALL netcdf_create_var( id_set_mask(mid,av),                         &
-                                  (/ id_dim_time_mask(mid,av) /), 'time',      &
-                                  NF90_DOUBLE, id_var_time_mask(mid,av),       &
-                                 'seconds', '', 468, 469, 000 )
-!
-!--       Define spatial dimensions and coordinates:
-!--       Define vertical coordinate grid (zu grid)
-          CALL netcdf_create_dim( id_set_mask(mid,av), 'zu_3d',                &
-                                  mask_size(mid,3), id_dim_zu_mask(mid,av),    &
-                                  470 )
-          CALL netcdf_create_var( id_set_mask(mid,av),                         &
-                                  (/ id_dim_zu_mask(mid,av) /), 'zu_3d',       &
-                                  NF90_DOUBLE, id_var_zu_mask(mid,av),         &
-                                  'meters', '', 471, 472, 000 )
-!
-!--       Define vertical coordinate grid (zw grid)
-          CALL netcdf_create_dim( id_set_mask(mid,av), 'zw_3d',                &
-                                  mask_size(mid,3), id_dim_zw_mask(mid,av),    &
-                                  473 )
-          CALL netcdf_create_var( id_set_mask(mid,av),                         &
-                                  (/ id_dim_zw_mask(mid,av) /), 'zw_3d',       &
-                                  NF90_DOUBLE, id_var_zw_mask(mid,av),         &
-                                 'meters', '', 474, 475, 000 )
-!
-!--       Define x-axis (for scalar position)
-          CALL netcdf_create_dim( id_set_mask(mid,av), 'x', mask_size(mid,1),  &
-                                  id_dim_x_mask(mid,av), 476 )
-          CALL netcdf_create_var( id_set_mask(mid,av),                         &
-                                  (/ id_dim_x_mask(mid,av) /), 'x',            &
-                                  NF90_DOUBLE, id_var_x_mask(mid,av),          &
-                                  'meters', '', 477, 478, 000 )
-!
-!--       Define x-axis (for u position)
-          CALL netcdf_create_dim( id_set_mask(mid,av), 'xu', mask_size(mid,1), &
-                                  id_dim_xu_mask(mid,av), 479 )
-          CALL netcdf_create_var( id_set_mask(mid,av),                         &
-                                  (/ id_dim_xu_mask(mid,av) /), 'xu',          &
-                                  NF90_DOUBLE, id_var_xu_mask(mid,av),         &
-                                  'meters', '', 480, 481, 000 )
-!
-!--       Define y-axis (for scalar position)
-          CALL netcdf_create_dim( id_set_mask(mid,av), 'y', mask_size(mid,2),  &
-                                  id_dim_y_mask(mid,av), 482 )
-          CALL netcdf_create_var( id_set_mask(mid,av),                         &
-                                  (/ id_dim_y_mask(mid,av) /), 'y',            &
-                                  NF90_DOUBLE, id_var_y_mask(mid,av),          &
-                                  'meters', '', 483, 484, 000 )
-!
-!--       Define y-axis (for v position)
-          CALL netcdf_create_dim( id_set_mask(mid,av), 'yv', mask_size(mid,2), &
-                                  id_dim_yv_mask(mid,av), 485 )
-          CALL netcdf_create_var( id_set_mask(mid,av),                         &
-                                  (/ id_dim_yv_mask(mid,av) /),                &
-                                  'yv', NF90_DOUBLE, id_var_yv_mask(mid,av),   &
-                                  'meters', '', 486, 487, 000 )
-!
-!--       In case of non-flat topography define 2d-arrays containing the height
-!--       information
-          IF ( TRIM( topography ) /= 'flat' )  THEN
-!
-!--          Define zusi = zu(nzb_s_inner)
-             CALL netcdf_create_var( id_set_mask(mid,av),                      &
-                                     (/ id_dim_x_mask(mid,av),                 &
-                                        id_dim_y_mask(mid,av) /), 'zusi',      &
-                                     NF90_DOUBLE, id_var_zusi_mask(mid,av),    &
-                                     'meters', 'zu(nzb_s_inner)', 488, 489,    &
-                                     490 )
-!             
-!--          Define zwwi = zw(nzb_w_inner)
-             CALL netcdf_create_var( id_set_mask(mid,av),                      &
-                                     (/ id_dim_x_mask(mid,av),                 &
-                                        id_dim_y_mask(mid,av) /), 'zwwi',      &
-                                     NF90_DOUBLE, id_var_zwwi_mask(mid,av),    &
-                                     'meters', 'zw(nzb_w_inner)', 491, 492,    &
-                                     493 )
-          ENDIF             
- 
-          IF ( land_surface )  THEN
-!
-!--          Define vertical coordinate grid (zw grid)
-             CALL netcdf_create_dim( id_set_mask(mid,av), 'zs_3d',             &
-                                     mask_size(mid,3), id_dim_zs_mask(mid,av), &
-                                     536 )
-             CALL netcdf_create_var( id_set_mask(mid,av),                      &
-                                     (/ id_dim_zs_mask(mid,av) /), 'zs_3d',    &
-                                     NF90_DOUBLE, id_var_zs_mask(mid,av),      &
-                                     'meters', '', 537, 555, 000 )
-          ENDIF
-
-!
-!--       Define the variables
-          var_list = ';'
-          i = 1
-
-          DO WHILE ( domask(mid,av,i)(1:1) /= ' ' )
-
-!
-!--          Check for the grid
-             found = .TRUE.
-             SELECT CASE ( domask(mid,av,i) )
-!
-!--             Most variables are defined on the scalar grid
-                CASE ( 'e', 'lpt', 'nr', 'p', 'pc', 'pr', 'prr', 'pt', 'q',    &
-                       'qc', 'ql', 'ql_c', 'ql_v', 'ql_vp', 'qr', 'qv',        &
-                       'rad_lw_cs_hr', 'rad_lw_hr', 'rad_sw_cs_hr',            &
-                       'rad_sw_hr', 'rho', 's', 'sa', 'vpt'  )
-
-                   grid_x = 'x'
-                   grid_y = 'y'
-                   grid_z = 'zu'
-!
-!--             u grid
-                CASE ( 'u' )
-
-                   grid_x = 'xu'
-                   grid_y = 'y'
-                   grid_z = 'zu'
-!
-!--             v grid
-                CASE ( 'v' )
-
-                   grid_x = 'x'
-                   grid_y = 'yv'
-                   grid_z = 'zu'
-!
-!--             w grid
-                CASE ( 'rad_lw_in', 'rad_lw_out', 'rad_sw_in', 'rad_sw_out',   &
-                       'w' )
-
-                   grid_x = 'x'
-                   grid_y = 'y'
-                   grid_z = 'zw'
-!
-!--             soil grid
-                CASE ( 'm_soil', 't_soil' )
-
-                   grid_x = 'x'
-                   grid_y = 'y'
-                   grid_z = 'zs'
-
-                CASE DEFAULT
-!
-!--                Check for user-defined quantities
-                   CALL user_define_netcdf_grid( domask(mid,av,i), found,      &
-                                                 grid_x, grid_y, grid_z )
-
-                   IF ( .NOT. found )  THEN
-                      WRITE ( message_string, * ) 'no grid defined for',       &
-                           ' variable ', TRIM( domask(mid,av,i) )
-                      CALL message( 'define_netcdf_header', 'PA0244', 0, 1, 0, &
-                                    6, 0 )
-                   ENDIF
-
-             END SELECT
-
-!
-!--          Select the respective dimension ids
-             IF ( grid_x == 'x' )  THEN
-                id_x = id_dim_x_mask(mid,av)
-             ELSEIF ( grid_x == 'xu' )  THEN
-                id_x = id_dim_xu_mask(mid,av)
-             ENDIF
-
-             IF ( grid_y == 'y' )  THEN
-                id_y = id_dim_y_mask(mid,av)
-             ELSEIF ( grid_y == 'yv' )  THEN
-                id_y = id_dim_yv_mask(mid,av)
-             ENDIF
-
-             IF ( grid_z == 'zu' )  THEN
-                id_z = id_dim_zu_mask(mid,av)
-             ELSEIF ( grid_z == 'zw' )  THEN
-                id_z = id_dim_zw_mask(mid,av)
-             ELSEIF ( grid_z == "zs" )  THEN
-                id_z = id_dim_zs_mask(mid,av)
-             ENDIF
-
-!
-!--          Define the grid
-             CALL netcdf_create_var( id_set_mask(mid,av), (/ id_x, id_y, id_z, &
-                                     id_dim_time_mask(mid,av) /),              &
-                                     domask(mid,av,i), nc_precision(11),       &
-                                     id_var_domask(mid,av,i),                  &
-                                     TRIM( domask_unit(mid,av,i) ),            &
-                                     domask(mid,av,i), 494, 495, 496 )
-
-             var_list = TRIM( var_list ) // TRIM( domask(mid,av,i) ) // ';'
-
-             i = i + 1
-
-          ENDDO
-
-!
-!--       No arrays to output
-          IF ( i == 1 )  RETURN
-
-!
-!--       Write the list of variables as global attribute (this is used by
-!--       restart runs and by combine_plot_fields)
-          nc_stat = NF90_PUT_ATT( id_set_mask(mid,av), NF90_GLOBAL, &
-                                  'VAR_LIST', var_list )
-          CALL netcdf_handle_error( 'netcdf_define_header', 497 )
-
-!
-!--       Leave netCDF define mode
-          nc_stat = NF90_ENDDEF( id_set_mask(mid,av) )
-          CALL netcdf_handle_error( 'netcdf_define_header', 498 )
-
-!
-!--       Write data for x (shifted by +dx/2) and xu axis
-          ALLOCATE( netcdf_data(mask_size(mid,1)) )
-
-          netcdf_data = ( mask_i_global(mid,:mask_size(mid,1)) + 0.5_wp ) * dx
-
-          nc_stat = NF90_PUT_VAR( id_set_mask(mid,av), id_var_x_mask(mid,av), &
-                                  netcdf_data, start = (/ 1 /),               &
-                                  count = (/ mask_size(mid,1) /) )
-          CALL netcdf_handle_error( 'netcdf_define_header', 499 )
-
-          netcdf_data = mask_i_global(mid,:mask_size(mid,1)) * dx
-
-          nc_stat = NF90_PUT_VAR( id_set_mask(mid,av), id_var_xu_mask(mid,av),&
-                                  netcdf_data, start = (/ 1 /),               &
-                                  count = (/ mask_size(mid,1) /) )
-          CALL netcdf_handle_error( 'netcdf_define_header', 500 )
-
-          DEALLOCATE( netcdf_data )
-
-!
-!--       Write data for y (shifted by +dy/2) and yv axis
-          ALLOCATE( netcdf_data(mask_size(mid,2)) )
-
-          netcdf_data = ( mask_j_global(mid,:mask_size(mid,2)) + 0.5_wp ) * dy
-
-          nc_stat = NF90_PUT_VAR( id_set_mask(mid,av), id_var_y_mask(mid,av), &
-                                  netcdf_data, start = (/ 1 /),               &
-                                  count = (/ mask_size(mid,2) /))
-          CALL netcdf_handle_error( 'netcdf_define_header', 501 )
-
-          netcdf_data = mask_j_global(mid,:mask_size(mid,2)) * dy
-
-          nc_stat = NF90_PUT_VAR( id_set_mask(mid,av), id_var_yv_mask(mid,av), &
-                                  netcdf_data, start = (/ 1 /),    &
-                                  count = (/ mask_size(mid,2) /))
-          CALL netcdf_handle_error( 'netcdf_define_header', 502 )
-
-          DEALLOCATE( netcdf_data )
-
-!
-!--       Write zu and zw data (vertical axes)
-          ALLOCATE( netcdf_data(mask_size(mid,3)) )
-
-          netcdf_data = zu( mask_k_global(mid,:mask_size(mid,3)) )
-
-          nc_stat = NF90_PUT_VAR( id_set_mask(mid,av), id_var_zu_mask(mid,av), &
-                                  netcdf_data, start = (/ 1 /), &
-                                  count = (/ mask_size(mid,3) /) )
-          CALL netcdf_handle_error( 'netcdf_define_header', 503 )
-
-          netcdf_data = zw( mask_k_global(mid,:mask_size(mid,3)) )
-
-          nc_stat = NF90_PUT_VAR( id_set_mask(mid,av), id_var_zw_mask(mid,av), &
-                                  netcdf_data, start = (/ 1 /), &
-                                  count = (/ mask_size(mid,3) /) )
-          CALL netcdf_handle_error( 'netcdf_define_header', 504 )
-
-          DEALLOCATE( netcdf_data )
-
-!
-!--       In case of non-flat topography write height information
-          IF ( TRIM( topography ) /= 'flat' )  THEN
-
-             ALLOCATE( netcdf_data_2d(mask_size(mid,1),mask_size(mid,2)) )
-             netcdf_data_2d = zu_s_inner( mask_i_global(mid,:mask_size(mid,1)),&
-                                          mask_j_global(mid,:mask_size(mid,2)) )
-
-             nc_stat = NF90_PUT_VAR( id_set_mask(mid,av),         &
-                                     id_var_zusi_mask(mid,av),    &
-                                     netcdf_data_2d,              &
-                                     start = (/ 1, 1 /),          &
-                                     count = (/ mask_size(mid,1), &
-                                                mask_size(mid,2) /) )
-             CALL netcdf_handle_error( 'netcdf_define_header', 505 )
-
-             netcdf_data_2d = zw_w_inner( mask_i_global(mid,:mask_size(mid,1)),&
-                                          mask_j_global(mid,:mask_size(mid,2)) )
-
-             nc_stat = NF90_PUT_VAR( id_set_mask(mid,av),         &
-                                     id_var_zwwi_mask(mid,av),    &
-                                     netcdf_data_2d,              &
-                                     start = (/ 1, 1 /),          &
-                                     count = (/ mask_size(mid,1), &
-                                                mask_size(mid,2) /) )
-             CALL netcdf_handle_error( 'netcdf_define_header', 506 )
-
-             DEALLOCATE( netcdf_data_2d )
-
-          ENDIF
-
-          IF ( land_surface )  THEN
-!
-!--          Write zs data (vertical axes for soil model), use negative values
-!--          to indicate soil depth
-             ALLOCATE( netcdf_data(mask_size(mid,3)) )
-
-             netcdf_data = zs( mask_k_global(mid,:mask_size(mid,3)) )
-
-             nc_stat = NF90_PUT_VAR( id_set_mask(mid,av), id_var_zs_mask(mid,av), &
-                                     netcdf_data, start = (/ 1 /), &
-                                     count = (/ mask_size(mid,3) /) )
-             CALL netcdf_handle_error( 'netcdf_define_header', 538 )
-
-             DEALLOCATE( netcdf_data )
-
-          ENDIF
-
-!
-!--       restore original parameter file_id (=formal parameter av) into av
-          av = file_id
-
-
-       CASE ( 'ma_ext' )
-
-!
-!--       decompose actual parameter file_id (=formal parameter av) into 
-!--       mid and av
-          file_id = av
-          IF ( file_id <= 200+max_masks )  THEN
-             mid = file_id - 200
-             av = 0
-          ELSE
-             mid = file_id - (200+max_masks)
-             av = 1
-          ENDIF
-
-!
-!--       Get the list of variables and compare with the actual run.
-!--       First var_list_old has to be reset, since GET_ATT does not assign
-!--       trailing blanks.
-          var_list_old = ' '
-          nc_stat = NF90_GET_ATT( id_set_mask(mid,av), NF90_GLOBAL, 'VAR_LIST',&
-                                  var_list_old )
-          CALL netcdf_handle_error( 'netcdf_define_header', 507 )
-
-          var_list = ';'
-          i = 1
-          DO WHILE ( domask(mid,av,i)(1:1) /= ' ' )
-             var_list = TRIM(var_list) // TRIM( domask(mid,av,i) ) // ';'
-             i = i + 1
-          ENDDO
-
-          IF ( av == 0 )  THEN
-             var = '(mask)'
-          ELSE
-             var = '(mask_av)'
-          ENDIF
-
-          IF ( TRIM( var_list ) /= TRIM( var_list_old ) )  THEN
-             WRITE ( message_string, * ) 'netCDF file for ', TRIM( var ), &
-                  ' data for mask', mid, ' from previous run found,', &
-                  '&but this file cannot be extended due to variable ', &
-                  'mismatch.&New file is created instead.'
-             CALL message( 'define_netcdf_header', 'PA0335', 0, 1, 0, 6, 0 )
-             extend = .FALSE.
-             RETURN
-          ENDIF
-
-!
-!--       Get and compare the number of vertical gridpoints
-          nc_stat = NF90_INQ_VARID( id_set_mask(mid,av), 'zu_3d', &
-                                    id_var_zu_mask(mid,av) )
-          CALL netcdf_handle_error( 'netcdf_define_header', 508 )
-
-          nc_stat = NF90_INQUIRE_VARIABLE( id_set_mask(mid,av),     &
-                                           id_var_zu_mask(mid,av),  &
-                                           dimids = id_dim_zu_mask_old )
-          CALL netcdf_handle_error( 'netcdf_define_header', 509 )
-          id_dim_zu_mask(mid,av) = id_dim_zu_mask_old(1)
-
-          nc_stat = NF90_INQUIRE_DIMENSION( id_set_mask(mid,av),    &
-                                            id_dim_zu_mask(mid,av), &
-                                            len = nz_old )
-          CALL netcdf_handle_error( 'netcdf_define_header', 510 )
-
-          IF ( mask_size(mid,3) /= nz_old )  THEN
-             WRITE ( message_string, * ) 'netCDF file for ', TRIM( var ), &
-                  ' data for mask', mid, ' from previous run found,', &
-                  '&but this file cannot be extended due to mismatch in ', &
-                  ' number of&vertical grid points.', &
-                  '&New file is created instead.'
-             CALL message( 'define_netcdf_header', 'PA0336', 0, 1, 0, 6, 0 )
-             extend = .FALSE.
-             RETURN
-          ENDIF
-
-!
-!--       Get the id of the time coordinate (unlimited coordinate) and its
-!--       last index on the file. The next time level is plmask..count+1.
-!--       The current time must be larger than the last output time
-!--       on the file.
-          nc_stat = NF90_INQ_VARID( id_set_mask(mid,av), 'time', &
-                                    id_var_time_mask(mid,av) )
-          CALL netcdf_handle_error( 'netcdf_define_header', 511 )
-
-          nc_stat = NF90_INQUIRE_VARIABLE( id_set_mask(mid,av), &
-                                           id_var_time_mask(mid,av), &
-                                           dimids = id_dim_time_old )
-          CALL netcdf_handle_error( 'netcdf_define_header', 512 )
-          id_dim_time_mask(mid,av) = id_dim_time_old(1)
-
-          nc_stat = NF90_INQUIRE_DIMENSION( id_set_mask(mid,av), &
-                                            id_dim_time_mask(mid,av), &
-                                            len = domask_time_count(mid,av) )
-          CALL netcdf_handle_error( 'netcdf_define_header', 513 )
-
-          nc_stat = NF90_GET_VAR( id_set_mask(mid,av), &
-                                  id_var_time_mask(mid,av), &
-                                  last_time_coordinate,              &
-                                  start = (/ domask_time_count(mid,av) /), &
-                                  count = (/ 1 /) )
-          CALL netcdf_handle_error( 'netcdf_define_header', 514 )
-
-          IF ( last_time_coordinate(1) >= simulated_time )  THEN
-             WRITE ( message_string, * ) 'netCDF file for ', TRIM( var ), &
-                  ' data for mask', mid, ' from previous run found,', &
-                  '&but this file cannot be extended because the current ', &
-                  'output time&is less or equal than the last output time ', &
-                  'on this file.&New file is created instead.'
-             CALL message( 'define_netcdf_header', 'PA0337', 0, 1, 0, 6, 0 )
-             domask_time_count(mid,av) = 0
-             extend = .FALSE.
-             RETURN
-          ENDIF
-
-!
-!--       Dataset seems to be extendable.
-!--       Now get the variable ids.
-          i = 1
-          DO WHILE ( domask(mid,av,i)(1:1) /= ' ' )
-             nc_stat = NF90_INQ_VARID( id_set_mask(mid,av), &
-                                       TRIM( domask(mid,av,i) ), &
-                                       id_var_domask(mid,av,i) )
-             CALL netcdf_handle_error( 'netcdf_define_header', 515 )
-             i = i + 1
-          ENDDO
-
-!
-!--       Update the title attribute on file
-!--       In order to avoid 'data mode' errors if updated attributes are larger 
-!--       than their original size, NF90_PUT_ATT is called in 'define mode' 
-!--       enclosed by NF90_REDEF and NF90_ENDDEF calls. This implies a possible 
-!--       performance loss due to data copying; an alternative strategy would be 
-!--       to ensure equal attribute size in a job chain. Maybe revise later.
-          IF ( av == 0 )  THEN
-             time_average_text = ' '
-          ELSE
-             WRITE (time_average_text, '('', '',F7.1,'' s average'')') &
-                                                            averaging_interval
-          ENDIF
-          nc_stat = NF90_REDEF( id_set_mask(mid,av) )
-          CALL netcdf_handle_error( 'netcdf_define_header', 516 )
-          nc_stat = NF90_PUT_ATT( id_set_mask(mid,av), NF90_GLOBAL, 'title', &
-                                  TRIM( run_description_header ) //    &
-                                  TRIM( time_average_text ) )
-          CALL netcdf_handle_error( 'netcdf_define_header', 517 )
-          nc_stat = NF90_ENDDEF( id_set_mask(mid,av) )
-          CALL netcdf_handle_error( 'netcdf_define_header', 518 )
-          WRITE ( message_string, * ) 'netCDF file for ', TRIM( var ), &
-               ' data for mask', mid, ' from previous run found.', &
-               '&This file will be extended.'
-          CALL message( 'define_netcdf_header', 'PA0338', 0, 0, 0, 6, 0 )
-!
-!--       restore original parameter file_id (=formal parameter av) into av
-          av = file_id
-
-
-       CASE ( '3d_new' )
-
-!
-!--       Define some global attributes of the dataset
-          nc_stat = NF90_PUT_ATT( id_set_3d(av), NF90_GLOBAL, 'Conventions', &
-                                  'COARDS' )
-          CALL netcdf_handle_error( 'netcdf_define_header', 62 )
-
-          IF ( av == 0 )  THEN
-             time_average_text = ' '
-          ELSE
-             WRITE (time_average_text, '('', '',F7.1,'' s average'')') &
-                                                            averaging_interval
-          ENDIF
-          nc_stat = NF90_PUT_ATT( id_set_3d(av), NF90_GLOBAL, 'title', &
-                                  TRIM( run_description_header ) //    &
-                                  TRIM( time_average_text ) )
-          CALL netcdf_handle_error( 'netcdf_define_header', 63 )
-          IF ( av == 1 )  THEN
-             WRITE ( time_average_text,'(F7.1,'' s avg'')' )  averaging_interval
-             nc_stat = NF90_PUT_ATT( id_set_3d(av), NF90_GLOBAL, 'time_avg', &
-                                     TRIM( time_average_text ) )
-             CALL netcdf_handle_error( 'netcdf_define_header', 63 )
-          ENDIF
-
-!
-!--       Define time coordinate for volume data.
-!--       For parallel output the time dimensions has to be limited, otherwise
-!--       the performance drops significantly.
-          IF ( netcdf_data_format < 5 )  THEN
-             CALL netcdf_create_dim( id_set_3d(av), 'time', NF90_UNLIMITED,    &
-                                     id_dim_time_3d(av), 64 )
-          ELSE
-             CALL netcdf_create_dim( id_set_3d(av), 'time', ntdim_3d(av),      &
-                                     id_dim_time_3d(av), 523 )
-          ENDIF
-
-          CALL netcdf_create_var( id_set_3d(av), (/ id_dim_time_3d(av) /),     &
-                                  'time', NF90_DOUBLE, id_var_time_3d(av),     &
-                                  'seconds', '', 65, 66, 00 )
-!
-!--       Define spatial dimensions and coordinates:
-!--       Define vertical coordinate grid (zu grid)
-          CALL netcdf_create_dim( id_set_3d(av), 'zu_3d', nz_do3d-nzb+1,       &
-                                  id_dim_zu_3d(av), 67 )
-          CALL netcdf_create_var( id_set_3d(av), (/ id_dim_zu_3d(av) /),       &
-                                  'zu_3d', NF90_DOUBLE, id_var_zu_3d(av),      &
-                                  'meters', '', 68, 69, 00 )
-!
-!--       Define vertical coordinate grid (zw grid)
-          CALL netcdf_create_dim( id_set_3d(av), 'zw_3d', nz_do3d-nzb+1,       &
-                                  id_dim_zw_3d(av), 70 )
-          CALL netcdf_create_var( id_set_3d(av), (/ id_dim_zw_3d(av) /),       &
-                                  'zw_3d', NF90_DOUBLE, id_var_zw_3d(av),      &
-                                  'meters', '', 71, 72, 00 )
-!
-!--       Define x-axis (for scalar position)
-          CALL netcdf_create_dim( id_set_3d(av), 'x', nx+2, id_dim_x_3d(av),   &
-                                  73 )
-          CALL netcdf_create_var( id_set_3d(av), (/ id_dim_x_3d(av) /), 'x',   &
-                                  NF90_DOUBLE, id_var_x_3d(av), 'meters', '',  &
-                                  74, 75, 00 )
-!
-!--       Define x-axis (for u position)
-          CALL netcdf_create_dim( id_set_3d(av), 'xu', nx+2, id_dim_xu_3d(av), &
-                                  358 )
-          CALL netcdf_create_var( id_set_3d(av), (/ id_dim_xu_3d(av) /), 'xu', &
-                                  NF90_DOUBLE, id_var_xu_3d(av), 'meters', '', &
-                                  359, 360, 000 )
-!
-!--       Define y-axis (for scalar position)
-          CALL netcdf_create_dim( id_set_3d(av), 'y', ny+2, id_dim_y_3d(av),   &
-                                  76 )
-          CALL netcdf_create_var( id_set_3d(av), (/ id_dim_y_3d(av) /), 'y',   &
-                                  NF90_DOUBLE, id_var_y_3d(av), 'meters', '',  &
-                                  77, 78, 00 )
-!
-!--       Define y-axis (for v position)
-          CALL netcdf_create_dim( id_set_3d(av), 'yv', ny+2, id_dim_yv_3d(av), &
-                                  361 )
-          CALL netcdf_create_var( id_set_3d(av), (/ id_dim_yv_3d(av) /), 'yv', &
-                                  NF90_DOUBLE, id_var_yv_3d(av), 'meters', '', &
-                                  362, 363, 000 )
-!
-!--       In case of non-flat topography define 2d-arrays containing the height
-!--       information
-          IF ( TRIM( topography ) /= 'flat' )  THEN
-!
-!--          Define zusi = zu(nzb_s_inner)
-             CALL netcdf_create_var( id_set_3d(av), (/ id_dim_x_3d(av),        &
-                                     id_dim_y_3d(av) /), 'zusi', NF90_DOUBLE,  &
-                                     id_var_zusi_3d(av), 'meters',             &
-                                     'zu(nzb_s_inner)', 413, 414, 415 )
-!             
-!--          Define zwwi = zw(nzb_w_inner)
-             CALL netcdf_create_var( id_set_3d(av), (/ id_dim_x_3d(av),        &
-                                     id_dim_y_3d(av) /), 'zwwi', NF90_DOUBLE,  &
-                                     id_var_zwwi_3d(av), 'meters',             &
-                                     'zw(nzb_w_inner)', 416, 417, 418 )
-
-          ENDIF             
-
-          IF ( land_surface )  THEN
-!
-!--          Define vertical coordinate grid (zs grid)
-             CALL netcdf_create_dim( id_set_3d(av), 'zs_3d',                   &
-                                     nzt_soil-nzb_soil+1, id_dim_zs_3d(av), 70 )
-             CALL netcdf_create_var( id_set_3d(av), (/ id_dim_zs_3d(av) /),    &
-                                     'zs_3d', NF90_DOUBLE, id_var_zs_3d(av),   &
-                                     'meters', '', 71, 72, 00 )
-
-          ENDIF
-
-!
-!--       Define the variables
-          var_list = ';'
-          i = 1
-
-          DO WHILE ( do3d(av,i)(1:1) /= ' ' )
-
-!
-!--          Check for the grid
-             found = .TRUE.
-             SELECT CASE ( do3d(av,i) )
-!
-!--             Most variables are defined on the scalar grid
-                CASE ( 'e', 'lpt', 'nr', 'p', 'pc', 'pr', 'prr', 'pt', 'q',    &
-                       'qc', 'ql', 'ql_c', 'ql_v', 'ql_vp', 'qr', 'qv', 'rho', &
-                       's', 'sa', 'vpt' , 'rad_lw_cs_hr', 'rad_lw_hr',         &
-                       'rad_sw_cs_hr', 'rad_sw_hr' )
-
-                   grid_x = 'x'
-                   grid_y = 'y'
-                   grid_z = 'zu'
-!
-!--             u grid
-                CASE ( 'u' )
-
-                   grid_x = 'xu'
-                   grid_y = 'y'
-                   grid_z = 'zu'
-!
-!--             v grid
-                CASE ( 'v' )
-
-                   grid_x = 'x'
-                   grid_y = 'yv'
-                   grid_z = 'zu'
-!
-!--             w grid
-                CASE ( 'rad_lw_in', 'rad_lw_out', 'rad_sw_in', 'rad_sw_out',   &
-                       'w' )
-
-                   grid_x = 'x'
-                   grid_y = 'y'
-                   grid_z = 'zw'
-!
-!--             soil grid
-                CASE ( 'm_soil', 't_soil' )
-
-                   grid_x = 'x'
-                   grid_y = 'y'
-                   grid_z = 'zs'
-
-                CASE DEFAULT
-!
-!--                Check for user-defined quantities
-                   CALL user_define_netcdf_grid( do3d(av,i), found, grid_x, &
-                                                 grid_y, grid_z )
-
-                   IF ( .NOT. found )  THEN
-                      WRITE ( message_string, * ) 'no grid defined for varia', &
-                                                  'ble ', TRIM( do3d(av,i) )
-                      CALL message( 'define_netcdf_header', 'PA0244', 0, 1, 0, &
-                                    6, 0 )
-                   ENDIF
-
-             END SELECT
-
-!
-!--          Select the respective dimension ids
-             IF ( grid_x == 'x' )  THEN
-                id_x = id_dim_x_3d(av)
-             ELSEIF ( grid_x == 'xu' )  THEN
-                id_x = id_dim_xu_3d(av)
-             ENDIF
-
-             IF ( grid_y == 'y' )  THEN
-                id_y = id_dim_y_3d(av)
-             ELSEIF ( grid_y == 'yv' )  THEN
-                id_y = id_dim_yv_3d(av)
-             ENDIF
-
-             IF ( grid_z == 'zu' )  THEN
-                id_z = id_dim_zu_3d(av)
-             ELSEIF ( grid_z == 'zw' )  THEN
-                id_z = id_dim_zw_3d(av)
-             ELSEIF ( grid_z == 'zs' )  THEN
-                id_z = id_dim_zs_3d(av)
-             ENDIF
-
-!
-!--          Define the grid
-             CALL netcdf_create_var( id_set_3d(av),(/ id_x, id_y, id_z,        &
-                                     id_dim_time_3d(av) /), do3d(av,i),        &
-                                     nc_precision(4), id_var_do3d(av,i),       &
-                                     TRIM( do3d_unit(av,i) ), do3d(av,i), 79,  &
-                                     80, 357 )
-#if defined( __netcdf4_parallel )
-             IF ( netcdf_data_format > 4 )  THEN
-!
-!--             Set no fill for every variable to increase performance.
-                nc_stat = NF90_DEF_VAR_FILL( id_set_3d(av),     &
-                                             id_var_do3d(av,i), &
-                                             1, 0 )
-                CALL netcdf_handle_error( 'netcdf_define_header', 532 )
-!
-!--             Set collective io operations for parallel io
-                nc_stat = NF90_VAR_PAR_ACCESS( id_set_3d(av),     &
-                                               id_var_do3d(av,i), &
-                                               NF90_COLLECTIVE )
-                CALL netcdf_handle_error( 'netcdf_define_header', 445 )
-             ENDIF
-#endif
-             var_list = TRIM( var_list ) // TRIM( do3d(av,i) ) // ';'
-
-             i = i + 1
-
-          ENDDO
-
-!
-!--       No arrays to output
-          IF ( i == 1 )  RETURN
-
-!
-!--       Write the list of variables as global attribute (this is used by
-!--       restart runs and by combine_plot_fields)
-          nc_stat = NF90_PUT_ATT( id_set_3d(av), NF90_GLOBAL, 'VAR_LIST', &
-                                  var_list )
-          CALL netcdf_handle_error( 'netcdf_define_header', 81 )
-
-!
-!--       Set general no fill, otherwise the performance drops significantly for
-!--       parallel output.
-          nc_stat = NF90_SET_FILL( id_set_3d(av), NF90_NOFILL, oldmode )
-          CALL netcdf_handle_error( 'netcdf_define_header', 528 )
-
-!
-!--       Leave netCDF define mode
-          nc_stat = NF90_ENDDEF( id_set_3d(av) )
-          CALL netcdf_handle_error( 'netcdf_define_header', 82 )
-
-!
-!--       These data are only written by PE0 for parallel output to increase
-!--       the performance.
-          IF ( myid == 0  .OR.  netcdf_data_format < 5 )  THEN
-!
-!--          Write data for x (shifted by +dx/2) and xu axis
-             ALLOCATE( netcdf_data(0:nx+1) )
-
-             DO  i = 0, nx+1
-                netcdf_data(i) = ( i + 0.5 ) * dx
-             ENDDO
-
-             nc_stat = NF90_PUT_VAR( id_set_3d(av), id_var_x_3d(av),  &
-                                     netcdf_data, start = (/ 1 /),    &
-                                     count = (/ nx+2 /) )
-             CALL netcdf_handle_error( 'netcdf_define_header', 83 )
-
-             DO  i = 0, nx+1
-                netcdf_data(i) = i * dx
-             ENDDO
-
-             nc_stat = NF90_PUT_VAR( id_set_3d(av), id_var_xu_3d(av), &
-                                     netcdf_data, start = (/ 1 /),    &
-                                     count = (/ nx+2 /) )
-             CALL netcdf_handle_error( 'netcdf_define_header', 385 )
-
-             DEALLOCATE( netcdf_data )
-
-!
-!--          Write data for y (shifted by +dy/2) and yv axis
-             ALLOCATE( netcdf_data(0:ny+1) )
-
-             DO  i = 0, ny+1
-                netcdf_data(i) = ( i + 0.5_wp ) * dy
-             ENDDO
-
-             nc_stat = NF90_PUT_VAR( id_set_3d(av), id_var_y_3d(av),  &
-                                     netcdf_data, start = (/ 1 /),    &
-                                     count = (/ ny+2 /) )
-             CALL netcdf_handle_error( 'netcdf_define_header', 84 )
-
-             DO  i = 0, ny+1
-                netcdf_data(i) = i * dy
-             ENDDO
-
-             nc_stat = NF90_PUT_VAR( id_set_3d(av), id_var_yv_3d(av), &
-                                     netcdf_data, start = (/ 1 /),    &
-                                     count = (/ ny+2 /))
-             CALL netcdf_handle_error( 'netcdf_define_header', 387 )
-
-             DEALLOCATE( netcdf_data )
-
-!
-!--          Write zu and zw data (vertical axes)
-             nc_stat = NF90_PUT_VAR( id_set_3d(av), id_var_zu_3d(av),  &
-                                     zu(nzb:nz_do3d), start = (/ 1 /), &
-                                     count = (/ nz_do3d-nzb+1 /) )
-             CALL netcdf_handle_error( 'netcdf_define_header', 85 )
-
-
-             nc_stat = NF90_PUT_VAR( id_set_3d(av), id_var_zw_3d(av),  &
-                                     zw(nzb:nz_do3d), start = (/ 1 /), &
-                                     count = (/ nz_do3d-nzb+1 /) )
-             CALL netcdf_handle_error( 'netcdf_define_header', 86 )
-
-!
-!--          In case of non-flat topography write height information
-             IF ( TRIM( topography ) /= 'flat' )  THEN
-
-                nc_stat = NF90_PUT_VAR( id_set_3d(av), id_var_zusi_3d(av), &
-                                        zu_s_inner(0:nx+1,0:ny+1), &
-                                        start = (/ 1, 1 /), &
-                                        count = (/ nx+2, ny+2 /) )
-                CALL netcdf_handle_error( 'netcdf_define_header', 419 )
-
-                nc_stat = NF90_PUT_VAR( id_set_3d(av), id_var_zwwi_3d(av), &
-                                        zw_w_inner(0:nx+1,0:ny+1), &
-                                        start = (/ 1, 1 /), &
-                                        count = (/ nx+2, ny+2 /) )
-                CALL netcdf_handle_error( 'netcdf_define_header', 420 )
-
-             ENDIF
-
-             IF ( land_surface )  THEN
-!
-!--             Write zs grid
-                nc_stat = NF90_PUT_VAR( id_set_3d(av), id_var_zs_3d(av),  &
-                                        - zs(nzb_soil:nzt_soil), start = (/ 1 /), &
-                                        count = (/ nzt_soil-nzb_soil+1 /) )
-                CALL netcdf_handle_error( 'netcdf_define_header', 86 )
-             ENDIF
-
-          ENDIF
-
-       CASE ( '3d_ext' )
-
-!
-!--       Get the list of variables and compare with the actual run.
-!--       First var_list_old has to be reset, since GET_ATT does not assign
-!--       trailing blanks.
-          var_list_old = ' '
-          nc_stat = NF90_GET_ATT( id_set_3d(av), NF90_GLOBAL, 'VAR_LIST', &
-                                  var_list_old )
-          CALL netcdf_handle_error( 'netcdf_define_header', 87 )
-
-          var_list = ';'
-          i = 1
-          DO WHILE ( do3d(av,i)(1:1) /= ' ' )
-             var_list = TRIM(var_list) // TRIM( do3d(av,i) ) // ';'
-             i = i + 1
-          ENDDO
-
-          IF ( av == 0 )  THEN
-             var = '(3d)'
-          ELSE
-             var = '(3d_av)'
-          ENDIF
-
-          IF ( TRIM( var_list ) /= TRIM( var_list_old ) )  THEN
-             message_string = 'netCDF file for volume data ' //             &
-                              TRIM( var ) // ' from previous run found,' // &
-                              '&but this file cannot be extended due to' // &
-                              ' variable mismatch.' //                      &
-                              '&New file is created instead.'
-             CALL message( 'define_netcdf_header', 'PA0245', 0, 1, 0, 6, 0 )
-             extend = .FALSE.
-             RETURN
-          ENDIF
-
-!
-!--       Get and compare the number of vertical gridpoints
-          nc_stat = NF90_INQ_VARID( id_set_3d(av), 'zu_3d', id_var_zu_3d(av) )
-          CALL netcdf_handle_error( 'netcdf_define_header', 88 )
-
-          nc_stat = NF90_INQUIRE_VARIABLE( id_set_3d(av), id_var_zu_3d(av), &
-                                           dimids = id_dim_zu_3d_old )
-          CALL netcdf_handle_error( 'netcdf_define_header', 89 )
-          id_dim_zu_3d(av) = id_dim_zu_3d_old(1)
-
-          nc_stat = NF90_INQUIRE_DIMENSION( id_set_3d(av), id_dim_zu_3d(av), &
-                                            len = nz_old )
-          CALL netcdf_handle_error( 'netcdf_define_header', 90 )
-
-          IF ( nz_do3d-nzb+1 /= nz_old )  THEN
-              message_string = 'netCDF file for volume data ' //             &
-                               TRIM( var ) // ' from previous run found,' // &
-                               '&but this file cannot be extended due to' // &
-                               ' mismatch in number of' //                   &
-                               '&vertical grid points (nz_do3d).' //         &
-                               '&New file is created instead.'
-             CALL message( 'define_netcdf_header', 'PA0246', 0, 1, 0, 6, 0 )
-             extend = .FALSE.
-             RETURN
-          ENDIF
-
-!
-!--       Get the id of the time coordinate (unlimited coordinate) and its
-!--       last index on the file. The next time level is pl3d..count+1.
-!--       The current time must be larger than the last output time
-!--       on the file.
-          nc_stat = NF90_INQ_VARID( id_set_3d(av), 'time', id_var_time_3d(av) )
-          CALL netcdf_handle_error( 'netcdf_define_header', 91 )
-
-          nc_stat = NF90_INQUIRE_VARIABLE( id_set_3d(av), id_var_time_3d(av), &
-                                           dimids = id_dim_time_old )
-          CALL netcdf_handle_error( 'netcdf_define_header', 92 )
-
-          id_dim_time_3d(av) = id_dim_time_old(1)
-
-          nc_stat = NF90_INQUIRE_DIMENSION( id_set_3d(av), id_dim_time_3d(av), &
-                                            len = ntime_count )
-          CALL netcdf_handle_error( 'netcdf_define_header', 93 )
-
-!
-!--       For non-parallel output use the last output time level of the netcdf
-!--       file because the time dimension is unlimited. In case of parallel
-!--       output the variable ntime_count could get the value of 9*10E36 because
-!--       the time dimension is limited.
-          IF ( netcdf_data_format < 5 ) do3d_time_count(av) = ntime_count
-
-          nc_stat = NF90_GET_VAR( id_set_3d(av), id_var_time_3d(av), &
-                                  last_time_coordinate,              &
-                                  start = (/ do3d_time_count(av) /), &
-                                  count = (/ 1 /) )
-          CALL netcdf_handle_error( 'netcdf_define_header', 94 )
-
-          IF ( last_time_coordinate(1) >= simulated_time )  THEN
-             message_string = 'netCDF file for volume data ' // &
-                              TRIM( var ) // ' from previous run found,' // &
-                              '&but this file cannot be extended becaus' // &
-                              'e the current output time' //                &
-                              '&is less or equal than the last output t' // &
-                              'ime on this file.' //                        &
-                              '&New file is created instead.'
-             CALL message( 'define_netcdf_header', 'PA0247', 0, 1, 0, 6, 0 )
-             do3d_time_count(av) = 0
-             extend = .FALSE.
-             RETURN
-          ENDIF
-
-          IF ( netcdf_data_format > 4 )  THEN
-!
-!--          Set needed time levels (ntdim) to 
-!--          saved time levels + to be saved time levels.
-             IF ( av == 0 )  THEN 
-                ntdim_3d(0) = do3d_time_count(0) + CEILING(                &
-                              ( end_time - MAX( skip_time_do3d,            &
-                                                simulated_time_at_begin )  &
-                              ) / dt_do3d )
-             ELSE
-                ntdim_3d(1) = do3d_time_count(1) + CEILING(                &
-                              ( end_time - MAX( skip_time_data_output_av,  &
-                                                simulated_time_at_begin )  &
-                              ) / dt_data_output_av )
-             ENDIF
-
-!
-!--          Check if the needed number of output time levels is increased
-!--          compared to the number of time levels in the existing file.
-             IF ( ntdim_3d(av) > ntime_count )  THEN
-                message_string = 'netCDF file for volume data ' // &
-                                 TRIM( var ) // ' from previous run found,' // &
-                                 '&but this file cannot be extended becaus' // &
-                                 'e the number of output time levels&has b' // &
-                                 'een increased compared to the previous s' // &
-                                 'imulation.' //                               &
-                                 '&New file is created instead.'
-                CALL message( 'define_netcdf_header', 'PA0388', 0, 1, 0, 6, 0 )
-                do3d_time_count(av) = 0
-                extend = .FALSE.
-!
-!--             Recalculate the needed time levels for the new file.
-                IF ( av == 0 )  THEN
-                   ntdim_3d(0) = CEILING(                               &
-                           ( end_time - MAX( skip_time_do3d,            &
-                                             simulated_time_at_begin )  &
-                           ) / dt_do3d )
-                ELSE
-                   ntdim_3d(1) = CEILING(                               &
-                           ( end_time - MAX( skip_time_data_output_av,  &
-                                             simulated_time_at_begin )  &
-                           ) / dt_data_output_av )
-                ENDIF
-                RETURN
-             ENDIF
-          ENDIF
-
-!
-!--       Dataset seems to be extendable.
-!--       Now get the variable ids.
-          i = 1
-          DO WHILE ( do3d(av,i)(1:1) /= ' ' )
-             nc_stat = NF90_INQ_VARID( id_set_3d(av), TRIM( do3d(av,i) ), &
-                                       id_var_do3d(av,i) )
-             CALL netcdf_handle_error( 'netcdf_define_header', 95 )
-#if defined( __netcdf4_parallel )
-!
-!--          Set collective io operations for parallel io
-             IF ( netcdf_data_format > 4 )  THEN
-                nc_stat = NF90_VAR_PAR_ACCESS( id_set_3d(av),     &
-                                               id_var_do3d(av,i), &
-                                               NF90_COLLECTIVE )
-                CALL netcdf_handle_error( 'netcdf_define_header', 453 )
-             ENDIF
-#endif
-             i = i + 1
-          ENDDO
-
-!
-!--       Update the title attribute on file
-!--       In order to avoid 'data mode' errors if updated attributes are larger 
-!--       than their original size, NF90_PUT_ATT is called in 'define mode' 
-!--       enclosed by NF90_REDEF and NF90_ENDDEF calls. This implies a possible 
-!--       performance loss due to data copying; an alternative strategy would be 
-!--       to ensure equal attribute size. Maybe revise later.
-          IF ( av == 0 )  THEN
-             time_average_text = ' '
-          ELSE
-             WRITE (time_average_text, '('', '',F7.1,'' s average'')') &
-                                                            averaging_interval
-          ENDIF
-          nc_stat = NF90_REDEF( id_set_3d(av) )
-          CALL netcdf_handle_error( 'netcdf_define_header', 429 )
-          nc_stat = NF90_PUT_ATT( id_set_3d(av), NF90_GLOBAL, 'title', &
-                                  TRIM( run_description_header ) //    &
-                                  TRIM( time_average_text ) )
-          CALL netcdf_handle_error( 'netcdf_define_header', 96 )
-          nc_stat = NF90_ENDDEF( id_set_3d(av) )
-          CALL netcdf_handle_error( 'netcdf_define_header', 430 )
-          message_string = 'netCDF file for volume data ' //             &
-                           TRIM( var ) // ' from previous run found.' // &
-                           '&This file will be extended.'
-          CALL message( 'define_netcdf_header', 'PA0248', 0, 0, 0, 6, 0 )
-
-       CASE ( 'xy_new' )
-
-!
-!--       Define some global attributes of the dataset
-          nc_stat = NF90_PUT_ATT( id_set_xy(av), NF90_GLOBAL, 'Conventions', &
-                                  'COARDS' )
-          CALL netcdf_handle_error( 'netcdf_define_header', 97 )
-
-          IF ( av == 0 )  THEN
-             time_average_text = ' '
-          ELSE
-             WRITE (time_average_text, '('', '',F7.1,'' s average'')') &
-                                                            averaging_interval
-          ENDIF
-          nc_stat = NF90_PUT_ATT( id_set_xy(av), NF90_GLOBAL, 'title', &
-                                  TRIM( run_description_header ) //    &
-                                  TRIM( time_average_text ) )
-          CALL netcdf_handle_error( 'netcdf_define_header', 98 )
-          IF ( av == 1 )  THEN
-             WRITE ( time_average_text,'(F7.1,'' s avg'')' )  averaging_interval
-             nc_stat = NF90_PUT_ATT( id_set_xy(av), NF90_GLOBAL, 'time_avg', &
-                                     TRIM( time_average_text ) )
-             CALL netcdf_handle_error( 'netcdf_define_header', 98 )
-          ENDIF
-
-!
-!--       Define time coordinate for xy sections.
-!--       For parallel output the time dimensions has to be limited, otherwise
-!--       the performance drops significantly.
-          IF ( netcdf_data_format < 5 )  THEN
-             CALL netcdf_create_dim( id_set_xy(av), 'time', NF90_UNLIMITED,    &
-                                     id_dim_time_xy(av), 99 )
-          ELSE
-             CALL netcdf_create_dim( id_set_xy(av), 'time', ntdim_2d_xy(av),   &
-                                     id_dim_time_xy(av), 524 )
-          ENDIF
-
-          CALL netcdf_create_var( id_set_xy(av), (/ id_dim_time_xy(av) /),     &
-                                  'time', NF90_DOUBLE, id_var_time_xy(av),     &
-                                  'seconds', '', 100, 101, 000 )
-!
-!--       Define the spatial dimensions and coordinates for xy-sections.
-!--       First, determine the number of horizontal sections to be written.
-          IF ( section(1,1) == -9999 )  THEN
-             RETURN
-          ELSE
-             ns = 1
-             DO WHILE ( section(ns,1) /= -9999  .AND.  ns <= 100 )
-                ns = ns + 1
-             ENDDO
-             ns = ns - 1
-          ENDIF
-
-!
-!--       Define vertical coordinate grid (zu grid)
-          CALL netcdf_create_dim( id_set_xy(av), 'zu_xy', ns,                  &
-                                  id_dim_zu_xy(av), 102 )
-          CALL netcdf_create_var( id_set_xy(av), (/ id_dim_zu_xy(av) /),       &
-                                  'zu_xy', NF90_DOUBLE, id_var_zu_xy(av),      &
-                                  'meters', '', 103, 104, 000 )
-!
-!--       Define vertical coordinate grid (zw grid)
-          CALL netcdf_create_dim( id_set_xy(av), 'zw_xy', ns,                  &
-                                  id_dim_zw_xy(av), 105 )
-          CALL netcdf_create_var( id_set_xy(av), (/ id_dim_zw_xy(av) /),       &
-                                  'zw_xy', NF90_DOUBLE, id_var_zw_xy(av),      &
-                                  'meters', '', 106, 107, 000 )
-
-          IF ( land_surface )  THEN
-
-             ns_do = 0
-             DO WHILE ( section(ns_do+1,1) < nzs )
-                ns_do = ns_do + 1
-             ENDDO
-!
-!--          Define vertical coordinate grid (zs grid)
-             CALL netcdf_create_dim( id_set_xy(av), 'zs_xy', ns_do,            &
-                                     id_dim_zs_xy(av), 539 )
-             CALL netcdf_create_var( id_set_xy(av), (/ id_dim_zs_xy(av) /),    &
-                                     'zs_xy', NF90_DOUBLE, id_var_zs_xy(av),   &
-                                     'meters', '', 540, 541, 000 )
-
-          ENDIF
-
-!
-!--       Define a pseudo vertical coordinate grid for the surface variables
-!--       u* and t* to store their height level
-          CALL netcdf_create_dim( id_set_xy(av), 'zu1_xy', 1,                  &
-                                  id_dim_zu1_xy(av), 108 )
-          CALL netcdf_create_var( id_set_xy(av), (/ id_dim_zu1_xy(av) /),      &
-                                  'zu1_xy', NF90_DOUBLE, id_var_zu1_xy(av),    &
-                                  'meters', '', 109, 110, 000 )
-!
-!--       Define a variable to store the layer indices of the horizontal cross
-!--       sections, too
-          CALL netcdf_create_var( id_set_xy(av), (/ id_dim_zu_xy(av) /),       &
-                                  'ind_z_xy', NF90_DOUBLE,                     &
-                                  id_var_ind_z_xy(av), 'gridpoints', '', 111,  &
-                                  112, 000 )
-!
-!--       Define x-axis (for scalar position)
-          CALL netcdf_create_dim( id_set_xy(av), 'x', nx+2, id_dim_x_xy(av),   &
-                                  113 )
-          CALL netcdf_create_var( id_set_xy(av), (/ id_dim_x_xy(av) /), 'x',   &
-                                  NF90_DOUBLE, id_var_x_xy(av), 'meters', '',  &
-                                  114, 115, 000 )
-!
-!--       Define x-axis (for u position)
-          CALL netcdf_create_dim( id_set_xy(av), 'xu', nx+2,                   &
-                                  id_dim_xu_xy(av), 388 )
-          CALL netcdf_create_var( id_set_xy(av), (/ id_dim_xu_xy(av) /), 'xu', &
-                                  NF90_DOUBLE, id_var_xu_xy(av), 'meters', '', &
-                                  389, 390, 000 )
-!
-!--       Define y-axis (for scalar position)
-          CALL netcdf_create_dim( id_set_xy(av), 'y', ny+2, id_dim_y_xy(av),   &
-                                  116 )
-          CALL netcdf_create_var( id_set_xy(av), (/ id_dim_y_xy(av) /), 'y',   &
-                                  NF90_DOUBLE, id_var_y_xy(av), 'meters', '',  &
-                                  117, 118, 000 )
-!
-!--       Define y-axis (for scalar position)
-          CALL netcdf_create_dim( id_set_xy(av), 'yv', ny+2,                   &
-                                  id_dim_yv_xy(av), 364 )
-          CALL netcdf_create_var( id_set_xy(av), (/ id_dim_yv_xy(av) /), 'yv', &
-                                  NF90_DOUBLE, id_var_yv_xy(av), 'meters', '', &
-                                  365, 366, 000 )
-!
-!--       In case of non-flat topography define 2d-arrays containing the height
-!--       information
-          IF ( TRIM( topography ) /= 'flat' )  THEN
-!
-!--          Define zusi = zu(nzb_s_inner)
-             CALL netcdf_create_var( id_set_xy(av), (/ id_dim_x_xy(av),        &
-                                     id_dim_y_xy(av) /), 'zusi', NF90_DOUBLE,  &
-                                     id_var_zusi_xy(av), 'meters',             &
-                                     'zu(nzb_s_inner)', 421, 422, 423 )
-!             
-!--          Define zwwi = zw(nzb_w_inner)
-             CALL netcdf_create_var( id_set_xy(av), (/ id_dim_x_xy(av),        &
-                                     id_dim_y_xy(av) /), 'zwwi', NF90_DOUBLE,  &
-                                     id_var_zwwi_xy(av), 'meters',             &
-                                     'zw(nzb_w_inner)', 424, 425, 426 )
-
-          ENDIF
-
-!
-!--       Define the variables
-          var_list = ';'
-          i = 1
-
-          DO WHILE ( do2d(av,i)(1:1) /= ' ' )
-
-             IF ( INDEX( do2d(av,i), 'xy' ) /= 0 )  THEN
-!
-!--             If there is a star in the variable name (u* or t*), it is a
-!--             surface variable. Define it with id_dim_zu1_xy.
-                IF ( INDEX( do2d(av,i), '*' ) /= 0 )  THEN
-
-                   CALL netcdf_create_var( id_set_xy(av), (/ id_dim_x_xy(av),  &
-                                           id_dim_y_xy(av), id_dim_zu1_xy(av), &
-                                           id_dim_time_xy(av) /), do2d(av,i),  &
-                                           nc_precision(1), id_var_do2d(av,i), &
-                                           TRIM( do2d_unit(av,i) ),            &
-                                           do2d(av,i), 119, 120, 354 )
-
-                ELSE
-
-!
-!--                Check for the grid
-                   found = .TRUE.
-                   SELECT CASE ( do2d(av,i) )
-!
-!--                   Most variables are defined on the zu grid
-                      CASE ( 'e_xy', 'lpt_xy', 'nr_xy', 'p_xy', 'pc_xy',       &
-                             'pr_xy', 'prr_xy', 'pt_xy', 'q_xy', 'qc_xy',      &
-                             'ql_xy', 'ql_c_xy', 'ql_v_xy', 'ql_vp_xy',        &
-                             'qr_xy', 'qv_xy', 'rad_lw_cs_hr_xy',              &
-                             'rad_lw_hr_xy', 'rad_sw_cs_hr_xy', 'rad_sw_hr_xy',& 
-                             'rho_xy', 's_xy', 'sa_xy', 'vpt_xy' )
-
-                         grid_x = 'x'
-                         grid_y = 'y'
-                         grid_z = 'zu'
-!
-!--                   u grid
-                      CASE ( 'u_xy' )
-
-                         grid_x = 'xu'
-                         grid_y = 'y'
-                         grid_z = 'zu'
-!
-!--                   v grid
-                      CASE ( 'v_xy' )
-
-                         grid_x = 'x'
-                         grid_y = 'yv'
-                         grid_z = 'zu'
-!
-!--                   w grid
-                      CASE ( 'rad_lw_in_xy', 'rad_lw_out_xy', 'rad_sw_in_xy',  &
-                             'rad_sw_out_xy' , 'w_xy' )
-
-                         grid_x = 'x'
-                         grid_y = 'y'
-                         grid_z = 'zw'
-!
-!--                   soil grid
-                      CASE ( 'm_soil_xy', 't_soil_xy' )
-                         grid_x = 'x'
-                         grid_y = 'y'
-                         grid_z = 'zs'
-
-                      CASE DEFAULT
-!
-!--                      Check for user-defined quantities
-                         CALL user_define_netcdf_grid( do2d(av,i), found, &
-                                                       grid_x, grid_y, grid_z )
-
-                         IF ( .NOT. found )  THEN
-                            WRITE ( message_string, * ) 'no grid defined for', &
-                                                ' variable ', TRIM( do2d(av,i) )
-                            CALL message( 'define_netcdf_header', 'PA0244',    &
-                                          0, 1, 0, 6, 0 )
-                         ENDIF
-
-                   END SELECT
-
-!
-!--                Select the respective dimension ids
-                   IF ( grid_x == 'x' )  THEN
-                      id_x = id_dim_x_xy(av)
-                   ELSEIF ( grid_x == 'xu' )  THEN
-                      id_x = id_dim_xu_xy(av)
-                   ENDIF
-
-                   IF ( grid_y == 'y' )  THEN
-                      id_y = id_dim_y_xy(av)
-                   ELSEIF ( grid_y == 'yv' )  THEN
-                      id_y = id_dim_yv_xy(av)
-                   ENDIF
-
-                   IF ( grid_z == 'zu' )  THEN
-                      id_z = id_dim_zu_xy(av)
-                   ELSEIF ( grid_z == 'zw' )  THEN
-                      id_z = id_dim_zw_xy(av)
-                   ELSEIF ( grid_z == 'zs' )  THEN
-                      id_z = id_dim_zs_xy(av)
-                   ENDIF
-
-!
-!--                Define the grid
-                   CALL netcdf_create_var( id_set_xy(av), (/ id_x, id_y, id_z, &
-                                           id_dim_time_xy(av) /), do2d(av,i),  &
-                                           nc_precision(1), id_var_do2d(av,i), &
-                                           TRIM( do2d_unit(av,i) ),            &
-                                           do2d(av,i), 119, 120, 354 )
-
-                ENDIF
-
-#if defined( __netcdf4_parallel )
-                IF ( netcdf_data_format > 4 )  THEN
-!
-!--                Set no fill for every variable to increase performance.
-                   nc_stat = NF90_DEF_VAR_FILL( id_set_xy(av),     &
-                                                id_var_do2d(av,i), &
-                                                1, 0 )
-                   CALL netcdf_handle_error( 'netcdf_define_header', 533 )
-!
-!--                Set collective io operations for parallel io
-                   nc_stat = NF90_VAR_PAR_ACCESS( id_set_xy(av),     &
-                                                  id_var_do2d(av,i), &
-                                                  NF90_COLLECTIVE )
-                   CALL netcdf_handle_error( 'netcdf_define_header', 448 )
-                ENDIF
-#endif
-                var_list = TRIM( var_list) // TRIM( do2d(av,i) ) // ';'
-
-             ENDIF
-
-             i = i + 1
-
-          ENDDO
-
-!
-!--       No arrays to output. Close the netcdf file and return.
-          IF ( i == 1 )  RETURN
-
-!
-!--       Write the list of variables as global attribute (this is used by
-!--       restart runs and by combine_plot_fields)
-          nc_stat = NF90_PUT_ATT( id_set_xy(av), NF90_GLOBAL, 'VAR_LIST', &
-                                  var_list )
-          CALL netcdf_handle_error( 'netcdf_define_header', 121 )
-
-!
-!--       Set general no fill, otherwise the performance drops significantly for
-!--       parallel output.
-          nc_stat = NF90_SET_FILL( id_set_xy(av), NF90_NOFILL, oldmode )
-          CALL netcdf_handle_error( 'netcdf_define_header', 529 )
-
-!
-!--       Leave netCDF define mode
-          nc_stat = NF90_ENDDEF( id_set_xy(av) )
-          CALL netcdf_handle_error( 'netcdf_define_header', 122 )
-
-!
-!--       These data are only written by PE0 for parallel output to increase
-!--       the performance.
-          IF ( myid == 0  .OR.  netcdf_data_format < 5 )  THEN
-
-!
-!--          Write axis data: z_xy, x, y
-             ALLOCATE( netcdf_data(1:ns) )
-
-!
-!--          Write zu data
-             DO  i = 1, ns
-                IF( section(i,1) == -1 )  THEN
-                   netcdf_data(i) = -1.0_wp  ! section averaged along z
-                ELSE
-                   netcdf_data(i) = zu( section(i,1) )
-                ENDIF
-             ENDDO
-             nc_stat = NF90_PUT_VAR( id_set_xy(av), id_var_zu_xy(av), &
-                                     netcdf_data, start = (/ 1 /),    &
-                                     count = (/ ns /) )
-             CALL netcdf_handle_error( 'netcdf_define_header', 123 )
-
-!
-!--          Write zw data
-             DO  i = 1, ns
-                IF( section(i,1) == -1 )  THEN
-                   netcdf_data(i) = -1.0_wp  ! section averaged along z
-                ELSE
-                   netcdf_data(i) = zw( section(i,1) )
-                ENDIF
-             ENDDO
-             nc_stat = NF90_PUT_VAR( id_set_xy(av), id_var_zw_xy(av), &
-                                     netcdf_data, start = (/ 1 /),    &
-                                     count = (/ ns /) )
-             CALL netcdf_handle_error( 'netcdf_define_header', 124 )
-
-!
-!--             Write zs data
-             IF ( land_surface )  THEN
-                ns_do = 0
-                DO  i = 1, ns
-                   IF( section(i,1) == -1 )  THEN
-                      netcdf_data(i) = 1.0_wp  ! section averaged along z
-                      ns_do = ns_do + 1
-                   ELSEIF ( section(i,1) < nzs )  THEN
-                      netcdf_data(i) = - zs( section(i,1) )
-                      ns_do = ns_do + 1
-                   ENDIF
-                ENDDO
-
-                nc_stat = NF90_PUT_VAR( id_set_xy(av), id_var_zs_xy(av), &
-                                        netcdf_data(1:ns_do), start = (/ 1 /),    &
-                                        count = (/ ns_do /) )
-                CALL netcdf_handle_error( 'netcdf_define_header', 124 )
-
-             ENDIF
-
-!
-!--          Write gridpoint number data
-             netcdf_data(1:ns) = section(1:ns,1)
-             nc_stat = NF90_PUT_VAR( id_set_xy(av), id_var_ind_z_xy(av), &
-                                     netcdf_data, start = (/ 1 /),       &
-                                     count = (/ ns /) )
-             CALL netcdf_handle_error( 'netcdf_define_header', 125 )
-
-             DEALLOCATE( netcdf_data )
-
-!
-!--          Write the cross section height u*, t*
-             nc_stat = NF90_PUT_VAR( id_set_xy(av), id_var_zu1_xy(av), &
-                                     (/ zu(nzb+1) /), start = (/ 1 /), &
-                                     count = (/ 1 /) )
-             CALL netcdf_handle_error( 'netcdf_define_header', 126 )
-
-!
-!--          Write data for x (shifted by +dx/2) and xu axis
-             ALLOCATE( netcdf_data(0:nx+1) )
-
-             DO  i = 0, nx+1
-                netcdf_data(i) = ( i + 0.5_wp ) * dx
-             ENDDO
-
-             nc_stat = NF90_PUT_VAR( id_set_xy(av), id_var_x_xy(av), &
-                                     netcdf_data, start = (/ 1 /),   &
-                                     count = (/ nx+2 /) )
-             CALL netcdf_handle_error( 'netcdf_define_header', 127 )
-
-             DO  i = 0, nx+1
-                netcdf_data(i) = i * dx
-             ENDDO
-
-             nc_stat = NF90_PUT_VAR( id_set_xy(av), id_var_xu_xy(av), &
-                                     netcdf_data, start = (/ 1 /),    &
-                                     count = (/ nx+2 /) )
-             CALL netcdf_handle_error( 'netcdf_define_header', 367 )
-
-             DEALLOCATE( netcdf_data )
-
-!
-!--          Write data for y (shifted by +dy/2) and yv axis
-             ALLOCATE( netcdf_data(0:ny+1) )
-
-             DO  i = 0, ny+1
-                netcdf_data(i) = ( i + 0.5_wp ) * dy
-             ENDDO
-
-             nc_stat = NF90_PUT_VAR( id_set_xy(av), id_var_y_xy(av), &
-                                     netcdf_data, start = (/ 1 /),   &
-                                     count = (/ ny+2 /))
-             CALL netcdf_handle_error( 'netcdf_define_header', 128 )
-
-             DO  i = 0, ny+1
-                netcdf_data(i) = i * dy
-             ENDDO
-
-             nc_stat = NF90_PUT_VAR( id_set_xy(av), id_var_yv_xy(av), &
-                                     netcdf_data, start = (/ 1 /),    &
-                                     count = (/ ny+2 /))
-             CALL netcdf_handle_error( 'netcdf_define_header', 368 )
-
-             DEALLOCATE( netcdf_data )
-
-!
-!--          In case of non-flat topography write height information
-             IF ( TRIM( topography ) /= 'flat' )  THEN
-
-                nc_stat = NF90_PUT_VAR( id_set_xy(av), id_var_zusi_xy(av), &
-                                        zu_s_inner(0:nx+1,0:ny+1), &
-                                        start = (/ 1, 1 /), &
-                                        count = (/ nx+2, ny+2 /) )
-                CALL netcdf_handle_error( 'netcdf_define_header', 427 )
-
-                nc_stat = NF90_PUT_VAR( id_set_xy(av), id_var_zwwi_xy(av), &
-                                        zw_w_inner(0:nx+1,0:ny+1), &
-                                        start = (/ 1, 1 /), &
-                                        count = (/ nx+2, ny+2 /) )
-                CALL netcdf_handle_error( 'netcdf_define_header', 428 )
-
-             ENDIF
-
-
-
-          ENDIF
-
-       CASE ( 'xy_ext' )
-
-!
-!--       Get the list of variables and compare with the actual run.
-!--       First var_list_old has to be reset, since GET_ATT does not assign
-!--       trailing blanks.
-          var_list_old = ' '
-          nc_stat = NF90_GET_ATT( id_set_xy(av), NF90_GLOBAL, 'VAR_LIST', &
-                                  var_list_old )
-          CALL netcdf_handle_error( 'netcdf_define_header', 129 )
-
-          var_list = ';'
-          i = 1
-          DO WHILE ( do2d(av,i)(1:1) /= ' ' )
-             IF ( INDEX( do2d(av,i), 'xy' ) /= 0 )  THEN
-                var_list = TRIM( var_list ) // TRIM( do2d(av,i) ) // ';'
-             ENDIF
-             i = i + 1
-          ENDDO
-
-          IF ( av == 0 )  THEN
-             var = '(xy)'
-          ELSE
-             var = '(xy_av)'
-          ENDIF
-
-          IF ( TRIM( var_list ) /= TRIM( var_list_old ) )  THEN
-             message_string = 'netCDF file for cross-sections ' //           &
-                              TRIM( var ) // ' from previous run found,' //  &
-                              '& but this file cannot be extended due to' // &
-                              ' variable mismatch.' //                       &
-                              '&New file is created instead.'
-             CALL message( 'define_netcdf_header', 'PA0249', 0, 1, 0, 6, 0 )
-             extend = .FALSE.
-             RETURN
-          ENDIF
-
-!
-!--       Calculate the number of current sections
-          ns = 1
-          DO WHILE ( section(ns,1) /= -9999  .AND.  ns <= 100 )
-             ns = ns + 1
-          ENDDO
-          ns = ns - 1
-
-!
-!--       Get and compare the number of horizontal cross sections
-          nc_stat = NF90_INQ_VARID( id_set_xy(av), 'zu_xy', id_var_zu_xy(av) )
-          CALL netcdf_handle_error( 'netcdf_define_header', 130 )
-
-          nc_stat = NF90_INQUIRE_VARIABLE( id_set_xy(av), id_var_zu_xy(av), &
-                                           dimids = id_dim_zu_xy_old )
-          CALL netcdf_handle_error( 'netcdf_define_header', 131 )
-          id_dim_zu_xy(av) = id_dim_zu_xy_old(1)
-
-          nc_stat = NF90_INQUIRE_DIMENSION( id_set_xy(av), id_dim_zu_xy(av), &
-                                            len = ns_old )
-          CALL netcdf_handle_error( 'netcdf_define_header', 132 )
-
-          IF ( ns /= ns_old )  THEN
-             message_string = 'netCDF file for cross-sections ' //          &
-                              TRIM( var ) // ' from previous run found,' // &
-                              '&but this file cannot be extended due to' // &
-                              ' mismatch in number of' //                   &
-                              '&cross sections.' //                         &
-                              '&New file is created instead.'
-             CALL message( 'define_netcdf_header', 'PA0250', 0, 1, 0, 6, 0 )
-             extend = .FALSE.
-             RETURN
-          ENDIF
-
-!
-!--       Get and compare the heights of the cross sections
-          ALLOCATE( netcdf_data(1:ns_old) )
-
-          nc_stat = NF90_GET_VAR( id_set_xy(av), id_var_zu_xy(av), netcdf_data )
-          CALL netcdf_handle_error( 'netcdf_define_header', 133 )
-
-          DO  i = 1, ns
-             IF ( section(i,1) /= -1 )  THEN
-                IF ( zu(section(i,1)) /= netcdf_data(i) )  THEN
-                   message_string = 'netCDF file for cross-sections ' //     &
-                               TRIM( var ) // ' from previous run found,' // &
-                               '&but this file cannot be extended' //        &
-                               ' due to mismatch in cross' //                &
-                               '&section levels.' //                         &
-                               '&New file is created instead.'
-                   CALL message( 'define_netcdf_header', 'PA0251', &
-                                                                 0, 1, 0, 6, 0 )
-                   extend = .FALSE.
-                   RETURN
-                ENDIF
-             ELSE
-                IF ( -1.0_wp /= netcdf_data(i) )  THEN
-                   message_string = 'netCDF file for cross-sections ' //     &
-                               TRIM( var ) // ' from previous run found,' // &
-                               '&but this file cannot be extended' //        &
-                               ' due to mismatch in cross' //                &
-                               '&section levels.' //                         &
-                               '&New file is created instead.'
-                   CALL message( 'define_netcdf_header', 'PA0251',&
-                                                                 0, 1, 0, 6, 0 )
-                   extend = .FALSE.
-                   RETURN
-                ENDIF
-             ENDIF
-          ENDDO
-
-          DEALLOCATE( netcdf_data )
-
-!
-!--       Get the id of the time coordinate (unlimited coordinate) and its
-!--       last index on the file. The next time level is do2d..count+1.
-!--       The current time must be larger than the last output time
-!--       on the file.
-          nc_stat = NF90_INQ_VARID( id_set_xy(av), 'time', id_var_time_xy(av) )
-          CALL netcdf_handle_error( 'netcdf_define_header', 134 )
-
-          nc_stat = NF90_INQUIRE_VARIABLE( id_set_xy(av), id_var_time_xy(av), &
-                                           dimids = id_dim_time_old )
-          CALL netcdf_handle_error( 'netcdf_define_header', 135 )
-          id_dim_time_xy(av) = id_dim_time_old(1)
-
-          nc_stat = NF90_INQUIRE_DIMENSION( id_set_xy(av), id_dim_time_xy(av), &
-                                            len = ntime_count )
-          CALL netcdf_handle_error( 'netcdf_define_header', 136 )
-
-!
-!--       For non-parallel output use the last output time level of the netcdf
-!--       file because the time dimension is unlimited. In case of parallel
-!--       output the variable ntime_count could get the value of 9*10E36 because
-!--       the time dimension is limited.
-          IF ( netcdf_data_format < 5 ) do2d_xy_time_count(av) = ntime_count
-
-          nc_stat = NF90_GET_VAR( id_set_xy(av), id_var_time_xy(av),    &
-                                  last_time_coordinate,                 &
-                                  start = (/ do2d_xy_time_count(av) /), &
-                                  count = (/ 1 /) )
-          CALL netcdf_handle_error( 'netcdf_define_header', 137 )
-
-          IF ( last_time_coordinate(1) >= simulated_time )  THEN
-             message_string = 'netCDF file for cross sections ' //          &
-                              TRIM( var ) // ' from previous run found,' // &
-                              '&but this file cannot be extended becaus' // &
-                              'e the current output time' //                &
-                              '&is less or equal than the last output t' // &
-                              'ime on this file.' //                        &
-                              '&New file is created instead.'
-             CALL message( 'define_netcdf_header', 'PA0252', 0, 1, 0, 6, 0 )
-             do2d_xy_time_count(av) = 0
-             extend = .FALSE.
-             RETURN
-          ENDIF
-
-          IF ( netcdf_data_format > 4 )  THEN
-!
-!--          Set needed time levels (ntdim) to 
-!--          saved time levels + to be saved time levels.
-             IF ( av == 0 )  THEN 
-                ntdim_2d_xy(0) = do2d_xy_time_count(0) + CEILING(             &
-                                 ( end_time - MAX( skip_time_do2d_xy,         &
-                                                   simulated_time_at_begin )  &
-                                 ) / dt_do2d_xy )
-             ELSE
-                ntdim_2d_xy(1) = do2d_xy_time_count(1) + CEILING(             &
-                                 ( end_time - MAX( skip_time_data_output_av,  &
-                                                   simulated_time_at_begin )  &
-                                 ) / dt_data_output_av )
-             ENDIF
-
-!
-!--          Check if the needed number of output time levels is increased
-!--          compared to the number of time levels in the existing file.
-             IF ( ntdim_2d_xy(av) > ntime_count )  THEN
-                message_string = 'netCDF file for cross sections ' //          &
-                                 TRIM( var ) // ' from previous run found,' // &
-                                 '&but this file cannot be extended becaus' // &
-                                 'e the number of output time levels&has b' // &
-                                 'een increased compared to the previous s' // &
-                                 'imulation.' //                               &
-                                 '&New file is created instead.'
-                CALL message( 'define_netcdf_header', 'PA0389', 0, 1, 0, 6, 0 )
-                do2d_xy_time_count(av) = 0
-                extend = .FALSE.
-!
-!--             Recalculate the needed time levels for the new file.
-                IF ( av == 0 )  THEN
-                   ntdim_2d_xy(0) = CEILING(                            &
-                           ( end_time - MAX( skip_time_do2d_xy,         &
-                                             simulated_time_at_begin )  &
-                           ) / dt_do2d_xy )
-                ELSE
-                   ntdim_2d_xy(1) = CEILING(                            &
-                           ( end_time - MAX( skip_time_data_output_av,  &
-                                             simulated_time_at_begin )  &
-                           ) / dt_data_output_av )
-                ENDIF
-                RETURN
-             ENDIF
-          ENDIF
-
-!
-!--       Dataset seems to be extendable.
-!--       Now get the variable ids.
-          i = 1
-          DO WHILE ( do2d(av,i)(1:1) /= ' ' )
-             IF ( INDEX( do2d(av,i), 'xy' ) /= 0 )  THEN
-                nc_stat = NF90_INQ_VARID( id_set_xy(av), do2d(av,i), &
-                                          id_var_do2d(av,i) )
-                CALL netcdf_handle_error( 'netcdf_define_header', 138 )
-#if defined( __netcdf4_parallel )
-!
-!--             Set collective io operations for parallel io
-                IF ( netcdf_data_format > 4 )  THEN
-                   nc_stat = NF90_VAR_PAR_ACCESS( id_set_xy(av),     &
-                                                  id_var_do2d(av,i), &
-                                                  NF90_COLLECTIVE )
-                   CALL netcdf_handle_error( 'netcdf_define_header', 454 )
-                ENDIF
-#endif
-             ENDIF
-             i = i + 1
-          ENDDO
-
-!
-!--       Update the title attribute on file
-!--       In order to avoid 'data mode' errors if updated attributes are larger 
-!--       than their original size, NF90_PUT_ATT is called in 'define mode' 
-!--       enclosed by NF90_REDEF and NF90_ENDDEF calls. This implies a possible 
-!--       performance loss due to data copying; an alternative strategy would be 
-!--       to ensure equal attribute size in a job chain. Maybe revise later.
-          IF ( av == 0 )  THEN
-             time_average_text = ' '
-          ELSE
-             WRITE (time_average_text, '('', '',F7.1,'' s average'')') &
-                                                            averaging_interval
-          ENDIF
-          nc_stat = NF90_REDEF( id_set_xy(av) )
-          CALL netcdf_handle_error( 'netcdf_define_header', 431 )
-          nc_stat = NF90_PUT_ATT( id_set_xy(av), NF90_GLOBAL, 'title', &
-                                  TRIM( run_description_header ) //    &
-                                  TRIM( time_average_text ) )
-          CALL netcdf_handle_error( 'netcdf_define_header', 139 )
-          nc_stat = NF90_ENDDEF( id_set_xy(av) )
-          CALL netcdf_handle_error( 'netcdf_define_header', 432 )
-          message_string = 'netCDF file for cross-sections ' //           &
-                            TRIM( var ) // ' from previous run found.' // &
-                           '&This file will be extended.'
-          CALL message( 'define_netcdf_header', 'PA0253', 0, 0, 0, 6, 0 )
-          
-
-       CASE ( 'xz_new' )
-
-!
-!--       Define some global attributes of the dataset
-          nc_stat = NF90_PUT_ATT( id_set_xz(av), NF90_GLOBAL, 'Conventions', &
-                                  'COARDS' )
-          CALL netcdf_handle_error( 'netcdf_define_header', 140 )
-
-          IF ( av == 0 )  THEN
-             time_average_text = ' '
-          ELSE
-             WRITE (time_average_text, '('', '',F7.1,'' s average'')') &
-                                                            averaging_interval
-          ENDIF
-          nc_stat = NF90_PUT_ATT( id_set_xz(av), NF90_GLOBAL, 'title', &
-                                  TRIM( run_description_header )  //   &
-                                  TRIM( time_average_text ) )
-          CALL netcdf_handle_error( 'netcdf_define_header', 141 )
-          IF ( av == 1 )  THEN
-             WRITE ( time_average_text,'(F7.1,'' s avg'')' )  averaging_interval
-             nc_stat = NF90_PUT_ATT( id_set_xz(av), NF90_GLOBAL, 'time_avg', &
-                                     TRIM( time_average_text ) )
-             CALL netcdf_handle_error( 'netcdf_define_header', 141 )
-          ENDIF
-
-!
-!--       Define time coordinate for xz sections.
-!--       For parallel output the time dimensions has to be limited, otherwise
-!--       the performance drops significantly.
-          IF ( netcdf_data_format < 5 )  THEN
-             CALL netcdf_create_dim( id_set_xz(av), 'time', NF90_UNLIMITED,    &
-                                     id_dim_time_xz(av), 142 )
-          ELSE
-             CALL netcdf_create_dim( id_set_xz(av), 'time', ntdim_2d_xz(av),   &
-                                     id_dim_time_xz(av), 525 )
-          ENDIF
-
-          CALL netcdf_create_var( id_set_xz(av), (/ id_dim_time_xz(av) /),     &
-                                  'time', NF90_DOUBLE, id_var_time_xz(av),     &
-                                  'seconds', '', 143, 144, 000 )
-!
-!--       Define the spatial dimensions and coordinates for xz-sections.
-!--       First, determine the number of vertical sections to be written.
-          IF ( section(1,2) == -9999 )  THEN
-             RETURN
-          ELSE
-             ns = 1
-             DO WHILE ( section(ns,2) /= -9999  .AND.  ns <= 100 )
-                ns = ns + 1
-             ENDDO
-             ns = ns - 1
-          ENDIF
-
-!
-!--       Define y-axis (for scalar position)
-          CALL netcdf_create_dim( id_set_xz(av), 'y_xz', ns, id_dim_y_xz(av),  &
-                                  145 )
-          CALL netcdf_create_var( id_set_xz(av), (/ id_dim_y_xz(av) /),        &
-                                  'y_xz', NF90_DOUBLE, id_var_y_xz(av),        &
-                                  'meters', '', 146, 147, 000 )
-!
-!--       Define y-axis (for v position)
-          CALL netcdf_create_dim( id_set_xz(av), 'yv_xz', ns,                  &
-                                  id_dim_yv_xz(av), 369 )
-          CALL netcdf_create_var( id_set_xz(av), (/ id_dim_yv_xz(av) /),       &
-                                  'yv_xz', NF90_DOUBLE, id_var_yv_xz(av),      &
-                                  'meters', '', 370, 371, 000 )
-!
-!--       Define a variable to store the layer indices of the vertical cross
-!--       sections
-          CALL netcdf_create_var( id_set_xz(av), (/ id_dim_y_xz(av) /),        &
-                                  'ind_y_xz', NF90_DOUBLE,                     &
-                                  id_var_ind_y_xz(av), 'gridpoints', '', 148,  &
-                                  149, 000 )
-!
-!--       Define x-axis (for scalar position)
-          CALL netcdf_create_dim( id_set_xz(av), 'x', nx+2, id_dim_x_xz(av),   &
-                                  150 )
-          CALL netcdf_create_var( id_set_xz(av), (/ id_dim_x_xz(av) /), 'x',   &
-                                  NF90_DOUBLE, id_var_x_xz(av), 'meters', '',  &
-                                  151, 152, 000 )
-!
-!--       Define x-axis (for u position)
-          CALL netcdf_create_dim( id_set_xz(av), 'xu', nx+2, id_dim_xu_xz(av), &
-                                  372 )
-          CALL netcdf_create_var( id_set_xz(av), (/ id_dim_xu_xz(av) /), 'xu', &
-                                  NF90_DOUBLE, id_var_xu_xz(av), 'meters', '', &
-                                  373, 374, 000 )
-!
-!--       Define the three z-axes (zu, zw, and zs)
-          CALL netcdf_create_dim( id_set_xz(av), 'zu', nz+2, id_dim_zu_xz(av), &
-                                  153 )
-          CALL netcdf_create_var( id_set_xz(av), (/ id_dim_zu_xz(av) /), 'zu', &
-                                  NF90_DOUBLE, id_var_zu_xz(av), 'meters', '', &
-                                  154, 155, 000 )
-          CALL netcdf_create_dim( id_set_xz(av), 'zw', nz+2, id_dim_zw_xz(av), &
-                                  156 )
-          CALL netcdf_create_var( id_set_xz(av), (/ id_dim_zw_xz(av) /), 'zw', &
-                                  NF90_DOUBLE, id_var_zw_xz(av), 'meters', '', &
-                                  157, 158, 000 )
-
-          IF ( land_surface )  THEN
-
-             CALL netcdf_create_dim( id_set_xz(av), 'zs', nzs,                 &
-                                     id_dim_zs_xz(av), 542 )
-             CALL netcdf_create_var( id_set_xz(av), (/ id_dim_zs_xz(av) /),    &
-                                     'zs', NF90_DOUBLE, id_var_zs_xz(av),      &
-                                     'meters', '', 543, 544, 000 )
-
-          ENDIF
-
-!
-!--       Define the variables
-          var_list = ';'
-          i = 1
-
-          DO WHILE ( do2d(av,i)(1:1) /= ' ' )
-
-             IF ( INDEX( do2d(av,i), 'xz' ) /= 0 )  THEN
-
-!
-!--             Check for the grid
-                found = .TRUE.
-                SELECT CASE ( do2d(av,i) )
-!
-!--                Most variables are defined on the zu grid
-                   CASE ( 'e_xz', 'lpt_xz', 'nr_xz', 'p_xz', 'pc_xz', 'pr_xz', &
-                          'prr_xz', 'pt_xz', 'q_xz', 'qc_xz', 'ql_xz',         &
-                          'ql_c_xz', 'ql_v_xz', 'ql_vp_xz', 'qr_xz', 'qv_xz',  &
-                          'rad_lw_cs_hr_xz', 'rad_lw_hr_xz',                   &
-                          'rad_sw_cs_hr_xz', 'rad_sw_hr_xz''rho_xz', 's_xz',   &
-                          'sa_xz', 'vpt_xz' )
-
-                      grid_x = 'x'
-                      grid_y = 'y'
-                      grid_z = 'zu'
-!
-!--                u grid
-                   CASE ( 'u_xz' )
-
-                      grid_x = 'xu'
-                      grid_y = 'y'
-                      grid_z = 'zu'
-!
-!--                v grid
-                   CASE ( 'v_xz' )
-
-                      grid_x = 'x'
-                      grid_y = 'yv'
-                      grid_z = 'zu'
-!
-!--                w grid
-                   CASE ( 'rad_lw_in_xz', 'rad_lw_out_xz', 'rad_sw_in_xz',     &
-                          'rad_sw_out_xz', 'w_xz' )
-
-                      grid_x = 'x'
-                      grid_y = 'y'
-                      grid_z = 'zw'
-
-!
-!--                soil grid
-                   CASE ( 'm_soil_xz', 't_soil_xz' )
-
-                      grid_x = 'x'
-                      grid_y = 'y'
-                      grid_z = 'zs'
-
-                   CASE DEFAULT
-!
-!--                   Check for user-defined quantities
-                      CALL user_define_netcdf_grid( do2d(av,i), found, &
-                                                    grid_x, grid_y, grid_z )
-                      IF ( .NOT. found )  THEN
-                         WRITE ( message_string, * ) 'no grid defined for', &
-                                                ' variable ', TRIM( do2d(av,i) )
-                         CALL message( 'define_netcdf_header', 'PA0244', &
-                                       0, 1, 0, 6, 0 )
-                      ENDIF
-
-                END SELECT
-
-!
-!--             Select the respective dimension ids
-                IF ( grid_x == 'x' )  THEN
-                   id_x = id_dim_x_xz(av)
-                ELSEIF ( grid_x == 'xu' )  THEN
-                   id_x = id_dim_xu_xz(av)
-                ENDIF
-
-                IF ( grid_y == 'y' )  THEN
-                   id_y = id_dim_y_xz(av)
-                ELSEIF ( grid_y == 'yv' )  THEN
-                   id_y = id_dim_yv_xz(av)
-                ENDIF
-
-                IF ( grid_z == 'zu' )  THEN
-                   id_z = id_dim_zu_xz(av)
-                ELSEIF ( grid_z == 'zw' )  THEN
-                   id_z = id_dim_zw_xz(av)
-                ELSEIF ( grid_z == 'zs' )  THEN
-                   id_z = id_dim_zs_xz(av)
-                ENDIF
-
-!
-!--             Define the grid
-                CALL netcdf_create_var( id_set_xz(av), (/ id_x, id_y, id_z,    &
-                                        id_dim_time_xz(av) /), do2d(av,i),     &
-                                        nc_precision(2), id_var_do2d(av,i),    &
-                                        TRIM( do2d_unit(av,i) ), do2d(av,i),   &
-                                        159, 160, 355 )
-
-#if defined( __netcdf4_parallel )
-
-                IF ( netcdf_data_format > 4 )  THEN
-!
-!--                Set no fill for every variable to increase performance.
-                   nc_stat = NF90_DEF_VAR_FILL( id_set_xz(av),     &
-                                                id_var_do2d(av,i), &
-                                                1, 0 )
-                   CALL netcdf_handle_error( 'netcdf_define_header', 534 )
-!
-!--                Set independent io operations for parallel io. Collective io
-!--                is only allowed in case of a 1d-decomposition along x,
-!--                because otherwise, not all PEs have output data.
-                   IF ( npey == 1 )  THEN
-                      nc_stat = NF90_VAR_PAR_ACCESS( id_set_xz(av),     &
-                                                     id_var_do2d(av,i), &
-                                                     NF90_COLLECTIVE )
-                   ELSE
-!
-!--                   Test simulations showed that the output of cross sections
-!--                   by all PEs in data_output_2d using NF90_COLLECTIVE is 
-!--                   faster than the output by the first row of PEs in
-!--                   x-direction using NF90_INDEPENDENT.
-                      nc_stat = NF90_VAR_PAR_ACCESS( id_set_xz(av),    & 
-                                                    id_var_do2d(av,i), &
-                                                    NF90_COLLECTIVE )
-!                      nc_stat = NF90_VAR_PAR_ACCESS( id_set_xz(av),     &
-!                                                     id_var_do2d(av,i), &
-!                                                     NF90_INDEPENDENT )
-                   ENDIF
-                   CALL netcdf_handle_error( 'netcdf_define_header', 449 )
-                ENDIF
-#endif
-                var_list = TRIM( var_list ) // TRIM( do2d(av,i) ) // ';'
-
-             ENDIF
-
-             i = i + 1
-
-          ENDDO
-
-!
-!--       No arrays to output. Close the netcdf file and return.
-          IF ( i == 1 )  RETURN
-
-!
-!--       Write the list of variables as global attribute (this is used by
-!--       restart runs and by combine_plot_fields)
-          nc_stat = NF90_PUT_ATT( id_set_xz(av), NF90_GLOBAL, 'VAR_LIST', &
-                                  var_list )
-          CALL netcdf_handle_error( 'netcdf_define_header', 161 )
-
-!
-!--       Set general no fill, otherwise the performance drops significantly for
-!--       parallel output.
-          nc_stat = NF90_SET_FILL( id_set_xz(av), NF90_NOFILL, oldmode )
-          CALL netcdf_handle_error( 'netcdf_define_header', 530 )
-
-!
-!--       Leave netCDF define mode
-          nc_stat = NF90_ENDDEF( id_set_xz(av) )
-          CALL netcdf_handle_error( 'netcdf_define_header', 162 )
-
-!
-!--       These data are only written by PE0 for parallel output to increase
-!--       the performance.
-          IF ( myid == 0  .OR.  netcdf_data_format < 5 )  THEN
-
-!
-!--          Write axis data: y_xz, x, zu, zw
-             ALLOCATE( netcdf_data(1:ns) )
-
-!
-!--          Write y_xz data (shifted by +dy/2)
-             DO  i = 1, ns
-                IF( section(i,2) == -1 )  THEN
-                   netcdf_data(i) = -1.0_wp  ! section averaged along y
-                ELSE
-                   netcdf_data(i) = ( section(i,2) + 0.5_wp ) * dy
-                ENDIF
-             ENDDO
-             nc_stat = NF90_PUT_VAR( id_set_xz(av), id_var_y_xz(av), &
-                                     netcdf_data, start = (/ 1 /),   &
-                                     count = (/ ns /) )
-             CALL netcdf_handle_error( 'netcdf_define_header', 163 )
-
-!
-!--          Write yv_xz data
-             DO  i = 1, ns
-                IF( section(i,2) == -1 )  THEN
-                   netcdf_data(i) = -1.0_wp  ! section averaged along y
-                ELSE
-                   netcdf_data(i) = section(i,2) * dy
-                ENDIF
-             ENDDO
-             nc_stat = NF90_PUT_VAR( id_set_xz(av), id_var_yv_xz(av), &
-                                     netcdf_data, start = (/ 1 /),    &
-                                     count = (/ ns /) )
-             CALL netcdf_handle_error( 'netcdf_define_header', 375 )
-
-!
-!--          Write gridpoint number data
-             netcdf_data(1:ns) = section(1:ns,2)
-             nc_stat = NF90_PUT_VAR( id_set_xz(av), id_var_ind_y_xz(av), &
-                                     netcdf_data, start = (/ 1 /),       &
-                                     count = (/ ns /) )
-             CALL netcdf_handle_error( 'netcdf_define_header', 164 )
-
-
-             DEALLOCATE( netcdf_data )
-
-!
-!--          Write data for x (shifted by +dx/2) and xu axis
-             ALLOCATE( netcdf_data(0:nx+1) )
-
-             DO  i = 0, nx+1
-                netcdf_data(i) = ( i + 0.5_wp ) * dx
-             ENDDO
-
-             nc_stat = NF90_PUT_VAR( id_set_xz(av), id_var_x_xz(av), &
-                                     netcdf_data, start = (/ 1 /),   &
-                                     count = (/ nx+2 /) )
-             CALL netcdf_handle_error( 'netcdf_define_header', 165 )
-
-             DO  i = 0, nx+1
-                netcdf_data(i) = i * dx
-             ENDDO
-
-             nc_stat = NF90_PUT_VAR( id_set_xz(av), id_var_xu_xz(av), &
-                                     netcdf_data, start = (/ 1 /),    &
-                                     count = (/ nx+2 /) )
-             CALL netcdf_handle_error( 'netcdf_define_header', 377 )
-
-             DEALLOCATE( netcdf_data )
-
-!
-!--          Write zu and zw data (vertical axes)
-             ALLOCATE( netcdf_data(0:nz+1) )
-
-             netcdf_data(0:nz+1) = zu(nzb:nzt+1)
-             nc_stat = NF90_PUT_VAR( id_set_xz(av), id_var_zu_xz(av), &
-                                     netcdf_data, start = (/ 1 /),    &
-                                     count = (/ nz+2 /) )
-             CALL netcdf_handle_error( 'netcdf_define_header', 166 )
-
-             netcdf_data(0:nz+1) = zw(nzb:nzt+1)
-             nc_stat = NF90_PUT_VAR( id_set_xz(av), id_var_zw_xz(av), &
-                                     netcdf_data, start = (/ 1 /),    &
-                                     count = (/ nz+2 /) )
-             CALL netcdf_handle_error( 'netcdf_define_header', 167 )
-
-!
-!--          Write zs data
-             IF ( land_surface )  THEN
-                netcdf_data(0:nzs-1) = - zs(nzb_soil:nzt_soil)
-                nc_stat = NF90_PUT_VAR( id_set_xz(av), id_var_zs_xz(av), &
-                                        netcdf_data(0:nzs), start = (/ 1 /),    &
-                                        count = (/ nzt_soil-nzb_soil+1 /) )
-               CALL netcdf_handle_error( 'netcdf_define_header', 548 )
-             ENDIF
-
-
-             DEALLOCATE( netcdf_data )
-
-          ENDIF
-
-
-       CASE ( 'xz_ext' )
-
-!
-!--       Get the list of variables and compare with the actual run.
-!--       First var_list_old has to be reset, since GET_ATT does not assign
-!--       trailing blanks.
-          var_list_old = ' '
-          nc_stat = NF90_GET_ATT( id_set_xz(av), NF90_GLOBAL, 'VAR_LIST', &
-                                  var_list_old )
-          CALL netcdf_handle_error( 'netcdf_define_header', 168 )
-
-          var_list = ';'
-          i = 1
-          DO WHILE ( do2d(av,i)(1:1) /= ' ' )
-             IF ( INDEX( do2d(av,i), 'xz' ) /= 0 )  THEN
-                var_list = TRIM( var_list ) // TRIM( do2d(av,i) ) // ';'
-             ENDIF
-             i = i + 1
-          ENDDO
-
-          IF ( av == 0 )  THEN
-             var = '(xz)'
-          ELSE
-             var = '(xz_av)'
-          ENDIF
-
-          IF ( TRIM( var_list ) /= TRIM( var_list_old ) )  THEN
-             message_string = 'netCDF file for cross-sections ' //           &
-                              TRIM( var ) // ' from previous run found,' //  &
-                              '& but this file cannot be extended due to' // &
-                              ' variable mismatch.' //                       &
-                              '&New file is created instead.'
-             CALL message( 'define_netcdf_header', 'PA0249', 0, 1, 0, 6, 0 )
-             extend = .FALSE.
-             RETURN
-          ENDIF
-
-!
-!--       Calculate the number of current sections
-          ns = 1
-          DO WHILE ( section(ns,2) /= -9999  .AND.  ns <= 100 )
-             ns = ns + 1
-          ENDDO
-          ns = ns - 1
-
-!
-!--       Get and compare the number of vertical cross sections
-          nc_stat = NF90_INQ_VARID( id_set_xz(av), 'y_xz', id_var_y_xz(av) )
-          CALL netcdf_handle_error( 'netcdf_define_header', 169 )
-
-          nc_stat = NF90_INQUIRE_VARIABLE( id_set_xz(av), id_var_y_xz(av), &
-                                           dimids = id_dim_y_xz_old )
-          CALL netcdf_handle_error( 'netcdf_define_header', 170 )
-          id_dim_y_xz(av) = id_dim_y_xz_old(1)
-
-          nc_stat = NF90_INQUIRE_DIMENSION( id_set_xz(av), id_dim_y_xz(av), &
-                                            len = ns_old )
-          CALL netcdf_handle_error( 'netcdf_define_header', 171 )
-
-          IF ( ns /= ns_old )  THEN
-             message_string = 'netCDF file for cross-sections ' //          &
-                              TRIM( var ) // ' from previous run found,' // &
-                              '&but this file cannot be extended due to' // &
-                              ' mismatch in number of' //                   & 
-                              '&cross sections.' //                         &
-                              '&New file is created instead.'
-             CALL message( 'define_netcdf_header', 'PA0250', 0, 1, 0, 6, 0 )
-             extend = .FALSE.
-             RETURN
-          ENDIF
-
-!
-!--       Get and compare the heights of the cross sections
-          ALLOCATE( netcdf_data(1:ns_old) )
-
-          nc_stat = NF90_GET_VAR( id_set_xz(av), id_var_y_xz(av), netcdf_data )
-          CALL netcdf_handle_error( 'netcdf_define_header', 172 )
-
-          DO  i = 1, ns
-             IF ( section(i,2) /= -1 )  THEN
-                IF ( ( ( section(i,2) + 0.5 ) * dy ) /= netcdf_data(i) )  THEN
-                   message_string = 'netCDF file for cross-sections ' //     &
-                               TRIM( var ) // ' from previous run found,' // &
-                               '&but this file cannot be extended' //        &
-                               ' due to mismatch in cross' //                &
-                               '&section levels.' //                         &
-                                '&New file is created instead.'
-                   CALL message( 'define_netcdf_header', 'PA0251', &
-                                                                 0, 1, 0, 6, 0 )
-                   extend = .FALSE.
-                   RETURN
-                ENDIF
-             ELSE
-                IF ( -1.0_wp /= netcdf_data(i) )  THEN
-                   message_string = 'netCDF file for cross-sections ' //     &
-                               TRIM( var ) // ' from previous run found,' // &
-                               '&but this file cannot be extended' //        &
-                               ' due to mismatch in cross' //                &
-                               '&section levels.' //                         &
-                               '&New file is created instead.'
-                   CALL message( 'define_netcdf_header', 'PA0251', &
-                                                                 0, 1, 0, 6, 0 )
-                   extend = .FALSE.
-                   RETURN
-                ENDIF
-             ENDIF
-          ENDDO
-
-          DEALLOCATE( netcdf_data )
-
-!
-!--       Get the id of the time coordinate (unlimited coordinate) and its
-!--       last index on the file. The next time level is do2d..count+1.
-!--       The current time must be larger than the last output time
-!--       on the file.
-          nc_stat = NF90_INQ_VARID( id_set_xz(av), 'time', id_var_time_xz(av) )
-          CALL netcdf_handle_error( 'netcdf_define_header', 173 )
-
-          nc_stat = NF90_INQUIRE_VARIABLE( id_set_xz(av), id_var_time_xz(av), &
-                                           dimids = id_dim_time_old )
-          CALL netcdf_handle_error( 'netcdf_define_header', 174 )
-          id_dim_time_xz(av) = id_dim_time_old(1)
-
-          nc_stat = NF90_INQUIRE_DIMENSION( id_set_xz(av), id_dim_time_xz(av), &
-                                            len = ntime_count )
-          CALL netcdf_handle_error( 'netcdf_define_header', 175 )
-
-!
-!--       For non-parallel output use the last output time level of the netcdf
-!--       file because the time dimension is unlimited. In case of parallel
-!--       output the variable ntime_count could get the value of 9*10E36 because
-!--       the time dimension is limited.
-          IF ( netcdf_data_format < 5 ) do2d_xz_time_count(av) = ntime_count
-
-          nc_stat = NF90_GET_VAR( id_set_xz(av), id_var_time_xz(av),    &
-                                  last_time_coordinate,                 &
-                                  start = (/ do2d_xz_time_count(av) /), &
-                                  count = (/ 1 /) )
-          CALL netcdf_handle_error( 'netcdf_define_header', 176 )
-
-          IF ( last_time_coordinate(1) >= simulated_time )  THEN
-             message_string = 'netCDF file for cross sections ' //          &
-                              TRIM( var ) // ' from previous run found,' // &
-                              '&but this file cannot be extended becaus' // &
-                              'e the current output time' //                &
-                              '&is less or equal than the last output t' // &
-                              'ime on this file.' //                        &
-                              '&New file is created instead.'
-             CALL message( 'define_netcdf_header', 'PA0252', 0, 1, 0, 6, 0 )
-             do2d_xz_time_count(av) = 0
-             extend = .FALSE.
-             RETURN
-          ENDIF
-
-          IF ( netcdf_data_format > 4 )  THEN
-!
-!--          Set needed time levels (ntdim) to 
-!--          saved time levels + to be saved time levels.
-             IF ( av == 0 )  THEN 
-                ntdim_2d_xz(0) = do2d_xz_time_count(0) + CEILING(             &
-                                 ( end_time - MAX( skip_time_do2d_xz,         &
-                                                   simulated_time_at_begin )  &
-                                 ) / dt_do2d_xz )
-             ELSE
-                ntdim_2d_xz(1) = do2d_xz_time_count(1) + CEILING(             &
-                                 ( end_time - MAX( skip_time_data_output_av,  &
-                                                   simulated_time_at_begin )  &
-                                 ) / dt_data_output_av )
-             ENDIF
-
-!
-!--          Check if the needed number of output time levels is increased
-!--          compared to the number of time levels in the existing file.
-             IF ( ntdim_2d_xz(av) > ntime_count )  THEN
-                message_string = 'netCDF file for cross sections ' // &
-                                 TRIM( var ) // ' from previous run found,' // &
-                                 '&but this file cannot be extended becaus' // &
-                                 'e the number of output time levels&has b' // &
-                                 'een increased compared to the previous s' // &
-                                 'imulation.' //                               &
-                                 '&New file is created instead.'
-                CALL message( 'define_netcdf_header', 'PA0390', 0, 1, 0, 6, 0 )
-                do2d_xz_time_count(av) = 0
-                extend = .FALSE.
-!
-!--             Recalculate the needed time levels for the new file.
-                IF ( av == 0 )  THEN
-                   ntdim_2d_xz(0) = CEILING(                            &
-                           ( end_time - MAX( skip_time_do2d_xz,         &
-                                             simulated_time_at_begin )  &
-                           ) / dt_do2d_xz )
-                ELSE
-                   ntdim_2d_xz(1) = CEILING(                            &
-                           ( end_time - MAX( skip_time_data_output_av,  &
-                                             simulated_time_at_begin )  &
-                           ) / dt_data_output_av )
-                ENDIF
-                RETURN
-             ENDIF
-          ENDIF
-
-!
-!--       Dataset seems to be extendable.
-!--       Now get the variable ids.
-          i = 1
-          DO WHILE ( do2d(av,i)(1:1) /= ' ' )
-             IF ( INDEX( do2d(av,i), 'xz' ) /= 0 )  THEN
-                nc_stat = NF90_INQ_VARID( id_set_xz(av), do2d(av,i), &
-                                          id_var_do2d(av,i) )
-                CALL netcdf_handle_error( 'netcdf_define_header', 177 )
-#if defined( __netcdf4_parallel )
-!
-!--             Set independent io operations for parallel io. Collective io
-!--             is only allowed in case of a 1d-decomposition along x, because
-!--             otherwise, not all PEs have output data.
-                IF ( netcdf_data_format > 4 )  THEN
-                   IF ( npey == 1 )  THEN
-                      nc_stat = NF90_VAR_PAR_ACCESS( id_set_xz(av),     &
-                                                     id_var_do2d(av,i), &
-                                                     NF90_COLLECTIVE )
-                   ELSE
-!
-!--                   Test simulations showed that the output of cross sections
-!--                   by all PEs in data_output_2d using NF90_COLLECTIVE is 
-!--                   faster than the output by the first row of PEs in
-!--                   x-direction using NF90_INDEPENDENT.
-                      nc_stat = NF90_VAR_PAR_ACCESS( id_set_xz(av),     &
-                                                     id_var_do2d(av,i), &
-                                                     NF90_COLLECTIVE )
-!                      nc_stat = NF90_VAR_PAR_ACCESS( id_set_xz(av),     &
-!                                                     id_var_do2d(av,i), &
-!                                                     NF90_INDEPENDENT )
-                   ENDIF
-                   CALL netcdf_handle_error( 'netcdf_define_header', 455 )
-                ENDIF
-#endif
-             ENDIF
-             i = i + 1
-          ENDDO
-
-!
-!--       Update the title attribute on file
-!--       In order to avoid 'data mode' errors if updated attributes are larger 
-!--       than their original size, NF90_PUT_ATT is called in 'define mode' 
-!--       enclosed by NF90_REDEF and NF90_ENDDEF calls. This implies a possible 
-!--       performance loss due to data copying; an alternative strategy would be 
-!--       to ensure equal attribute size in a job chain. Maybe revise later.
-          IF ( av == 0 )  THEN
-             time_average_text = ' '
-          ELSE
-             WRITE (time_average_text, '('', '',F7.1,'' s average'')') &
-                                                            averaging_interval
-          ENDIF
-          nc_stat = NF90_REDEF( id_set_xz(av) )
-          CALL netcdf_handle_error( 'netcdf_define_header', 433 )
-          nc_stat = NF90_PUT_ATT( id_set_xz(av), NF90_GLOBAL, 'title', &
-                                  TRIM( run_description_header ) //    &
-                                  TRIM( time_average_text ) )
-          CALL netcdf_handle_error( 'netcdf_define_header', 178 )
-          nc_stat = NF90_ENDDEF( id_set_xz(av) )
-          CALL netcdf_handle_error( 'netcdf_define_header', 434 )
-          message_string = 'netCDF file for cross-sections ' //           &
-                            TRIM( var ) // ' from previous run found.' // &
-                           '&This file will be extended.'
-          CALL message( 'define_netcdf_header', 'PA0253', 0, 0, 0, 6, 0 )
-
-
-       CASE ( 'yz_new' )
-
-!
-!--       Define some global attributes of the dataset
-          nc_stat = NF90_PUT_ATT( id_set_yz(av), NF90_GLOBAL, 'Conventions', &
-                                  'COARDS' )
-          CALL netcdf_handle_error( 'netcdf_define_header', 179 )
-
-          IF ( av == 0 )  THEN
-             time_average_text = ' '
-          ELSE
-             WRITE (time_average_text, '('', '',F7.1,'' s average'')') &
-                                                            averaging_interval
-          ENDIF
-          nc_stat = NF90_PUT_ATT( id_set_yz(av), NF90_GLOBAL, 'title', &
-                                  TRIM( run_description_header ) //    &
-                                  TRIM( time_average_text ) )
-          CALL netcdf_handle_error( 'netcdf_define_header', 180 )
-          IF ( av == 1 )  THEN
-             WRITE ( time_average_text,'(F7.1,'' s avg'')' )  averaging_interval
-             nc_stat = NF90_PUT_ATT( id_set_yz(av), NF90_GLOBAL, 'time_avg', &
-                                     TRIM( time_average_text ) )
-             CALL netcdf_handle_error( 'netcdf_define_header', 180 )
-          ENDIF
-
-!
-!--       Define time coordinate for yz sections.
-!--       For parallel output the time dimensions has to be limited, otherwise
-!--       the performance drops significantly.
-          IF ( netcdf_data_format < 5 )  THEN
-             CALL netcdf_create_dim( id_set_yz(av), 'time', NF90_UNLIMITED,    &
-                                     id_dim_time_yz(av), 181 )
-          ELSE
-             CALL netcdf_create_dim( id_set_yz(av), 'time', ntdim_2d_yz(av),   &
-                                     id_dim_time_yz(av), 526 )
-          ENDIF
-
-          CALL netcdf_create_var( id_set_yz(av), (/ id_dim_time_yz(av) /),     &
-                                  'time', NF90_DOUBLE, id_var_time_yz(av),     &
-                                  'seconds', '', 182, 183, 000 )
-!
-!--       Define the spatial dimensions and coordinates for yz-sections.
-!--       First, determine the number of vertical sections to be written.
-          IF ( section(1,3) == -9999 )  THEN
-             RETURN
-          ELSE
-             ns = 1
-             DO WHILE ( section(ns,3) /= -9999  .AND.  ns <= 100 )
-                ns = ns + 1
-             ENDDO
-             ns = ns - 1
-          ENDIF
-
-!
-!--       Define x axis (for scalar position)
-          CALL netcdf_create_dim( id_set_yz(av), 'x_yz', ns, id_dim_x_yz(av),  &
-                                  184 )
-          CALL netcdf_create_var( id_set_yz(av), (/ id_dim_x_yz(av) /),        &
-                                  'x_yz', NF90_DOUBLE, id_var_x_yz(av),        &
-                                  'meters', '', 185, 186, 000 )
-!
-!--       Define x axis (for u position)
-          CALL netcdf_create_dim( id_set_yz(av), 'xu_yz', ns,                  &
-                                  id_dim_xu_yz(av), 377 )
-          CALL netcdf_create_var( id_set_yz(av), (/ id_dim_xu_yz(av) /),       &
-                                  'xu_yz', NF90_DOUBLE, id_var_xu_yz(av),      &
-                                  'meters', '', 378, 379, 000 )
-!
-!--       Define a variable to store the layer indices of the vertical cross
-!--       sections
-          CALL netcdf_create_var( id_set_yz(av), (/ id_dim_x_yz(av) /),        &
-                                  'ind_x_yz', NF90_DOUBLE,                     &
-                                  id_var_ind_x_yz(av), 'gridpoints', '', 187,  &
-                                  188, 000 )
-!
-!--       Define y-axis (for scalar position)
-          CALL netcdf_create_dim( id_set_yz(av), 'y', ny+2, id_dim_y_yz(av),   &
-                                  189 )
-          CALL netcdf_create_var( id_set_yz(av), (/ id_dim_y_yz(av) /), 'y',   &
-                                  NF90_DOUBLE, id_var_y_yz(av), 'meters', '',  &
-                                  190, 191, 000 )
-!
-!--       Define y-axis (for v position)
-          CALL netcdf_create_dim( id_set_yz(av), 'yv', ny+2, id_dim_yv_yz(av), &
-                                  380 )
-          CALL netcdf_create_var( id_set_yz(av), (/ id_dim_yv_yz(av) /), 'yv', &
-                                  NF90_DOUBLE, id_var_yv_yz(av), 'meters', '', &
-                                  381, 382, 000 )
-!
-!--       Define the two z-axes (zu and zw)
-          CALL netcdf_create_dim( id_set_yz(av), 'zu', nz+2, id_dim_zu_yz(av), &
-                                  192 )
-          CALL netcdf_create_var( id_set_yz(av), (/ id_dim_zu_yz(av) /), 'zu', &
-                                  NF90_DOUBLE, id_var_zu_yz(av), 'meters', '', &
-                                  193, 194, 000 )
-
-          CALL netcdf_create_dim( id_set_yz(av), 'zw', nz+2, id_dim_zw_yz(av), &
-                                  195 )
-          CALL netcdf_create_var( id_set_yz(av), (/ id_dim_zw_yz(av) /), 'zw', &
-                                  NF90_DOUBLE, id_var_zw_yz(av), 'meters', '', &
-                                  196, 197, 000 )
-
-          IF ( land_surface )  THEN
-
-             CALL netcdf_create_dim( id_set_yz(av), 'zs', nzs,                 &
-                                     id_dim_zs_yz(av), 545 )
-             CALL netcdf_create_var( id_set_yz(av), (/ id_dim_zs_yz(av) /),    &
-                                     'zs', NF90_DOUBLE, id_var_zs_yz(av),      &
-                                     'meters', '', 546, 547, 000 )
-
-          ENDIF
-
-!
-!--       Define the variables
-          var_list = ';'
-          i = 1
-
-          DO WHILE ( do2d(av,i)(1:1) /= ' ' )
-
-             IF ( INDEX( do2d(av,i), 'yz' ) /= 0 )  THEN
-
-!
-!--             Check for the grid
-                found = .TRUE.
-                SELECT CASE ( do2d(av,i) )
-!
-!--                Most variables are defined on the zu grid
-                   CASE ( 'e_yz', 'lpt_yz', 'nr_yz', 'p_yz', 'pc_yz', 'pr_yz', &
-                          'prr_yz', 'pt_yz', 'q_yz', 'qc_yz', 'ql_yz',         &
-                          'ql_c_yz', 'ql_v_yz', 'ql_vp_yz', 'qr_yz', 'qv_yz',  &
-                          'rad_lw_cs_hr_yz', 'rad_lw_hr_yz',                   &
-                          'rad_sw_cs_hr_yz', 'rad_sw_hr_yz''rho_yz', 's_yz',   &
-                          'sa_yz', 'vpt_yz' )
-
-                      grid_x = 'x'
-                      grid_y = 'y'
-                      grid_z = 'zu'
-!
-!--                u grid
-                   CASE ( 'u_yz' )
-
-                      grid_x = 'xu'
-                      grid_y = 'y'
-                      grid_z = 'zu'
-!
-!--                v grid
-                   CASE ( 'v_yz' )
-
-                      grid_x = 'x'
-                      grid_y = 'yv'
-                      grid_z = 'zu'
-!
-!--                w grid
-                   CASE ( 'rad_lw_in_yz', 'rad_lw_out_yz', 'rad_sw_in_yz',     &
-                          'rad_sw_out_yz', 'w_yz' )
-
-                      grid_x = 'x'
-                      grid_y = 'y'
-                      grid_z = 'zw'
-!
-!--                soil grid
-                   CASE ( 'm_soil_yz', 't_soil_yz' )
-
-                      grid_x = 'x'
-                      grid_y = 'y'
-                      grid_z = 'zs'
-
-                   CASE DEFAULT
-!
-!--                   Check for user-defined quantities
-                      CALL user_define_netcdf_grid( do2d(av,i), found, &
-                                                    grid_x, grid_y, grid_z )
-
-                      IF ( .NOT. found )  THEN
-                         WRITE ( message_string, * ) 'no grid defined for',    &
-                                                ' variable ', TRIM( do2d(av,i) )
-                         CALL message( 'define_netcdf_header', 'PA0244',       &
-                                       0, 1, 0, 6, 0 )
-                      ENDIF
-
-                END SELECT
-
-!
-!--             Select the respective dimension ids
-                IF ( grid_x == 'x' )  THEN
-                   id_x = id_dim_x_yz(av)
-                ELSEIF ( grid_x == 'xu' )  THEN
-                   id_x = id_dim_xu_yz(av)
-                ENDIF
-
-                IF ( grid_y == 'y' )  THEN
-                   id_y = id_dim_y_yz(av)
-                ELSEIF ( grid_y == 'yv' )  THEN
-                   id_y = id_dim_yv_yz(av)
-                ENDIF
-
-                IF ( grid_z == 'zu' )  THEN
-                   id_z = id_dim_zu_yz(av)
-                ELSEIF ( grid_z == 'zw' )  THEN
-                   id_z = id_dim_zw_yz(av)
-                ELSEIF ( grid_z == 'zs' )  THEN
-                   id_z = id_dim_zs_yz(av)
-                ENDIF
-
-!
-!--             Define the grid
-                CALL netcdf_create_var( id_set_yz(av),  (/ id_x, id_y, id_z,   &
-                                        id_dim_time_yz(av) /), do2d(av,i),     &
-                                        nc_precision(3), id_var_do2d(av,i),    &
-                                        TRIM( do2d_unit(av,i) ), do2d(av,i),   &
-                                        198, 199, 356 )
-
-#if defined( __netcdf4_parallel )
-                IF ( netcdf_data_format > 4 )  THEN
-!
-!--                Set no fill for every variable to increase performance.
-                   nc_stat = NF90_DEF_VAR_FILL( id_set_yz(av),     &
-                                                id_var_do2d(av,i), &
-                                                1, 0 )
-                   CALL netcdf_handle_error( 'netcdf_define_header', 535 )
-!
-!--                Set independent io operations for parallel io. Collective io
-!--                is only allowed in case of a 1d-decomposition along y,
-!--                because otherwise, not all PEs have output data.
-                   IF ( npex == 1 )  THEN
-                      nc_stat = NF90_VAR_PAR_ACCESS( id_set_yz(av),     &
-                                                     id_var_do2d(av,i), &
-                                                     NF90_COLLECTIVE )
-                   ELSE
-!
-!--                   Test simulations showed that the output of cross sections
-!--                   by all PEs in data_output_2d using NF90_COLLECTIVE is 
-!--                   faster than the output by the first row of PEs in
-!--                   y-direction using NF90_INDEPENDENT.
-                      nc_stat = NF90_VAR_PAR_ACCESS( id_set_yz(av),     &
-                                                     id_var_do2d(av,i), &
-                                                     NF90_COLLECTIVE )
-!                      nc_stat = NF90_VAR_PAR_ACCESS( id_set_yz(av),     &
-!                                                     id_var_do2d(av,i), &
-!                                                     NF90_INDEPENDENT )
-                   ENDIF
-                   CALL netcdf_handle_error( 'netcdf_define_header', 450 )
-                ENDIF
-#endif
-                var_list = TRIM( var_list ) // TRIM( do2d(av,i) ) // ';'
-
-             ENDIF
-
-             i = i + 1
-
-          ENDDO
-
-!
-!--       No arrays to output. Close the netcdf file and return.
-          IF ( i == 1 )  RETURN
-
-!
-!--       Write the list of variables as global attribute (this is used by
-!--       restart runs and by combine_plot_fields)
-          nc_stat = NF90_PUT_ATT( id_set_yz(av), NF90_GLOBAL, 'VAR_LIST', &
-                                  var_list )
-          CALL netcdf_handle_error( 'netcdf_define_header', 200 )
-
-!
-!--       Set general no fill, otherwise the performance drops significantly for
-!--       parallel output.
-          nc_stat = NF90_SET_FILL( id_set_yz(av), NF90_NOFILL, oldmode )
-          CALL netcdf_handle_error( 'netcdf_define_header', 531 )
-
-!
-!--       Leave netCDF define mode
-          nc_stat = NF90_ENDDEF( id_set_yz(av) )
-          CALL netcdf_handle_error( 'netcdf_define_header', 201 )
-
-!
-!--       These data are only written by PE0 for parallel output to increase
-!--       the performance.
-          IF ( myid == 0  .OR.  netcdf_data_format < 5 )  THEN
-
-!
-!--          Write axis data: x_yz, y, zu, zw
-             ALLOCATE( netcdf_data(1:ns) )
-
-!
-!--          Write x_yz data (shifted by +dx/2)
-             DO  i = 1, ns
-                IF( section(i,3) == -1 )  THEN
-                   netcdf_data(i) = -1.0_wp  ! section averaged along x
-                ELSE
-                   netcdf_data(i) = ( section(i,3) + 0.5_wp ) * dx
-                ENDIF
-             ENDDO
-             nc_stat = NF90_PUT_VAR( id_set_yz(av), id_var_x_yz(av), &
-                                     netcdf_data, start = (/ 1 /),   &
-                                     count = (/ ns /) )
-             CALL netcdf_handle_error( 'netcdf_define_header', 202 )
-
-!
-!--          Write x_yz data (xu grid)
-             DO  i = 1, ns
-                IF( section(i,3) == -1 )  THEN
-                   netcdf_data(i) = -1.0_wp  ! section averaged along x
-                ELSE
-                   netcdf_data(i) = section(i,3) * dx
-                ENDIF
-             ENDDO
-             nc_stat = NF90_PUT_VAR( id_set_yz(av), id_var_xu_yz(av), &
-                                     netcdf_data, start = (/ 1 /),    &
-                                     count = (/ ns /) )
-             CALL netcdf_handle_error( 'netcdf_define_header', 383 )
-
-!
-!--          Write gridpoint number data
-             netcdf_data(1:ns) = section(1:ns,3)
-             nc_stat = NF90_PUT_VAR( id_set_yz(av), id_var_ind_x_yz(av), &
-                                     netcdf_data, start = (/ 1 /),       &
-                                     count = (/ ns /) )
-             CALL netcdf_handle_error( 'netcdf_define_header', 203 )
-
-             DEALLOCATE( netcdf_data )
-
-!
-!--          Write data for y (shifted by +dy/2) and yv axis
-             ALLOCATE( netcdf_data(0:ny+1) )
-
-             DO  j = 0, ny+1
-                netcdf_data(j) = ( j + 0.5_wp ) * dy
-             ENDDO
-
-             nc_stat = NF90_PUT_VAR( id_set_yz(av), id_var_y_yz(av), &
-                                     netcdf_data, start = (/ 1 /),   &
-                                     count = (/ ny+2 /) )
-             CALL netcdf_handle_error( 'netcdf_define_header', 204 )
-
-             DO  j = 0, ny+1
-                netcdf_data(j) = j * dy
-             ENDDO
-
-             nc_stat = NF90_PUT_VAR( id_set_yz(av), id_var_yv_yz(av), &
-                                     netcdf_data, start = (/ 1 /),    &
-                                     count = (/ ny+2 /) )
-             CALL netcdf_handle_error( 'netcdf_define_header', 384 )
-
-             DEALLOCATE( netcdf_data )
-
-!
-!--          Write zu and zw data (vertical axes)
-             ALLOCATE( netcdf_data(0:nz+1) )
-
-             netcdf_data(0:nz+1) = zu(nzb:nzt+1)
-             nc_stat = NF90_PUT_VAR( id_set_yz(av), id_var_zu_yz(av), &
-                                     netcdf_data, start = (/ 1 /),    &
-                                     count = (/ nz+2 /) )
-             CALL netcdf_handle_error( 'netcdf_define_header', 205 )
-
-             netcdf_data(0:nz+1) = zw(nzb:nzt+1)
-             nc_stat = NF90_PUT_VAR( id_set_yz(av), id_var_zw_yz(av), &
-                                     netcdf_data, start = (/ 1 /),    &
-                                     count = (/ nz+2 /) )
-             CALL netcdf_handle_error( 'netcdf_define_header', 206 )
-
-             DEALLOCATE( netcdf_data )
-
-          ENDIF
-
-
-       CASE ( 'yz_ext' )
-
-!
-!--       Get the list of variables and compare with the actual run.
-!--       First var_list_old has to be reset, since GET_ATT does not assign
-!--       trailing blanks.
-          var_list_old = ' '
-          nc_stat = NF90_GET_ATT( id_set_yz(av), NF90_GLOBAL, 'VAR_LIST', &
-                                  var_list_old )
-          CALL netcdf_handle_error( 'netcdf_define_header', 207 )
-
-          var_list = ';'
-          i = 1
-          DO WHILE ( do2d(av,i)(1:1) /= ' ' )
-             IF ( INDEX( do2d(av,i), 'yz' ) /= 0 )  THEN
-                var_list = TRIM( var_list ) // TRIM( do2d(av,i) ) // ';'
-             ENDIF
-             i = i + 1
-          ENDDO
-
-          IF ( av == 0 )  THEN
-             var = '(yz)'
-          ELSE
-             var = '(yz_av)'
-          ENDIF
-
-          IF ( TRIM( var_list ) /= TRIM( var_list_old ) )  THEN
-             message_string = 'netCDF file for cross-sections ' //           &
-                              TRIM( var ) // ' from previous run found,' //  &
-                              '& but this file cannot be extended due to' // &
-                              ' variable mismatch.' //                       & 
-                              '&New file is created instead.'
-             CALL message( 'define_netcdf_header', 'PA0249', 0, 1, 0, 6, 0 )
-             extend = .FALSE.
-             RETURN
-          ENDIF
-
-!
-!--       Calculate the number of current sections
-          ns = 1
-          DO WHILE ( section(ns,3) /= -9999  .AND.  ns <= 100 )
-             ns = ns + 1
-          ENDDO
-          ns = ns - 1
-
-!
-!--       Get and compare the number of vertical cross sections
-          nc_stat = NF90_INQ_VARID( id_set_yz(av), 'x_yz', id_var_x_yz(av) )
-          CALL netcdf_handle_error( 'netcdf_define_header', 208 )
-
-          nc_stat = NF90_INQUIRE_VARIABLE( id_set_yz(av), id_var_x_yz(av), &
-                                           dimids = id_dim_x_yz_old )
-          CALL netcdf_handle_error( 'netcdf_define_header', 209 )
-          id_dim_x_yz(av) = id_dim_x_yz_old(1)
-
-          nc_stat = NF90_INQUIRE_DIMENSION( id_set_yz(av), id_dim_x_yz(av), &
-                                            len = ns_old )
-          CALL netcdf_handle_error( 'netcdf_define_header', 210 )
-
-          IF ( ns /= ns_old )  THEN
-             message_string = 'netCDF file for cross-sections ' //          &
-                              TRIM( var ) // ' from previous run found,' // &
-                              '&but this file cannot be extended due to' // &
-                              ' mismatch in number of' //                   &
-                              '&cross sections.' //                         &
-                              '&New file is created instead.'
-             CALL message( 'define_netcdf_header', 'PA0250', 0, 1, 0, 6, 0 )
-             extend = .FALSE.
-             RETURN
-          ENDIF
-
-!
-!--       Get and compare the heights of the cross sections
-          ALLOCATE( netcdf_data(1:ns_old) )
-
-          nc_stat = NF90_GET_VAR( id_set_yz(av), id_var_x_yz(av), netcdf_data )
-          CALL netcdf_handle_error( 'netcdf_define_header', 211 )
-
-          DO  i = 1, ns
-             IF ( section(i,3) /= -1 )  THEN
-                IF ( ( ( section(i,3) + 0.5 ) * dx ) /= netcdf_data(i) )  THEN
-                   message_string = 'netCDF file for cross-sections ' //    &
-                              TRIM( var ) // ' from previous run found,' // &
-                              '&but this file cannot be extended' //        &
-                              ' due to mismatch in cross' //                &
-                              '&section levels.' //                         &
-                             '&New file is created instead.'
-                   CALL message( 'define_netcdf_header', 'PA0251', &
-                                                                 0, 1, 0, 6, 0 )
-                   extend = .FALSE.
-                   RETURN
-                ENDIF
-             ELSE
-                IF ( -1.0_wp /= netcdf_data(i) )  THEN
-                   message_string = 'netCDF file for cross-sections ' //    &
-                              TRIM( var ) // ' from previous run found,' // &
-                              '&but this file cannot be extended' //        &
-                              ' due to mismatch in cross' //                &
-                              '&section levels.' //                         &
-                              '&New file is created instead.'
-                   CALL message( 'define_netcdf_header', 'PA0251', &
-                                                                 0, 1, 0, 6, 0 )
-                   extend = .FALSE.
-                   RETURN
-                ENDIF
-             ENDIF
-          ENDDO
-
-          DEALLOCATE( netcdf_data )
-
-!
-!--       Get the id of the time coordinate (unlimited coordinate) and its
-!--       last index on the file. The next time level is pl2d..count+1.
-!--       The current time must be larger than the last output time
-!--       on the file.
-          nc_stat = NF90_INQ_VARID( id_set_yz(av), 'time', id_var_time_yz(av) )
-          CALL netcdf_handle_error( 'netcdf_define_header', 212 )
-
-          nc_stat = NF90_INQUIRE_VARIABLE( id_set_yz(av), id_var_time_yz(av), &
-                                           dimids = id_dim_time_old )
-          CALL netcdf_handle_error( 'netcdf_define_header', 213 )
-          id_dim_time_yz(av) = id_dim_time_old(1)
-
-          nc_stat = NF90_INQUIRE_DIMENSION( id_set_yz(av), id_dim_time_yz(av), &
-                                            len = ntime_count )
-          CALL netcdf_handle_error( 'netcdf_define_header', 214 )
-
-!
-!--       For non-parallel output use the last output time level of the netcdf
-!--       file because the time dimension is unlimited. In case of parallel
-!--       output the variable ntime_count could get the value of 9*10E36 because
-!--       the time dimension is limited.
-          IF ( netcdf_data_format < 5 ) do2d_yz_time_count(av) = ntime_count
-
-          nc_stat = NF90_GET_VAR( id_set_yz(av), id_var_time_yz(av),    &
-                                  last_time_coordinate,                 &
-                                  start = (/ do2d_yz_time_count(av) /), &
-                                  count = (/ 1 /) )
-          CALL netcdf_handle_error( 'netcdf_define_header', 215 )
-
-          IF ( last_time_coordinate(1) >= simulated_time )  THEN
-             message_string = 'netCDF file for cross sections ' //          &
-                              TRIM( var ) // ' from previous run found,' // &
-                              '&but this file cannot be extended becaus' // &
-                              'e the current output time' //                &
-                              '&is less or equal than the last output t' // &
-                              'ime on this file.' //                        &
-                              '&New file is created instead.'
-             CALL message( 'define_netcdf_header', 'PA0252', 0, 1, 0, 6, 0 )
-             do2d_yz_time_count(av) = 0
-             extend = .FALSE.
-             RETURN
-          ENDIF
-
-          IF ( netcdf_data_format > 4 )  THEN
-!
-!--          Set needed time levels (ntdim) to 
-!--          saved time levels + to be saved time levels.
-             IF ( av == 0 )  THEN 
-                ntdim_2d_yz(0) = do2d_yz_time_count(0) + CEILING(             &
-                                 ( end_time - MAX( skip_time_do2d_yz,         &
-                                                   simulated_time_at_begin )  &
-                                 ) / dt_do2d_yz )
-             ELSE
-                ntdim_2d_yz(1) = do2d_yz_time_count(1) + CEILING(             &
-                                 ( end_time - MAX( skip_time_data_output_av,  &
-                                                   simulated_time_at_begin )  &
-                                 ) / dt_data_output_av )
-             ENDIF
-
-!
-!--          Check if the needed number of output time levels is increased
-!--          compared to the number of time levels in the existing file.
-             IF ( ntdim_2d_yz(av) > ntime_count )  THEN
-                message_string = 'netCDF file for cross sections ' //          &
-                                 TRIM( var ) // ' from previous run found,' // &
-                                 '&but this file cannot be extended becaus' // &
-                                 'e the number of output time levels&has b' // &
-                                 'een increased compared to the previous s' // &
-                                 'imulation.' //                               &
-                                 '&New file is created instead.'
-                CALL message( 'define_netcdf_header', 'PA0391', 0, 1, 0, 6, 0 )
-                do2d_yz_time_count(av) = 0
-                extend = .FALSE.
-!
-!--             Recalculate the needed time levels for the new file.
-                IF ( av == 0 )  THEN
-                   ntdim_2d_yz(0) = CEILING(                            &
-                           ( end_time - MAX( skip_time_do2d_yz,         &
-                                             simulated_time_at_begin )  &
-                           ) / dt_do2d_yz )
-                ELSE
-                   ntdim_2d_yz(1) = CEILING(                            &
-                           ( end_time - MAX( skip_time_data_output_av,  &
-                                             simulated_time_at_begin )  &
-                           ) / dt_data_output_av )
-                ENDIF
-                RETURN
-             ENDIF
-          ENDIF
-
-!
-!--       Dataset seems to be extendable.
-!--       Now get the variable ids.
-          i = 1
-          DO WHILE ( do2d(av,i)(1:1) /= ' ' )
-             IF ( INDEX( do2d(av,i), 'yz' ) /= 0 )  THEN
-                nc_stat = NF90_INQ_VARID( id_set_yz(av), do2d(av,i), &
-                                          id_var_do2d(av,i) )
-                CALL netcdf_handle_error( 'netcdf_define_header', 216 )
-#if defined( __netcdf4_parallel )
-!
-!--             Set independent io operations for parallel io. Collective io
-!--             is only allowed in case of a 1d-decomposition along y, because
-!--             otherwise, not all PEs have output data.
-                IF ( netcdf_data_format > 4 )  THEN
-                   IF ( npex == 1 )  THEN
-                      nc_stat = NF90_VAR_PAR_ACCESS( id_set_yz(av),     &
-                                                     id_var_do2d(av,i), &
-                                                     NF90_COLLECTIVE )
-                   ELSE
-!
-!--                   Test simulations showed that the output of cross sections
-!--                   by all PEs in data_output_2d using NF90_COLLECTIVE is 
-!--                   faster than the output by the first row of PEs in
-!--                   y-direction using NF90_INDEPENDENT.
-                      nc_stat = NF90_VAR_PAR_ACCESS( id_set_yz(av),     &
-                                                     id_var_do2d(av,i), &
-                                                     NF90_COLLECTIVE )
-!                      nc_stat = NF90_VAR_PAR_ACCESS( id_set_yz(av),     &
-!                                                     id_var_do2d(av,i), &
-!                                                     NF90_INDEPENDENT )
-                   ENDIF
-                   CALL netcdf_handle_error( 'netcdf_define_header', 450 )
-                ENDIF
-#endif
-             ENDIF
-             i = i + 1
-          ENDDO
-
-!
-!--       Update the title attribute on file
-!--       In order to avoid 'data mode' errors if updated attributes are larger 
-!--       than their original size, NF90_PUT_ATT is called in 'define mode' 
-!--       enclosed by NF90_REDEF and NF90_ENDDEF calls. This implies a possible 
-!--       performance loss due to data copying; an alternative strategy would be 
-!--       to ensure equal attribute size in a job chain. Maybe revise later.
-          IF ( av == 0 )  THEN
-             time_average_text = ' '
-          ELSE
-             WRITE (time_average_text, '('', '',F7.1,'' s average'')') &
-                                                            averaging_interval
-          ENDIF
-          nc_stat = NF90_REDEF( id_set_yz(av) )
-          CALL netcdf_handle_error( 'netcdf_define_header', 435 )
-          nc_stat = NF90_PUT_ATT( id_set_yz(av), NF90_GLOBAL, 'title', &
-                                  TRIM( run_description_header ) //    &
-                                  TRIM( time_average_text ) )
-          CALL netcdf_handle_error( 'netcdf_define_header', 217 )
-          nc_stat = NF90_ENDDEF( id_set_yz(av) )
-          CALL netcdf_handle_error( 'netcdf_define_header', 436 )
-          message_string = 'netCDF file for cross-sections ' //           &
-                            TRIM( var ) // ' from previous run found.' // &
-                           '&This file will be extended.'
-          CALL message( 'define_netcdf_header', 'PA0253', 0, 0, 0, 6, 0 )
-
-
-       CASE ( 'pr_new' )
-
-!
-!--       Define some global attributes of the dataset
-          IF ( averaging_interval_pr /= 0.0_wp )  THEN
-             WRITE (time_average_text,'('', '',F7.1,'' s average'')') &
-                                                            averaging_interval_pr
-             nc_stat = NF90_PUT_ATT( id_set_pr, NF90_GLOBAL, 'title',   &
-                                     TRIM( run_description_header ) //  &
-                                     TRIM( time_average_text ) )
-             CALL netcdf_handle_error( 'netcdf_define_header', 218 )
-
-             WRITE ( time_average_text,'(F7.1,'' s avg'')' ) averaging_interval_pr
-             nc_stat = NF90_PUT_ATT( id_set_pr, NF90_GLOBAL, 'time_avg', &
-                                     TRIM( time_average_text ) )
-          ELSE
-             nc_stat = NF90_PUT_ATT( id_set_pr, NF90_GLOBAL, 'title', &
-                                     TRIM( run_description_header ) )
-          ENDIF
-          CALL netcdf_handle_error( 'netcdf_define_header', 219 )
-
-!
-!--       Write number of columns and rows of coordinate systems to be plotted
-!--       on one page to the netcdf header.
-!--       This information can be used by palmplot.
-          nc_stat = NF90_PUT_ATT( id_set_pr, NF90_GLOBAL,                     &
-                                  'no_rows',                                  & 
-                                  profile_rows ) 
-          CALL netcdf_handle_error( 'netcdf_define_header', 519 )
-
-          nc_stat = NF90_PUT_ATT( id_set_pr, NF90_GLOBAL,                     &
-                                  'no_columns',                               & 
-                                  profile_columns ) 
-          CALL netcdf_handle_error( 'netcdf_define_header', 520 )
-
-
-          cross_profiles_adj  = ADJUSTL( cross_profiles )
-          cross_profiles_numb = 999999
-          cross_profiles_char = ''
-
-!
-!--       Each profile defined in cross_profiles is written to an array
-!--       (cross_profiles_char). The number of the respective coordinate
-!--       system is assigned in a second array (cross_profiles_numb).
-          k = 1
-
-          DO  i = 1, crmax
-
-             IF ( TRIM( cross_profiles_adj(i) ) == ' ' )  EXIT
-             delim_old = 0
-
-             DO   j = 1, crmax
-                delim = INDEX( cross_profiles_adj(i)(delim_old+1:), ' ' )
-                IF ( delim == 1 )  EXIT
-                kk = MIN( crmax, k )
-                cross_profiles_char(kk) = cross_profiles_adj(i)(delim_old+1: &
-                                                              delim_old+delim-1)
-                cross_profiles_numb(kk) = i
-                k = k + 1
-                cross_profiles_maxi  = i
-                delim_old = delim_old + delim
-             ENDDO
-
-          ENDDO
-
-          cross_profiles_count = MIN( crmax, k-1 )
-!
-!--       Check if all profiles defined in cross_profiles are defined in 
-!--       data_output_pr. If not, they will be skipped.
-          DO  i = 1, cross_profiles_count
-             DO  j = 1, dopr_n
-
-                IF ( TRIM(cross_profiles_char(i)) == TRIM(data_output_pr(j)) ) &
-                THEN
-                   EXIT
-                ENDIF
-
-                IF ( j == dopr_n )  THEN
-                   cross_profiles_numb(i) = 999999
-                ENDIF
-
-             ENDDO
-          ENDDO
-
-          DO i = 1, crmax
-             IF ( cross_profiles_numb(i) == 999999 ) THEN
-                DO j = i + 1, crmax
-                   IF ( cross_profiles_numb(j) /= 999999 ) THEN
-                      cross_profiles_char(i) = cross_profiles_char(j)
-                      cross_profiles_numb(i) = cross_profiles_numb(j)
-                      cross_profiles_numb(j) = 999999
-                      EXIT
-                   ENDIF
-                ENDDO
-             ENDIF
-          ENDDO
-
-          DO i = 1, crmax-1
-             IF ( cross_profiles_numb(i + 1) == 999999 ) THEN
-                cross_profiles_count = i
-                EXIT
-             ENDIF
-          ENDDO
-!
-!--       Check if all profiles defined in data_output_pr are defined in 
-!--       cross_profiles. If not, they will be added to cross_profiles.
-          DO  i = 1, dopr_n
-             DO  j = 1, cross_profiles_count
-
-                IF ( TRIM(cross_profiles_char(j)) == TRIM(data_output_pr(i))) &
-                THEN
-                   EXIT
-                ENDIF
-
-                IF (( j == cross_profiles_count ) .AND.                        &
-                    ( cross_profiles_count <= crmax - 1))  THEN
-                   cross_profiles_count = cross_profiles_count + 1
-                   cross_profiles_maxi  = cross_profiles_maxi  + 1
-                   cross_profiles_char(MIN( crmax, cross_profiles_count )) =  &
-                                                      TRIM( data_output_pr(i) )
-                   cross_profiles_numb(MIN( crmax, cross_profiles_count )) =  &
-                                                      cross_profiles_maxi
-                ENDIF
-
-             ENDDO
-          ENDDO
-
-          IF ( cross_profiles_count >= crmax )  THEN
-             message_string = 'It is not allowed to arrange more than '     &
-                              // '100 profiles with & cross_profiles. Apart'&
-                              // ' from that, all profiles are saved & to ' &
-                              // 'the netCDF file.'
-             CALL message( 'define_netcdf_header', 'PA0354', 0, 0, 0, 6, 0 )
-          ENDIF
-
-!
-!--       Writing cross_profiles to netcdf header. This information can be 
-!--       used by palmplot. Each profile is separated by ",", each cross is 
-!--       separated by ";".
-          char_cross_profiles = ';'
-          id_last = 1
-          cross_profiles_count = MIN( cross_profiles_count, crmax )
-
-          DO  i = 1, cross_profiles_count
-
-             IF ( cross_profiles_numb(i) /= 999999 )  THEN
-                IF ( TRIM( char_cross_profiles ) == ';' )  THEN
-                   char_cross_profiles = TRIM( char_cross_profiles ) // &
-                                         TRIM( cross_profiles_char(i) )
-                ELSEIF ( id_last == cross_profiles_numb(i) )  THEN
-                   char_cross_profiles = TRIM( char_cross_profiles ) // &
-                                         ',' // TRIM( cross_profiles_char(i) )
-                ELSE
-                   char_cross_profiles = TRIM( char_cross_profiles ) // &
-                                         ';' // TRIM( cross_profiles_char(i) )
-                ENDIF
-                id_last = cross_profiles_numb(i)
-             ENDIF
-
-          ENDDO
-
-          char_cross_profiles = TRIM( char_cross_profiles ) // ';'
-
-          nc_stat = NF90_PUT_ATT( id_set_pr, NF90_GLOBAL, 'cross_profiles',   &
-                                  TRIM( char_cross_profiles ) )
-          CALL netcdf_handle_error( 'netcdf_define_header', 521 )
-
-!
-!--       Define time coordinate for profiles (unlimited dimension)
-          CALL netcdf_create_dim( id_set_pr, 'time', NF90_UNLIMITED,           &
-                                  id_dim_time_pr, 220 )
-          CALL netcdf_create_var( id_set_pr, (/ id_dim_time_pr /), 'time',     &
-                                  NF90_DOUBLE, id_var_time_pr, 'seconds', '',  &
-                                  221, 222, 000 )
-!
-!--       Define the variables
-          var_list = ';'
-          DO  i = 1, dopr_n
-
-             IF ( statistic_regions == 0 )  THEN
-
-!
-!--             Define the z-axes (each variable gets its own z-axis)
-                CALL netcdf_create_dim( id_set_pr,                             &
-                                        'z' // TRIM( data_output_pr(i) ),      &
-                                        nzt+2-nzb, id_dim_z_pr(i,0), 223 )
-                CALL netcdf_create_var( id_set_pr, (/ id_dim_z_pr(i,0) /),     &
-                                        'z' // TRIM( data_output_pr(i) ),      &
-                                       NF90_DOUBLE, id_var_z_pr(i,0),          &
-                                       'meters', '', 224, 225, 000 )
-!
-!--             Define the variable
-                CALL netcdf_create_var( id_set_pr, (/ id_dim_z_pr(i,0),        &
-                                        id_dim_time_pr /), data_output_pr(i),  &
-                                        nc_precision(5), id_var_dopr(i,0),     &
-                                        TRIM( dopr_unit(i) ),                  &
-                                        TRIM( data_output_pr(i) ), 226, 227,   &
-                                        228 )
-
-                var_list = TRIM( var_list ) // TRIM( data_output_pr(i) ) //  ';'
-
-             ELSE
-!
-!--             If statistic regions are defined, add suffix _SR+#SR to the
-!--             names
-                DO  j = 0, statistic_regions
-                   WRITE ( suffix, '(''_'',I1)' )  j
-
-!
-!--                Define the z-axes (each variable gets it own z-axis)
-                   CALL netcdf_create_dim( id_set_pr, 'z' //                   &
-                                           TRIM(data_output_pr(i)) // suffix,  &
-                                           nzt+2-nzb, id_dim_z_pr(i,j), 229 )
-                   CALL netcdf_create_var( id_set_pr, (/ id_dim_z_pr(i,j) /),  &
-                                           'z' // TRIM(data_output_pr(i)) //   &
-                                           suffix, NF90_DOUBLE,                &
-                                           id_var_z_pr(i,j), 'meters', '',     &
-                                           230, 231, 000 )
-!
-!--                Define the variable
-                   CALL netcdf_create_var( id_set_pr, (/ id_dim_z_pr(i,j),     &
-                                           id_dim_time_pr /),                  &
-                                           TRIM(data_output_pr(i)) // suffix,  &
-                                           nc_precision(5), id_var_dopr(i,j),  &
-                                           TRIM( dopr_unit(i) ),               &
-                                           TRIM( data_output_pr(i) ) //        &
-                                           ' SR ', 232, 233, 234 )
-
-                   var_list = TRIM( var_list ) // TRIM( data_output_pr(i) ) // &
-                              suffix // ';'
-
-                ENDDO
-
-             ENDIF
-
-          ENDDO
-
-!
-!--       Write the list of variables as global attribute (this is used by
-!--       restart runs)
-          nc_stat = NF90_PUT_ATT( id_set_pr, NF90_GLOBAL, 'VAR_LIST', var_list )
-          CALL netcdf_handle_error( 'netcdf_define_header', 235 )
-
-!
-!--       Define normalization variables (as time series)
-          DO  i = 1, dopr_norm_num
-
-             CALL netcdf_create_var( id_set_pr, (/ id_dim_time_pr /),          &
-                                     'NORM_' // TRIM( dopr_norm_names(i) ),    &
-                                     nc_precision(5), id_var_norm_dopr(i),     &
-                                     '', TRIM( dopr_norm_longnames(i) ), 236,  &
-                                     000, 237 )
-
-          ENDDO
-
-!
-!--       Leave netCDF define mode
-          nc_stat = NF90_ENDDEF( id_set_pr )
-          CALL netcdf_handle_error( 'netcdf_define_header', 238 )
-
-!
-!--       Write z-axes data
-          DO  i = 1, dopr_n
-             DO  j = 0, statistic_regions
-
-                nc_stat = NF90_PUT_VAR( id_set_pr, id_var_z_pr(i,j),      &
-                                        hom(nzb:nzt+1,2,dopr_index(i),0), &
-                                        start = (/ 1 /),                  &
-                                        count = (/ nzt-nzb+2 /) )
-                CALL netcdf_handle_error( 'netcdf_define_header', 239 )
-
-             ENDDO
-          ENDDO
-
-
-       CASE ( 'pr_ext' )
-
-!
-!--       Get the list of variables and compare with the actual run.
-!--       First var_list_old has to be reset, since GET_ATT does not assign
-!--       trailing blanks.
-          var_list_old = ' '
-          nc_stat = NF90_GET_ATT( id_set_pr, NF90_GLOBAL, 'VAR_LIST', &
-                                  var_list_old )
-          CALL netcdf_handle_error( 'netcdf_define_header', 240 )
-
-          var_list = ';'
-          DO  i = 1, dopr_n
-
-             IF ( statistic_regions == 0 )  THEN
-                var_list = TRIM( var_list ) // TRIM( data_output_pr(i) ) // ';'
-             ELSE
-                DO  j = 0, statistic_regions
-                   WRITE ( suffix, '(''_'',I1)' )  j
-                   var_list = TRIM( var_list ) // TRIM( data_output_pr(i) ) // &
-                              suffix // ';'
-                ENDDO
-             ENDIF
-
-          ENDDO
-
-          IF ( TRIM( var_list ) /= TRIM( var_list_old ) )  THEN
-             message_string = 'netCDF file for vertical profiles ' //        &
-                              'from previous run found,' //                  &
-                              '& but this file cannot be extended due to' // &
-                              ' variable mismatch.' //                       &
-                              '&New file is created instead.'
-             CALL message( 'define_netcdf_header', 'PA0254', 0, 1, 0, 6, 0 )
-             extend = .FALSE.
-             RETURN
-          ENDIF
-
-!
-!--       Get the id of the time coordinate (unlimited coordinate) and its
-!--       last index on the file. The next time level is dopr..count+1.
-!--       The current time must be larger than the last output time
-!--       on the file.
-          nc_stat = NF90_INQ_VARID( id_set_pr, 'time', id_var_time_pr )
-          CALL netcdf_handle_error( 'netcdf_define_header', 241 )
-
-          nc_stat = NF90_INQUIRE_VARIABLE( id_set_pr, id_var_time_pr, &
-                                           dimids = id_dim_time_old )
-          CALL netcdf_handle_error( 'netcdf_define_header', 242 )
-          id_dim_time_pr = id_dim_time_old(1)
-
-          nc_stat = NF90_INQUIRE_DIMENSION( id_set_pr, id_dim_time_pr, &
-                                            len = dopr_time_count )
-          CALL netcdf_handle_error( 'netcdf_define_header', 243 )
-
-          nc_stat = NF90_GET_VAR( id_set_pr, id_var_time_pr,        &
-                                  last_time_coordinate,             &
-                                  start = (/ dopr_time_count /), &
-                                  count = (/ 1 /) )
-          CALL netcdf_handle_error( 'netcdf_define_header', 244 )
-
-          IF ( last_time_coordinate(1) >= simulated_time )  THEN
-             message_string = 'netCDF file for vertical profiles ' //       &
-                              'from previous run found,' //                 &
-                              '&but this file cannot be extended becaus' // &
-                              'e the current output time' //                &
-                              '&is less or equal than the last output t' // &
-                              'ime on this file.' //                        &
-                              '&New file is created instead.'
-             CALL message( 'define_netcdf_header', 'PA0255', 0, 1, 0, 6, 0 )
-             dopr_time_count = 0
-             extend = .FALSE.
-             RETURN
-          ENDIF
-
-!
-!--       Dataset seems to be extendable.
-!--       Now get the variable ids.
-          i = 1
-          DO  i = 1, dopr_n
- 
-             IF ( statistic_regions == 0 )  THEN
-                nc_stat = NF90_INQ_VARID( id_set_pr, data_output_pr(i), &
-                                          id_var_dopr(i,0) )
-                CALL netcdf_handle_error( 'netcdf_define_header', 245 )
-             ELSE
-                DO  j = 0, statistic_regions
-                   WRITE ( suffix, '(''_'',I1)' )  j
-                   netcdf_var_name = TRIM( data_output_pr(i) ) // suffix
-                   nc_stat = NF90_INQ_VARID( id_set_pr, netcdf_var_name, &
-                                             id_var_dopr(i,j) )
-                   CALL netcdf_handle_error( 'netcdf_define_header', 246 )
-                ENDDO
-             ENDIF
-
-          ENDDO
-
-!
-!--       Get ids of the normalization variables
-          DO  i = 1, dopr_norm_num
-             nc_stat = NF90_INQ_VARID( id_set_pr,                             &
-                                       'NORM_' // TRIM( dopr_norm_names(i) ), &
-                                       id_var_norm_dopr(i) )
-             CALL netcdf_handle_error( 'netcdf_define_header', 247 )
-          ENDDO
-
-!
-!--       Update the title attribute on file
-!--       In order to avoid 'data mode' errors if updated attributes are larger 
-!--       than their original size, NF90_PUT_ATT is called in 'define mode' 
-!--       enclosed by NF90_REDEF and NF90_ENDDEF calls. This implies a possible 
-!--       performance loss due to data copying; an alternative strategy would be 
-!--       to ensure equal attribute size in a job chain. Maybe revise later.
-          IF ( averaging_interval_pr == 0.0_wp )  THEN
-             time_average_text = ' '
-          ELSE
-             WRITE (time_average_text, '('', '',F7.1,'' s average'')') &
-                                                            averaging_interval_pr
-          ENDIF
-          nc_stat = NF90_REDEF( id_set_pr )
-          CALL netcdf_handle_error( 'netcdf_define_header', 437 )
-          nc_stat = NF90_PUT_ATT( id_set_pr, NF90_GLOBAL, 'title', &
-                                  TRIM( run_description_header ) //    &
-                                  TRIM( time_average_text ) )
-          CALL netcdf_handle_error( 'netcdf_define_header', 248 )
-
-          nc_stat = NF90_ENDDEF( id_set_pr )
-          CALL netcdf_handle_error( 'netcdf_define_header', 438 )
-          message_string = 'netCDF file for vertical profiles ' // &
-                           'from previous run found.' //           &
-                           '&This file will be extended.'
-          CALL message( 'define_netcdf_header', 'PA0256', 0, 0, 0, 6, 0 )
-
-
-       CASE ( 'ts_new' )
-
-!
-!--       Define some global attributes of the dataset
-          nc_stat = NF90_PUT_ATT( id_set_ts, NF90_GLOBAL, 'title', &
-                                  TRIM( run_description_header ) )
-          CALL netcdf_handle_error( 'netcdf_define_header', 249 )
-
-!
-!--       Define time coordinate for time series (unlimited dimension)
-          CALL netcdf_create_dim( id_set_ts, 'time', NF90_UNLIMITED,           &
-                                  id_dim_time_ts, 250 )
-          CALL netcdf_create_var( id_set_ts, (/ id_dim_time_ts /), 'time',     &
-                                  NF90_DOUBLE, id_var_time_ts, 'seconds', '',  &
-                                  251, 252, 000 )
-!
-!--       Define the variables
-          var_list = ';'
-          DO  i = 1, dots_num
-
-             IF ( statistic_regions == 0 )  THEN
-
-                CALL netcdf_create_var( id_set_ts, (/ id_dim_time_ts /),       &
-                                        dots_label(i), nc_precision(6),        &
-                                        id_var_dots(i,0),                      &
-                                        TRIM( dots_unit(i) ),                  &
-                                        TRIM( dots_label(i) ), 253, 254, 255 )
-
-             ELSE
-!
-!--             If statistic regions are defined, add suffix _SR+#SR to the
-!--             names
-                DO  j = 0, statistic_regions
-                   WRITE ( suffix, '(''_'',I1)' )  j
-
-                   CALL netcdf_create_var( id_set_ts, (/ id_dim_time_ts /),    &
-                                           TRIM( dots_label(i) ) // suffix,    &
-                                           nc_precision(6), id_var_dots(i,j),  &
-                                           TRIM( dots_unit(i) ),               &
-                                           TRIM( dots_label(i) ) // ' SR ' //  &
-                                           suffix(2:2), 256, 257, 347)
-
-                ENDDO
-
-             ENDIF
-
-          ENDDO
-
-!
-!--       Write the list of variables as global attribute (this is used by
-!--       restart runs)
-          nc_stat = NF90_PUT_ATT( id_set_ts, NF90_GLOBAL, 'VAR_LIST', var_list )
-          CALL netcdf_handle_error( 'netcdf_define_header', 258 )
-
-!
-!--       Leave netCDF define mode
-          nc_stat = NF90_ENDDEF( id_set_ts )
-          CALL netcdf_handle_error( 'netcdf_define_header', 259 )
-
-
-       CASE ( 'ts_ext' )
-
-!
-!--       Get the list of variables and compare with the actual run.
-!--       First var_list_old has to be reset, since GET_ATT does not assign
-!--       trailing blanks.
-          var_list_old = ' '
-          nc_stat = NF90_GET_ATT( id_set_ts, NF90_GLOBAL, 'VAR_LIST', &
-                                  var_list_old )
-          CALL netcdf_handle_error( 'netcdf_define_header', 260 )
-
-          var_list = ';'
-          i = 1
-          DO  i = 1, dots_num
-
-             IF ( statistic_regions == 0 )  THEN
-                var_list = TRIM( var_list ) // TRIM( dots_label(i) ) // ';'
-             ELSE
-                DO  j = 0, statistic_regions
-                   WRITE ( suffix, '(''_'',I1)' )  j
-                   var_list = TRIM( var_list ) // TRIM( dots_label(i) ) // &
-                              suffix // ';'
-                ENDDO
-             ENDIF
-
-          ENDDO
-
-          IF ( TRIM( var_list ) /= TRIM( var_list_old ) )  THEN
-             message_string = 'netCDF file for time series ' //              &
-                              'from previous run found,' //                  &
-                              '& but this file cannot be extended due to' // &
-                              ' variable mismatch.' //                       &
-                              '&New file is created instead.'
-             CALL message( 'define_netcdf_header', 'PA0257', 0, 1, 0, 6, 0 )
-             extend = .FALSE.
-             RETURN
-          ENDIF
-
-!
-!--       Get the id of the time coordinate (unlimited coordinate) and its
-!--       last index on the file. The next time level is dots..count+1.
-!--       The current time must be larger than the last output time
-!--       on the file.
-          nc_stat = NF90_INQ_VARID( id_set_ts, 'time', id_var_time_ts )
-          CALL netcdf_handle_error( 'netcdf_define_header', 261 )
-
-          nc_stat = NF90_INQUIRE_VARIABLE( id_set_ts, id_var_time_ts, &
-                                           dimids = id_dim_time_old )
-          CALL netcdf_handle_error( 'netcdf_define_header', 262 )
-          id_dim_time_ts = id_dim_time_old(1)
-
-          nc_stat = NF90_INQUIRE_DIMENSION( id_set_ts, id_dim_time_ts, &
-                                            len = dots_time_count )
-          CALL netcdf_handle_error( 'netcdf_define_header', 263 )
-
-          nc_stat = NF90_GET_VAR( id_set_ts, id_var_time_ts,        &
-                                  last_time_coordinate,             &
-                                  start = (/ dots_time_count /), &
-                                  count = (/ 1 /) )
-          CALL netcdf_handle_error( 'netcdf_define_header', 264 )
-
-          IF ( last_time_coordinate(1) >= simulated_time )  THEN
-             message_string = 'netCDF file for time series ' //             &
-                              'from previous run found,' //                 &
-                              '&but this file cannot be extended becaus' // &
-                              'e the current output time' //                &
-                              '&is less or equal than the last output t' // &
-                              'ime on this file.' //                        &
-                              '&New file is created instead.'
-             CALL message( 'define_netcdf_header', 'PA0258', 0, 1, 0, 6, 0 )
-             dots_time_count = 0
-             extend = .FALSE.
-             RETURN
-          ENDIF
-
-!
-!--       Dataset seems to be extendable.
-!--       Now get the variable ids
-          i = 1
-          DO  i = 1, dots_num
- 
-             IF ( statistic_regions == 0 )  THEN
-                nc_stat = NF90_INQ_VARID( id_set_ts, dots_label(i), &
-                                          id_var_dots(i,0) )
-                CALL netcdf_handle_error( 'netcdf_define_header', 265 )
-             ELSE
-                DO  j = 0, statistic_regions
-                   WRITE ( suffix, '(''_'',I1)' )  j
-                   netcdf_var_name = TRIM( dots_label(i) ) // suffix
-                   nc_stat = NF90_INQ_VARID( id_set_ts, netcdf_var_name, &
-                                             id_var_dots(i,j) )
-                   CALL netcdf_handle_error( 'netcdf_define_header', 266 )
-                ENDDO
-             ENDIF
-
-          ENDDO
-
-!
-!--       Update the title attribute on file
-!--       In order to avoid 'data mode' errors if updated attributes are larger 
-!--       than their original size, NF90_PUT_ATT is called in 'define mode' 
-!--       enclosed by NF90_REDEF and NF90_ENDDEF calls. This implies a possible 
-!--       performance loss due to data copying; an alternative strategy would be 
-!--       to ensure equal attribute size in a job chain. Maybe revise later.
-          nc_stat = NF90_REDEF( id_set_ts )
-          CALL netcdf_handle_error( 'netcdf_define_header', 439 )
-          nc_stat = NF90_PUT_ATT( id_set_ts, NF90_GLOBAL, 'title', &
-                                  TRIM( run_description_header ) )
-          CALL netcdf_handle_error( 'netcdf_define_header', 267 )
-          nc_stat = NF90_ENDDEF( id_set_ts )
-          CALL netcdf_handle_error( 'netcdf_define_header', 440 )
-          message_string = 'netCDF file for time series ' // &
-                           'from previous run found.' //     &
-                           '&This file will be extended.'
-          CALL message( 'define_netcdf_header', 'PA0259', 0, 0, 0, 6, 0 )
-
-
-       CASE ( 'sp_new' )
-
-!
-!--       Define some global attributes of the dataset
-          IF ( averaging_interval_sp /= 0.0_wp )  THEN
-             WRITE (time_average_text,'('', '',F7.1,'' s average'')') &
-                                                            averaging_interval_sp
-             nc_stat = NF90_PUT_ATT( id_set_sp, NF90_GLOBAL, 'title',  &
-                                     TRIM( run_description_header ) // &
-                                     TRIM( time_average_text ) )
-             CALL netcdf_handle_error( 'netcdf_define_header', 268 )
-
-             WRITE ( time_average_text,'(F7.1,'' s avg'')' )  averaging_interval_sp
-             nc_stat = NF90_PUT_ATT( id_set_sp, NF90_GLOBAL, 'time_avg', &
-                                     TRIM( time_average_text ) )
-          ELSE
-             nc_stat = NF90_PUT_ATT( id_set_sp, NF90_GLOBAL, 'title', &
-                                     TRIM( run_description_header ) )
-          ENDIF
-          CALL netcdf_handle_error( 'netcdf_define_header', 269 )
-
-!
-!--       Define time coordinate for spectra (unlimited dimension)
-          CALL netcdf_create_dim( id_set_sp, 'time', NF90_UNLIMITED,           &
-                                  id_dim_time_sp, 270 )
-          CALL netcdf_create_var( id_set_sp, (/ id_dim_time_sp /), 'time',     &
-                                  NF90_DOUBLE, id_var_time_sp, 'seconds', '',  &
-                                  271, 272, 000 )
-!
-!--       Define the spatial dimensions and coordinates for spectra.
-!--       First, determine the number of vertical levels for which spectra
-!--       are to be output.
-          ns = 1
-          DO WHILE ( comp_spectra_level(ns) /= 999999  .AND.  ns <= 100 )
-             ns = ns + 1
-          ENDDO
-          ns = ns - 1
-
-!
-!--       Define vertical coordinate grid (zu grid)
-          CALL netcdf_create_dim( id_set_sp, 'zu_sp', ns, id_dim_zu_sp, 273 )
-          CALL netcdf_create_var( id_set_sp, (/ id_dim_zu_sp /), 'zu_sp',      &
-                                  NF90_DOUBLE, id_var_zu_sp, 'meters', '',     &
-                                  274, 275, 000 )
-!
-!--       Define vertical coordinate grid (zw grid)
-          CALL netcdf_create_dim( id_set_sp, 'zw_sp', ns, id_dim_zw_sp, 276 )
-          CALL netcdf_create_var( id_set_sp, (/ id_dim_zw_sp /), 'zw_sp',      &
-                                  NF90_DOUBLE, id_var_zw_sp, 'meters', '',     &
-                                  277, 278, 000 )
-!
-!--       Define x-axis
-          CALL netcdf_create_dim( id_set_sp, 'k_x', nx/2, id_dim_x_sp, 279 )
-          CALL netcdf_create_var( id_set_sp, (/ id_dim_x_sp /), 'k_x',         &
-                                  NF90_DOUBLE, id_var_x_sp, 'm-1', '', 280,    &
-                                  281, 000 )
-!
-!--       Define y-axis
-          CALL netcdf_create_dim(id_set_sp, 'k_y', ny/2, id_dim_y_sp, 282 )
-          CALL netcdf_create_var( id_set_sp, (/ id_dim_y_sp /), 'k_y',         &
-                                  NF90_DOUBLE, id_var_y_sp, 'm-1', '', 283,    &
-                                  284, 000 )
-!
-!--       Define the variables
-          var_list = ';'
-          i = 1
-          DO WHILE ( data_output_sp(i) /= ' '  .AND.  i <= 10 )
-!
-!--          First check for the vertical grid
-             found = .TRUE.
-             SELECT CASE ( data_output_sp(i) )
-!
-!--             Most variables are defined on the zu levels
-                CASE ( 'e', 'lpt', 'nr', 'p', 'pc', 'pr', 'prr', 'pt', 'q',   &
-                       'qc', 'ql', 'ql_c', 'ql_v', 'ql_vp', 'qr', 'qv', 'rho',&
-                       's', 'sa', 'u', 'v', 'vpt' )
-
-                   grid_z = 'zu'
-!
-!--             zw levels
-                CASE ( 'w' )
-
-                   grid_z = 'zw'
-
-                CASE DEFAULT
-!
-!--                Check for user-defined quantities (found, grid_x and grid_y
-!--                are dummies)
-                   CALL user_define_netcdf_grid( data_output_sp(i), found,  &
-                                                 grid_x, grid_y, grid_z )
-
-             END SELECT
-
-             IF ( INDEX( spectra_direction(i), 'x' ) /= 0 )  THEN
-
-!
-!--             Define the variable
-                netcdf_var_name = TRIM( data_output_sp(i) ) // '_x'
-                IF ( TRIM( grid_z ) == 'zw' )  THEN
-                   CALL netcdf_create_var( id_set_sp, (/ id_dim_x_sp,          &
-                                           id_dim_zw_sp, id_dim_time_sp /),    &
-                                           netcdf_var_name, nc_precision(7),   &
-                                           id_var_dospx(i), 'unknown',         &
-                                           netcdf_var_name, 285, 286, 287 )
-                ELSE
-                   CALL netcdf_create_var( id_set_sp, (/ id_dim_x_sp,          &
-                                           id_dim_zu_sp, id_dim_time_sp /),    &
-                                           netcdf_var_name, nc_precision(7),   &
-                                           id_var_dospx(i), 'unknown',         &
-                                           netcdf_var_name, 285, 286, 287 )
-                ENDIF
-
-                var_list = TRIM( var_list ) // TRIM( netcdf_var_name ) // ';'
-
-             ENDIF
-
-             IF ( INDEX( spectra_direction(i), 'y' ) /= 0 )  THEN
-
-!
-!--             Define the variable
-                netcdf_var_name = TRIM( data_output_sp(i) ) // '_y'
-                IF ( TRIM( grid_z ) == 'zw' )  THEN
-                   CALL netcdf_create_var( id_set_sp, (/ id_dim_y_sp,          &
-                                           id_dim_zw_sp, id_dim_time_sp /),    &
-                                           netcdf_var_name, nc_precision(7),   &
-                                           id_var_dospy(i), 'unknown',         &
-                                           netcdf_var_name, 288, 289, 290 )
-                ELSE
-                   CALL netcdf_create_var( id_set_sp, (/ id_dim_y_sp,          &
-                                           id_dim_zu_sp, id_dim_time_sp /),    &
-                                           netcdf_var_name, nc_precision(7),   &
-                                           id_var_dospy(i), 'unknown',         &
-                                           netcdf_var_name, 288, 289, 290 )
-                ENDIF
-
-                var_list = TRIM( var_list ) // TRIM( netcdf_var_name ) // ';'
-
-             ENDIF
-
-             i = i + 1
-
-          ENDDO
-
-!
-!--       Write the list of variables as global attribute (this is used by
-!--       restart runs)
-          nc_stat = NF90_PUT_ATT( id_set_sp, NF90_GLOBAL, 'VAR_LIST', var_list )
-          CALL netcdf_handle_error( 'netcdf_define_header', 291 )
-
-!
-!--       Leave netCDF define mode
-          nc_stat = NF90_ENDDEF( id_set_sp )
-          CALL netcdf_handle_error( 'netcdf_define_header', 292 )
-
-!
-!--       Write axis data: zu_sp, zw_sp, k_x, k_y
-          ALLOCATE( netcdf_data(1:ns) )
-
-!
-!--       Write zu data
-          netcdf_data(1:ns) = zu( comp_spectra_level(1:ns) )
-          nc_stat = NF90_PUT_VAR( id_set_sp, id_var_zu_sp, netcdf_data, &
-                                  start = (/ 1 /), count = (/ ns /) )
-          CALL netcdf_handle_error( 'netcdf_define_header', 293 )
-
-!
-!--       Write zw data
-          netcdf_data(1:ns) = zw( comp_spectra_level(1:ns) )
-          nc_stat = NF90_PUT_VAR( id_set_sp, id_var_zw_sp, netcdf_data, &
-                                  start = (/ 1 /), count = (/ ns /) )
-          CALL netcdf_handle_error( 'netcdf_define_header', 294 )
-
-          DEALLOCATE( netcdf_data )
-
-!
-!--       Write data for x and y axis (wavenumbers)
-          ALLOCATE( netcdf_data(nx/2) )
-          DO  i = 1, nx/2
-             netcdf_data(i) = 2.0_wp * pi * i / ( dx * ( nx + 1 ) )
-          ENDDO
-
-          nc_stat = NF90_PUT_VAR( id_set_sp, id_var_x_sp, netcdf_data, &
-                                  start = (/ 1 /), count = (/ nx/2 /) )
-          CALL netcdf_handle_error( 'netcdf_define_header', 295 )
-
-          DEALLOCATE( netcdf_data )
-
-          ALLOCATE( netcdf_data(ny/2) )
-          DO  i = 1, ny/2
-             netcdf_data(i) = 2.0_wp * pi * i / ( dy * ( ny + 1 ) )
-          ENDDO
-
-          nc_stat = NF90_PUT_VAR( id_set_sp, id_var_y_sp, netcdf_data, &
-                                  start = (/ 1 /), count = (/ ny/2 /) )
-          CALL netcdf_handle_error( 'netcdf_define_header', 296 )
-
-          DEALLOCATE( netcdf_data )
-
-
-       CASE ( 'sp_ext' )
-
-!
-!--       Get the list of variables and compare with the actual run.
-!--       First var_list_old has to be reset, since GET_ATT does not assign
-!--       trailing blanks.
-          var_list_old = ' '
-          nc_stat = NF90_GET_ATT( id_set_sp, NF90_GLOBAL, 'VAR_LIST', &
-                                  var_list_old )
-          CALL netcdf_handle_error( 'netcdf_define_header', 297 )
-          var_list = ';'
-          i = 1
-          DO WHILE ( data_output_sp(i) /= ' '  .AND.  i <= 10 )
-
-             IF ( INDEX( spectra_direction(i), 'x' ) /= 0 )  THEN
-                netcdf_var_name = TRIM( data_output_sp(i) ) // '_x'
-                var_list = TRIM( var_list ) // TRIM( netcdf_var_name ) // ';'
-             ENDIF
-
-             IF ( INDEX( spectra_direction(i), 'y' ) /= 0 )  THEN
-                netcdf_var_name = TRIM( data_output_sp(i) ) // '_y'
-                var_list = TRIM( var_list ) // TRIM( netcdf_var_name ) // ';'
-             ENDIF
-
-             i = i + 1
-
-          ENDDO
-
-          IF ( TRIM( var_list ) /= TRIM( var_list_old ) )  THEN
-             message_string = 'netCDF file for spectra  ' //                 &
-                              'from previous run found,' //                  &
-                              '& but this file cannot be extended due to' // &
-                              ' variable mismatch.' //                       &
-                              '&New file is created instead.'
-             CALL message( 'define_netcdf_header', 'PA0260', 0, 1, 0, 6, 0 )
-             extend = .FALSE.
-             RETURN
-          ENDIF
-
-!
-!--       Determine the number of current vertical levels for which spectra
-!--       shall be output
-          ns = 1
-          DO WHILE ( comp_spectra_level(ns) /= 999999  .AND.  ns <= 100 )
-             ns = ns + 1
-          ENDDO
-          ns = ns - 1
-
-!
-!--       Get and compare the number of vertical levels
-          nc_stat = NF90_INQ_VARID( id_set_sp, 'zu_sp', id_var_zu_sp )
-          CALL netcdf_handle_error( 'netcdf_define_header', 298 )
-
-          nc_stat = NF90_INQUIRE_VARIABLE( id_set_sp, id_var_zu_sp, &
-                                           dimids = id_dim_zu_sp_old )
-          CALL netcdf_handle_error( 'netcdf_define_header', 299 )
-          id_dim_zu_sp = id_dim_zu_sp_old(1)
-
-          nc_stat = NF90_INQUIRE_DIMENSION( id_set_sp, id_dim_zu_sp, &
-                                            len = ns_old )
-          CALL netcdf_handle_error( 'netcdf_define_header', 300 )
-
-          IF ( ns /= ns_old )  THEN
-             message_string = 'netCDF file for spectra ' //                 &
-                              ' from previous run found,' //                &
-                              '&but this file cannot be extended due to' // &
-                              ' mismatch in number of' //                   &
-                              '&vertical levels.' //                        &
-                              '&New file is created instead.'
-             CALL message( 'define_netcdf_header', 'PA0261', 0, 1, 0, 6, 0 )
-             extend = .FALSE.
-             RETURN
-          ENDIF
-
-!
-!--       Get and compare the heights of the cross sections
-          ALLOCATE( netcdf_data(1:ns_old) )
-
-          nc_stat = NF90_GET_VAR( id_set_sp, id_var_zu_sp, netcdf_data )
-          CALL netcdf_handle_error( 'netcdf_define_header', 301 )
-
-          DO  i = 1, ns
-             IF ( zu(comp_spectra_level(i)) /= netcdf_data(i) )  THEN
-                message_string = 'netCDF file for spectra ' //                 &
-                                 ' from previous run found,' //                &
-                                 '&but this file cannot be extended due to' // &
-                                 ' mismatch in heights of' //                  &
-                                 '&vertical levels.' //                        &
-                                 '&New file is created instead.'
-                CALL message( 'define_netcdf_header', 'PA0262', 0, 1, 0, 6, 0 )
-                extend = .FALSE.
-                RETURN
-             ENDIF
-          ENDDO
-
-          DEALLOCATE( netcdf_data )
-
-!
-!--       Get the id of the time coordinate (unlimited coordinate) and its
-!--       last index on the file. The next time level is plsp..count+1.
-!--       The current time must be larger than the last output time
-!--       on the file.
-          nc_stat = NF90_INQ_VARID( id_set_sp, 'time', id_var_time_sp )
-          CALL netcdf_handle_error( 'netcdf_define_header', 302 )
-
-          nc_stat = NF90_INQUIRE_VARIABLE( id_set_sp, id_var_time_sp, &
-                                           dimids = id_dim_time_old )
-          CALL netcdf_handle_error( 'netcdf_define_header', 303 )
-          id_dim_time_sp = id_dim_time_old(1)
-
-          nc_stat = NF90_INQUIRE_DIMENSION( id_set_sp, id_dim_time_sp, &
-                                            len = dosp_time_count )
-          CALL netcdf_handle_error( 'netcdf_define_header', 304 )
-
-          nc_stat = NF90_GET_VAR( id_set_sp, id_var_time_sp,        &
-                                  last_time_coordinate,             &
-                                  start = (/ dosp_time_count /), &
-                                  count = (/ 1 /) )
-          CALL netcdf_handle_error( 'netcdf_define_header', 305 )
-
-          IF ( last_time_coordinate(1) >= simulated_time )  THEN
-             message_string = 'netCDF file for spectra ' //                 &
-                              'from previous run found,' //                 &
-                              '&but this file cannot be extended becaus' // &
-                              'e the current output time' //                & 
-                              '&is less or equal than the last output t' // &
-                              'ime on this file.' //                        &
-                              '&New file is created instead.'
-             CALL message( 'define_netcdf_header', 'PA0263', 0, 1, 0, 6, 0 )
-             dosp_time_count = 0
-             extend = .FALSE.
-             RETURN
-          ENDIF
-
-!
-!--       Dataset seems to be extendable.
-!--       Now get the variable ids.
-          i = 1
-          DO WHILE ( data_output_sp(i) /= ' '  .AND.  i <= 10 )
-
-             IF ( INDEX( spectra_direction(i), 'x' ) /= 0 )  THEN
-                netcdf_var_name = TRIM( data_output_sp(i) ) // '_x'
-                nc_stat = NF90_INQ_VARID( id_set_sp, netcdf_var_name, &
-                                          id_var_dospx(i) )
-                CALL netcdf_handle_error( 'netcdf_define_header', 306 )
-             ENDIF
-
-             IF ( INDEX( spectra_direction(i), 'y' ) /= 0 )  THEN
-                netcdf_var_name = TRIM( data_output_sp(i) ) // '_y'
-                nc_stat = NF90_INQ_VARID( id_set_sp, netcdf_var_name, &
-                                          id_var_dospy(i) )
-                CALL netcdf_handle_error( 'netcdf_define_header', 307 )
-             ENDIF
-
-             i = i + 1
-
-          ENDDO
-
-!
-!--       Update the title attribute on file
-!--       In order to avoid 'data mode' errors if updated attributes are larger 
-!--       than their original size, NF90_PUT_ATT is called in 'define mode' 
-!--       enclosed by NF90_REDEF and NF90_ENDDEF calls. This implies a possible 
-!--       performance loss due to data copying; an alternative strategy would be 
-!--       to ensure equal attribute size in a job chain. Maybe revise later.
-          nc_stat = NF90_REDEF( id_set_sp )
-          CALL netcdf_handle_error( 'netcdf_define_header', 441 )
-          IF ( averaging_interval_sp /= 0.0_wp )  THEN
-             WRITE (time_average_text,'('', '',F7.1,'' s average'')') &
-                                                           averaging_interval_sp
-             nc_stat = NF90_PUT_ATT( id_set_sp, NF90_GLOBAL, 'title',  &
-                                     TRIM( run_description_header ) // &
-                                     TRIM( time_average_text ) )
-             CALL netcdf_handle_error( 'netcdf_define_header', 308 )
-
-             WRITE ( time_average_text,'(F7.1,'' s avg'')' )  averaging_interval_sp
-             nc_stat = NF90_PUT_ATT( id_set_sp, NF90_GLOBAL, 'time_avg', &
-                                     TRIM( time_average_text ) )
-          ELSE
-             nc_stat = NF90_PUT_ATT( id_set_sp, NF90_GLOBAL, 'title', &
-                                     TRIM( run_description_header ) )
-          ENDIF
-          CALL netcdf_handle_error( 'netcdf_define_header', 309 )
-          nc_stat = NF90_ENDDEF( id_set_sp )
-          CALL netcdf_handle_error( 'netcdf_define_header', 442 )
-          message_string = 'netCDF file for spectra ' //     &
-                           'from previous run found.' //     &
-                           '&This file will be extended.'
-          CALL message( 'define_netcdf_header', 'PA0264', 0, 0, 0, 6, 0 )
-
-
-       CASE ( 'pt_new' )
-
-!
-!--       Define some global attributes of the dataset
-          nc_stat = NF90_PUT_ATT( id_set_prt, NF90_GLOBAL, 'title', &
-                                  TRIM( run_description_header ) )
-          CALL netcdf_handle_error( 'netcdf_define_header', 310 )
-
-!
-!--       Define time coordinate for particles (unlimited dimension)
-          CALL netcdf_create_dim( id_set_prt, 'time', NF90_UNLIMITED,          &
-                                  id_dim_time_prt, 311 )
-          CALL netcdf_create_var( id_set_prt, (/ id_dim_time_prt /), 'time',   &
-                                  NF90_DOUBLE, id_var_time_prt, 'seconds', '', &
-                                  312, 313, 000 )
-!
-!--       Define particle coordinate (maximum particle number)
-          IF ( netcdf_data_format < 3 )  THEN
-             CALL netcdf_create_dim( id_set_prt, 'particle_number',            &
-                                     maximum_number_of_particles,              &
-                                     id_dim_prtnum, 314 )
-          ELSE
-!
-!--          netCDF4 allows more than one unlimited dimension
-             CALL netcdf_create_dim( id_set_prt, 'particle_number',            &
-                                     NF90_UNLIMITED, id_dim_prtnum, 314 )
-          ENDIF
-
-          CALL netcdf_create_var( id_set_prt, (/ id_dim_prtnum /),             &
-                                  'particle_number', NF90_DOUBLE,              &
-                                  id_var_prtnum, 'particle number', '', 315,   &
-                                  316, 000 )
-!
-!--       Define variable which contains the real number of particles in use
-          CALL netcdf_create_var( id_set_prt, (/ id_dim_time_prt /),           &
-                                  'real_num_of_prt', NF90_DOUBLE,              &
-                                  id_var_rnop_prt, 'particle number', '', 317, &
-                                  318, 000 )
-!
-!--       Define the variables
-          DO  i = 1, 17
-
-             CALL netcdf_create_var( id_set_prt, (/ id_dim_prtnum,             &
-                                     id_dim_time_prt /), prt_var_names(i),     &
-                                     nc_precision(8), id_var_prt(i),           &
-                                     TRIM( prt_var_units(i) ),                 &
-                                     TRIM( prt_var_names(i) ), 319, 320, 321 )
-
-          ENDDO
-
-!
-!--       Leave netCDF define mode
-          nc_stat = NF90_ENDDEF( id_set_prt )
-          CALL netcdf_handle_error( 'netcdf_define_header', 322 )
-
-
-       CASE ( 'pt_ext' )
-
-!
-!--       Get the id of the time coordinate (unlimited coordinate) and its
-!--       last index on the file. The next time level is prt..count+1.
-!--       The current time must be larger than the last output time
-!--       on the file.
-          nc_stat = NF90_INQ_VARID( id_set_prt, 'time', id_var_time_prt )
-          CALL netcdf_handle_error( 'netcdf_define_header', 323 )
-
-          nc_stat = NF90_INQUIRE_VARIABLE( id_set_prt, id_var_time_prt, &
-                                           dimids = id_dim_time_old )
-          CALL netcdf_handle_error( 'netcdf_define_header', 324 )
-          id_dim_time_prt = id_dim_time_old(1)
-
-          nc_stat = NF90_INQUIRE_DIMENSION( id_set_prt, id_dim_time_prt, &
-                                            len = prt_time_count )
-          CALL netcdf_handle_error( 'netcdf_define_header', 325 )
-
-          nc_stat = NF90_GET_VAR( id_set_prt, id_var_time_prt,  &
-                                  last_time_coordinate,         &
-                                  start = (/ prt_time_count /), &
-                                  count = (/ 1 /) )
-          CALL netcdf_handle_error( 'netcdf_define_header', 326 )
-
-          IF ( last_time_coordinate(1) >= simulated_time )  THEN
-             message_string = 'netCDF file for particles ' //               &
-                              'from previous run found,' //                 &
-                              '&but this file cannot be extended becaus' // &
-                              'e the current output time' //                &
-                              '&is less or equal than the last output t' // &
-                              'ime on this file.' //                        &
-                              '&New file is created instead.'
-             CALL message( 'define_netcdf_header', 'PA0265', 0, 1, 0, 6, 0 )
-             prt_time_count = 0
-             extend = .FALSE.
-             RETURN
-          ENDIF
-
-!
-!--       Dataset seems to be extendable.
-!--       Now get the variable ids.
-          nc_stat = NF90_INQ_VARID( id_set_prt, 'real_num_of_prt', &
-                                    id_var_rnop_prt )
-          CALL netcdf_handle_error( 'netcdf_define_header', 327 )
-
-          DO  i = 1, 17
-
-             nc_stat = NF90_INQ_VARID( id_set_prt, prt_var_names(i), &
-                                       id_var_prt(i) )
-             CALL netcdf_handle_error( 'netcdf_define_header', 328 )
-
-          ENDDO
-
-          message_string = 'netCDF file for particles ' // &
-                           'from previous run found.' //   &
-                           '&This file will be extended.'
-          CALL message( 'define_netcdf_header', 'PA0266', 0, 0, 0, 6, 0 )
-        
-
-
-       CASE ( 'ps_new' )
-
-!
-!--       Define some global attributes of the dataset
-          nc_stat = NF90_PUT_ATT( id_set_pts, NF90_GLOBAL, 'title', &
-                                  TRIM( run_description_header ) )
-          CALL netcdf_handle_error( 'netcdf_define_header', 396 )
-
-!
-!--       Define time coordinate for particle time series (unlimited dimension)
-          CALL netcdf_create_dim( id_set_pts, 'time', NF90_UNLIMITED,          &
-                                  id_dim_time_pts, 397 )
-          CALL netcdf_create_var( id_set_pts, (/ id_dim_time_pts /), 'time',   &
-                                  NF90_DOUBLE, id_var_time_pts, 'seconds', '', &
-                                  398, 399, 000 )
-!
-!--       Define the variables. If more than one particle group is defined,
-!--       define seperate variables for each group
-          var_list = ';'
-          DO  i = 1, dopts_num
-
-             DO  j = 0, number_of_particle_groups
-
-                IF ( j == 0 )  THEN
-                   suffix1 = ''
-                ELSE
-                   WRITE ( suffix1, '(''_'',I2.2)' )  j
-                ENDIF
-
-                IF ( j == 0 )  THEN
-                   CALL netcdf_create_var( id_set_pts, (/ id_dim_time_pts /),  &
-                                           TRIM( dopts_label(i) ) // suffix1,  &
-                                           nc_precision(6), id_var_dopts(i,j), &
-                                           TRIM( dopts_unit(i) ),              &
-                                           TRIM( dopts_label(i) ), 400, 401,   &
-                                           402 )
-                ELSE
-                   CALL netcdf_create_var( id_set_pts, (/ id_dim_time_pts /),  &
-                                           TRIM( dopts_label(i) ) // suffix1,  &
-                                           nc_precision(6), id_var_dopts(i,j), &
-                                           TRIM( dopts_unit(i) ),              &
-                                           TRIM( dopts_label(i) ) // ' PG ' // &
-                                           suffix1(2:3), 400, 401, 402 )
-                ENDIF
-
-                var_list = TRIM( var_list ) // TRIM( dopts_label(i) ) // &
-                           suffix1 // ';'
-
-                IF ( number_of_particle_groups == 1 )  EXIT
-
-             ENDDO
-
-          ENDDO
-
-!
-!--       Write the list of variables as global attribute (this is used by
-!--       restart runs)
-          nc_stat = NF90_PUT_ATT( id_set_pts, NF90_GLOBAL, 'VAR_LIST', &
-                                  var_list )
-          CALL netcdf_handle_error( 'netcdf_define_header', 403 )
-
-
-!
-!--       Leave netCDF define mode
-          nc_stat = NF90_ENDDEF( id_set_pts )
-          CALL netcdf_handle_error( 'netcdf_define_header', 404 )
-
-
-       CASE ( 'ps_ext' )
-
-!
-!--       Get the list of variables and compare with the actual run.
-!--       First var_list_old has to be reset, since GET_ATT does not assign
-!--       trailing blanks.
-          var_list_old = ' '
-          nc_stat = NF90_GET_ATT( id_set_pts, NF90_GLOBAL, 'VAR_LIST', &
-                                  var_list_old )
-          CALL netcdf_handle_error( 'netcdf_define_header', 405 )
-
-          var_list = ';'
-          i = 1
-          DO  i = 1, dopts_num
-
-             DO  j = 0, number_of_particle_groups
-
-                IF ( j == 0 )  THEN
-                   suffix1 = ''
-                ELSE
-                   WRITE ( suffix1, '(''_'',I2.2)' )  j
-                ENDIF
-
-                var_list = TRIM( var_list ) // TRIM( dopts_label(i) ) // &
-                           suffix1 // ';'
-
-                IF ( number_of_particle_groups == 1 )  EXIT
-
-             ENDDO
-
-          ENDDO
-
-          IF ( TRIM( var_list ) /= TRIM( var_list_old ) )  THEN
-             message_string = 'netCDF file for particle time series ' //     &
-                              'from previous run found,' //                  &
-                              '& but this file cannot be extended due to' // &
-                              ' variable mismatch.' //                       &
-                              '&New file is created instead.'
-             CALL message( 'define_netcdf_header', 'PA0267', 0, 1, 0, 6, 0 )
-             extend = .FALSE.
-             RETURN
-          ENDIF
-
-!
-!--       Get the id of the time coordinate (unlimited coordinate) and its
-!--       last index on the file. The next time level is dots..count+1.
-!--       The current time must be larger than the last output time
-!--       on the file.
-          nc_stat = NF90_INQ_VARID( id_set_pts, 'time', id_var_time_pts )
-          CALL netcdf_handle_error( 'netcdf_define_header', 406 )
-
-          nc_stat = NF90_INQUIRE_VARIABLE( id_set_pts, id_var_time_pts, &
-                                           dimids = id_dim_time_old )
-          CALL netcdf_handle_error( 'netcdf_define_header', 407 )
-          id_dim_time_pts = id_dim_time_old(1)
-
-          nc_stat = NF90_INQUIRE_DIMENSION( id_set_pts, id_dim_time_pts, &
-                                            len = dopts_time_count )
-          CALL netcdf_handle_error( 'netcdf_define_header', 408 )
-
-          nc_stat = NF90_GET_VAR( id_set_pts, id_var_time_pts,    &
-                                  last_time_coordinate,           &
-                                  start = (/ dopts_time_count /), &
-                                  count = (/ 1 /) )
-          CALL netcdf_handle_error( 'netcdf_define_header', 409 )
-
-          IF ( last_time_coordinate(1) >= simulated_time )  THEN
-             message_string = 'netCDF file for particle time series ' //    &
-                              'from previous run found,' //                 &
-                              '&but this file cannot be extended becaus' // &
-                              'e the current output time' //                &
-                              '&is less or equal than the last output t' // &
-                              'ime on this file.' //                        &
-                              '&New file is created instead.'
-             CALL message( 'define_netcdf_header', 'PA0268', 0, 1, 0, 6, 0 )
-             dopts_time_count = 0
-             extend = .FALSE.
-             RETURN
-          ENDIF
-
-!
-!--       Dataset seems to be extendable.
-!--       Now get the variable ids
-          i = 1
-          DO  i = 1, dopts_num
- 
-             DO  j = 0, number_of_particle_groups
-
-                IF ( j == 0 )  THEN
-                   suffix1 = ''
-                ELSE
-                   WRITE ( suffix1, '(''_'',I2.2)' )  j
-                ENDIF
-
-                netcdf_var_name = TRIM( dopts_label(i) ) // suffix1
-
-                nc_stat = NF90_INQ_VARID( id_set_pts, netcdf_var_name, &
-                                          id_var_dopts(i,j) )
-                CALL netcdf_handle_error( 'netcdf_define_header', 410 )
-
-                IF ( number_of_particle_groups == 1 )  EXIT
-
-             ENDDO
-
-          ENDDO
-
-!
-!--       Update the title attribute on file
-!--       In order to avoid 'data mode' errors if updated attributes are larger 
-!--       than their original size, NF90_PUT_ATT is called in 'define mode' 
-!--       enclosed by NF90_REDEF and NF90_ENDDEF calls. This implies a possible 
-!--       performance loss due to data copying; an alternative strategy would be 
-!--       to ensure equal attribute size in a job chain. Maybe revise later.
-          nc_stat = NF90_REDEF( id_set_pts )
-          CALL netcdf_handle_error( 'netcdf_define_header', 443 )
-          nc_stat = NF90_PUT_ATT( id_set_pts, NF90_GLOBAL, 'title', &
-                                  TRIM( run_description_header ) )
-          CALL netcdf_handle_error( 'netcdf_define_header', 411 )
-          nc_stat = NF90_ENDDEF( id_set_pts )
-          CALL netcdf_handle_error( 'netcdf_define_header', 444 )
-          message_string = 'netCDF file for particle time series ' // &
-                           'from previous run found.' //              &
-                           '&This file will be extended.'
-          CALL message( 'netcdf_define_header', 'PA0269', 0, 0, 0, 6, 0 )
-
-
-       CASE DEFAULT
-
-          message_string = 'mode "' // TRIM( mode) // '" not supported'
-          CALL message( 'netcdf_define_header', 'PA0270', 0, 0, 0, 6, 0 )
-
-    END SELECT
-
-#endif
- END SUBROUTINE netcdf_define_header
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Creates a netCDF file and give back the id. The parallel flag has to be TRUE
-!> for parallel netCDF output support.
-!------------------------------------------------------------------------------!
- 
- SUBROUTINE netcdf_create_file( filename , id, parallel, errno )
-#if defined( __netcdf )
-
-    USE pegrid
-
-    IMPLICIT NONE
-
-    CHARACTER (LEN=*), INTENT(IN) :: filename
-    INTEGER, INTENT(IN)           :: errno
-    INTEGER, INTENT(OUT)          :: id
-    LOGICAL, INTENT(IN)           :: parallel
-
-
-!
-!-- Create a new netCDF output file with requested netCDF format
-    IF ( netcdf_data_format == 1 )  THEN
-!
-!--    Classic netCDF format
-       nc_stat = NF90_CREATE( filename, NF90_NOCLOBBER, id )
-
-    ELSEIF ( netcdf_data_format == 2 )  THEN
-!
-!--    64bit-offset format
-       nc_stat = NF90_CREATE( filename,                                        &
-                              IOR( NF90_NOCLOBBER, NF90_64BIT_OFFSET ), id )
-
-#if defined( __netcdf4 )
-    ELSEIF ( netcdf_data_format == 3  .OR.                                     &
-             ( .NOT. parallel  .AND.  netcdf_data_format == 5 ) )  THEN
-!
-!--    netCDF4/HDF5 format
-       nc_stat = NF90_CREATE( filename, IOR( NF90_NOCLOBBER, NF90_NETCDF4 ), id )
-
-    ELSEIF ( netcdf_data_format == 4  .OR.                                     &
-             ( .NOT. parallel  .AND.  netcdf_data_format == 6 ) )  THEN
-!
-!--    netCDF4/HDF5 format with classic model flag
-       nc_stat = NF90_CREATE( filename,                                        &
-                              IOR( NF90_NOCLOBBER,                             &
-                              IOR( NF90_CLASSIC_MODEL, NF90_HDF5 ) ), id )
-
-#if defined( __netcdf4_parallel )
-    ELSEIF ( netcdf_data_format == 5  .AND.  parallel )  THEN
-!
-!--    netCDF4/HDF5 format, parallel
-       nc_stat = NF90_CREATE( filename,                                        &
-                              IOR( NF90_NOCLOBBER,                             &
-                              IOR( NF90_NETCDF4, NF90_MPIIO ) ),               &
-                              id, COMM = comm2d, INFO = MPI_INFO_NULL )
-
-    ELSEIF ( netcdf_data_format == 6  .AND.  parallel )  THEN
-!
-!--    netCDF4/HDF5 format with classic model flag, parallel
-       nc_stat = NF90_CREATE( filename,                                        &
-                              IOR( NF90_NOCLOBBER,                             &
-                              IOR( NF90_MPIIO,                                 &
-                              IOR( NF90_CLASSIC_MODEL, NF90_HDF5 ) ) ),        &
-                              id, COMM = comm2d, INFO = MPI_INFO_NULL )
-
-#endif
-#endif
-    ENDIF
-
-    CALL netcdf_handle_error( 'netcdf_create_file', errno )
-#endif
- END SUBROUTINE netcdf_create_file
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Opens an existing netCDF file for writing and gives back the id.
-!> The parallel flag has to be TRUE for parallel netCDF output support.
-!------------------------------------------------------------------------------!
- 
- SUBROUTINE netcdf_open_write_file( filename, id, parallel, errno )
-#if defined( __netcdf )
-
-    USE pegrid
-
-    IMPLICIT NONE
-
-    CHARACTER (LEN=*), INTENT(IN) :: filename
-    INTEGER, INTENT(IN)           :: errno
-    INTEGER, INTENT(OUT)          :: id
-    LOGICAL, INTENT(IN)           :: parallel
-
-
-    IF ( netcdf_data_format < 5  .OR.  .NOT. parallel )  THEN
-       nc_stat = NF90_OPEN( filename, NF90_WRITE, id )
-#if defined( __netcdf4 )
-#if defined( __netcdf4_parallel )
-    ELSEIF ( netcdf_data_format > 4  .AND.  parallel )  THEN
-       nc_stat = NF90_OPEN( filename, IOR( NF90_WRITE, NF90_MPIIO ), id,  &
-                            COMM = comm2d, INFO = MPI_INFO_NULL )
-#endif
-#endif
-    ENDIF
-
-    CALL netcdf_handle_error( 'netcdf_open_write_file', errno )
-#endif
- END SUBROUTINE netcdf_open_write_file
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Prints out a text message corresponding to the current status.
-!------------------------------------------------------------------------------!
- 
- SUBROUTINE netcdf_handle_error( routine_name, errno )
-#if defined( __netcdf )
-
-
-    USE control_parameters,                                                    &
-        ONLY:  message_string
-
-    IMPLICIT NONE
-
-    CHARACTER(LEN=6) ::  message_identifier
-    CHARACTER(LEN=*) ::  routine_name
-
-    INTEGER(iwp) ::  errno
-
-    IF ( nc_stat /= NF90_NOERR )  THEN
-
-       WRITE( message_identifier, '(''NC'',I4.4)' )  errno
-       message_string = TRIM( NF90_STRERROR( nc_stat ) )
-
-       CALL message( routine_name, message_identifier, 2, 2, 0, 6, 1 )
-
-    ENDIF
-
-#endif
- END SUBROUTINE netcdf_handle_error
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Create a dimension in NetCDF file
-!------------------------------------------------------------------------------!
-
- SUBROUTINE netcdf_create_dim(ncid, dim_name, ncdim_type, ncdim_id, error_no)
-
-#if defined( __netcdf )
-
-    USE kinds
-
-    IMPLICIT NONE
-
-    CHARACTER(LEN=*), INTENT(IN) ::  dim_name
-
-    INTEGER, INTENT(IN)  ::  error_no
-    INTEGER, INTENT(IN)  ::  ncid
-    INTEGER, INTENT(OUT) ::  ncdim_id
-    INTEGER, INTENT(IN)  ::  ncdim_type
-
-!
-!-- Define time coordinate for volume data (unlimited dimension)
-    nc_stat = NF90_DEF_DIM( ncid, dim_name, ncdim_type, ncdim_id )
-    CALL netcdf_handle_error( 'netcdf_create_dim', error_no )
-
-#endif
-
- END SUBROUTINE netcdf_create_dim
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Create a one dimensional variable in specific units in NetCDF file
-!------------------------------------------------------------------------------!
-
- SUBROUTINE netcdf_create_var( ncid, dim_id, var_name, var_type, var_id,       &
-                               unit_name, long_name, error_no1, error_no2,     &
-                               error_no3 )
-
-#if defined( __netcdf )
-    IMPLICIT NONE
-
-    CHARACTER(LEN=*), INTENT(IN) ::  long_name
-    CHARACTER(LEN=*), INTENT(IN) ::  unit_name
-    CHARACTER(LEN=*), INTENT(IN) ::  var_name
-
-    INTEGER, INTENT(IN)  ::  error_no1
-    INTEGER, INTENT(IN)  ::  error_no2
-    INTEGER, INTENT(IN)  ::  error_no3
-    INTEGER, INTENT(IN)  ::  ncid
-    INTEGER, INTENT(OUT) ::  var_id
-    INTEGER, INTENT(IN)  ::  var_type
-
-    INTEGER, DIMENSION(:), INTENT(IN) ::  dim_id
-
-!
-!-- Define variable
-    nc_stat = NF90_DEF_VAR( ncid, var_name, var_type, dim_id, var_id )
-    CALL netcdf_handle_error( 'netcdf_create_var', error_no1 )
-
-#if defined( __netcdf4 )
-!
-!-- Check if variable should be deflate (including shuffling)
-!-- and if it is possible (only NetCDF4 with HDF5 supports compression)
-    IF ( netcdf_data_format > 2  .AND.  netcdf_deflate > 0 )  THEN
-       nc_stat = NF90_DEF_VAR_DEFLATE( ncid, var_id, 1, 1, netcdf_deflate )
-       CALL netcdf_handle_error( 'netcdf_create_var_deflate', error_no1 )
-    ENDIF
-#endif
-!
-!-- Set unit name if set
-    IF ( unit_name /= '' )  THEN
-       nc_stat = NF90_PUT_ATT( ncid, var_id, 'units', unit_name )
-       CALL netcdf_handle_error( 'netcdf_create_var', error_no2 )
-    ENDIF
-
-!
-!-- Set long name if set
-    IF ( long_name /= '' )  THEN
-       nc_stat = NF90_PUT_ATT( ncid, var_id, 'long_name', long_name )
-       CALL netcdf_handle_error( 'netcdf_create_var', error_no3 )
-    ENDIF
-
-#endif
- END SUBROUTINE netcdf_create_var
-
- END MODULE netcdf_interface
Index: /palm/trunk/SOURCE/netcdf_interface_mod.f90
===================================================================
--- /palm/trunk/SOURCE/netcdf_interface_mod.f90	(revision 1850)
+++ /palm/trunk/SOURCE/netcdf_interface_mod.f90	(revision 1850)
@@ -0,0 +1,5130 @@
+!> @file netcdf_interface_mod.f90
+!--------------------------------------------------------------------------------!
+! This file is part of PALM.
+!
+! PALM is free software: you can redistribute it and/or modify it under the terms
+! of the GNU General Public License as published by the Free Software Foundation,
+! either version 3 of the License, or (at your option) any later version.
+!
+! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
+! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
+! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along with
+! PALM. If not, see <http://www.gnu.org/licenses/>.
+!
+! Copyright 1997-2016 Leibniz Universitaet Hannover
+!--------------------------------------------------------------------------------!
+!
+! Current revisions:
+! ------------------
+! Module renamed
+! 
+! 
+! Former revisions:
+! -----------------
+! $Id$
+!
+! 1833 2016-04-07 14:23:03Z raasch
+! spectrum renamed spectra_mod
+!
+! 1786 2016-03-08 05:49:27Z raasch
+! Bugfix: id_var_time_sp made public
+!
+! 1783 2016-03-06 18:36:17Z raasch
+! netcdf interface has been modularized, former file netcdf renamed to
+! netcdf_interface, creation of netcdf-dimensions and -variables moved to
+! specific new subroutines create_netcdf_dim and create_netcdf_var,
+! compression (deflation) of variables implemented,
+! ibmy special cpp directive removed
+!
+! 1745 2016-02-05 13:06:51Z gronemeier
+! Bugfix: recalculating ntdim_3d, ntdim_2d_xy/xz/yz when checking the
+!         extensibility of an existing file (only when using parallel NetCDF). 
+! 
+! 1691 2015-10-26 16:17:44Z maronga
+! Added output of radiative heating rates for RRTMG. Corrected output of 
+! radiative fluxes
+! 
+! 1682 2015-10-07 23:56:08Z knoop
+! Code annotations made doxygen readable 
+! 
+! 1596 2015-05-21 09:34:28Z gronemeier
+! Bugfix in masked data output. Read 'zu_3d' when trying to extend masked data
+! 
+! 1551 2015-03-03 14:18:16Z maronga
+! Added support for land surface model and radiation model output. In the course
+! of this action a new vertical grid zs (soil) was introduced.
+! 
+! 1353 2014-04-08 15:21:23Z heinze
+! REAL constants provided with KIND-attribute
+!
+! 1322 2014-03-20 16:38:49Z raasch
+! Forgotten ONLY-attribute added to USE-statements
+!
+! 1320 2014-03-20 08:40:49Z raasch
+! ONLY-attribute added to USE-statements,
+! kind-parameters added to all INTEGER and REAL declaration statements,
+! kinds are defined in new module kinds,
+! revision history before 2012 removed,
+! comment fields (!:) to be used for variable explanations added to
+! all variable declaration statements
+!
+! 1308 2014-03-13 14:58:42Z fricke
+! +ntime_count, oldmode
+! Adjust NF90_CREATE and NF90_OPEN statement for parallel output
+! To increase the performance for parallel output, the following is done:
+! - Limit time dimension
+! - Values of axis data are only written by PE0
+! - No fill is set for all variables
+! Check the number of output time levels for restart jobs
+!
+! 1206 2013-07-18 12:49:16Z witha
+! Bugfix: typo in preprocessor directive in subroutine open_write_netcdf_file
+!
+! 1092 2013-02-02 11:24:22Z raasch
+! unused variables removed
+!
+! 1053 2012-11-13 17:11:03Z hoffmann
+! +qr, nr, prr
+!
+! 1036 2012-10-22 13:43:42Z raasch
+! code put under GPL (PALM 3.9)
+!
+! 1031 2012-10-19 14:35:30Z raasch
+! netCDF4 without parallel file support implemented, new routines
+! create_netcdf_file and open_write_netcdf_file at end
+!
+! 992 2012-09-05 15:08:26Z hoffmann
+! Removal of the informative messages PA0352 and PA0353.
+!  
+! 983 2012-08-21 14:17:57Z hoffmann
+! Bugfix in cross_profiles.
+!
+! 964 2012-07-26 09:14:24Z raasch
+! rev 951 and 959 reformatted
+!
+! 959 2012-07-24 13:13:41Z hoffmann
+! Bugfix in cross_profiles. It is not allowed to arrange more than 100
+! profiles with cross_profiles. 
+!
+! 951 2012-07-19 14:22:52Z hoffmann
+! cross_profiles, profile_rows, profile_columns are written to netCDF header
+!
+! Revision 1.1  2005/05/18 15:37:16  raasch
+! Initial revision
+!
+!
+! Description:
+! ------------
+!> In case of extend = .FALSE.:
+!> Define all necessary dimensions, axes and variables for the different
+!> netCDF datasets. This subroutine is called from check_open after a new
+!> dataset is created. It leaves the open netCDF files ready to write.
+!>
+!> In case of extend = .TRUE.:
+!> Find out if dimensions and variables of an existing file match the values
+!> of the actual run. If so, get all necessary information (ids, etc.) from
+!> this file.
+!>
+!> Parameter av can assume values 0 (non-averaged data) and 1 (time averaged
+!> data)
+!>
+!> @todo calculation of output time levels for parallel NetCDF still does not
+!>       cover every exception (change of dt_do, end_time in restart)
+!------------------------------------------------------------------------------!
+ MODULE netcdf_interface
+
+    USE control_parameters, ONLY: max_masks
+    USE kinds
+#if defined( __netcdf )
+    USE NETCDF
+#endif
+
+    PRIVATE
+
+    INTEGER(iwp), PARAMETER ::  dopr_norm_num = 7, dopts_num = 29, dots_max = 100
+
+    CHARACTER (LEN=6), DIMENSION(dopr_norm_num) ::  dopr_norm_names =          &
+         (/ 'wpt0  ', 'ws2   ', 'tsw2  ', 'ws3   ', 'ws2tsw', 'wstsw2',        &
+            'z_i   ' /)
+
+    CHARACTER (LEN=6), DIMENSION(dopr_norm_num) ::  dopr_norm_longnames =      &
+         (/ 'wpt0  ', 'w*2   ', 't*w2  ', 'w*3   ', 'w*2t*w', 'w*t*w2',        &
+            'z_i   ' /)
+
+    CHARACTER (LEN=7), DIMENSION(dopts_num) :: dopts_label =                   &
+          (/ 'tnpt   ', 'x_     ', 'y_     ', 'z_     ', 'z_abs  ', 'u      ', &
+             'v      ', 'w      ', 'u"     ', 'v"     ', 'w"     ', 'npt_up ', &
+             'w_up   ', 'w_down ', 'radius ', 'r_min  ', 'r_max  ', 'npt_max', &
+             'npt_min', 'x*2    ', 'y*2    ', 'z*2    ', 'u*2    ', 'v*2    ', &
+             'w*2    ', 'u"2    ', 'v"2    ', 'w"2    ', 'npt*2  ' /)
+
+    CHARACTER (LEN=7), DIMENSION(dopts_num) :: dopts_unit =                    &
+          (/ 'number ', 'm      ', 'm      ', 'm      ', 'm      ', 'm/s    ', &
+             'm/s    ', 'm/s    ', 'm/s    ', 'm/s    ', 'm/s    ', 'number ', &
+             'm/s    ', 'm/s    ', 'm      ', 'm      ', 'm      ', 'number ', &
+             'number ', 'm2     ', 'm2     ', 'm2     ', 'm2/s2  ', 'm2/s2  ', &
+             'm2/s2  ', 'm2/s2  ', 'm2/s2  ', 'm2/s2  ', 'number2' /)
+
+    INTEGER(iwp) ::  dots_num  = 31  !< number of timeseries defined by default
+    INTEGER(iwp) ::  dots_soil = 24  !< starting index for soil-timeseries
+    INTEGER(iwp) ::  dots_rad  = 32  !< starting index for radiation-timeseries
+
+    CHARACTER (LEN=13), DIMENSION(dots_max) :: dots_label =                    &
+          (/ 'E            ', 'E*           ', 'dt           ',                &
+             'u*           ', 'th*          ', 'umax         ',                &
+             'vmax         ', 'wmax         ', 'div_new      ',                &
+             'div_old      ', 'z_i_wpt      ', 'z_i_pt       ',                &
+             'w*           ', 'w"pt"0       ', 'w"pt"        ',                &
+             'wpt          ', 'pt(0)        ', 'pt(z_mo)     ',                &
+             'w"u"0        ', 'w"v"0        ', 'w"q"0        ',                &
+             'ol           ', 'q*           ', 'ghf_eb       ',                &
+             'shf_eb       ', 'qsws_eb      ', 'qsws_liq_eb  ',                &
+             'qsws_soil_eb ', 'qsws_veg_eb  ', 'r_a          ',                &
+             'r_s          ', 'rad_net      ', 'rad_lw_in    ',                &
+             'rad_lw_out   ', 'rad_sw_in    ', 'rad_sw_out   ',                &
+             'rrtm_aldif   ', 'rrtm_aldir   ', 'rrtm_asdif   ',                &
+             'rrtm_asdir   ',                                                  &
+             ( 'unknown      ', i9 = 1, dots_max-40 ) /)
+
+    CHARACTER (LEN=13), DIMENSION(dots_max) :: dots_unit =                     &
+          (/ 'm2/s2        ', 'm2/s2        ', 's            ',                &
+             'm/s          ', 'K            ', 'm/s          ',                &
+             'm/s          ', 'm/s          ', 's-1          ',                &
+             's-1          ', 'm            ', 'm            ',                &
+             'm/s          ', 'K m/s        ', 'K m/s        ',                &
+             'K m/s        ', 'K            ', 'K            ',                &
+             'm2/s2        ', 'm2/s2        ', 'kg m/s       ',                &
+             'm            ', 'kg/kg        ', '             ',                &
+             '             ', '             ', '             ',                &
+             '             ', 'W/m2         ', 's/m          ',                &
+             '             ', 'W/m2         ', 'W/m2         ',                &
+             'W/m2         ', 'W/m2         ', 'W/m2         ',                &
+             '             ', '             ', '             ',                &
+             '             ',                                                  &
+             ( 'unknown      ', i9 = 1, dots_max-40 ) /)
+
+    CHARACTER (LEN=9), DIMENSION(300) ::  dopr_unit = 'unknown'
+
+    CHARACTER (LEN=7), DIMENSION(0:1,100) ::  do2d_unit, do3d_unit
+
+    CHARACTER (LEN=16), DIMENSION(25) ::  prt_var_names = &
+          (/ 'pt_age          ', 'pt_dvrp_size    ', 'pt_origin_x     ', &
+             'pt_origin_y     ', 'pt_origin_z     ', 'pt_radius       ', &
+             'pt_speed_x      ', 'pt_speed_y      ', 'pt_speed_z      ', &
+             'pt_weight_factor', 'pt_x            ', 'pt_y            ', &
+             'pt_z            ', 'pt_color        ', 'pt_group        ', &
+             'pt_tailpoints   ', 'pt_tail_id      ', 'pt_density_ratio', &
+             'pt_exp_arg      ', 'pt_exp_term     ', 'not_used        ', &
+             'not_used        ', 'not_used        ', 'not_used        ', &
+             'not_used        ' /)
+
+    CHARACTER (LEN=16), DIMENSION(25) ::  prt_var_units = &
+          (/ 'seconds         ', 'meters          ', 'meters          ', &
+             'meters          ', 'meters          ', 'meters          ', &
+             'm/s             ', 'm/s             ', 'm/s             ', &
+             'factor          ', 'meters          ', 'meters          ', &
+             'meters          ', 'none            ', 'none            ', &
+             'none            ', 'none            ', 'ratio           ', &
+             'none            ', 'none            ', 'not_used        ', &
+             'not_used        ', 'not_used        ', 'not_used        ', &
+             'not_used        ' /)
+
+    CHARACTER(LEN=20), DIMENSION(11) ::  netcdf_precision = ' '
+    CHARACTER(LEN=40) ::  netcdf_data_format_string
+
+    INTEGER(iwp) ::  id_dim_prtnum, id_dim_time_pr, id_dim_time_prt, &
+                     id_dim_time_pts, id_dim_time_sp, id_dim_time_ts, id_dim_x_sp, &
+                     id_dim_y_sp, id_dim_zu_sp, id_dim_zw_sp, id_set_pr, &
+                     id_set_prt, id_set_pts, id_set_sp, id_set_ts, id_var_prtnum, &
+                     id_var_rnop_prt, id_var_time_pr, id_var_time_prt, &
+                     id_var_time_pts, id_var_time_sp, id_var_time_ts, id_var_x_sp, &
+                     id_var_y_sp, id_var_zu_sp, id_var_zw_sp, nc_stat
+
+    INTEGER(iwp), DIMENSION(0:1) ::  id_dim_time_xy, id_dim_time_xz, &
+                    id_dim_time_yz, id_dim_time_3d, id_dim_x_xy, id_dim_xu_xy, &
+                    id_dim_x_xz, id_dim_xu_xz, id_dim_x_yz, id_dim_xu_yz, &
+                    id_dim_x_3d, id_dim_xu_3d, id_dim_y_xy, id_dim_yv_xy, &
+                    id_dim_y_xz, id_dim_yv_xz, id_dim_y_yz, id_dim_yv_yz, &
+                    id_dim_y_3d, id_dim_yv_3d, id_dim_zs_xy, id_dim_zs_xz, &
+                    id_dim_zs_yz, id_dim_zs_3d, id_dim_zu_xy, id_dim_zu1_xy, &
+                    id_dim_zu_xz, id_dim_zu_yz, id_dim_zu_3d, id_dim_zw_xy, &
+                    id_dim_zw_xz, id_dim_zw_yz, id_dim_zw_3d, id_set_xy, &
+                    id_set_xz, id_set_yz, id_set_3d, id_var_ind_x_yz, &
+                    id_var_ind_y_xz, id_var_ind_z_xy, id_var_time_xy, &
+                    id_var_time_xz, id_var_time_yz, id_var_time_3d, id_var_x_xy, &
+                    id_var_xu_xy, id_var_x_xz, id_var_xu_xz, id_var_x_yz, &
+                    id_var_xu_yz, id_var_x_3d, id_var_xu_3d, id_var_y_xy, &
+                    id_var_yv_xy, id_var_y_xz, id_var_yv_xz, id_var_y_yz, &
+                    id_var_yv_yz, id_var_y_3d, id_var_yv_3d, id_var_zs_xy, &
+                    id_var_zs_xz, id_var_zs_yz, id_var_zs_3d, id_var_zusi_xy, &
+                    id_var_zusi_3d, id_var_zu_xy, id_var_zu1_xy, id_var_zu_xz, &
+                    id_var_zu_yz, id_var_zu_3d, id_var_zwwi_xy, id_var_zwwi_3d, &
+                    id_var_zw_xy, id_var_zw_xz, id_var_zw_yz, id_var_zw_3d
+
+    INTEGER ::  netcdf_data_format = 2  !< NetCDF3 64bit offset format
+    INTEGER ::  netcdf_deflate = 0      !< NetCDF compression, default: no
+                                        !< compression
+
+    INTEGER(iwp), DIMENSION(10)  ::  id_var_dospx, id_var_dospy
+    INTEGER(iwp), DIMENSION(20)  ::  id_var_prt
+    INTEGER(iwp), DIMENSION(11)  ::  nc_precision
+    INTEGER(iwp), DIMENSION(dopr_norm_num) ::  id_var_norm_dopr
+
+    INTEGER(iwp), DIMENSION(dopts_num,0:10) ::  id_var_dopts
+    INTEGER(iwp), DIMENSION(0:1,100)        ::  id_var_do2d, id_var_do3d
+    INTEGER(iwp), DIMENSION(100,0:9)        ::  id_dim_z_pr, id_var_dopr, &
+                                                id_var_z_pr
+    INTEGER(iwp), DIMENSION(dots_max,0:9)   ::  id_var_dots
+
+!
+!-- Masked output
+    CHARACTER (LEN=7), DIMENSION(max_masks,0:1,100) ::  domask_unit
+
+    LOGICAL ::  output_for_t0 = .FALSE.
+
+    INTEGER(iwp), DIMENSION(1:max_masks,0:1) ::  id_dim_time_mask, id_dim_x_mask, &
+                   id_dim_xu_mask, id_dim_y_mask, id_dim_yv_mask, id_dim_zs_mask, &
+                   id_dim_zu_mask, id_dim_zw_mask, &
+                   id_set_mask, &
+                   id_var_time_mask, id_var_x_mask, id_var_xu_mask, &
+                   id_var_y_mask, id_var_yv_mask, id_var_zs_mask, &
+                   id_var_zu_mask, id_var_zw_mask, &
+                   id_var_zusi_mask, id_var_zwwi_mask
+
+    INTEGER(iwp), DIMENSION(1:max_masks,0:1,100) ::  id_var_domask
+
+
+    PUBLIC  domask_unit, dopr_unit, dopts_num, dots_label, dots_max, dots_num, &
+            dots_rad, dots_soil, dots_unit, do2d_unit, do3d_unit, id_set_mask, &
+            id_set_pr, id_set_prt, id_set_pts, id_set_sp, id_set_ts,           &
+            id_set_xy, id_set_xz, id_set_yz, id_set_3d, id_var_domask,         &
+            id_var_dopr, id_var_dopts, id_var_dospx, id_var_dospy,             &
+            id_var_dots, id_var_do2d, id_var_do3d, id_var_norm_dopr,           &
+            id_var_time_mask, id_var_time_pr, id_var_time_pts, id_var_time_sp, &
+            id_var_time_ts, id_var_time_xy, id_var_time_xz, id_var_time_yz,    &
+            id_var_time_3d, nc_stat, netcdf_data_format,                       &
+            netcdf_data_format_string, netcdf_deflate, netcdf_precision,       &
+            output_for_t0
+
+    SAVE
+
+    INTERFACE netcdf_create_dim
+       MODULE PROCEDURE netcdf_create_dim
+    END INTERFACE netcdf_create_dim
+
+    INTERFACE netcdf_create_file
+       MODULE PROCEDURE netcdf_create_file
+    END INTERFACE netcdf_create_file
+
+    INTERFACE netcdf_create_var
+       MODULE PROCEDURE netcdf_create_var
+    END INTERFACE netcdf_create_var
+
+    INTERFACE netcdf_define_header
+       MODULE PROCEDURE netcdf_define_header
+    END INTERFACE netcdf_define_header
+
+    INTERFACE netcdf_handle_error
+       MODULE PROCEDURE netcdf_handle_error
+    END INTERFACE netcdf_handle_error
+
+    INTERFACE netcdf_open_write_file
+       MODULE PROCEDURE netcdf_open_write_file
+    END INTERFACE netcdf_open_write_file
+
+    PUBLIC netcdf_create_file, netcdf_define_header, netcdf_handle_error,      &
+           netcdf_open_write_file
+
+ CONTAINS
+
+ SUBROUTINE netcdf_define_header( callmode, extend, av )
+ 
+#if defined( __netcdf )
+
+    USE arrays_3d,                                                             &
+        ONLY:  zu, zw
+
+    USE constants,                                                             &
+        ONLY:  pi
+
+    USE control_parameters,                                                    &
+        ONLY:  averaging_interval, averaging_interval_pr,                      &
+               data_output_pr,  domask,  dopr_n,        &
+               dopr_time_count, dopts_time_count, dots_time_count,             &
+               do2d, do2d_xz_time_count, do3d,                &
+               do2d_yz_time_count, dt_data_output_av, dt_do2d_xy, dt_do2d_xz,  &
+               dt_do2d_yz, dt_do3d, mask_size, do2d_xy_time_count,             &
+               do3d_time_count, domask_time_count, end_time, mask_i_global,    &
+               mask_j_global, mask_k_global, message_string, mid, ntdim_2d_xy, &
+               ntdim_2d_xz, ntdim_2d_yz, ntdim_3d, nz_do3d, prt_time_count,    &
+               run_description_header, section, simulated_time,                &
+               simulated_time_at_begin, skip_time_data_output_av,              &
+               skip_time_do2d_xy, skip_time_do2d_xz, skip_time_do2d_yz,        &
+               skip_time_do3d, topography
+
+    USE grid_variables,                                                        &
+        ONLY:  dx, dy, zu_s_inner, zw_w_inner
+
+    USE indices,                                                               &
+        ONLY:  nx, ny, nz ,nzb, nzt
+
+    USE kinds
+
+    USE land_surface_model_mod,                                                &
+        ONLY: land_surface, nzb_soil, nzt_soil, nzs, zs
+
+    USE pegrid
+
+    USE particle_attributes,                                                   &
+        ONLY:  maximum_number_of_particles, number_of_particle_groups
+
+    USE profil_parameter,                                                      &
+        ONLY:  crmax, cross_profiles, dopr_index, profile_columns, profile_rows
+
+    USE spectra_mod,                                                           &
+        ONLY:  averaging_interval_sp, comp_spectra_level, data_output_sp, dosp_time_count, spectra_direction
+
+    USE statistics,                                                            &
+        ONLY:  hom, statistic_regions
+
+
+    IMPLICIT NONE
+
+    CHARACTER (LEN=2)              ::  suffix                !<
+    CHARACTER (LEN=2), INTENT (IN) ::  callmode              !<
+    CHARACTER (LEN=3)              ::  suffix1               !<
+    CHARACTER (LEN=4)              ::  grid_x                !<
+    CHARACTER (LEN=4)              ::  grid_y                !<
+    CHARACTER (LEN=4)              ::  grid_z                !<
+    CHARACTER (LEN=6)              ::  mode                  !<
+    CHARACTER (LEN=10)             ::  netcdf_var_name       !<
+    CHARACTER (LEN=10)             ::  precision             !<
+    CHARACTER (LEN=10)             ::  var                   !<
+    CHARACTER (LEN=80)             ::  time_average_text     !<
+    CHARACTER (LEN=2000)           ::  char_cross_profiles   !<
+    CHARACTER (LEN=2000)           ::  var_list              !<
+    CHARACTER (LEN=2000)           ::  var_list_old          !<
+
+    CHARACTER (LEN=100), DIMENSION(1:crmax) ::  cross_profiles_adj   !<
+    CHARACTER (LEN=100), DIMENSION(1:crmax) ::  cross_profiles_char  !<
+
+    INTEGER(iwp) ::  av                                      !<
+    INTEGER(iwp) ::  cross_profiles_count                    !<
+    INTEGER(iwp) ::  cross_profiles_maxi                     !<
+    INTEGER(iwp) ::  delim                                   !<
+    INTEGER(iwp) ::  delim_old                               !<
+    INTEGER(iwp) ::  file_id                                 !<
+    INTEGER(iwp) ::  i                                       !<
+    INTEGER(iwp) ::  id_last                                 !<
+    INTEGER(iwp) ::  id_x                                    !<
+    INTEGER(iwp) ::  id_y                                    !<
+    INTEGER(iwp) ::  id_z                                    !<
+    INTEGER(iwp) ::  j                                       !<
+    INTEGER(iwp) ::  k                                       !<
+    INTEGER(iwp) ::  kk                                      !<
+    INTEGER(iwp) ::  ns                                      !<
+    INTEGER(iwp) ::  ns_do                                   !< actual value of ns for soil model data
+    INTEGER(iwp) ::  ns_old                                  !<
+    INTEGER(iwp) ::  ntime_count                             !< number of time levels found in file
+    INTEGER(iwp) ::  nz_old                                  !<
+
+    INTEGER(iwp), SAVE ::  oldmode                           !<
+
+    INTEGER(iwp), DIMENSION(1) ::  id_dim_time_old           !<
+    INTEGER(iwp), DIMENSION(1) ::  id_dim_x_yz_old           !<
+    INTEGER(iwp), DIMENSION(1) ::  id_dim_y_xz_old           !<
+    INTEGER(iwp), DIMENSION(1) ::  id_dim_zu_sp_old          !<
+    INTEGER(iwp), DIMENSION(1) ::  id_dim_zu_xy_old          !<
+    INTEGER(iwp), DIMENSION(1) ::  id_dim_zu_3d_old          !<
+    INTEGER(iwp), DIMENSION(1) ::  id_dim_zu_mask_old        !<
+
+
+    INTEGER(iwp), DIMENSION(1:crmax) ::  cross_profiles_numb !<
+
+    LOGICAL ::  found                                        !<
+
+    LOGICAL, INTENT (INOUT) ::  extend                       !<
+
+    LOGICAL, SAVE ::  init_netcdf = .FALSE.                  !<
+
+    REAL(wp), DIMENSION(1) ::  last_time_coordinate          !< last time value in file
+
+    REAL(wp), DIMENSION(:), ALLOCATABLE   ::  netcdf_data    !<
+    REAL(wp), DIMENSION(:,:), ALLOCATABLE ::  netcdf_data_2d !<
+
+!
+!-- Initializing actions
+    IF ( .NOT. init_netcdf )  THEN
+!
+!--    Check and set accuracy for netCDF output. First set default value
+       nc_precision = NF90_REAL4
+
+       i = 1
+       DO  WHILE ( netcdf_precision(i) /= ' ' )
+          j = INDEX( netcdf_precision(i), '_' )
+          IF ( j == 0 )  THEN
+             WRITE ( message_string, * ) 'netcdf_precision must contain a ', &
+                                         '"_"netcdf_precision(', i, ')="',   &
+                                         TRIM( netcdf_precision(i) ),'"'
+             CALL message( 'netcdf_define_header', 'PA0241', 2, 2, 0, 6, 0 )
+          ENDIF
+
+          var       = netcdf_precision(i)(1:j-1)
+          precision = netcdf_precision(i)(j+1:)
+
+          IF ( precision == 'NF90_REAL4' )  THEN
+             j = NF90_REAL4
+          ELSEIF ( precision == 'NF90_REAL8' )  THEN
+             j = NF90_REAL8
+          ELSE
+             WRITE ( message_string, * ) 'illegal netcdf precision: ',  &
+                                         'netcdf_precision(', i, ')="', &
+                                         TRIM( netcdf_precision(i) ),'"'
+             CALL message( 'netcdf_define_header', 'PA0242', 1, 2, 0, 6, 0 )
+          ENDIF
+
+          SELECT CASE ( var )
+             CASE ( 'xy' )
+                nc_precision(1) = j
+             CASE ( 'xz' )
+                nc_precision(2) = j
+             CASE ( 'yz' )
+                nc_precision(3) = j
+             CASE ( '2d' )
+                nc_precision(1:3) = j
+             CASE ( '3d' )
+                nc_precision(4) = j
+             CASE ( 'pr' )
+                nc_precision(5) = j
+             CASE ( 'ts' )
+                nc_precision(6) = j
+             CASE ( 'sp' )
+                nc_precision(7) = j
+             CASE ( 'prt' )
+                nc_precision(8) = j
+             CASE ( 'masks' )
+                nc_precision(11) = j
+             CASE ( 'all' )
+                nc_precision    = j
+
+             CASE DEFAULT
+                WRITE ( message_string, * ) 'unknown variable in inipar ',    & 
+                                  'assignment: netcdf_precision(', i, ')="',  &
+                                            TRIM( netcdf_precision(i) ),'"'
+                CALL message( 'netcdf_define_header', 'PA0243', 1, 2, 0, 6, 0 )
+
+          END SELECT
+
+          i = i + 1
+          IF ( i > 50 )  EXIT
+       ENDDO
+
+!
+!--    Check for allowed parameter range
+       IF ( netcdf_deflate < 0  .OR.  netcdf_deflate > 9 )  THEN
+          WRITE ( message_string, '(A,I3,A)' ) 'netcdf_deflate out of ' //     &
+                                      'range & given value: ', netcdf_deflate, &
+                                      ', allowed range: 0-9'
+          CALL message( 'netcdf_define_header', 'PA0355', 2, 2, 0, 6, 0 )
+       ENDIF
+!
+!--    Data compression does not work with parallel NetCDF/HDF5
+       IF ( netcdf_deflate > 0  .AND.  netcdf_data_format /= 3 )  THEN
+          message_string = 'netcdf_deflate reset to 0'
+          CALL message( 'netcdf_define_header', 'PA0356', 0, 1, 0, 6, 0 )
+
+          netcdf_deflate = 0
+       ENDIF
+
+       init_netcdf = .TRUE.
+
+    ENDIF
+
+!
+!-- Determine the mode to be processed
+    IF ( extend )  THEN
+       mode = callmode // '_ext'
+    ELSE
+       mode = callmode // '_new'
+    ENDIF
+
+!
+!-- Select the mode to be processed. Possibilities are 3d, mask, xy, xz, yz, 
+!-- pr and ts.
+    SELECT CASE ( mode )
+
+       CASE ( 'ma_new' )
+
+!
+!--       decompose actual parameter file_id (=formal parameter av) into 
+!--       mid and av
+          file_id = av
+          IF ( file_id <= 200+max_masks )  THEN
+             mid = file_id - 200
+             av = 0
+          ELSE
+             mid = file_id - (200+max_masks)
+             av = 1
+          ENDIF
+
+!
+!--       Define some global attributes of the dataset
+          nc_stat = NF90_PUT_ATT( id_set_mask(mid,av), NF90_GLOBAL, &
+                                  'Conventions', 'COARDS' )
+          CALL netcdf_handle_error( 'netcdf_define_header', 464 )
+
+          IF ( av == 0 )  THEN
+             time_average_text = ' '
+          ELSE
+             WRITE (time_average_text, '('', '',F7.1,'' s average'')') &
+                                                            averaging_interval
+          ENDIF
+          nc_stat = NF90_PUT_ATT( id_set_mask(mid,av), NF90_GLOBAL, 'title', &
+                                  TRIM( run_description_header ) //    &
+                                  TRIM( time_average_text ) )
+          CALL netcdf_handle_error( 'netcdf_define_header', 465 )
+          IF ( av == 1 )  THEN
+             WRITE ( time_average_text,'(F7.1,'' s avg'')' )  averaging_interval
+             nc_stat = NF90_PUT_ATT( id_set_mask(mid,av), NF90_GLOBAL, &
+                                     'time_avg', TRIM( time_average_text ) )
+             CALL netcdf_handle_error( 'netcdf_define_header', 466 )
+          ENDIF
+
+!
+!--       Define time coordinate for volume data (unlimited dimension)
+          CALL netcdf_create_dim( id_set_mask(mid,av), 'time', NF90_UNLIMITED, &
+                                  id_dim_time_mask(mid,av), 467 )
+          CALL netcdf_create_var( id_set_mask(mid,av),                         &
+                                  (/ id_dim_time_mask(mid,av) /), 'time',      &
+                                  NF90_DOUBLE, id_var_time_mask(mid,av),       &
+                                 'seconds', '', 468, 469, 000 )
+!
+!--       Define spatial dimensions and coordinates:
+!--       Define vertical coordinate grid (zu grid)
+          CALL netcdf_create_dim( id_set_mask(mid,av), 'zu_3d',                &
+                                  mask_size(mid,3), id_dim_zu_mask(mid,av),    &
+                                  470 )
+          CALL netcdf_create_var( id_set_mask(mid,av),                         &
+                                  (/ id_dim_zu_mask(mid,av) /), 'zu_3d',       &
+                                  NF90_DOUBLE, id_var_zu_mask(mid,av),         &
+                                  'meters', '', 471, 472, 000 )
+!
+!--       Define vertical coordinate grid (zw grid)
+          CALL netcdf_create_dim( id_set_mask(mid,av), 'zw_3d',                &
+                                  mask_size(mid,3), id_dim_zw_mask(mid,av),    &
+                                  473 )
+          CALL netcdf_create_var( id_set_mask(mid,av),                         &
+                                  (/ id_dim_zw_mask(mid,av) /), 'zw_3d',       &
+                                  NF90_DOUBLE, id_var_zw_mask(mid,av),         &
+                                 'meters', '', 474, 475, 000 )
+!
+!--       Define x-axis (for scalar position)
+          CALL netcdf_create_dim( id_set_mask(mid,av), 'x', mask_size(mid,1),  &
+                                  id_dim_x_mask(mid,av), 476 )
+          CALL netcdf_create_var( id_set_mask(mid,av),                         &
+                                  (/ id_dim_x_mask(mid,av) /), 'x',            &
+                                  NF90_DOUBLE, id_var_x_mask(mid,av),          &
+                                  'meters', '', 477, 478, 000 )
+!
+!--       Define x-axis (for u position)
+          CALL netcdf_create_dim( id_set_mask(mid,av), 'xu', mask_size(mid,1), &
+                                  id_dim_xu_mask(mid,av), 479 )
+          CALL netcdf_create_var( id_set_mask(mid,av),                         &
+                                  (/ id_dim_xu_mask(mid,av) /), 'xu',          &
+                                  NF90_DOUBLE, id_var_xu_mask(mid,av),         &
+                                  'meters', '', 480, 481, 000 )
+!
+!--       Define y-axis (for scalar position)
+          CALL netcdf_create_dim( id_set_mask(mid,av), 'y', mask_size(mid,2),  &
+                                  id_dim_y_mask(mid,av), 482 )
+          CALL netcdf_create_var( id_set_mask(mid,av),                         &
+                                  (/ id_dim_y_mask(mid,av) /), 'y',            &
+                                  NF90_DOUBLE, id_var_y_mask(mid,av),          &
+                                  'meters', '', 483, 484, 000 )
+!
+!--       Define y-axis (for v position)
+          CALL netcdf_create_dim( id_set_mask(mid,av), 'yv', mask_size(mid,2), &
+                                  id_dim_yv_mask(mid,av), 485 )
+          CALL netcdf_create_var( id_set_mask(mid,av),                         &
+                                  (/ id_dim_yv_mask(mid,av) /),                &
+                                  'yv', NF90_DOUBLE, id_var_yv_mask(mid,av),   &
+                                  'meters', '', 486, 487, 000 )
+!
+!--       In case of non-flat topography define 2d-arrays containing the height
+!--       information
+          IF ( TRIM( topography ) /= 'flat' )  THEN
+!
+!--          Define zusi = zu(nzb_s_inner)
+             CALL netcdf_create_var( id_set_mask(mid,av),                      &
+                                     (/ id_dim_x_mask(mid,av),                 &
+                                        id_dim_y_mask(mid,av) /), 'zusi',      &
+                                     NF90_DOUBLE, id_var_zusi_mask(mid,av),    &
+                                     'meters', 'zu(nzb_s_inner)', 488, 489,    &
+                                     490 )
+!             
+!--          Define zwwi = zw(nzb_w_inner)
+             CALL netcdf_create_var( id_set_mask(mid,av),                      &
+                                     (/ id_dim_x_mask(mid,av),                 &
+                                        id_dim_y_mask(mid,av) /), 'zwwi',      &
+                                     NF90_DOUBLE, id_var_zwwi_mask(mid,av),    &
+                                     'meters', 'zw(nzb_w_inner)', 491, 492,    &
+                                     493 )
+          ENDIF             
+ 
+          IF ( land_surface )  THEN
+!
+!--          Define vertical coordinate grid (zw grid)
+             CALL netcdf_create_dim( id_set_mask(mid,av), 'zs_3d',             &
+                                     mask_size(mid,3), id_dim_zs_mask(mid,av), &
+                                     536 )
+             CALL netcdf_create_var( id_set_mask(mid,av),                      &
+                                     (/ id_dim_zs_mask(mid,av) /), 'zs_3d',    &
+                                     NF90_DOUBLE, id_var_zs_mask(mid,av),      &
+                                     'meters', '', 537, 555, 000 )
+          ENDIF
+
+!
+!--       Define the variables
+          var_list = ';'
+          i = 1
+
+          DO WHILE ( domask(mid,av,i)(1:1) /= ' ' )
+
+!
+!--          Check for the grid
+             found = .TRUE.
+             SELECT CASE ( domask(mid,av,i) )
+!
+!--             Most variables are defined on the scalar grid
+                CASE ( 'e', 'lpt', 'nr', 'p', 'pc', 'pr', 'prr', 'pt', 'q',    &
+                       'qc', 'ql', 'ql_c', 'ql_v', 'ql_vp', 'qr', 'qv',        &
+                       'rad_lw_cs_hr', 'rad_lw_hr', 'rad_sw_cs_hr',            &
+                       'rad_sw_hr', 'rho', 's', 'sa', 'vpt'  )
+
+                   grid_x = 'x'
+                   grid_y = 'y'
+                   grid_z = 'zu'
+!
+!--             u grid
+                CASE ( 'u' )
+
+                   grid_x = 'xu'
+                   grid_y = 'y'
+                   grid_z = 'zu'
+!
+!--             v grid
+                CASE ( 'v' )
+
+                   grid_x = 'x'
+                   grid_y = 'yv'
+                   grid_z = 'zu'
+!
+!--             w grid
+                CASE ( 'rad_lw_in', 'rad_lw_out', 'rad_sw_in', 'rad_sw_out',   &
+                       'w' )
+
+                   grid_x = 'x'
+                   grid_y = 'y'
+                   grid_z = 'zw'
+!
+!--             soil grid
+                CASE ( 'm_soil', 't_soil' )
+
+                   grid_x = 'x'
+                   grid_y = 'y'
+                   grid_z = 'zs'
+
+                CASE DEFAULT
+!
+!--                Check for user-defined quantities
+                   CALL user_define_netcdf_grid( domask(mid,av,i), found,      &
+                                                 grid_x, grid_y, grid_z )
+
+                   IF ( .NOT. found )  THEN
+                      WRITE ( message_string, * ) 'no grid defined for',       &
+                           ' variable ', TRIM( domask(mid,av,i) )
+                      CALL message( 'define_netcdf_header', 'PA0244', 0, 1, 0, &
+                                    6, 0 )
+                   ENDIF
+
+             END SELECT
+
+!
+!--          Select the respective dimension ids
+             IF ( grid_x == 'x' )  THEN
+                id_x = id_dim_x_mask(mid,av)
+             ELSEIF ( grid_x == 'xu' )  THEN
+                id_x = id_dim_xu_mask(mid,av)
+             ENDIF
+
+             IF ( grid_y == 'y' )  THEN
+                id_y = id_dim_y_mask(mid,av)
+             ELSEIF ( grid_y == 'yv' )  THEN
+                id_y = id_dim_yv_mask(mid,av)
+             ENDIF
+
+             IF ( grid_z == 'zu' )  THEN
+                id_z = id_dim_zu_mask(mid,av)
+             ELSEIF ( grid_z == 'zw' )  THEN
+                id_z = id_dim_zw_mask(mid,av)
+             ELSEIF ( grid_z == "zs" )  THEN
+                id_z = id_dim_zs_mask(mid,av)
+             ENDIF
+
+!
+!--          Define the grid
+             CALL netcdf_create_var( id_set_mask(mid,av), (/ id_x, id_y, id_z, &
+                                     id_dim_time_mask(mid,av) /),              &
+                                     domask(mid,av,i), nc_precision(11),       &
+                                     id_var_domask(mid,av,i),                  &
+                                     TRIM( domask_unit(mid,av,i) ),            &
+                                     domask(mid,av,i), 494, 495, 496 )
+
+             var_list = TRIM( var_list ) // TRIM( domask(mid,av,i) ) // ';'
+
+             i = i + 1
+
+          ENDDO
+
+!
+!--       No arrays to output
+          IF ( i == 1 )  RETURN
+
+!
+!--       Write the list of variables as global attribute (this is used by
+!--       restart runs and by combine_plot_fields)
+          nc_stat = NF90_PUT_ATT( id_set_mask(mid,av), NF90_GLOBAL, &
+                                  'VAR_LIST', var_list )
+          CALL netcdf_handle_error( 'netcdf_define_header', 497 )
+
+!
+!--       Leave netCDF define mode
+          nc_stat = NF90_ENDDEF( id_set_mask(mid,av) )
+          CALL netcdf_handle_error( 'netcdf_define_header', 498 )
+
+!
+!--       Write data for x (shifted by +dx/2) and xu axis
+          ALLOCATE( netcdf_data(mask_size(mid,1)) )
+
+          netcdf_data = ( mask_i_global(mid,:mask_size(mid,1)) + 0.5_wp ) * dx
+
+          nc_stat = NF90_PUT_VAR( id_set_mask(mid,av), id_var_x_mask(mid,av), &
+                                  netcdf_data, start = (/ 1 /),               &
+                                  count = (/ mask_size(mid,1) /) )
+          CALL netcdf_handle_error( 'netcdf_define_header', 499 )
+
+          netcdf_data = mask_i_global(mid,:mask_size(mid,1)) * dx
+
+          nc_stat = NF90_PUT_VAR( id_set_mask(mid,av), id_var_xu_mask(mid,av),&
+                                  netcdf_data, start = (/ 1 /),               &
+                                  count = (/ mask_size(mid,1) /) )
+          CALL netcdf_handle_error( 'netcdf_define_header', 500 )
+
+          DEALLOCATE( netcdf_data )
+
+!
+!--       Write data for y (shifted by +dy/2) and yv axis
+          ALLOCATE( netcdf_data(mask_size(mid,2)) )
+
+          netcdf_data = ( mask_j_global(mid,:mask_size(mid,2)) + 0.5_wp ) * dy
+
+          nc_stat = NF90_PUT_VAR( id_set_mask(mid,av), id_var_y_mask(mid,av), &
+                                  netcdf_data, start = (/ 1 /),               &
+                                  count = (/ mask_size(mid,2) /))
+          CALL netcdf_handle_error( 'netcdf_define_header', 501 )
+
+          netcdf_data = mask_j_global(mid,:mask_size(mid,2)) * dy
+
+          nc_stat = NF90_PUT_VAR( id_set_mask(mid,av), id_var_yv_mask(mid,av), &
+                                  netcdf_data, start = (/ 1 /),    &
+                                  count = (/ mask_size(mid,2) /))
+          CALL netcdf_handle_error( 'netcdf_define_header', 502 )
+
+          DEALLOCATE( netcdf_data )
+
+!
+!--       Write zu and zw data (vertical axes)
+          ALLOCATE( netcdf_data(mask_size(mid,3)) )
+
+          netcdf_data = zu( mask_k_global(mid,:mask_size(mid,3)) )
+
+          nc_stat = NF90_PUT_VAR( id_set_mask(mid,av), id_var_zu_mask(mid,av), &
+                                  netcdf_data, start = (/ 1 /), &
+                                  count = (/ mask_size(mid,3) /) )
+          CALL netcdf_handle_error( 'netcdf_define_header', 503 )
+
+          netcdf_data = zw( mask_k_global(mid,:mask_size(mid,3)) )
+
+          nc_stat = NF90_PUT_VAR( id_set_mask(mid,av), id_var_zw_mask(mid,av), &
+                                  netcdf_data, start = (/ 1 /), &
+                                  count = (/ mask_size(mid,3) /) )
+          CALL netcdf_handle_error( 'netcdf_define_header', 504 )
+
+          DEALLOCATE( netcdf_data )
+
+!
+!--       In case of non-flat topography write height information
+          IF ( TRIM( topography ) /= 'flat' )  THEN
+
+             ALLOCATE( netcdf_data_2d(mask_size(mid,1),mask_size(mid,2)) )
+             netcdf_data_2d = zu_s_inner( mask_i_global(mid,:mask_size(mid,1)),&
+                                          mask_j_global(mid,:mask_size(mid,2)) )
+
+             nc_stat = NF90_PUT_VAR( id_set_mask(mid,av),         &
+                                     id_var_zusi_mask(mid,av),    &
+                                     netcdf_data_2d,              &
+                                     start = (/ 1, 1 /),          &
+                                     count = (/ mask_size(mid,1), &
+                                                mask_size(mid,2) /) )
+             CALL netcdf_handle_error( 'netcdf_define_header', 505 )
+
+             netcdf_data_2d = zw_w_inner( mask_i_global(mid,:mask_size(mid,1)),&
+                                          mask_j_global(mid,:mask_size(mid,2)) )
+
+             nc_stat = NF90_PUT_VAR( id_set_mask(mid,av),         &
+                                     id_var_zwwi_mask(mid,av),    &
+                                     netcdf_data_2d,              &
+                                     start = (/ 1, 1 /),          &
+                                     count = (/ mask_size(mid,1), &
+                                                mask_size(mid,2) /) )
+             CALL netcdf_handle_error( 'netcdf_define_header', 506 )
+
+             DEALLOCATE( netcdf_data_2d )
+
+          ENDIF
+
+          IF ( land_surface )  THEN
+!
+!--          Write zs data (vertical axes for soil model), use negative values
+!--          to indicate soil depth
+             ALLOCATE( netcdf_data(mask_size(mid,3)) )
+
+             netcdf_data = zs( mask_k_global(mid,:mask_size(mid,3)) )
+
+             nc_stat = NF90_PUT_VAR( id_set_mask(mid,av), id_var_zs_mask(mid,av), &
+                                     netcdf_data, start = (/ 1 /), &
+                                     count = (/ mask_size(mid,3) /) )
+             CALL netcdf_handle_error( 'netcdf_define_header', 538 )
+
+             DEALLOCATE( netcdf_data )
+
+          ENDIF
+
+!
+!--       restore original parameter file_id (=formal parameter av) into av
+          av = file_id
+
+
+       CASE ( 'ma_ext' )
+
+!
+!--       decompose actual parameter file_id (=formal parameter av) into 
+!--       mid and av
+          file_id = av
+          IF ( file_id <= 200+max_masks )  THEN
+             mid = file_id - 200
+             av = 0
+          ELSE
+             mid = file_id - (200+max_masks)
+             av = 1
+          ENDIF
+
+!
+!--       Get the list of variables and compare with the actual run.
+!--       First var_list_old has to be reset, since GET_ATT does not assign
+!--       trailing blanks.
+          var_list_old = ' '
+          nc_stat = NF90_GET_ATT( id_set_mask(mid,av), NF90_GLOBAL, 'VAR_LIST',&
+                                  var_list_old )
+          CALL netcdf_handle_error( 'netcdf_define_header', 507 )
+
+          var_list = ';'
+          i = 1
+          DO WHILE ( domask(mid,av,i)(1:1) /= ' ' )
+             var_list = TRIM(var_list) // TRIM( domask(mid,av,i) ) // ';'
+             i = i + 1
+          ENDDO
+
+          IF ( av == 0 )  THEN
+             var = '(mask)'
+          ELSE
+             var = '(mask_av)'
+          ENDIF
+
+          IF ( TRIM( var_list ) /= TRIM( var_list_old ) )  THEN
+             WRITE ( message_string, * ) 'netCDF file for ', TRIM( var ), &
+                  ' data for mask', mid, ' from previous run found,', &
+                  '&but this file cannot be extended due to variable ', &
+                  'mismatch.&New file is created instead.'
+             CALL message( 'define_netcdf_header', 'PA0335', 0, 1, 0, 6, 0 )
+             extend = .FALSE.
+             RETURN
+          ENDIF
+
+!
+!--       Get and compare the number of vertical gridpoints
+          nc_stat = NF90_INQ_VARID( id_set_mask(mid,av), 'zu_3d', &
+                                    id_var_zu_mask(mid,av) )
+          CALL netcdf_handle_error( 'netcdf_define_header', 508 )
+
+          nc_stat = NF90_INQUIRE_VARIABLE( id_set_mask(mid,av),     &
+                                           id_var_zu_mask(mid,av),  &
+                                           dimids = id_dim_zu_mask_old )
+          CALL netcdf_handle_error( 'netcdf_define_header', 509 )
+          id_dim_zu_mask(mid,av) = id_dim_zu_mask_old(1)
+
+          nc_stat = NF90_INQUIRE_DIMENSION( id_set_mask(mid,av),    &
+                                            id_dim_zu_mask(mid,av), &
+                                            len = nz_old )
+          CALL netcdf_handle_error( 'netcdf_define_header', 510 )
+
+          IF ( mask_size(mid,3) /= nz_old )  THEN
+             WRITE ( message_string, * ) 'netCDF file for ', TRIM( var ), &
+                  ' data for mask', mid, ' from previous run found,', &
+                  '&but this file cannot be extended due to mismatch in ', &
+                  ' number of&vertical grid points.', &
+                  '&New file is created instead.'
+             CALL message( 'define_netcdf_header', 'PA0336', 0, 1, 0, 6, 0 )
+             extend = .FALSE.
+             RETURN
+          ENDIF
+
+!
+!--       Get the id of the time coordinate (unlimited coordinate) and its
+!--       last index on the file. The next time level is plmask..count+1.
+!--       The current time must be larger than the last output time
+!--       on the file.
+          nc_stat = NF90_INQ_VARID( id_set_mask(mid,av), 'time', &
+                                    id_var_time_mask(mid,av) )
+          CALL netcdf_handle_error( 'netcdf_define_header', 511 )
+
+          nc_stat = NF90_INQUIRE_VARIABLE( id_set_mask(mid,av), &
+                                           id_var_time_mask(mid,av), &
+                                           dimids = id_dim_time_old )
+          CALL netcdf_handle_error( 'netcdf_define_header', 512 )
+          id_dim_time_mask(mid,av) = id_dim_time_old(1)
+
+          nc_stat = NF90_INQUIRE_DIMENSION( id_set_mask(mid,av), &
+                                            id_dim_time_mask(mid,av), &
+                                            len = domask_time_count(mid,av) )
+          CALL netcdf_handle_error( 'netcdf_define_header', 513 )
+
+          nc_stat = NF90_GET_VAR( id_set_mask(mid,av), &
+                                  id_var_time_mask(mid,av), &
+                                  last_time_coordinate,              &
+                                  start = (/ domask_time_count(mid,av) /), &
+                                  count = (/ 1 /) )
+          CALL netcdf_handle_error( 'netcdf_define_header', 514 )
+
+          IF ( last_time_coordinate(1) >= simulated_time )  THEN
+             WRITE ( message_string, * ) 'netCDF file for ', TRIM( var ), &
+                  ' data for mask', mid, ' from previous run found,', &
+                  '&but this file cannot be extended because the current ', &
+                  'output time&is less or equal than the last output time ', &
+                  'on this file.&New file is created instead.'
+             CALL message( 'define_netcdf_header', 'PA0337', 0, 1, 0, 6, 0 )
+             domask_time_count(mid,av) = 0
+             extend = .FALSE.
+             RETURN
+          ENDIF
+
+!
+!--       Dataset seems to be extendable.
+!--       Now get the variable ids.
+          i = 1
+          DO WHILE ( domask(mid,av,i)(1:1) /= ' ' )
+             nc_stat = NF90_INQ_VARID( id_set_mask(mid,av), &
+                                       TRIM( domask(mid,av,i) ), &
+                                       id_var_domask(mid,av,i) )
+             CALL netcdf_handle_error( 'netcdf_define_header', 515 )
+             i = i + 1
+          ENDDO
+
+!
+!--       Update the title attribute on file
+!--       In order to avoid 'data mode' errors if updated attributes are larger 
+!--       than their original size, NF90_PUT_ATT is called in 'define mode' 
+!--       enclosed by NF90_REDEF and NF90_ENDDEF calls. This implies a possible 
+!--       performance loss due to data copying; an alternative strategy would be 
+!--       to ensure equal attribute size in a job chain. Maybe revise later.
+          IF ( av == 0 )  THEN
+             time_average_text = ' '
+          ELSE
+             WRITE (time_average_text, '('', '',F7.1,'' s average'')') &
+                                                            averaging_interval
+          ENDIF
+          nc_stat = NF90_REDEF( id_set_mask(mid,av) )
+          CALL netcdf_handle_error( 'netcdf_define_header', 516 )
+          nc_stat = NF90_PUT_ATT( id_set_mask(mid,av), NF90_GLOBAL, 'title', &
+                                  TRIM( run_description_header ) //    &
+                                  TRIM( time_average_text ) )
+          CALL netcdf_handle_error( 'netcdf_define_header', 517 )
+          nc_stat = NF90_ENDDEF( id_set_mask(mid,av) )
+          CALL netcdf_handle_error( 'netcdf_define_header', 518 )
+          WRITE ( message_string, * ) 'netCDF file for ', TRIM( var ), &
+               ' data for mask', mid, ' from previous run found.', &
+               '&This file will be extended.'
+          CALL message( 'define_netcdf_header', 'PA0338', 0, 0, 0, 6, 0 )
+!
+!--       restore original parameter file_id (=formal parameter av) into av
+          av = file_id
+
+
+       CASE ( '3d_new' )
+
+!
+!--       Define some global attributes of the dataset
+          nc_stat = NF90_PUT_ATT( id_set_3d(av), NF90_GLOBAL, 'Conventions', &
+                                  'COARDS' )
+          CALL netcdf_handle_error( 'netcdf_define_header', 62 )
+
+          IF ( av == 0 )  THEN
+             time_average_text = ' '
+          ELSE
+             WRITE (time_average_text, '('', '',F7.1,'' s average'')') &
+                                                            averaging_interval
+          ENDIF
+          nc_stat = NF90_PUT_ATT( id_set_3d(av), NF90_GLOBAL, 'title', &
+                                  TRIM( run_description_header ) //    &
+                                  TRIM( time_average_text ) )
+          CALL netcdf_handle_error( 'netcdf_define_header', 63 )
+          IF ( av == 1 )  THEN
+             WRITE ( time_average_text,'(F7.1,'' s avg'')' )  averaging_interval
+             nc_stat = NF90_PUT_ATT( id_set_3d(av), NF90_GLOBAL, 'time_avg', &
+                                     TRIM( time_average_text ) )
+             CALL netcdf_handle_error( 'netcdf_define_header', 63 )
+          ENDIF
+
+!
+!--       Define time coordinate for volume data.
+!--       For parallel output the time dimensions has to be limited, otherwise
+!--       the performance drops significantly.
+          IF ( netcdf_data_format < 5 )  THEN
+             CALL netcdf_create_dim( id_set_3d(av), 'time', NF90_UNLIMITED,    &
+                                     id_dim_time_3d(av), 64 )
+          ELSE
+             CALL netcdf_create_dim( id_set_3d(av), 'time', ntdim_3d(av),      &
+                                     id_dim_time_3d(av), 523 )
+          ENDIF
+
+          CALL netcdf_create_var( id_set_3d(av), (/ id_dim_time_3d(av) /),     &
+                                  'time', NF90_DOUBLE, id_var_time_3d(av),     &
+                                  'seconds', '', 65, 66, 00 )
+!
+!--       Define spatial dimensions and coordinates:
+!--       Define vertical coordinate grid (zu grid)
+          CALL netcdf_create_dim( id_set_3d(av), 'zu_3d', nz_do3d-nzb+1,       &
+                                  id_dim_zu_3d(av), 67 )
+          CALL netcdf_create_var( id_set_3d(av), (/ id_dim_zu_3d(av) /),       &
+                                  'zu_3d', NF90_DOUBLE, id_var_zu_3d(av),      &
+                                  'meters', '', 68, 69, 00 )
+!
+!--       Define vertical coordinate grid (zw grid)
+          CALL netcdf_create_dim( id_set_3d(av), 'zw_3d', nz_do3d-nzb+1,       &
+                                  id_dim_zw_3d(av), 70 )
+          CALL netcdf_create_var( id_set_3d(av), (/ id_dim_zw_3d(av) /),       &
+                                  'zw_3d', NF90_DOUBLE, id_var_zw_3d(av),      &
+                                  'meters', '', 71, 72, 00 )
+!
+!--       Define x-axis (for scalar position)
+          CALL netcdf_create_dim( id_set_3d(av), 'x', nx+2, id_dim_x_3d(av),   &
+                                  73 )
+          CALL netcdf_create_var( id_set_3d(av), (/ id_dim_x_3d(av) /), 'x',   &
+                                  NF90_DOUBLE, id_var_x_3d(av), 'meters', '',  &
+                                  74, 75, 00 )
+!
+!--       Define x-axis (for u position)
+          CALL netcdf_create_dim( id_set_3d(av), 'xu', nx+2, id_dim_xu_3d(av), &
+                                  358 )
+          CALL netcdf_create_var( id_set_3d(av), (/ id_dim_xu_3d(av) /), 'xu', &
+                                  NF90_DOUBLE, id_var_xu_3d(av), 'meters', '', &
+                                  359, 360, 000 )
+!
+!--       Define y-axis (for scalar position)
+          CALL netcdf_create_dim( id_set_3d(av), 'y', ny+2, id_dim_y_3d(av),   &
+                                  76 )
+          CALL netcdf_create_var( id_set_3d(av), (/ id_dim_y_3d(av) /), 'y',   &
+                                  NF90_DOUBLE, id_var_y_3d(av), 'meters', '',  &
+                                  77, 78, 00 )
+!
+!--       Define y-axis (for v position)
+          CALL netcdf_create_dim( id_set_3d(av), 'yv', ny+2, id_dim_yv_3d(av), &
+                                  361 )
+          CALL netcdf_create_var( id_set_3d(av), (/ id_dim_yv_3d(av) /), 'yv', &
+                                  NF90_DOUBLE, id_var_yv_3d(av), 'meters', '', &
+                                  362, 363, 000 )
+!
+!--       In case of non-flat topography define 2d-arrays containing the height
+!--       information
+          IF ( TRIM( topography ) /= 'flat' )  THEN
+!
+!--          Define zusi = zu(nzb_s_inner)
+             CALL netcdf_create_var( id_set_3d(av), (/ id_dim_x_3d(av),        &
+                                     id_dim_y_3d(av) /), 'zusi', NF90_DOUBLE,  &
+                                     id_var_zusi_3d(av), 'meters',             &
+                                     'zu(nzb_s_inner)', 413, 414, 415 )
+!             
+!--          Define zwwi = zw(nzb_w_inner)
+             CALL netcdf_create_var( id_set_3d(av), (/ id_dim_x_3d(av),        &
+                                     id_dim_y_3d(av) /), 'zwwi', NF90_DOUBLE,  &
+                                     id_var_zwwi_3d(av), 'meters',             &
+                                     'zw(nzb_w_inner)', 416, 417, 418 )
+
+          ENDIF             
+
+          IF ( land_surface )  THEN
+!
+!--          Define vertical coordinate grid (zs grid)
+             CALL netcdf_create_dim( id_set_3d(av), 'zs_3d',                   &
+                                     nzt_soil-nzb_soil+1, id_dim_zs_3d(av), 70 )
+             CALL netcdf_create_var( id_set_3d(av), (/ id_dim_zs_3d(av) /),    &
+                                     'zs_3d', NF90_DOUBLE, id_var_zs_3d(av),   &
+                                     'meters', '', 71, 72, 00 )
+
+          ENDIF
+
+!
+!--       Define the variables
+          var_list = ';'
+          i = 1
+
+          DO WHILE ( do3d(av,i)(1:1) /= ' ' )
+
+!
+!--          Check for the grid
+             found = .TRUE.
+             SELECT CASE ( do3d(av,i) )
+!
+!--             Most variables are defined on the scalar grid
+                CASE ( 'e', 'lpt', 'nr', 'p', 'pc', 'pr', 'prr', 'pt', 'q',    &
+                       'qc', 'ql', 'ql_c', 'ql_v', 'ql_vp', 'qr', 'qv', 'rho', &
+                       's', 'sa', 'vpt' , 'rad_lw_cs_hr', 'rad_lw_hr',         &
+                       'rad_sw_cs_hr', 'rad_sw_hr' )
+
+                   grid_x = 'x'
+                   grid_y = 'y'
+                   grid_z = 'zu'
+!
+!--             u grid
+                CASE ( 'u' )
+
+                   grid_x = 'xu'
+                   grid_y = 'y'
+                   grid_z = 'zu'
+!
+!--             v grid
+                CASE ( 'v' )
+
+                   grid_x = 'x'
+                   grid_y = 'yv'
+                   grid_z = 'zu'
+!
+!--             w grid
+                CASE ( 'rad_lw_in', 'rad_lw_out', 'rad_sw_in', 'rad_sw_out',   &
+                       'w' )
+
+                   grid_x = 'x'
+                   grid_y = 'y'
+                   grid_z = 'zw'
+!
+!--             soil grid
+                CASE ( 'm_soil', 't_soil' )
+
+                   grid_x = 'x'
+                   grid_y = 'y'
+                   grid_z = 'zs'
+
+                CASE DEFAULT
+!
+!--                Check for user-defined quantities
+                   CALL user_define_netcdf_grid( do3d(av,i), found, grid_x, &
+                                                 grid_y, grid_z )
+
+                   IF ( .NOT. found )  THEN
+                      WRITE ( message_string, * ) 'no grid defined for varia', &
+                                                  'ble ', TRIM( do3d(av,i) )
+                      CALL message( 'define_netcdf_header', 'PA0244', 0, 1, 0, &
+                                    6, 0 )
+                   ENDIF
+
+             END SELECT
+
+!
+!--          Select the respective dimension ids
+             IF ( grid_x == 'x' )  THEN
+                id_x = id_dim_x_3d(av)
+             ELSEIF ( grid_x == 'xu' )  THEN
+                id_x = id_dim_xu_3d(av)
+             ENDIF
+
+             IF ( grid_y == 'y' )  THEN
+                id_y = id_dim_y_3d(av)
+             ELSEIF ( grid_y == 'yv' )  THEN
+                id_y = id_dim_yv_3d(av)
+             ENDIF
+
+             IF ( grid_z == 'zu' )  THEN
+                id_z = id_dim_zu_3d(av)
+             ELSEIF ( grid_z == 'zw' )  THEN
+                id_z = id_dim_zw_3d(av)
+             ELSEIF ( grid_z == 'zs' )  THEN
+                id_z = id_dim_zs_3d(av)
+             ENDIF
+
+!
+!--          Define the grid
+             CALL netcdf_create_var( id_set_3d(av),(/ id_x, id_y, id_z,        &
+                                     id_dim_time_3d(av) /), do3d(av,i),        &
+                                     nc_precision(4), id_var_do3d(av,i),       &
+                                     TRIM( do3d_unit(av,i) ), do3d(av,i), 79,  &
+                                     80, 357 )
+#if defined( __netcdf4_parallel )
+             IF ( netcdf_data_format > 4 )  THEN
+!
+!--             Set no fill for every variable to increase performance.
+                nc_stat = NF90_DEF_VAR_FILL( id_set_3d(av),     &
+                                             id_var_do3d(av,i), &
+                                             1, 0 )
+                CALL netcdf_handle_error( 'netcdf_define_header', 532 )
+!
+!--             Set collective io operations for parallel io
+                nc_stat = NF90_VAR_PAR_ACCESS( id_set_3d(av),     &
+                                               id_var_do3d(av,i), &
+                                               NF90_COLLECTIVE )
+                CALL netcdf_handle_error( 'netcdf_define_header', 445 )
+             ENDIF
+#endif
+             var_list = TRIM( var_list ) // TRIM( do3d(av,i) ) // ';'
+
+             i = i + 1
+
+          ENDDO
+
+!
+!--       No arrays to output
+          IF ( i == 1 )  RETURN
+
+!
+!--       Write the list of variables as global attribute (this is used by
+!--       restart runs and by combine_plot_fields)
+          nc_stat = NF90_PUT_ATT( id_set_3d(av), NF90_GLOBAL, 'VAR_LIST', &
+                                  var_list )
+          CALL netcdf_handle_error( 'netcdf_define_header', 81 )
+
+!
+!--       Set general no fill, otherwise the performance drops significantly for
+!--       parallel output.
+          nc_stat = NF90_SET_FILL( id_set_3d(av), NF90_NOFILL, oldmode )
+          CALL netcdf_handle_error( 'netcdf_define_header', 528 )
+
+!
+!--       Leave netCDF define mode
+          nc_stat = NF90_ENDDEF( id_set_3d(av) )
+          CALL netcdf_handle_error( 'netcdf_define_header', 82 )
+
+!
+!--       These data are only written by PE0 for parallel output to increase
+!--       the performance.
+          IF ( myid == 0  .OR.  netcdf_data_format < 5 )  THEN
+!
+!--          Write data for x (shifted by +dx/2) and xu axis
+             ALLOCATE( netcdf_data(0:nx+1) )
+
+             DO  i = 0, nx+1
+                netcdf_data(i) = ( i + 0.5 ) * dx
+             ENDDO
+
+             nc_stat = NF90_PUT_VAR( id_set_3d(av), id_var_x_3d(av),  &
+                                     netcdf_data, start = (/ 1 /),    &
+                                     count = (/ nx+2 /) )
+             CALL netcdf_handle_error( 'netcdf_define_header', 83 )
+
+             DO  i = 0, nx+1
+                netcdf_data(i) = i * dx
+             ENDDO
+
+             nc_stat = NF90_PUT_VAR( id_set_3d(av), id_var_xu_3d(av), &
+                                     netcdf_data, start = (/ 1 /),    &
+                                     count = (/ nx+2 /) )
+             CALL netcdf_handle_error( 'netcdf_define_header', 385 )
+
+             DEALLOCATE( netcdf_data )
+
+!
+!--          Write data for y (shifted by +dy/2) and yv axis
+             ALLOCATE( netcdf_data(0:ny+1) )
+
+             DO  i = 0, ny+1
+                netcdf_data(i) = ( i + 0.5_wp ) * dy
+             ENDDO
+
+             nc_stat = NF90_PUT_VAR( id_set_3d(av), id_var_y_3d(av),  &
+                                     netcdf_data, start = (/ 1 /),    &
+                                     count = (/ ny+2 /) )
+             CALL netcdf_handle_error( 'netcdf_define_header', 84 )
+
+             DO  i = 0, ny+1
+                netcdf_data(i) = i * dy
+             ENDDO
+
+             nc_stat = NF90_PUT_VAR( id_set_3d(av), id_var_yv_3d(av), &
+                                     netcdf_data, start = (/ 1 /),    &
+                                     count = (/ ny+2 /))
+             CALL netcdf_handle_error( 'netcdf_define_header', 387 )
+
+             DEALLOCATE( netcdf_data )
+
+!
+!--          Write zu and zw data (vertical axes)
+             nc_stat = NF90_PUT_VAR( id_set_3d(av), id_var_zu_3d(av),  &
+                                     zu(nzb:nz_do3d), start = (/ 1 /), &
+                                     count = (/ nz_do3d-nzb+1 /) )
+             CALL netcdf_handle_error( 'netcdf_define_header', 85 )
+
+
+             nc_stat = NF90_PUT_VAR( id_set_3d(av), id_var_zw_3d(av),  &
+                                     zw(nzb:nz_do3d), start = (/ 1 /), &
+                                     count = (/ nz_do3d-nzb+1 /) )
+             CALL netcdf_handle_error( 'netcdf_define_header', 86 )
+
+!
+!--          In case of non-flat topography write height information
+             IF ( TRIM( topography ) /= 'flat' )  THEN
+
+                nc_stat = NF90_PUT_VAR( id_set_3d(av), id_var_zusi_3d(av), &
+                                        zu_s_inner(0:nx+1,0:ny+1), &
+                                        start = (/ 1, 1 /), &
+                                        count = (/ nx+2, ny+2 /) )
+                CALL netcdf_handle_error( 'netcdf_define_header', 419 )
+
+                nc_stat = NF90_PUT_VAR( id_set_3d(av), id_var_zwwi_3d(av), &
+                                        zw_w_inner(0:nx+1,0:ny+1), &
+                                        start = (/ 1, 1 /), &
+                                        count = (/ nx+2, ny+2 /) )
+                CALL netcdf_handle_error( 'netcdf_define_header', 420 )
+
+             ENDIF
+
+             IF ( land_surface )  THEN
+!
+!--             Write zs grid
+                nc_stat = NF90_PUT_VAR( id_set_3d(av), id_var_zs_3d(av),  &
+                                        - zs(nzb_soil:nzt_soil), start = (/ 1 /), &
+                                        count = (/ nzt_soil-nzb_soil+1 /) )
+                CALL netcdf_handle_error( 'netcdf_define_header', 86 )
+             ENDIF
+
+          ENDIF
+
+       CASE ( '3d_ext' )
+
+!
+!--       Get the list of variables and compare with the actual run.
+!--       First var_list_old has to be reset, since GET_ATT does not assign
+!--       trailing blanks.
+          var_list_old = ' '
+          nc_stat = NF90_GET_ATT( id_set_3d(av), NF90_GLOBAL, 'VAR_LIST', &
+                                  var_list_old )
+          CALL netcdf_handle_error( 'netcdf_define_header', 87 )
+
+          var_list = ';'
+          i = 1
+          DO WHILE ( do3d(av,i)(1:1) /= ' ' )
+             var_list = TRIM(var_list) // TRIM( do3d(av,i) ) // ';'
+             i = i + 1
+          ENDDO
+
+          IF ( av == 0 )  THEN
+             var = '(3d)'
+          ELSE
+             var = '(3d_av)'
+          ENDIF
+
+          IF ( TRIM( var_list ) /= TRIM( var_list_old ) )  THEN
+             message_string = 'netCDF file for volume data ' //             &
+                              TRIM( var ) // ' from previous run found,' // &
+                              '&but this file cannot be extended due to' // &
+                              ' variable mismatch.' //                      &
+                              '&New file is created instead.'
+             CALL message( 'define_netcdf_header', 'PA0245', 0, 1, 0, 6, 0 )
+             extend = .FALSE.
+             RETURN
+          ENDIF
+
+!
+!--       Get and compare the number of vertical gridpoints
+          nc_stat = NF90_INQ_VARID( id_set_3d(av), 'zu_3d', id_var_zu_3d(av) )
+          CALL netcdf_handle_error( 'netcdf_define_header', 88 )
+
+          nc_stat = NF90_INQUIRE_VARIABLE( id_set_3d(av), id_var_zu_3d(av), &
+                                           dimids = id_dim_zu_3d_old )
+          CALL netcdf_handle_error( 'netcdf_define_header', 89 )
+          id_dim_zu_3d(av) = id_dim_zu_3d_old(1)
+
+          nc_stat = NF90_INQUIRE_DIMENSION( id_set_3d(av), id_dim_zu_3d(av), &
+                                            len = nz_old )
+          CALL netcdf_handle_error( 'netcdf_define_header', 90 )
+
+          IF ( nz_do3d-nzb+1 /= nz_old )  THEN
+              message_string = 'netCDF file for volume data ' //             &
+                               TRIM( var ) // ' from previous run found,' // &
+                               '&but this file cannot be extended due to' // &
+                               ' mismatch in number of' //                   &
+                               '&vertical grid points (nz_do3d).' //         &
+                               '&New file is created instead.'
+             CALL message( 'define_netcdf_header', 'PA0246', 0, 1, 0, 6, 0 )
+             extend = .FALSE.
+             RETURN
+          ENDIF
+
+!
+!--       Get the id of the time coordinate (unlimited coordinate) and its
+!--       last index on the file. The next time level is pl3d..count+1.
+!--       The current time must be larger than the last output time
+!--       on the file.
+          nc_stat = NF90_INQ_VARID( id_set_3d(av), 'time', id_var_time_3d(av) )
+          CALL netcdf_handle_error( 'netcdf_define_header', 91 )
+
+          nc_stat = NF90_INQUIRE_VARIABLE( id_set_3d(av), id_var_time_3d(av), &
+                                           dimids = id_dim_time_old )
+          CALL netcdf_handle_error( 'netcdf_define_header', 92 )
+
+          id_dim_time_3d(av) = id_dim_time_old(1)
+
+          nc_stat = NF90_INQUIRE_DIMENSION( id_set_3d(av), id_dim_time_3d(av), &
+                                            len = ntime_count )
+          CALL netcdf_handle_error( 'netcdf_define_header', 93 )
+
+!
+!--       For non-parallel output use the last output time level of the netcdf
+!--       file because the time dimension is unlimited. In case of parallel
+!--       output the variable ntime_count could get the value of 9*10E36 because
+!--       the time dimension is limited.
+          IF ( netcdf_data_format < 5 ) do3d_time_count(av) = ntime_count
+
+          nc_stat = NF90_GET_VAR( id_set_3d(av), id_var_time_3d(av), &
+                                  last_time_coordinate,              &
+                                  start = (/ do3d_time_count(av) /), &
+                                  count = (/ 1 /) )
+          CALL netcdf_handle_error( 'netcdf_define_header', 94 )
+
+          IF ( last_time_coordinate(1) >= simulated_time )  THEN
+             message_string = 'netCDF file for volume data ' // &
+                              TRIM( var ) // ' from previous run found,' // &
+                              '&but this file cannot be extended becaus' // &
+                              'e the current output time' //                &
+                              '&is less or equal than the last output t' // &
+                              'ime on this file.' //                        &
+                              '&New file is created instead.'
+             CALL message( 'define_netcdf_header', 'PA0247', 0, 1, 0, 6, 0 )
+             do3d_time_count(av) = 0
+             extend = .FALSE.
+             RETURN
+          ENDIF
+
+          IF ( netcdf_data_format > 4 )  THEN
+!
+!--          Set needed time levels (ntdim) to 
+!--          saved time levels + to be saved time levels.
+             IF ( av == 0 )  THEN 
+                ntdim_3d(0) = do3d_time_count(0) + CEILING(                &
+                              ( end_time - MAX( skip_time_do3d,            &
+                                                simulated_time_at_begin )  &
+                              ) / dt_do3d )
+             ELSE
+                ntdim_3d(1) = do3d_time_count(1) + CEILING(                &
+                              ( end_time - MAX( skip_time_data_output_av,  &
+                                                simulated_time_at_begin )  &
+                              ) / dt_data_output_av )
+             ENDIF
+
+!
+!--          Check if the needed number of output time levels is increased
+!--          compared to the number of time levels in the existing file.
+             IF ( ntdim_3d(av) > ntime_count )  THEN
+                message_string = 'netCDF file for volume data ' // &
+                                 TRIM( var ) // ' from previous run found,' // &
+                                 '&but this file cannot be extended becaus' // &
+                                 'e the number of output time levels&has b' // &
+                                 'een increased compared to the previous s' // &
+                                 'imulation.' //                               &
+                                 '&New file is created instead.'
+                CALL message( 'define_netcdf_header', 'PA0388', 0, 1, 0, 6, 0 )
+                do3d_time_count(av) = 0
+                extend = .FALSE.
+!
+!--             Recalculate the needed time levels for the new file.
+                IF ( av == 0 )  THEN
+                   ntdim_3d(0) = CEILING(                               &
+                           ( end_time - MAX( skip_time_do3d,            &
+                                             simulated_time_at_begin )  &
+                           ) / dt_do3d )
+                ELSE
+                   ntdim_3d(1) = CEILING(                               &
+                           ( end_time - MAX( skip_time_data_output_av,  &
+                                             simulated_time_at_begin )  &
+                           ) / dt_data_output_av )
+                ENDIF
+                RETURN
+             ENDIF
+          ENDIF
+
+!
+!--       Dataset seems to be extendable.
+!--       Now get the variable ids.
+          i = 1
+          DO WHILE ( do3d(av,i)(1:1) /= ' ' )
+             nc_stat = NF90_INQ_VARID( id_set_3d(av), TRIM( do3d(av,i) ), &
+                                       id_var_do3d(av,i) )
+             CALL netcdf_handle_error( 'netcdf_define_header', 95 )
+#if defined( __netcdf4_parallel )
+!
+!--          Set collective io operations for parallel io
+             IF ( netcdf_data_format > 4 )  THEN
+                nc_stat = NF90_VAR_PAR_ACCESS( id_set_3d(av),     &
+                                               id_var_do3d(av,i), &
+                                               NF90_COLLECTIVE )
+                CALL netcdf_handle_error( 'netcdf_define_header', 453 )
+             ENDIF
+#endif
+             i = i + 1
+          ENDDO
+
+!
+!--       Update the title attribute on file
+!--       In order to avoid 'data mode' errors if updated attributes are larger 
+!--       than their original size, NF90_PUT_ATT is called in 'define mode' 
+!--       enclosed by NF90_REDEF and NF90_ENDDEF calls. This implies a possible 
+!--       performance loss due to data copying; an alternative strategy would be 
+!--       to ensure equal attribute size. Maybe revise later.
+          IF ( av == 0 )  THEN
+             time_average_text = ' '
+          ELSE
+             WRITE (time_average_text, '('', '',F7.1,'' s average'')') &
+                                                            averaging_interval
+          ENDIF
+          nc_stat = NF90_REDEF( id_set_3d(av) )
+          CALL netcdf_handle_error( 'netcdf_define_header', 429 )
+          nc_stat = NF90_PUT_ATT( id_set_3d(av), NF90_GLOBAL, 'title', &
+                                  TRIM( run_description_header ) //    &
+                                  TRIM( time_average_text ) )
+          CALL netcdf_handle_error( 'netcdf_define_header', 96 )
+          nc_stat = NF90_ENDDEF( id_set_3d(av) )
+          CALL netcdf_handle_error( 'netcdf_define_header', 430 )
+          message_string = 'netCDF file for volume data ' //             &
+                           TRIM( var ) // ' from previous run found.' // &
+                           '&This file will be extended.'
+          CALL message( 'define_netcdf_header', 'PA0248', 0, 0, 0, 6, 0 )
+
+       CASE ( 'xy_new' )
+
+!
+!--       Define some global attributes of the dataset
+          nc_stat = NF90_PUT_ATT( id_set_xy(av), NF90_GLOBAL, 'Conventions', &
+                                  'COARDS' )
+          CALL netcdf_handle_error( 'netcdf_define_header', 97 )
+
+          IF ( av == 0 )  THEN
+             time_average_text = ' '
+          ELSE
+             WRITE (time_average_text, '('', '',F7.1,'' s average'')') &
+                                                            averaging_interval
+          ENDIF
+          nc_stat = NF90_PUT_ATT( id_set_xy(av), NF90_GLOBAL, 'title', &
+                                  TRIM( run_description_header ) //    &
+                                  TRIM( time_average_text ) )
+          CALL netcdf_handle_error( 'netcdf_define_header', 98 )
+          IF ( av == 1 )  THEN
+             WRITE ( time_average_text,'(F7.1,'' s avg'')' )  averaging_interval
+             nc_stat = NF90_PUT_ATT( id_set_xy(av), NF90_GLOBAL, 'time_avg', &
+                                     TRIM( time_average_text ) )
+             CALL netcdf_handle_error( 'netcdf_define_header', 98 )
+          ENDIF
+
+!
+!--       Define time coordinate for xy sections.
+!--       For parallel output the time dimensions has to be limited, otherwise
+!--       the performance drops significantly.
+          IF ( netcdf_data_format < 5 )  THEN
+             CALL netcdf_create_dim( id_set_xy(av), 'time', NF90_UNLIMITED,    &
+                                     id_dim_time_xy(av), 99 )
+          ELSE
+             CALL netcdf_create_dim( id_set_xy(av), 'time', ntdim_2d_xy(av),   &
+                                     id_dim_time_xy(av), 524 )
+          ENDIF
+
+          CALL netcdf_create_var( id_set_xy(av), (/ id_dim_time_xy(av) /),     &
+                                  'time', NF90_DOUBLE, id_var_time_xy(av),     &
+                                  'seconds', '', 100, 101, 000 )
+!
+!--       Define the spatial dimensions and coordinates for xy-sections.
+!--       First, determine the number of horizontal sections to be written.
+          IF ( section(1,1) == -9999 )  THEN
+             RETURN
+          ELSE
+             ns = 1
+             DO WHILE ( section(ns,1) /= -9999  .AND.  ns <= 100 )
+                ns = ns + 1
+             ENDDO
+             ns = ns - 1
+          ENDIF
+
+!
+!--       Define vertical coordinate grid (zu grid)
+          CALL netcdf_create_dim( id_set_xy(av), 'zu_xy', ns,                  &
+                                  id_dim_zu_xy(av), 102 )
+          CALL netcdf_create_var( id_set_xy(av), (/ id_dim_zu_xy(av) /),       &
+                                  'zu_xy', NF90_DOUBLE, id_var_zu_xy(av),      &
+                                  'meters', '', 103, 104, 000 )
+!
+!--       Define vertical coordinate grid (zw grid)
+          CALL netcdf_create_dim( id_set_xy(av), 'zw_xy', ns,                  &
+                                  id_dim_zw_xy(av), 105 )
+          CALL netcdf_create_var( id_set_xy(av), (/ id_dim_zw_xy(av) /),       &
+                                  'zw_xy', NF90_DOUBLE, id_var_zw_xy(av),      &
+                                  'meters', '', 106, 107, 000 )
+
+          IF ( land_surface )  THEN
+
+             ns_do = 0
+             DO WHILE ( section(ns_do+1,1) < nzs )
+                ns_do = ns_do + 1
+             ENDDO
+!
+!--          Define vertical coordinate grid (zs grid)
+             CALL netcdf_create_dim( id_set_xy(av), 'zs_xy', ns_do,            &
+                                     id_dim_zs_xy(av), 539 )
+             CALL netcdf_create_var( id_set_xy(av), (/ id_dim_zs_xy(av) /),    &
+                                     'zs_xy', NF90_DOUBLE, id_var_zs_xy(av),   &
+                                     'meters', '', 540, 541, 000 )
+
+          ENDIF
+
+!
+!--       Define a pseudo vertical coordinate grid for the surface variables
+!--       u* and t* to store their height level
+          CALL netcdf_create_dim( id_set_xy(av), 'zu1_xy', 1,                  &
+                                  id_dim_zu1_xy(av), 108 )
+          CALL netcdf_create_var( id_set_xy(av), (/ id_dim_zu1_xy(av) /),      &
+                                  'zu1_xy', NF90_DOUBLE, id_var_zu1_xy(av),    &
+                                  'meters', '', 109, 110, 000 )
+!
+!--       Define a variable to store the layer indices of the horizontal cross
+!--       sections, too
+          CALL netcdf_create_var( id_set_xy(av), (/ id_dim_zu_xy(av) /),       &
+                                  'ind_z_xy', NF90_DOUBLE,                     &
+                                  id_var_ind_z_xy(av), 'gridpoints', '', 111,  &
+                                  112, 000 )
+!
+!--       Define x-axis (for scalar position)
+          CALL netcdf_create_dim( id_set_xy(av), 'x', nx+2, id_dim_x_xy(av),   &
+                                  113 )
+          CALL netcdf_create_var( id_set_xy(av), (/ id_dim_x_xy(av) /), 'x',   &
+                                  NF90_DOUBLE, id_var_x_xy(av), 'meters', '',  &
+                                  114, 115, 000 )
+!
+!--       Define x-axis (for u position)
+          CALL netcdf_create_dim( id_set_xy(av), 'xu', nx+2,                   &
+                                  id_dim_xu_xy(av), 388 )
+          CALL netcdf_create_var( id_set_xy(av), (/ id_dim_xu_xy(av) /), 'xu', &
+                                  NF90_DOUBLE, id_var_xu_xy(av), 'meters', '', &
+                                  389, 390, 000 )
+!
+!--       Define y-axis (for scalar position)
+          CALL netcdf_create_dim( id_set_xy(av), 'y', ny+2, id_dim_y_xy(av),   &
+                                  116 )
+          CALL netcdf_create_var( id_set_xy(av), (/ id_dim_y_xy(av) /), 'y',   &
+                                  NF90_DOUBLE, id_var_y_xy(av), 'meters', '',  &
+                                  117, 118, 000 )
+!
+!--       Define y-axis (for scalar position)
+          CALL netcdf_create_dim( id_set_xy(av), 'yv', ny+2,                   &
+                                  id_dim_yv_xy(av), 364 )
+          CALL netcdf_create_var( id_set_xy(av), (/ id_dim_yv_xy(av) /), 'yv', &
+                                  NF90_DOUBLE, id_var_yv_xy(av), 'meters', '', &
+                                  365, 366, 000 )
+!
+!--       In case of non-flat topography define 2d-arrays containing the height
+!--       information
+          IF ( TRIM( topography ) /= 'flat' )  THEN
+!
+!--          Define zusi = zu(nzb_s_inner)
+             CALL netcdf_create_var( id_set_xy(av), (/ id_dim_x_xy(av),        &
+                                     id_dim_y_xy(av) /), 'zusi', NF90_DOUBLE,  &
+                                     id_var_zusi_xy(av), 'meters',             &
+                                     'zu(nzb_s_inner)', 421, 422, 423 )
+!             
+!--          Define zwwi = zw(nzb_w_inner)
+             CALL netcdf_create_var( id_set_xy(av), (/ id_dim_x_xy(av),        &
+                                     id_dim_y_xy(av) /), 'zwwi', NF90_DOUBLE,  &
+                                     id_var_zwwi_xy(av), 'meters',             &
+                                     'zw(nzb_w_inner)', 424, 425, 426 )
+
+          ENDIF
+
+!
+!--       Define the variables
+          var_list = ';'
+          i = 1
+
+          DO WHILE ( do2d(av,i)(1:1) /= ' ' )
+
+             IF ( INDEX( do2d(av,i), 'xy' ) /= 0 )  THEN
+!
+!--             If there is a star in the variable name (u* or t*), it is a
+!--             surface variable. Define it with id_dim_zu1_xy.
+                IF ( INDEX( do2d(av,i), '*' ) /= 0 )  THEN
+
+                   CALL netcdf_create_var( id_set_xy(av), (/ id_dim_x_xy(av),  &
+                                           id_dim_y_xy(av), id_dim_zu1_xy(av), &
+                                           id_dim_time_xy(av) /), do2d(av,i),  &
+                                           nc_precision(1), id_var_do2d(av,i), &
+                                           TRIM( do2d_unit(av,i) ),            &
+                                           do2d(av,i), 119, 120, 354 )
+
+                ELSE
+
+!
+!--                Check for the grid
+                   found = .TRUE.
+                   SELECT CASE ( do2d(av,i) )
+!
+!--                   Most variables are defined on the zu grid
+                      CASE ( 'e_xy', 'lpt_xy', 'nr_xy', 'p_xy', 'pc_xy',       &
+                             'pr_xy', 'prr_xy', 'pt_xy', 'q_xy', 'qc_xy',      &
+                             'ql_xy', 'ql_c_xy', 'ql_v_xy', 'ql_vp_xy',        &
+                             'qr_xy', 'qv_xy', 'rad_lw_cs_hr_xy',              &
+                             'rad_lw_hr_xy', 'rad_sw_cs_hr_xy', 'rad_sw_hr_xy',& 
+                             'rho_xy', 's_xy', 'sa_xy', 'vpt_xy' )
+
+                         grid_x = 'x'
+                         grid_y = 'y'
+                         grid_z = 'zu'
+!
+!--                   u grid
+                      CASE ( 'u_xy' )
+
+                         grid_x = 'xu'
+                         grid_y = 'y'
+                         grid_z = 'zu'
+!
+!--                   v grid
+                      CASE ( 'v_xy' )
+
+                         grid_x = 'x'
+                         grid_y = 'yv'
+                         grid_z = 'zu'
+!
+!--                   w grid
+                      CASE ( 'rad_lw_in_xy', 'rad_lw_out_xy', 'rad_sw_in_xy',  &
+                             'rad_sw_out_xy' , 'w_xy' )
+
+                         grid_x = 'x'
+                         grid_y = 'y'
+                         grid_z = 'zw'
+!
+!--                   soil grid
+                      CASE ( 'm_soil_xy', 't_soil_xy' )
+                         grid_x = 'x'
+                         grid_y = 'y'
+                         grid_z = 'zs'
+
+                      CASE DEFAULT
+!
+!--                      Check for user-defined quantities
+                         CALL user_define_netcdf_grid( do2d(av,i), found, &
+                                                       grid_x, grid_y, grid_z )
+
+                         IF ( .NOT. found )  THEN
+                            WRITE ( message_string, * ) 'no grid defined for', &
+                                                ' variable ', TRIM( do2d(av,i) )
+                            CALL message( 'define_netcdf_header', 'PA0244',    &
+                                          0, 1, 0, 6, 0 )
+                         ENDIF
+
+                   END SELECT
+
+!
+!--                Select the respective dimension ids
+                   IF ( grid_x == 'x' )  THEN
+                      id_x = id_dim_x_xy(av)
+                   ELSEIF ( grid_x == 'xu' )  THEN
+                      id_x = id_dim_xu_xy(av)
+                   ENDIF
+
+                   IF ( grid_y == 'y' )  THEN
+                      id_y = id_dim_y_xy(av)
+                   ELSEIF ( grid_y == 'yv' )  THEN
+                      id_y = id_dim_yv_xy(av)
+                   ENDIF
+
+                   IF ( grid_z == 'zu' )  THEN
+                      id_z = id_dim_zu_xy(av)
+                   ELSEIF ( grid_z == 'zw' )  THEN
+                      id_z = id_dim_zw_xy(av)
+                   ELSEIF ( grid_z == 'zs' )  THEN
+                      id_z = id_dim_zs_xy(av)
+                   ENDIF
+
+!
+!--                Define the grid
+                   CALL netcdf_create_var( id_set_xy(av), (/ id_x, id_y, id_z, &
+                                           id_dim_time_xy(av) /), do2d(av,i),  &
+                                           nc_precision(1), id_var_do2d(av,i), &
+                                           TRIM( do2d_unit(av,i) ),            &
+                                           do2d(av,i), 119, 120, 354 )
+
+                ENDIF
+
+#if defined( __netcdf4_parallel )
+                IF ( netcdf_data_format > 4 )  THEN
+!
+!--                Set no fill for every variable to increase performance.
+                   nc_stat = NF90_DEF_VAR_FILL( id_set_xy(av),     &
+                                                id_var_do2d(av,i), &
+                                                1, 0 )
+                   CALL netcdf_handle_error( 'netcdf_define_header', 533 )
+!
+!--                Set collective io operations for parallel io
+                   nc_stat = NF90_VAR_PAR_ACCESS( id_set_xy(av),     &
+                                                  id_var_do2d(av,i), &
+                                                  NF90_COLLECTIVE )
+                   CALL netcdf_handle_error( 'netcdf_define_header', 448 )
+                ENDIF
+#endif
+                var_list = TRIM( var_list) // TRIM( do2d(av,i) ) // ';'
+
+             ENDIF
+
+             i = i + 1
+
+          ENDDO
+
+!
+!--       No arrays to output. Close the netcdf file and return.
+          IF ( i == 1 )  RETURN
+
+!
+!--       Write the list of variables as global attribute (this is used by
+!--       restart runs and by combine_plot_fields)
+          nc_stat = NF90_PUT_ATT( id_set_xy(av), NF90_GLOBAL, 'VAR_LIST', &
+                                  var_list )
+          CALL netcdf_handle_error( 'netcdf_define_header', 121 )
+
+!
+!--       Set general no fill, otherwise the performance drops significantly for
+!--       parallel output.
+          nc_stat = NF90_SET_FILL( id_set_xy(av), NF90_NOFILL, oldmode )
+          CALL netcdf_handle_error( 'netcdf_define_header', 529 )
+
+!
+!--       Leave netCDF define mode
+          nc_stat = NF90_ENDDEF( id_set_xy(av) )
+          CALL netcdf_handle_error( 'netcdf_define_header', 122 )
+
+!
+!--       These data are only written by PE0 for parallel output to increase
+!--       the performance.
+          IF ( myid == 0  .OR.  netcdf_data_format < 5 )  THEN
+
+!
+!--          Write axis data: z_xy, x, y
+             ALLOCATE( netcdf_data(1:ns) )
+
+!
+!--          Write zu data
+             DO  i = 1, ns
+                IF( section(i,1) == -1 )  THEN
+                   netcdf_data(i) = -1.0_wp  ! section averaged along z
+                ELSE
+                   netcdf_data(i) = zu( section(i,1) )
+                ENDIF
+             ENDDO
+             nc_stat = NF90_PUT_VAR( id_set_xy(av), id_var_zu_xy(av), &
+                                     netcdf_data, start = (/ 1 /),    &
+                                     count = (/ ns /) )
+             CALL netcdf_handle_error( 'netcdf_define_header', 123 )
+
+!
+!--          Write zw data
+             DO  i = 1, ns
+                IF( section(i,1) == -1 )  THEN
+                   netcdf_data(i) = -1.0_wp  ! section averaged along z
+                ELSE
+                   netcdf_data(i) = zw( section(i,1) )
+                ENDIF
+             ENDDO
+             nc_stat = NF90_PUT_VAR( id_set_xy(av), id_var_zw_xy(av), &
+                                     netcdf_data, start = (/ 1 /),    &
+                                     count = (/ ns /) )
+             CALL netcdf_handle_error( 'netcdf_define_header', 124 )
+
+!
+!--             Write zs data
+             IF ( land_surface )  THEN
+                ns_do = 0
+                DO  i = 1, ns
+                   IF( section(i,1) == -1 )  THEN
+                      netcdf_data(i) = 1.0_wp  ! section averaged along z
+                      ns_do = ns_do + 1
+                   ELSEIF ( section(i,1) < nzs )  THEN
+                      netcdf_data(i) = - zs( section(i,1) )
+                      ns_do = ns_do + 1
+                   ENDIF
+                ENDDO
+
+                nc_stat = NF90_PUT_VAR( id_set_xy(av), id_var_zs_xy(av), &
+                                        netcdf_data(1:ns_do), start = (/ 1 /),    &
+                                        count = (/ ns_do /) )
+                CALL netcdf_handle_error( 'netcdf_define_header', 124 )
+
+             ENDIF
+
+!
+!--          Write gridpoint number data
+             netcdf_data(1:ns) = section(1:ns,1)
+             nc_stat = NF90_PUT_VAR( id_set_xy(av), id_var_ind_z_xy(av), &
+                                     netcdf_data, start = (/ 1 /),       &
+                                     count = (/ ns /) )
+             CALL netcdf_handle_error( 'netcdf_define_header', 125 )
+
+             DEALLOCATE( netcdf_data )
+
+!
+!--          Write the cross section height u*, t*
+             nc_stat = NF90_PUT_VAR( id_set_xy(av), id_var_zu1_xy(av), &
+                                     (/ zu(nzb+1) /), start = (/ 1 /), &
+                                     count = (/ 1 /) )
+             CALL netcdf_handle_error( 'netcdf_define_header', 126 )
+
+!
+!--          Write data for x (shifted by +dx/2) and xu axis
+             ALLOCATE( netcdf_data(0:nx+1) )
+
+             DO  i = 0, nx+1
+                netcdf_data(i) = ( i + 0.5_wp ) * dx
+             ENDDO
+
+             nc_stat = NF90_PUT_VAR( id_set_xy(av), id_var_x_xy(av), &
+                                     netcdf_data, start = (/ 1 /),   &
+                                     count = (/ nx+2 /) )
+             CALL netcdf_handle_error( 'netcdf_define_header', 127 )
+
+             DO  i = 0, nx+1
+                netcdf_data(i) = i * dx
+             ENDDO
+
+             nc_stat = NF90_PUT_VAR( id_set_xy(av), id_var_xu_xy(av), &
+                                     netcdf_data, start = (/ 1 /),    &
+                                     count = (/ nx+2 /) )
+             CALL netcdf_handle_error( 'netcdf_define_header', 367 )
+
+             DEALLOCATE( netcdf_data )
+
+!
+!--          Write data for y (shifted by +dy/2) and yv axis
+             ALLOCATE( netcdf_data(0:ny+1) )
+
+             DO  i = 0, ny+1
+                netcdf_data(i) = ( i + 0.5_wp ) * dy
+             ENDDO
+
+             nc_stat = NF90_PUT_VAR( id_set_xy(av), id_var_y_xy(av), &
+                                     netcdf_data, start = (/ 1 /),   &
+                                     count = (/ ny+2 /))
+             CALL netcdf_handle_error( 'netcdf_define_header', 128 )
+
+             DO  i = 0, ny+1
+                netcdf_data(i) = i * dy
+             ENDDO
+
+             nc_stat = NF90_PUT_VAR( id_set_xy(av), id_var_yv_xy(av), &
+                                     netcdf_data, start = (/ 1 /),    &
+                                     count = (/ ny+2 /))
+             CALL netcdf_handle_error( 'netcdf_define_header', 368 )
+
+             DEALLOCATE( netcdf_data )
+
+!
+!--          In case of non-flat topography write height information
+             IF ( TRIM( topography ) /= 'flat' )  THEN
+
+                nc_stat = NF90_PUT_VAR( id_set_xy(av), id_var_zusi_xy(av), &
+                                        zu_s_inner(0:nx+1,0:ny+1), &
+                                        start = (/ 1, 1 /), &
+                                        count = (/ nx+2, ny+2 /) )
+                CALL netcdf_handle_error( 'netcdf_define_header', 427 )
+
+                nc_stat = NF90_PUT_VAR( id_set_xy(av), id_var_zwwi_xy(av), &
+                                        zw_w_inner(0:nx+1,0:ny+1), &
+                                        start = (/ 1, 1 /), &
+                                        count = (/ nx+2, ny+2 /) )
+                CALL netcdf_handle_error( 'netcdf_define_header', 428 )
+
+             ENDIF
+
+
+
+          ENDIF
+
+       CASE ( 'xy_ext' )
+
+!
+!--       Get the list of variables and compare with the actual run.
+!--       First var_list_old has to be reset, since GET_ATT does not assign
+!--       trailing blanks.
+          var_list_old = ' '
+          nc_stat = NF90_GET_ATT( id_set_xy(av), NF90_GLOBAL, 'VAR_LIST', &
+                                  var_list_old )
+          CALL netcdf_handle_error( 'netcdf_define_header', 129 )
+
+          var_list = ';'
+          i = 1
+          DO WHILE ( do2d(av,i)(1:1) /= ' ' )
+             IF ( INDEX( do2d(av,i), 'xy' ) /= 0 )  THEN
+                var_list = TRIM( var_list ) // TRIM( do2d(av,i) ) // ';'
+             ENDIF
+             i = i + 1
+          ENDDO
+
+          IF ( av == 0 )  THEN
+             var = '(xy)'
+          ELSE
+             var = '(xy_av)'
+          ENDIF
+
+          IF ( TRIM( var_list ) /= TRIM( var_list_old ) )  THEN
+             message_string = 'netCDF file for cross-sections ' //           &
+                              TRIM( var ) // ' from previous run found,' //  &
+                              '& but this file cannot be extended due to' // &
+                              ' variable mismatch.' //                       &
+                              '&New file is created instead.'
+             CALL message( 'define_netcdf_header', 'PA0249', 0, 1, 0, 6, 0 )
+             extend = .FALSE.
+             RETURN
+          ENDIF
+
+!
+!--       Calculate the number of current sections
+          ns = 1
+          DO WHILE ( section(ns,1) /= -9999  .AND.  ns <= 100 )
+             ns = ns + 1
+          ENDDO
+          ns = ns - 1
+
+!
+!--       Get and compare the number of horizontal cross sections
+          nc_stat = NF90_INQ_VARID( id_set_xy(av), 'zu_xy', id_var_zu_xy(av) )
+          CALL netcdf_handle_error( 'netcdf_define_header', 130 )
+
+          nc_stat = NF90_INQUIRE_VARIABLE( id_set_xy(av), id_var_zu_xy(av), &
+                                           dimids = id_dim_zu_xy_old )
+          CALL netcdf_handle_error( 'netcdf_define_header', 131 )
+          id_dim_zu_xy(av) = id_dim_zu_xy_old(1)
+
+          nc_stat = NF90_INQUIRE_DIMENSION( id_set_xy(av), id_dim_zu_xy(av), &
+                                            len = ns_old )
+          CALL netcdf_handle_error( 'netcdf_define_header', 132 )
+
+          IF ( ns /= ns_old )  THEN
+             message_string = 'netCDF file for cross-sections ' //          &
+                              TRIM( var ) // ' from previous run found,' // &
+                              '&but this file cannot be extended due to' // &
+                              ' mismatch in number of' //                   &
+                              '&cross sections.' //                         &
+                              '&New file is created instead.'
+             CALL message( 'define_netcdf_header', 'PA0250', 0, 1, 0, 6, 0 )
+             extend = .FALSE.
+             RETURN
+          ENDIF
+
+!
+!--       Get and compare the heights of the cross sections
+          ALLOCATE( netcdf_data(1:ns_old) )
+
+          nc_stat = NF90_GET_VAR( id_set_xy(av), id_var_zu_xy(av), netcdf_data )
+          CALL netcdf_handle_error( 'netcdf_define_header', 133 )
+
+          DO  i = 1, ns
+             IF ( section(i,1) /= -1 )  THEN
+                IF ( zu(section(i,1)) /= netcdf_data(i) )  THEN
+                   message_string = 'netCDF file for cross-sections ' //     &
+                               TRIM( var ) // ' from previous run found,' // &
+                               '&but this file cannot be extended' //        &
+                               ' due to mismatch in cross' //                &
+                               '&section levels.' //                         &
+                               '&New file is created instead.'
+                   CALL message( 'define_netcdf_header', 'PA0251', &
+                                                                 0, 1, 0, 6, 0 )
+                   extend = .FALSE.
+                   RETURN
+                ENDIF
+             ELSE
+                IF ( -1.0_wp /= netcdf_data(i) )  THEN
+                   message_string = 'netCDF file for cross-sections ' //     &
+                               TRIM( var ) // ' from previous run found,' // &
+                               '&but this file cannot be extended' //        &
+                               ' due to mismatch in cross' //                &
+                               '&section levels.' //                         &
+                               '&New file is created instead.'
+                   CALL message( 'define_netcdf_header', 'PA0251',&
+                                                                 0, 1, 0, 6, 0 )
+                   extend = .FALSE.
+                   RETURN
+                ENDIF
+             ENDIF
+          ENDDO
+
+          DEALLOCATE( netcdf_data )
+
+!
+!--       Get the id of the time coordinate (unlimited coordinate) and its
+!--       last index on the file. The next time level is do2d..count+1.
+!--       The current time must be larger than the last output time
+!--       on the file.
+          nc_stat = NF90_INQ_VARID( id_set_xy(av), 'time', id_var_time_xy(av) )
+          CALL netcdf_handle_error( 'netcdf_define_header', 134 )
+
+          nc_stat = NF90_INQUIRE_VARIABLE( id_set_xy(av), id_var_time_xy(av), &
+                                           dimids = id_dim_time_old )
+          CALL netcdf_handle_error( 'netcdf_define_header', 135 )
+          id_dim_time_xy(av) = id_dim_time_old(1)
+
+          nc_stat = NF90_INQUIRE_DIMENSION( id_set_xy(av), id_dim_time_xy(av), &
+                                            len = ntime_count )
+          CALL netcdf_handle_error( 'netcdf_define_header', 136 )
+
+!
+!--       For non-parallel output use the last output time level of the netcdf
+!--       file because the time dimension is unlimited. In case of parallel
+!--       output the variable ntime_count could get the value of 9*10E36 because
+!--       the time dimension is limited.
+          IF ( netcdf_data_format < 5 ) do2d_xy_time_count(av) = ntime_count
+
+          nc_stat = NF90_GET_VAR( id_set_xy(av), id_var_time_xy(av),    &
+                                  last_time_coordinate,                 &
+                                  start = (/ do2d_xy_time_count(av) /), &
+                                  count = (/ 1 /) )
+          CALL netcdf_handle_error( 'netcdf_define_header', 137 )
+
+          IF ( last_time_coordinate(1) >= simulated_time )  THEN
+             message_string = 'netCDF file for cross sections ' //          &
+                              TRIM( var ) // ' from previous run found,' // &
+                              '&but this file cannot be extended becaus' // &
+                              'e the current output time' //                &
+                              '&is less or equal than the last output t' // &
+                              'ime on this file.' //                        &
+                              '&New file is created instead.'
+             CALL message( 'define_netcdf_header', 'PA0252', 0, 1, 0, 6, 0 )
+             do2d_xy_time_count(av) = 0
+             extend = .FALSE.
+             RETURN
+          ENDIF
+
+          IF ( netcdf_data_format > 4 )  THEN
+!
+!--          Set needed time levels (ntdim) to 
+!--          saved time levels + to be saved time levels.
+             IF ( av == 0 )  THEN 
+                ntdim_2d_xy(0) = do2d_xy_time_count(0) + CEILING(             &
+                                 ( end_time - MAX( skip_time_do2d_xy,         &
+                                                   simulated_time_at_begin )  &
+                                 ) / dt_do2d_xy )
+             ELSE
+                ntdim_2d_xy(1) = do2d_xy_time_count(1) + CEILING(             &
+                                 ( end_time - MAX( skip_time_data_output_av,  &
+                                                   simulated_time_at_begin )  &
+                                 ) / dt_data_output_av )
+             ENDIF
+
+!
+!--          Check if the needed number of output time levels is increased
+!--          compared to the number of time levels in the existing file.
+             IF ( ntdim_2d_xy(av) > ntime_count )  THEN
+                message_string = 'netCDF file for cross sections ' //          &
+                                 TRIM( var ) // ' from previous run found,' // &
+                                 '&but this file cannot be extended becaus' // &
+                                 'e the number of output time levels&has b' // &
+                                 'een increased compared to the previous s' // &
+                                 'imulation.' //                               &
+                                 '&New file is created instead.'
+                CALL message( 'define_netcdf_header', 'PA0389', 0, 1, 0, 6, 0 )
+                do2d_xy_time_count(av) = 0
+                extend = .FALSE.
+!
+!--             Recalculate the needed time levels for the new file.
+                IF ( av == 0 )  THEN
+                   ntdim_2d_xy(0) = CEILING(                            &
+                           ( end_time - MAX( skip_time_do2d_xy,         &
+                                             simulated_time_at_begin )  &
+                           ) / dt_do2d_xy )
+                ELSE
+                   ntdim_2d_xy(1) = CEILING(                            &
+                           ( end_time - MAX( skip_time_data_output_av,  &
+                                             simulated_time_at_begin )  &
+                           ) / dt_data_output_av )
+                ENDIF
+                RETURN
+             ENDIF
+          ENDIF
+
+!
+!--       Dataset seems to be extendable.
+!--       Now get the variable ids.
+          i = 1
+          DO WHILE ( do2d(av,i)(1:1) /= ' ' )
+             IF ( INDEX( do2d(av,i), 'xy' ) /= 0 )  THEN
+                nc_stat = NF90_INQ_VARID( id_set_xy(av), do2d(av,i), &
+                                          id_var_do2d(av,i) )
+                CALL netcdf_handle_error( 'netcdf_define_header', 138 )
+#if defined( __netcdf4_parallel )
+!
+!--             Set collective io operations for parallel io
+                IF ( netcdf_data_format > 4 )  THEN
+                   nc_stat = NF90_VAR_PAR_ACCESS( id_set_xy(av),     &
+                                                  id_var_do2d(av,i), &
+                                                  NF90_COLLECTIVE )
+                   CALL netcdf_handle_error( 'netcdf_define_header', 454 )
+                ENDIF
+#endif
+             ENDIF
+             i = i + 1
+          ENDDO
+
+!
+!--       Update the title attribute on file
+!--       In order to avoid 'data mode' errors if updated attributes are larger 
+!--       than their original size, NF90_PUT_ATT is called in 'define mode' 
+!--       enclosed by NF90_REDEF and NF90_ENDDEF calls. This implies a possible 
+!--       performance loss due to data copying; an alternative strategy would be 
+!--       to ensure equal attribute size in a job chain. Maybe revise later.
+          IF ( av == 0 )  THEN
+             time_average_text = ' '
+          ELSE
+             WRITE (time_average_text, '('', '',F7.1,'' s average'')') &
+                                                            averaging_interval
+          ENDIF
+          nc_stat = NF90_REDEF( id_set_xy(av) )
+          CALL netcdf_handle_error( 'netcdf_define_header', 431 )
+          nc_stat = NF90_PUT_ATT( id_set_xy(av), NF90_GLOBAL, 'title', &
+                                  TRIM( run_description_header ) //    &
+                                  TRIM( time_average_text ) )
+          CALL netcdf_handle_error( 'netcdf_define_header', 139 )
+          nc_stat = NF90_ENDDEF( id_set_xy(av) )
+          CALL netcdf_handle_error( 'netcdf_define_header', 432 )
+          message_string = 'netCDF file for cross-sections ' //           &
+                            TRIM( var ) // ' from previous run found.' // &
+                           '&This file will be extended.'
+          CALL message( 'define_netcdf_header', 'PA0253', 0, 0, 0, 6, 0 )
+          
+
+       CASE ( 'xz_new' )
+
+!
+!--       Define some global attributes of the dataset
+          nc_stat = NF90_PUT_ATT( id_set_xz(av), NF90_GLOBAL, 'Conventions', &
+                                  'COARDS' )
+          CALL netcdf_handle_error( 'netcdf_define_header', 140 )
+
+          IF ( av == 0 )  THEN
+             time_average_text = ' '
+          ELSE
+             WRITE (time_average_text, '('', '',F7.1,'' s average'')') &
+                                                            averaging_interval
+          ENDIF
+          nc_stat = NF90_PUT_ATT( id_set_xz(av), NF90_GLOBAL, 'title', &
+                                  TRIM( run_description_header )  //   &
+                                  TRIM( time_average_text ) )
+          CALL netcdf_handle_error( 'netcdf_define_header', 141 )
+          IF ( av == 1 )  THEN
+             WRITE ( time_average_text,'(F7.1,'' s avg'')' )  averaging_interval
+             nc_stat = NF90_PUT_ATT( id_set_xz(av), NF90_GLOBAL, 'time_avg', &
+                                     TRIM( time_average_text ) )
+             CALL netcdf_handle_error( 'netcdf_define_header', 141 )
+          ENDIF
+
+!
+!--       Define time coordinate for xz sections.
+!--       For parallel output the time dimensions has to be limited, otherwise
+!--       the performance drops significantly.
+          IF ( netcdf_data_format < 5 )  THEN
+             CALL netcdf_create_dim( id_set_xz(av), 'time', NF90_UNLIMITED,    &
+                                     id_dim_time_xz(av), 142 )
+          ELSE
+             CALL netcdf_create_dim( id_set_xz(av), 'time', ntdim_2d_xz(av),   &
+                                     id_dim_time_xz(av), 525 )
+          ENDIF
+
+          CALL netcdf_create_var( id_set_xz(av), (/ id_dim_time_xz(av) /),     &
+                                  'time', NF90_DOUBLE, id_var_time_xz(av),     &
+                                  'seconds', '', 143, 144, 000 )
+!
+!--       Define the spatial dimensions and coordinates for xz-sections.
+!--       First, determine the number of vertical sections to be written.
+          IF ( section(1,2) == -9999 )  THEN
+             RETURN
+          ELSE
+             ns = 1
+             DO WHILE ( section(ns,2) /= -9999  .AND.  ns <= 100 )
+                ns = ns + 1
+             ENDDO
+             ns = ns - 1
+          ENDIF
+
+!
+!--       Define y-axis (for scalar position)
+          CALL netcdf_create_dim( id_set_xz(av), 'y_xz', ns, id_dim_y_xz(av),  &
+                                  145 )
+          CALL netcdf_create_var( id_set_xz(av), (/ id_dim_y_xz(av) /),        &
+                                  'y_xz', NF90_DOUBLE, id_var_y_xz(av),        &
+                                  'meters', '', 146, 147, 000 )
+!
+!--       Define y-axis (for v position)
+          CALL netcdf_create_dim( id_set_xz(av), 'yv_xz', ns,                  &
+                                  id_dim_yv_xz(av), 369 )
+          CALL netcdf_create_var( id_set_xz(av), (/ id_dim_yv_xz(av) /),       &
+                                  'yv_xz', NF90_DOUBLE, id_var_yv_xz(av),      &
+                                  'meters', '', 370, 371, 000 )
+!
+!--       Define a variable to store the layer indices of the vertical cross
+!--       sections
+          CALL netcdf_create_var( id_set_xz(av), (/ id_dim_y_xz(av) /),        &
+                                  'ind_y_xz', NF90_DOUBLE,                     &
+                                  id_var_ind_y_xz(av), 'gridpoints', '', 148,  &
+                                  149, 000 )
+!
+!--       Define x-axis (for scalar position)
+          CALL netcdf_create_dim( id_set_xz(av), 'x', nx+2, id_dim_x_xz(av),   &
+                                  150 )
+          CALL netcdf_create_var( id_set_xz(av), (/ id_dim_x_xz(av) /), 'x',   &
+                                  NF90_DOUBLE, id_var_x_xz(av), 'meters', '',  &
+                                  151, 152, 000 )
+!
+!--       Define x-axis (for u position)
+          CALL netcdf_create_dim( id_set_xz(av), 'xu', nx+2, id_dim_xu_xz(av), &
+                                  372 )
+          CALL netcdf_create_var( id_set_xz(av), (/ id_dim_xu_xz(av) /), 'xu', &
+                                  NF90_DOUBLE, id_var_xu_xz(av), 'meters', '', &
+                                  373, 374, 000 )
+!
+!--       Define the three z-axes (zu, zw, and zs)
+          CALL netcdf_create_dim( id_set_xz(av), 'zu', nz+2, id_dim_zu_xz(av), &
+                                  153 )
+          CALL netcdf_create_var( id_set_xz(av), (/ id_dim_zu_xz(av) /), 'zu', &
+                                  NF90_DOUBLE, id_var_zu_xz(av), 'meters', '', &
+                                  154, 155, 000 )
+          CALL netcdf_create_dim( id_set_xz(av), 'zw', nz+2, id_dim_zw_xz(av), &
+                                  156 )
+          CALL netcdf_create_var( id_set_xz(av), (/ id_dim_zw_xz(av) /), 'zw', &
+                                  NF90_DOUBLE, id_var_zw_xz(av), 'meters', '', &
+                                  157, 158, 000 )
+
+          IF ( land_surface )  THEN
+
+             CALL netcdf_create_dim( id_set_xz(av), 'zs', nzs,                 &
+                                     id_dim_zs_xz(av), 542 )
+             CALL netcdf_create_var( id_set_xz(av), (/ id_dim_zs_xz(av) /),    &
+                                     'zs', NF90_DOUBLE, id_var_zs_xz(av),      &
+                                     'meters', '', 543, 544, 000 )
+
+          ENDIF
+
+!
+!--       Define the variables
+          var_list = ';'
+          i = 1
+
+          DO WHILE ( do2d(av,i)(1:1) /= ' ' )
+
+             IF ( INDEX( do2d(av,i), 'xz' ) /= 0 )  THEN
+
+!
+!--             Check for the grid
+                found = .TRUE.
+                SELECT CASE ( do2d(av,i) )
+!
+!--                Most variables are defined on the zu grid
+                   CASE ( 'e_xz', 'lpt_xz', 'nr_xz', 'p_xz', 'pc_xz', 'pr_xz', &
+                          'prr_xz', 'pt_xz', 'q_xz', 'qc_xz', 'ql_xz',         &
+                          'ql_c_xz', 'ql_v_xz', 'ql_vp_xz', 'qr_xz', 'qv_xz',  &
+                          'rad_lw_cs_hr_xz', 'rad_lw_hr_xz',                   &
+                          'rad_sw_cs_hr_xz', 'rad_sw_hr_xz''rho_xz', 's_xz',   &
+                          'sa_xz', 'vpt_xz' )
+
+                      grid_x = 'x'
+                      grid_y = 'y'
+                      grid_z = 'zu'
+!
+!--                u grid
+                   CASE ( 'u_xz' )
+
+                      grid_x = 'xu'
+                      grid_y = 'y'
+                      grid_z = 'zu'
+!
+!--                v grid
+                   CASE ( 'v_xz' )
+
+                      grid_x = 'x'
+                      grid_y = 'yv'
+                      grid_z = 'zu'
+!
+!--                w grid
+                   CASE ( 'rad_lw_in_xz', 'rad_lw_out_xz', 'rad_sw_in_xz',     &
+                          'rad_sw_out_xz', 'w_xz' )
+
+                      grid_x = 'x'
+                      grid_y = 'y'
+                      grid_z = 'zw'
+
+!
+!--                soil grid
+                   CASE ( 'm_soil_xz', 't_soil_xz' )
+
+                      grid_x = 'x'
+                      grid_y = 'y'
+                      grid_z = 'zs'
+
+                   CASE DEFAULT
+!
+!--                   Check for user-defined quantities
+                      CALL user_define_netcdf_grid( do2d(av,i), found, &
+                                                    grid_x, grid_y, grid_z )
+                      IF ( .NOT. found )  THEN
+                         WRITE ( message_string, * ) 'no grid defined for', &
+                                                ' variable ', TRIM( do2d(av,i) )
+                         CALL message( 'define_netcdf_header', 'PA0244', &
+                                       0, 1, 0, 6, 0 )
+                      ENDIF
+
+                END SELECT
+
+!
+!--             Select the respective dimension ids
+                IF ( grid_x == 'x' )  THEN
+                   id_x = id_dim_x_xz(av)
+                ELSEIF ( grid_x == 'xu' )  THEN
+                   id_x = id_dim_xu_xz(av)
+                ENDIF
+
+                IF ( grid_y == 'y' )  THEN
+                   id_y = id_dim_y_xz(av)
+                ELSEIF ( grid_y == 'yv' )  THEN
+                   id_y = id_dim_yv_xz(av)
+                ENDIF
+
+                IF ( grid_z == 'zu' )  THEN
+                   id_z = id_dim_zu_xz(av)
+                ELSEIF ( grid_z == 'zw' )  THEN
+                   id_z = id_dim_zw_xz(av)
+                ELSEIF ( grid_z == 'zs' )  THEN
+                   id_z = id_dim_zs_xz(av)
+                ENDIF
+
+!
+!--             Define the grid
+                CALL netcdf_create_var( id_set_xz(av), (/ id_x, id_y, id_z,    &
+                                        id_dim_time_xz(av) /), do2d(av,i),     &
+                                        nc_precision(2), id_var_do2d(av,i),    &
+                                        TRIM( do2d_unit(av,i) ), do2d(av,i),   &
+                                        159, 160, 355 )
+
+#if defined( __netcdf4_parallel )
+
+                IF ( netcdf_data_format > 4 )  THEN
+!
+!--                Set no fill for every variable to increase performance.
+                   nc_stat = NF90_DEF_VAR_FILL( id_set_xz(av),     &
+                                                id_var_do2d(av,i), &
+                                                1, 0 )
+                   CALL netcdf_handle_error( 'netcdf_define_header', 534 )
+!
+!--                Set independent io operations for parallel io. Collective io
+!--                is only allowed in case of a 1d-decomposition along x,
+!--                because otherwise, not all PEs have output data.
+                   IF ( npey == 1 )  THEN
+                      nc_stat = NF90_VAR_PAR_ACCESS( id_set_xz(av),     &
+                                                     id_var_do2d(av,i), &
+                                                     NF90_COLLECTIVE )
+                   ELSE
+!
+!--                   Test simulations showed that the output of cross sections
+!--                   by all PEs in data_output_2d using NF90_COLLECTIVE is 
+!--                   faster than the output by the first row of PEs in
+!--                   x-direction using NF90_INDEPENDENT.
+                      nc_stat = NF90_VAR_PAR_ACCESS( id_set_xz(av),    & 
+                                                    id_var_do2d(av,i), &
+                                                    NF90_COLLECTIVE )
+!                      nc_stat = NF90_VAR_PAR_ACCESS( id_set_xz(av),     &
+!                                                     id_var_do2d(av,i), &
+!                                                     NF90_INDEPENDENT )
+                   ENDIF
+                   CALL netcdf_handle_error( 'netcdf_define_header', 449 )
+                ENDIF
+#endif
+                var_list = TRIM( var_list ) // TRIM( do2d(av,i) ) // ';'
+
+             ENDIF
+
+             i = i + 1
+
+          ENDDO
+
+!
+!--       No arrays to output. Close the netcdf file and return.
+          IF ( i == 1 )  RETURN
+
+!
+!--       Write the list of variables as global attribute (this is used by
+!--       restart runs and by combine_plot_fields)
+          nc_stat = NF90_PUT_ATT( id_set_xz(av), NF90_GLOBAL, 'VAR_LIST', &
+                                  var_list )
+          CALL netcdf_handle_error( 'netcdf_define_header', 161 )
+
+!
+!--       Set general no fill, otherwise the performance drops significantly for
+!--       parallel output.
+          nc_stat = NF90_SET_FILL( id_set_xz(av), NF90_NOFILL, oldmode )
+          CALL netcdf_handle_error( 'netcdf_define_header', 530 )
+
+!
+!--       Leave netCDF define mode
+          nc_stat = NF90_ENDDEF( id_set_xz(av) )
+          CALL netcdf_handle_error( 'netcdf_define_header', 162 )
+
+!
+!--       These data are only written by PE0 for parallel output to increase
+!--       the performance.
+          IF ( myid == 0  .OR.  netcdf_data_format < 5 )  THEN
+
+!
+!--          Write axis data: y_xz, x, zu, zw
+             ALLOCATE( netcdf_data(1:ns) )
+
+!
+!--          Write y_xz data (shifted by +dy/2)
+             DO  i = 1, ns
+                IF( section(i,2) == -1 )  THEN
+                   netcdf_data(i) = -1.0_wp  ! section averaged along y
+                ELSE
+                   netcdf_data(i) = ( section(i,2) + 0.5_wp ) * dy
+                ENDIF
+             ENDDO
+             nc_stat = NF90_PUT_VAR( id_set_xz(av), id_var_y_xz(av), &
+                                     netcdf_data, start = (/ 1 /),   &
+                                     count = (/ ns /) )
+             CALL netcdf_handle_error( 'netcdf_define_header', 163 )
+
+!
+!--          Write yv_xz data
+             DO  i = 1, ns
+                IF( section(i,2) == -1 )  THEN
+                   netcdf_data(i) = -1.0_wp  ! section averaged along y
+                ELSE
+                   netcdf_data(i) = section(i,2) * dy
+                ENDIF
+             ENDDO
+             nc_stat = NF90_PUT_VAR( id_set_xz(av), id_var_yv_xz(av), &
+                                     netcdf_data, start = (/ 1 /),    &
+                                     count = (/ ns /) )
+             CALL netcdf_handle_error( 'netcdf_define_header', 375 )
+
+!
+!--          Write gridpoint number data
+             netcdf_data(1:ns) = section(1:ns,2)
+             nc_stat = NF90_PUT_VAR( id_set_xz(av), id_var_ind_y_xz(av), &
+                                     netcdf_data, start = (/ 1 /),       &
+                                     count = (/ ns /) )
+             CALL netcdf_handle_error( 'netcdf_define_header', 164 )
+
+
+             DEALLOCATE( netcdf_data )
+
+!
+!--          Write data for x (shifted by +dx/2) and xu axis
+             ALLOCATE( netcdf_data(0:nx+1) )
+
+             DO  i = 0, nx+1
+                netcdf_data(i) = ( i + 0.5_wp ) * dx
+             ENDDO
+
+             nc_stat = NF90_PUT_VAR( id_set_xz(av), id_var_x_xz(av), &
+                                     netcdf_data, start = (/ 1 /),   &
+                                     count = (/ nx+2 /) )
+             CALL netcdf_handle_error( 'netcdf_define_header', 165 )
+
+             DO  i = 0, nx+1
+                netcdf_data(i) = i * dx
+             ENDDO
+
+             nc_stat = NF90_PUT_VAR( id_set_xz(av), id_var_xu_xz(av), &
+                                     netcdf_data, start = (/ 1 /),    &
+                                     count = (/ nx+2 /) )
+             CALL netcdf_handle_error( 'netcdf_define_header', 377 )
+
+             DEALLOCATE( netcdf_data )
+
+!
+!--          Write zu and zw data (vertical axes)
+             ALLOCATE( netcdf_data(0:nz+1) )
+
+             netcdf_data(0:nz+1) = zu(nzb:nzt+1)
+             nc_stat = NF90_PUT_VAR( id_set_xz(av), id_var_zu_xz(av), &
+                                     netcdf_data, start = (/ 1 /),    &
+                                     count = (/ nz+2 /) )
+             CALL netcdf_handle_error( 'netcdf_define_header', 166 )
+
+             netcdf_data(0:nz+1) = zw(nzb:nzt+1)
+             nc_stat = NF90_PUT_VAR( id_set_xz(av), id_var_zw_xz(av), &
+                                     netcdf_data, start = (/ 1 /),    &
+                                     count = (/ nz+2 /) )
+             CALL netcdf_handle_error( 'netcdf_define_header', 167 )
+
+!
+!--          Write zs data
+             IF ( land_surface )  THEN
+                netcdf_data(0:nzs-1) = - zs(nzb_soil:nzt_soil)
+                nc_stat = NF90_PUT_VAR( id_set_xz(av), id_var_zs_xz(av), &
+                                        netcdf_data(0:nzs), start = (/ 1 /),    &
+                                        count = (/ nzt_soil-nzb_soil+1 /) )
+               CALL netcdf_handle_error( 'netcdf_define_header', 548 )
+             ENDIF
+
+
+             DEALLOCATE( netcdf_data )
+
+          ENDIF
+
+
+       CASE ( 'xz_ext' )
+
+!
+!--       Get the list of variables and compare with the actual run.
+!--       First var_list_old has to be reset, since GET_ATT does not assign
+!--       trailing blanks.
+          var_list_old = ' '
+          nc_stat = NF90_GET_ATT( id_set_xz(av), NF90_GLOBAL, 'VAR_LIST', &
+                                  var_list_old )
+          CALL netcdf_handle_error( 'netcdf_define_header', 168 )
+
+          var_list = ';'
+          i = 1
+          DO WHILE ( do2d(av,i)(1:1) /= ' ' )
+             IF ( INDEX( do2d(av,i), 'xz' ) /= 0 )  THEN
+                var_list = TRIM( var_list ) // TRIM( do2d(av,i) ) // ';'
+             ENDIF
+             i = i + 1
+          ENDDO
+
+          IF ( av == 0 )  THEN
+             var = '(xz)'
+          ELSE
+             var = '(xz_av)'
+          ENDIF
+
+          IF ( TRIM( var_list ) /= TRIM( var_list_old ) )  THEN
+             message_string = 'netCDF file for cross-sections ' //           &
+                              TRIM( var ) // ' from previous run found,' //  &
+                              '& but this file cannot be extended due to' // &
+                              ' variable mismatch.' //                       &
+                              '&New file is created instead.'
+             CALL message( 'define_netcdf_header', 'PA0249', 0, 1, 0, 6, 0 )
+             extend = .FALSE.
+             RETURN
+          ENDIF
+
+!
+!--       Calculate the number of current sections
+          ns = 1
+          DO WHILE ( section(ns,2) /= -9999  .AND.  ns <= 100 )
+             ns = ns + 1
+          ENDDO
+          ns = ns - 1
+
+!
+!--       Get and compare the number of vertical cross sections
+          nc_stat = NF90_INQ_VARID( id_set_xz(av), 'y_xz', id_var_y_xz(av) )
+          CALL netcdf_handle_error( 'netcdf_define_header', 169 )
+
+          nc_stat = NF90_INQUIRE_VARIABLE( id_set_xz(av), id_var_y_xz(av), &
+                                           dimids = id_dim_y_xz_old )
+          CALL netcdf_handle_error( 'netcdf_define_header', 170 )
+          id_dim_y_xz(av) = id_dim_y_xz_old(1)
+
+          nc_stat = NF90_INQUIRE_DIMENSION( id_set_xz(av), id_dim_y_xz(av), &
+                                            len = ns_old )
+          CALL netcdf_handle_error( 'netcdf_define_header', 171 )
+
+          IF ( ns /= ns_old )  THEN
+             message_string = 'netCDF file for cross-sections ' //          &
+                              TRIM( var ) // ' from previous run found,' // &
+                              '&but this file cannot be extended due to' // &
+                              ' mismatch in number of' //                   & 
+                              '&cross sections.' //                         &
+                              '&New file is created instead.'
+             CALL message( 'define_netcdf_header', 'PA0250', 0, 1, 0, 6, 0 )
+             extend = .FALSE.
+             RETURN
+          ENDIF
+
+!
+!--       Get and compare the heights of the cross sections
+          ALLOCATE( netcdf_data(1:ns_old) )
+
+          nc_stat = NF90_GET_VAR( id_set_xz(av), id_var_y_xz(av), netcdf_data )
+          CALL netcdf_handle_error( 'netcdf_define_header', 172 )
+
+          DO  i = 1, ns
+             IF ( section(i,2) /= -1 )  THEN
+                IF ( ( ( section(i,2) + 0.5 ) * dy ) /= netcdf_data(i) )  THEN
+                   message_string = 'netCDF file for cross-sections ' //     &
+                               TRIM( var ) // ' from previous run found,' // &
+                               '&but this file cannot be extended' //        &
+                               ' due to mismatch in cross' //                &
+                               '&section levels.' //                         &
+                                '&New file is created instead.'
+                   CALL message( 'define_netcdf_header', 'PA0251', &
+                                                                 0, 1, 0, 6, 0 )
+                   extend = .FALSE.
+                   RETURN
+                ENDIF
+             ELSE
+                IF ( -1.0_wp /= netcdf_data(i) )  THEN
+                   message_string = 'netCDF file for cross-sections ' //     &
+                               TRIM( var ) // ' from previous run found,' // &
+                               '&but this file cannot be extended' //        &
+                               ' due to mismatch in cross' //                &
+                               '&section levels.' //                         &
+                               '&New file is created instead.'
+                   CALL message( 'define_netcdf_header', 'PA0251', &
+                                                                 0, 1, 0, 6, 0 )
+                   extend = .FALSE.
+                   RETURN
+                ENDIF
+             ENDIF
+          ENDDO
+
+          DEALLOCATE( netcdf_data )
+
+!
+!--       Get the id of the time coordinate (unlimited coordinate) and its
+!--       last index on the file. The next time level is do2d..count+1.
+!--       The current time must be larger than the last output time
+!--       on the file.
+          nc_stat = NF90_INQ_VARID( id_set_xz(av), 'time', id_var_time_xz(av) )
+          CALL netcdf_handle_error( 'netcdf_define_header', 173 )
+
+          nc_stat = NF90_INQUIRE_VARIABLE( id_set_xz(av), id_var_time_xz(av), &
+                                           dimids = id_dim_time_old )
+          CALL netcdf_handle_error( 'netcdf_define_header', 174 )
+          id_dim_time_xz(av) = id_dim_time_old(1)
+
+          nc_stat = NF90_INQUIRE_DIMENSION( id_set_xz(av), id_dim_time_xz(av), &
+                                            len = ntime_count )
+          CALL netcdf_handle_error( 'netcdf_define_header', 175 )
+
+!
+!--       For non-parallel output use the last output time level of the netcdf
+!--       file because the time dimension is unlimited. In case of parallel
+!--       output the variable ntime_count could get the value of 9*10E36 because
+!--       the time dimension is limited.
+          IF ( netcdf_data_format < 5 ) do2d_xz_time_count(av) = ntime_count
+
+          nc_stat = NF90_GET_VAR( id_set_xz(av), id_var_time_xz(av),    &
+                                  last_time_coordinate,                 &
+                                  start = (/ do2d_xz_time_count(av) /), &
+                                  count = (/ 1 /) )
+          CALL netcdf_handle_error( 'netcdf_define_header', 176 )
+
+          IF ( last_time_coordinate(1) >= simulated_time )  THEN
+             message_string = 'netCDF file for cross sections ' //          &
+                              TRIM( var ) // ' from previous run found,' // &
+                              '&but this file cannot be extended becaus' // &
+                              'e the current output time' //                &
+                              '&is less or equal than the last output t' // &
+                              'ime on this file.' //                        &
+                              '&New file is created instead.'
+             CALL message( 'define_netcdf_header', 'PA0252', 0, 1, 0, 6, 0 )
+             do2d_xz_time_count(av) = 0
+             extend = .FALSE.
+             RETURN
+          ENDIF
+
+          IF ( netcdf_data_format > 4 )  THEN
+!
+!--          Set needed time levels (ntdim) to 
+!--          saved time levels + to be saved time levels.
+             IF ( av == 0 )  THEN 
+                ntdim_2d_xz(0) = do2d_xz_time_count(0) + CEILING(             &
+                                 ( end_time - MAX( skip_time_do2d_xz,         &
+                                                   simulated_time_at_begin )  &
+                                 ) / dt_do2d_xz )
+             ELSE
+                ntdim_2d_xz(1) = do2d_xz_time_count(1) + CEILING(             &
+                                 ( end_time - MAX( skip_time_data_output_av,  &
+                                                   simulated_time_at_begin )  &
+                                 ) / dt_data_output_av )
+             ENDIF
+
+!
+!--          Check if the needed number of output time levels is increased
+!--          compared to the number of time levels in the existing file.
+             IF ( ntdim_2d_xz(av) > ntime_count )  THEN
+                message_string = 'netCDF file for cross sections ' // &
+                                 TRIM( var ) // ' from previous run found,' // &
+                                 '&but this file cannot be extended becaus' // &
+                                 'e the number of output time levels&has b' // &
+                                 'een increased compared to the previous s' // &
+                                 'imulation.' //                               &
+                                 '&New file is created instead.'
+                CALL message( 'define_netcdf_header', 'PA0390', 0, 1, 0, 6, 0 )
+                do2d_xz_time_count(av) = 0
+                extend = .FALSE.
+!
+!--             Recalculate the needed time levels for the new file.
+                IF ( av == 0 )  THEN
+                   ntdim_2d_xz(0) = CEILING(                            &
+                           ( end_time - MAX( skip_time_do2d_xz,         &
+                                             simulated_time_at_begin )  &
+                           ) / dt_do2d_xz )
+                ELSE
+                   ntdim_2d_xz(1) = CEILING(                            &
+                           ( end_time - MAX( skip_time_data_output_av,  &
+                                             simulated_time_at_begin )  &
+                           ) / dt_data_output_av )
+                ENDIF
+                RETURN
+             ENDIF
+          ENDIF
+
+!
+!--       Dataset seems to be extendable.
+!--       Now get the variable ids.
+          i = 1
+          DO WHILE ( do2d(av,i)(1:1) /= ' ' )
+             IF ( INDEX( do2d(av,i), 'xz' ) /= 0 )  THEN
+                nc_stat = NF90_INQ_VARID( id_set_xz(av), do2d(av,i), &
+                                          id_var_do2d(av,i) )
+                CALL netcdf_handle_error( 'netcdf_define_header', 177 )
+#if defined( __netcdf4_parallel )
+!
+!--             Set independent io operations for parallel io. Collective io
+!--             is only allowed in case of a 1d-decomposition along x, because
+!--             otherwise, not all PEs have output data.
+                IF ( netcdf_data_format > 4 )  THEN
+                   IF ( npey == 1 )  THEN
+                      nc_stat = NF90_VAR_PAR_ACCESS( id_set_xz(av),     &
+                                                     id_var_do2d(av,i), &
+                                                     NF90_COLLECTIVE )
+                   ELSE
+!
+!--                   Test simulations showed that the output of cross sections
+!--                   by all PEs in data_output_2d using NF90_COLLECTIVE is 
+!--                   faster than the output by the first row of PEs in
+!--                   x-direction using NF90_INDEPENDENT.
+                      nc_stat = NF90_VAR_PAR_ACCESS( id_set_xz(av),     &
+                                                     id_var_do2d(av,i), &
+                                                     NF90_COLLECTIVE )
+!                      nc_stat = NF90_VAR_PAR_ACCESS( id_set_xz(av),     &
+!                                                     id_var_do2d(av,i), &
+!                                                     NF90_INDEPENDENT )
+                   ENDIF
+                   CALL netcdf_handle_error( 'netcdf_define_header', 455 )
+                ENDIF
+#endif
+             ENDIF
+             i = i + 1
+          ENDDO
+
+!
+!--       Update the title attribute on file
+!--       In order to avoid 'data mode' errors if updated attributes are larger 
+!--       than their original size, NF90_PUT_ATT is called in 'define mode' 
+!--       enclosed by NF90_REDEF and NF90_ENDDEF calls. This implies a possible 
+!--       performance loss due to data copying; an alternative strategy would be 
+!--       to ensure equal attribute size in a job chain. Maybe revise later.
+          IF ( av == 0 )  THEN
+             time_average_text = ' '
+          ELSE
+             WRITE (time_average_text, '('', '',F7.1,'' s average'')') &
+                                                            averaging_interval
+          ENDIF
+          nc_stat = NF90_REDEF( id_set_xz(av) )
+          CALL netcdf_handle_error( 'netcdf_define_header', 433 )
+          nc_stat = NF90_PUT_ATT( id_set_xz(av), NF90_GLOBAL, 'title', &
+                                  TRIM( run_description_header ) //    &
+                                  TRIM( time_average_text ) )
+          CALL netcdf_handle_error( 'netcdf_define_header', 178 )
+          nc_stat = NF90_ENDDEF( id_set_xz(av) )
+          CALL netcdf_handle_error( 'netcdf_define_header', 434 )
+          message_string = 'netCDF file for cross-sections ' //           &
+                            TRIM( var ) // ' from previous run found.' // &
+                           '&This file will be extended.'
+          CALL message( 'define_netcdf_header', 'PA0253', 0, 0, 0, 6, 0 )
+
+
+       CASE ( 'yz_new' )
+
+!
+!--       Define some global attributes of the dataset
+          nc_stat = NF90_PUT_ATT( id_set_yz(av), NF90_GLOBAL, 'Conventions', &
+                                  'COARDS' )
+          CALL netcdf_handle_error( 'netcdf_define_header', 179 )
+
+          IF ( av == 0 )  THEN
+             time_average_text = ' '
+          ELSE
+             WRITE (time_average_text, '('', '',F7.1,'' s average'')') &
+                                                            averaging_interval
+          ENDIF
+          nc_stat = NF90_PUT_ATT( id_set_yz(av), NF90_GLOBAL, 'title', &
+                                  TRIM( run_description_header ) //    &
+                                  TRIM( time_average_text ) )
+          CALL netcdf_handle_error( 'netcdf_define_header', 180 )
+          IF ( av == 1 )  THEN
+             WRITE ( time_average_text,'(F7.1,'' s avg'')' )  averaging_interval
+             nc_stat = NF90_PUT_ATT( id_set_yz(av), NF90_GLOBAL, 'time_avg', &
+                                     TRIM( time_average_text ) )
+             CALL netcdf_handle_error( 'netcdf_define_header', 180 )
+          ENDIF
+
+!
+!--       Define time coordinate for yz sections.
+!--       For parallel output the time dimensions has to be limited, otherwise
+!--       the performance drops significantly.
+          IF ( netcdf_data_format < 5 )  THEN
+             CALL netcdf_create_dim( id_set_yz(av), 'time', NF90_UNLIMITED,    &
+                                     id_dim_time_yz(av), 181 )
+          ELSE
+             CALL netcdf_create_dim( id_set_yz(av), 'time', ntdim_2d_yz(av),   &
+                                     id_dim_time_yz(av), 526 )
+          ENDIF
+
+          CALL netcdf_create_var( id_set_yz(av), (/ id_dim_time_yz(av) /),     &
+                                  'time', NF90_DOUBLE, id_var_time_yz(av),     &
+                                  'seconds', '', 182, 183, 000 )
+!
+!--       Define the spatial dimensions and coordinates for yz-sections.
+!--       First, determine the number of vertical sections to be written.
+          IF ( section(1,3) == -9999 )  THEN
+             RETURN
+          ELSE
+             ns = 1
+             DO WHILE ( section(ns,3) /= -9999  .AND.  ns <= 100 )
+                ns = ns + 1
+             ENDDO
+             ns = ns - 1
+          ENDIF
+
+!
+!--       Define x axis (for scalar position)
+          CALL netcdf_create_dim( id_set_yz(av), 'x_yz', ns, id_dim_x_yz(av),  &
+                                  184 )
+          CALL netcdf_create_var( id_set_yz(av), (/ id_dim_x_yz(av) /),        &
+                                  'x_yz', NF90_DOUBLE, id_var_x_yz(av),        &
+                                  'meters', '', 185, 186, 000 )
+!
+!--       Define x axis (for u position)
+          CALL netcdf_create_dim( id_set_yz(av), 'xu_yz', ns,                  &
+                                  id_dim_xu_yz(av), 377 )
+          CALL netcdf_create_var( id_set_yz(av), (/ id_dim_xu_yz(av) /),       &
+                                  'xu_yz', NF90_DOUBLE, id_var_xu_yz(av),      &
+                                  'meters', '', 378, 379, 000 )
+!
+!--       Define a variable to store the layer indices of the vertical cross
+!--       sections
+          CALL netcdf_create_var( id_set_yz(av), (/ id_dim_x_yz(av) /),        &
+                                  'ind_x_yz', NF90_DOUBLE,                     &
+                                  id_var_ind_x_yz(av), 'gridpoints', '', 187,  &
+                                  188, 000 )
+!
+!--       Define y-axis (for scalar position)
+          CALL netcdf_create_dim( id_set_yz(av), 'y', ny+2, id_dim_y_yz(av),   &
+                                  189 )
+          CALL netcdf_create_var( id_set_yz(av), (/ id_dim_y_yz(av) /), 'y',   &
+                                  NF90_DOUBLE, id_var_y_yz(av), 'meters', '',  &
+                                  190, 191, 000 )
+!
+!--       Define y-axis (for v position)
+          CALL netcdf_create_dim( id_set_yz(av), 'yv', ny+2, id_dim_yv_yz(av), &
+                                  380 )
+          CALL netcdf_create_var( id_set_yz(av), (/ id_dim_yv_yz(av) /), 'yv', &
+                                  NF90_DOUBLE, id_var_yv_yz(av), 'meters', '', &
+                                  381, 382, 000 )
+!
+!--       Define the two z-axes (zu and zw)
+          CALL netcdf_create_dim( id_set_yz(av), 'zu', nz+2, id_dim_zu_yz(av), &
+                                  192 )
+          CALL netcdf_create_var( id_set_yz(av), (/ id_dim_zu_yz(av) /), 'zu', &
+                                  NF90_DOUBLE, id_var_zu_yz(av), 'meters', '', &
+                                  193, 194, 000 )
+
+          CALL netcdf_create_dim( id_set_yz(av), 'zw', nz+2, id_dim_zw_yz(av), &
+                                  195 )
+          CALL netcdf_create_var( id_set_yz(av), (/ id_dim_zw_yz(av) /), 'zw', &
+                                  NF90_DOUBLE, id_var_zw_yz(av), 'meters', '', &
+                                  196, 197, 000 )
+
+          IF ( land_surface )  THEN
+
+             CALL netcdf_create_dim( id_set_yz(av), 'zs', nzs,                 &
+                                     id_dim_zs_yz(av), 545 )
+             CALL netcdf_create_var( id_set_yz(av), (/ id_dim_zs_yz(av) /),    &
+                                     'zs', NF90_DOUBLE, id_var_zs_yz(av),      &
+                                     'meters', '', 546, 547, 000 )
+
+          ENDIF
+
+!
+!--       Define the variables
+          var_list = ';'
+          i = 1
+
+          DO WHILE ( do2d(av,i)(1:1) /= ' ' )
+
+             IF ( INDEX( do2d(av,i), 'yz' ) /= 0 )  THEN
+
+!
+!--             Check for the grid
+                found = .TRUE.
+                SELECT CASE ( do2d(av,i) )
+!
+!--                Most variables are defined on the zu grid
+                   CASE ( 'e_yz', 'lpt_yz', 'nr_yz', 'p_yz', 'pc_yz', 'pr_yz', &
+                          'prr_yz', 'pt_yz', 'q_yz', 'qc_yz', 'ql_yz',         &
+                          'ql_c_yz', 'ql_v_yz', 'ql_vp_yz', 'qr_yz', 'qv_yz',  &
+                          'rad_lw_cs_hr_yz', 'rad_lw_hr_yz',                   &
+                          'rad_sw_cs_hr_yz', 'rad_sw_hr_yz''rho_yz', 's_yz',   &
+                          'sa_yz', 'vpt_yz' )
+
+                      grid_x = 'x'
+                      grid_y = 'y'
+                      grid_z = 'zu'
+!
+!--                u grid
+                   CASE ( 'u_yz' )
+
+                      grid_x = 'xu'
+                      grid_y = 'y'
+                      grid_z = 'zu'
+!
+!--                v grid
+                   CASE ( 'v_yz' )
+
+                      grid_x = 'x'
+                      grid_y = 'yv'
+                      grid_z = 'zu'
+!
+!--                w grid
+                   CASE ( 'rad_lw_in_yz', 'rad_lw_out_yz', 'rad_sw_in_yz',     &
+                          'rad_sw_out_yz', 'w_yz' )
+
+                      grid_x = 'x'
+                      grid_y = 'y'
+                      grid_z = 'zw'
+!
+!--                soil grid
+                   CASE ( 'm_soil_yz', 't_soil_yz' )
+
+                      grid_x = 'x'
+                      grid_y = 'y'
+                      grid_z = 'zs'
+
+                   CASE DEFAULT
+!
+!--                   Check for user-defined quantities
+                      CALL user_define_netcdf_grid( do2d(av,i), found, &
+                                                    grid_x, grid_y, grid_z )
+
+                      IF ( .NOT. found )  THEN
+                         WRITE ( message_string, * ) 'no grid defined for',    &
+                                                ' variable ', TRIM( do2d(av,i) )
+                         CALL message( 'define_netcdf_header', 'PA0244',       &
+                                       0, 1, 0, 6, 0 )
+                      ENDIF
+
+                END SELECT
+
+!
+!--             Select the respective dimension ids
+                IF ( grid_x == 'x' )  THEN
+                   id_x = id_dim_x_yz(av)
+                ELSEIF ( grid_x == 'xu' )  THEN
+                   id_x = id_dim_xu_yz(av)
+                ENDIF
+
+                IF ( grid_y == 'y' )  THEN
+                   id_y = id_dim_y_yz(av)
+                ELSEIF ( grid_y == 'yv' )  THEN
+                   id_y = id_dim_yv_yz(av)
+                ENDIF
+
+                IF ( grid_z == 'zu' )  THEN
+                   id_z = id_dim_zu_yz(av)
+                ELSEIF ( grid_z == 'zw' )  THEN
+                   id_z = id_dim_zw_yz(av)
+                ELSEIF ( grid_z == 'zs' )  THEN
+                   id_z = id_dim_zs_yz(av)
+                ENDIF
+
+!
+!--             Define the grid
+                CALL netcdf_create_var( id_set_yz(av),  (/ id_x, id_y, id_z,   &
+                                        id_dim_time_yz(av) /), do2d(av,i),     &
+                                        nc_precision(3), id_var_do2d(av,i),    &
+                                        TRIM( do2d_unit(av,i) ), do2d(av,i),   &
+                                        198, 199, 356 )
+
+#if defined( __netcdf4_parallel )
+                IF ( netcdf_data_format > 4 )  THEN
+!
+!--                Set no fill for every variable to increase performance.
+                   nc_stat = NF90_DEF_VAR_FILL( id_set_yz(av),     &
+                                                id_var_do2d(av,i), &
+                                                1, 0 )
+                   CALL netcdf_handle_error( 'netcdf_define_header', 535 )
+!
+!--                Set independent io operations for parallel io. Collective io
+!--                is only allowed in case of a 1d-decomposition along y,
+!--                because otherwise, not all PEs have output data.
+                   IF ( npex == 1 )  THEN
+                      nc_stat = NF90_VAR_PAR_ACCESS( id_set_yz(av),     &
+                                                     id_var_do2d(av,i), &
+                                                     NF90_COLLECTIVE )
+                   ELSE
+!
+!--                   Test simulations showed that the output of cross sections
+!--                   by all PEs in data_output_2d using NF90_COLLECTIVE is 
+!--                   faster than the output by the first row of PEs in
+!--                   y-direction using NF90_INDEPENDENT.
+                      nc_stat = NF90_VAR_PAR_ACCESS( id_set_yz(av),     &
+                                                     id_var_do2d(av,i), &
+                                                     NF90_COLLECTIVE )
+!                      nc_stat = NF90_VAR_PAR_ACCESS( id_set_yz(av),     &
+!                                                     id_var_do2d(av,i), &
+!                                                     NF90_INDEPENDENT )
+                   ENDIF
+                   CALL netcdf_handle_error( 'netcdf_define_header', 450 )
+                ENDIF
+#endif
+                var_list = TRIM( var_list ) // TRIM( do2d(av,i) ) // ';'
+
+             ENDIF
+
+             i = i + 1
+
+          ENDDO
+
+!
+!--       No arrays to output. Close the netcdf file and return.
+          IF ( i == 1 )  RETURN
+
+!
+!--       Write the list of variables as global attribute (this is used by
+!--       restart runs and by combine_plot_fields)
+          nc_stat = NF90_PUT_ATT( id_set_yz(av), NF90_GLOBAL, 'VAR_LIST', &
+                                  var_list )
+          CALL netcdf_handle_error( 'netcdf_define_header', 200 )
+
+!
+!--       Set general no fill, otherwise the performance drops significantly for
+!--       parallel output.
+          nc_stat = NF90_SET_FILL( id_set_yz(av), NF90_NOFILL, oldmode )
+          CALL netcdf_handle_error( 'netcdf_define_header', 531 )
+
+!
+!--       Leave netCDF define mode
+          nc_stat = NF90_ENDDEF( id_set_yz(av) )
+          CALL netcdf_handle_error( 'netcdf_define_header', 201 )
+
+!
+!--       These data are only written by PE0 for parallel output to increase
+!--       the performance.
+          IF ( myid == 0  .OR.  netcdf_data_format < 5 )  THEN
+
+!
+!--          Write axis data: x_yz, y, zu, zw
+             ALLOCATE( netcdf_data(1:ns) )
+
+!
+!--          Write x_yz data (shifted by +dx/2)
+             DO  i = 1, ns
+                IF( section(i,3) == -1 )  THEN
+                   netcdf_data(i) = -1.0_wp  ! section averaged along x
+                ELSE
+                   netcdf_data(i) = ( section(i,3) + 0.5_wp ) * dx
+                ENDIF
+             ENDDO
+             nc_stat = NF90_PUT_VAR( id_set_yz(av), id_var_x_yz(av), &
+                                     netcdf_data, start = (/ 1 /),   &
+                                     count = (/ ns /) )
+             CALL netcdf_handle_error( 'netcdf_define_header', 202 )
+
+!
+!--          Write x_yz data (xu grid)
+             DO  i = 1, ns
+                IF( section(i,3) == -1 )  THEN
+                   netcdf_data(i) = -1.0_wp  ! section averaged along x
+                ELSE
+                   netcdf_data(i) = section(i,3) * dx
+                ENDIF
+             ENDDO
+             nc_stat = NF90_PUT_VAR( id_set_yz(av), id_var_xu_yz(av), &
+                                     netcdf_data, start = (/ 1 /),    &
+                                     count = (/ ns /) )
+             CALL netcdf_handle_error( 'netcdf_define_header', 383 )
+
+!
+!--          Write gridpoint number data
+             netcdf_data(1:ns) = section(1:ns,3)
+             nc_stat = NF90_PUT_VAR( id_set_yz(av), id_var_ind_x_yz(av), &
+                                     netcdf_data, start = (/ 1 /),       &
+                                     count = (/ ns /) )
+             CALL netcdf_handle_error( 'netcdf_define_header', 203 )
+
+             DEALLOCATE( netcdf_data )
+
+!
+!--          Write data for y (shifted by +dy/2) and yv axis
+             ALLOCATE( netcdf_data(0:ny+1) )
+
+             DO  j = 0, ny+1
+                netcdf_data(j) = ( j + 0.5_wp ) * dy
+             ENDDO
+
+             nc_stat = NF90_PUT_VAR( id_set_yz(av), id_var_y_yz(av), &
+                                     netcdf_data, start = (/ 1 /),   &
+                                     count = (/ ny+2 /) )
+             CALL netcdf_handle_error( 'netcdf_define_header', 204 )
+
+             DO  j = 0, ny+1
+                netcdf_data(j) = j * dy
+             ENDDO
+
+             nc_stat = NF90_PUT_VAR( id_set_yz(av), id_var_yv_yz(av), &
+                                     netcdf_data, start = (/ 1 /),    &
+                                     count = (/ ny+2 /) )
+             CALL netcdf_handle_error( 'netcdf_define_header', 384 )
+
+             DEALLOCATE( netcdf_data )
+
+!
+!--          Write zu and zw data (vertical axes)
+             ALLOCATE( netcdf_data(0:nz+1) )
+
+             netcdf_data(0:nz+1) = zu(nzb:nzt+1)
+             nc_stat = NF90_PUT_VAR( id_set_yz(av), id_var_zu_yz(av), &
+                                     netcdf_data, start = (/ 1 /),    &
+                                     count = (/ nz+2 /) )
+             CALL netcdf_handle_error( 'netcdf_define_header', 205 )
+
+             netcdf_data(0:nz+1) = zw(nzb:nzt+1)
+             nc_stat = NF90_PUT_VAR( id_set_yz(av), id_var_zw_yz(av), &
+                                     netcdf_data, start = (/ 1 /),    &
+                                     count = (/ nz+2 /) )
+             CALL netcdf_handle_error( 'netcdf_define_header', 206 )
+
+             DEALLOCATE( netcdf_data )
+
+          ENDIF
+
+
+       CASE ( 'yz_ext' )
+
+!
+!--       Get the list of variables and compare with the actual run.
+!--       First var_list_old has to be reset, since GET_ATT does not assign
+!--       trailing blanks.
+          var_list_old = ' '
+          nc_stat = NF90_GET_ATT( id_set_yz(av), NF90_GLOBAL, 'VAR_LIST', &
+                                  var_list_old )
+          CALL netcdf_handle_error( 'netcdf_define_header', 207 )
+
+          var_list = ';'
+          i = 1
+          DO WHILE ( do2d(av,i)(1:1) /= ' ' )
+             IF ( INDEX( do2d(av,i), 'yz' ) /= 0 )  THEN
+                var_list = TRIM( var_list ) // TRIM( do2d(av,i) ) // ';'
+             ENDIF
+             i = i + 1
+          ENDDO
+
+          IF ( av == 0 )  THEN
+             var = '(yz)'
+          ELSE
+             var = '(yz_av)'
+          ENDIF
+
+          IF ( TRIM( var_list ) /= TRIM( var_list_old ) )  THEN
+             message_string = 'netCDF file for cross-sections ' //           &
+                              TRIM( var ) // ' from previous run found,' //  &
+                              '& but this file cannot be extended due to' // &
+                              ' variable mismatch.' //                       & 
+                              '&New file is created instead.'
+             CALL message( 'define_netcdf_header', 'PA0249', 0, 1, 0, 6, 0 )
+             extend = .FALSE.
+             RETURN
+          ENDIF
+
+!
+!--       Calculate the number of current sections
+          ns = 1
+          DO WHILE ( section(ns,3) /= -9999  .AND.  ns <= 100 )
+             ns = ns + 1
+          ENDDO
+          ns = ns - 1
+
+!
+!--       Get and compare the number of vertical cross sections
+          nc_stat = NF90_INQ_VARID( id_set_yz(av), 'x_yz', id_var_x_yz(av) )
+          CALL netcdf_handle_error( 'netcdf_define_header', 208 )
+
+          nc_stat = NF90_INQUIRE_VARIABLE( id_set_yz(av), id_var_x_yz(av), &
+                                           dimids = id_dim_x_yz_old )
+          CALL netcdf_handle_error( 'netcdf_define_header', 209 )
+          id_dim_x_yz(av) = id_dim_x_yz_old(1)
+
+          nc_stat = NF90_INQUIRE_DIMENSION( id_set_yz(av), id_dim_x_yz(av), &
+                                            len = ns_old )
+          CALL netcdf_handle_error( 'netcdf_define_header', 210 )
+
+          IF ( ns /= ns_old )  THEN
+             message_string = 'netCDF file for cross-sections ' //          &
+                              TRIM( var ) // ' from previous run found,' // &
+                              '&but this file cannot be extended due to' // &
+                              ' mismatch in number of' //                   &
+                              '&cross sections.' //                         &
+                              '&New file is created instead.'
+             CALL message( 'define_netcdf_header', 'PA0250', 0, 1, 0, 6, 0 )
+             extend = .FALSE.
+             RETURN
+          ENDIF
+
+!
+!--       Get and compare the heights of the cross sections
+          ALLOCATE( netcdf_data(1:ns_old) )
+
+          nc_stat = NF90_GET_VAR( id_set_yz(av), id_var_x_yz(av), netcdf_data )
+          CALL netcdf_handle_error( 'netcdf_define_header', 211 )
+
+          DO  i = 1, ns
+             IF ( section(i,3) /= -1 )  THEN
+                IF ( ( ( section(i,3) + 0.5 ) * dx ) /= netcdf_data(i) )  THEN
+                   message_string = 'netCDF file for cross-sections ' //    &
+                              TRIM( var ) // ' from previous run found,' // &
+                              '&but this file cannot be extended' //        &
+                              ' due to mismatch in cross' //                &
+                              '&section levels.' //                         &
+                             '&New file is created instead.'
+                   CALL message( 'define_netcdf_header', 'PA0251', &
+                                                                 0, 1, 0, 6, 0 )
+                   extend = .FALSE.
+                   RETURN
+                ENDIF
+             ELSE
+                IF ( -1.0_wp /= netcdf_data(i) )  THEN
+                   message_string = 'netCDF file for cross-sections ' //    &
+                              TRIM( var ) // ' from previous run found,' // &
+                              '&but this file cannot be extended' //        &
+                              ' due to mismatch in cross' //                &
+                              '&section levels.' //                         &
+                              '&New file is created instead.'
+                   CALL message( 'define_netcdf_header', 'PA0251', &
+                                                                 0, 1, 0, 6, 0 )
+                   extend = .FALSE.
+                   RETURN
+                ENDIF
+             ENDIF
+          ENDDO
+
+          DEALLOCATE( netcdf_data )
+
+!
+!--       Get the id of the time coordinate (unlimited coordinate) and its
+!--       last index on the file. The next time level is pl2d..count+1.
+!--       The current time must be larger than the last output time
+!--       on the file.
+          nc_stat = NF90_INQ_VARID( id_set_yz(av), 'time', id_var_time_yz(av) )
+          CALL netcdf_handle_error( 'netcdf_define_header', 212 )
+
+          nc_stat = NF90_INQUIRE_VARIABLE( id_set_yz(av), id_var_time_yz(av), &
+                                           dimids = id_dim_time_old )
+          CALL netcdf_handle_error( 'netcdf_define_header', 213 )
+          id_dim_time_yz(av) = id_dim_time_old(1)
+
+          nc_stat = NF90_INQUIRE_DIMENSION( id_set_yz(av), id_dim_time_yz(av), &
+                                            len = ntime_count )
+          CALL netcdf_handle_error( 'netcdf_define_header', 214 )
+
+!
+!--       For non-parallel output use the last output time level of the netcdf
+!--       file because the time dimension is unlimited. In case of parallel
+!--       output the variable ntime_count could get the value of 9*10E36 because
+!--       the time dimension is limited.
+          IF ( netcdf_data_format < 5 ) do2d_yz_time_count(av) = ntime_count
+
+          nc_stat = NF90_GET_VAR( id_set_yz(av), id_var_time_yz(av),    &
+                                  last_time_coordinate,                 &
+                                  start = (/ do2d_yz_time_count(av) /), &
+                                  count = (/ 1 /) )
+          CALL netcdf_handle_error( 'netcdf_define_header', 215 )
+
+          IF ( last_time_coordinate(1) >= simulated_time )  THEN
+             message_string = 'netCDF file for cross sections ' //          &
+                              TRIM( var ) // ' from previous run found,' // &
+                              '&but this file cannot be extended becaus' // &
+                              'e the current output time' //                &
+                              '&is less or equal than the last output t' // &
+                              'ime on this file.' //                        &
+                              '&New file is created instead.'
+             CALL message( 'define_netcdf_header', 'PA0252', 0, 1, 0, 6, 0 )
+             do2d_yz_time_count(av) = 0
+             extend = .FALSE.
+             RETURN
+          ENDIF
+
+          IF ( netcdf_data_format > 4 )  THEN
+!
+!--          Set needed time levels (ntdim) to 
+!--          saved time levels + to be saved time levels.
+             IF ( av == 0 )  THEN 
+                ntdim_2d_yz(0) = do2d_yz_time_count(0) + CEILING(             &
+                                 ( end_time - MAX( skip_time_do2d_yz,         &
+                                                   simulated_time_at_begin )  &
+                                 ) / dt_do2d_yz )
+             ELSE
+                ntdim_2d_yz(1) = do2d_yz_time_count(1) + CEILING(             &
+                                 ( end_time - MAX( skip_time_data_output_av,  &
+                                                   simulated_time_at_begin )  &
+                                 ) / dt_data_output_av )
+             ENDIF
+
+!
+!--          Check if the needed number of output time levels is increased
+!--          compared to the number of time levels in the existing file.
+             IF ( ntdim_2d_yz(av) > ntime_count )  THEN
+                message_string = 'netCDF file for cross sections ' //          &
+                                 TRIM( var ) // ' from previous run found,' // &
+                                 '&but this file cannot be extended becaus' // &
+                                 'e the number of output time levels&has b' // &
+                                 'een increased compared to the previous s' // &
+                                 'imulation.' //                               &
+                                 '&New file is created instead.'
+                CALL message( 'define_netcdf_header', 'PA0391', 0, 1, 0, 6, 0 )
+                do2d_yz_time_count(av) = 0
+                extend = .FALSE.
+!
+!--             Recalculate the needed time levels for the new file.
+                IF ( av == 0 )  THEN
+                   ntdim_2d_yz(0) = CEILING(                            &
+                           ( end_time - MAX( skip_time_do2d_yz,         &
+                                             simulated_time_at_begin )  &
+                           ) / dt_do2d_yz )
+                ELSE
+                   ntdim_2d_yz(1) = CEILING(                            &
+                           ( end_time - MAX( skip_time_data_output_av,  &
+                                             simulated_time_at_begin )  &
+                           ) / dt_data_output_av )
+                ENDIF
+                RETURN
+             ENDIF
+          ENDIF
+
+!
+!--       Dataset seems to be extendable.
+!--       Now get the variable ids.
+          i = 1
+          DO WHILE ( do2d(av,i)(1:1) /= ' ' )
+             IF ( INDEX( do2d(av,i), 'yz' ) /= 0 )  THEN
+                nc_stat = NF90_INQ_VARID( id_set_yz(av), do2d(av,i), &
+                                          id_var_do2d(av,i) )
+                CALL netcdf_handle_error( 'netcdf_define_header', 216 )
+#if defined( __netcdf4_parallel )
+!
+!--             Set independent io operations for parallel io. Collective io
+!--             is only allowed in case of a 1d-decomposition along y, because
+!--             otherwise, not all PEs have output data.
+                IF ( netcdf_data_format > 4 )  THEN
+                   IF ( npex == 1 )  THEN
+                      nc_stat = NF90_VAR_PAR_ACCESS( id_set_yz(av),     &
+                                                     id_var_do2d(av,i), &
+                                                     NF90_COLLECTIVE )
+                   ELSE
+!
+!--                   Test simulations showed that the output of cross sections
+!--                   by all PEs in data_output_2d using NF90_COLLECTIVE is 
+!--                   faster than the output by the first row of PEs in
+!--                   y-direction using NF90_INDEPENDENT.
+                      nc_stat = NF90_VAR_PAR_ACCESS( id_set_yz(av),     &
+                                                     id_var_do2d(av,i), &
+                                                     NF90_COLLECTIVE )
+!                      nc_stat = NF90_VAR_PAR_ACCESS( id_set_yz(av),     &
+!                                                     id_var_do2d(av,i), &
+!                                                     NF90_INDEPENDENT )
+                   ENDIF
+                   CALL netcdf_handle_error( 'netcdf_define_header', 450 )
+                ENDIF
+#endif
+             ENDIF
+             i = i + 1
+          ENDDO
+
+!
+!--       Update the title attribute on file
+!--       In order to avoid 'data mode' errors if updated attributes are larger 
+!--       than their original size, NF90_PUT_ATT is called in 'define mode' 
+!--       enclosed by NF90_REDEF and NF90_ENDDEF calls. This implies a possible 
+!--       performance loss due to data copying; an alternative strategy would be 
+!--       to ensure equal attribute size in a job chain. Maybe revise later.
+          IF ( av == 0 )  THEN
+             time_average_text = ' '
+          ELSE
+             WRITE (time_average_text, '('', '',F7.1,'' s average'')') &
+                                                            averaging_interval
+          ENDIF
+          nc_stat = NF90_REDEF( id_set_yz(av) )
+          CALL netcdf_handle_error( 'netcdf_define_header', 435 )
+          nc_stat = NF90_PUT_ATT( id_set_yz(av), NF90_GLOBAL, 'title', &
+                                  TRIM( run_description_header ) //    &
+                                  TRIM( time_average_text ) )
+          CALL netcdf_handle_error( 'netcdf_define_header', 217 )
+          nc_stat = NF90_ENDDEF( id_set_yz(av) )
+          CALL netcdf_handle_error( 'netcdf_define_header', 436 )
+          message_string = 'netCDF file for cross-sections ' //           &
+                            TRIM( var ) // ' from previous run found.' // &
+                           '&This file will be extended.'
+          CALL message( 'define_netcdf_header', 'PA0253', 0, 0, 0, 6, 0 )
+
+
+       CASE ( 'pr_new' )
+
+!
+!--       Define some global attributes of the dataset
+          IF ( averaging_interval_pr /= 0.0_wp )  THEN
+             WRITE (time_average_text,'('', '',F7.1,'' s average'')') &
+                                                            averaging_interval_pr
+             nc_stat = NF90_PUT_ATT( id_set_pr, NF90_GLOBAL, 'title',   &
+                                     TRIM( run_description_header ) //  &
+                                     TRIM( time_average_text ) )
+             CALL netcdf_handle_error( 'netcdf_define_header', 218 )
+
+             WRITE ( time_average_text,'(F7.1,'' s avg'')' ) averaging_interval_pr
+             nc_stat = NF90_PUT_ATT( id_set_pr, NF90_GLOBAL, 'time_avg', &
+                                     TRIM( time_average_text ) )
+          ELSE
+             nc_stat = NF90_PUT_ATT( id_set_pr, NF90_GLOBAL, 'title', &
+                                     TRIM( run_description_header ) )
+          ENDIF
+          CALL netcdf_handle_error( 'netcdf_define_header', 219 )
+
+!
+!--       Write number of columns and rows of coordinate systems to be plotted
+!--       on one page to the netcdf header.
+!--       This information can be used by palmplot.
+          nc_stat = NF90_PUT_ATT( id_set_pr, NF90_GLOBAL,                     &
+                                  'no_rows',                                  & 
+                                  profile_rows ) 
+          CALL netcdf_handle_error( 'netcdf_define_header', 519 )
+
+          nc_stat = NF90_PUT_ATT( id_set_pr, NF90_GLOBAL,                     &
+                                  'no_columns',                               & 
+                                  profile_columns ) 
+          CALL netcdf_handle_error( 'netcdf_define_header', 520 )
+
+
+          cross_profiles_adj  = ADJUSTL( cross_profiles )
+          cross_profiles_numb = 999999
+          cross_profiles_char = ''
+
+!
+!--       Each profile defined in cross_profiles is written to an array
+!--       (cross_profiles_char). The number of the respective coordinate
+!--       system is assigned in a second array (cross_profiles_numb).
+          k = 1
+
+          DO  i = 1, crmax
+
+             IF ( TRIM( cross_profiles_adj(i) ) == ' ' )  EXIT
+             delim_old = 0
+
+             DO   j = 1, crmax
+                delim = INDEX( cross_profiles_adj(i)(delim_old+1:), ' ' )
+                IF ( delim == 1 )  EXIT
+                kk = MIN( crmax, k )
+                cross_profiles_char(kk) = cross_profiles_adj(i)(delim_old+1: &
+                                                              delim_old+delim-1)
+                cross_profiles_numb(kk) = i
+                k = k + 1
+                cross_profiles_maxi  = i
+                delim_old = delim_old + delim
+             ENDDO
+
+          ENDDO
+
+          cross_profiles_count = MIN( crmax, k-1 )
+!
+!--       Check if all profiles defined in cross_profiles are defined in 
+!--       data_output_pr. If not, they will be skipped.
+          DO  i = 1, cross_profiles_count
+             DO  j = 1, dopr_n
+
+                IF ( TRIM(cross_profiles_char(i)) == TRIM(data_output_pr(j)) ) &
+                THEN
+                   EXIT
+                ENDIF
+
+                IF ( j == dopr_n )  THEN
+                   cross_profiles_numb(i) = 999999
+                ENDIF
+
+             ENDDO
+          ENDDO
+
+          DO i = 1, crmax
+             IF ( cross_profiles_numb(i) == 999999 ) THEN
+                DO j = i + 1, crmax
+                   IF ( cross_profiles_numb(j) /= 999999 ) THEN
+                      cross_profiles_char(i) = cross_profiles_char(j)
+                      cross_profiles_numb(i) = cross_profiles_numb(j)
+                      cross_profiles_numb(j) = 999999
+                      EXIT
+                   ENDIF
+                ENDDO
+             ENDIF
+          ENDDO
+
+          DO i = 1, crmax-1
+             IF ( cross_profiles_numb(i + 1) == 999999 ) THEN
+                cross_profiles_count = i
+                EXIT
+             ENDIF
+          ENDDO
+!
+!--       Check if all profiles defined in data_output_pr are defined in 
+!--       cross_profiles. If not, they will be added to cross_profiles.
+          DO  i = 1, dopr_n
+             DO  j = 1, cross_profiles_count
+
+                IF ( TRIM(cross_profiles_char(j)) == TRIM(data_output_pr(i))) &
+                THEN
+                   EXIT
+                ENDIF
+
+                IF (( j == cross_profiles_count ) .AND.                        &
+                    ( cross_profiles_count <= crmax - 1))  THEN
+                   cross_profiles_count = cross_profiles_count + 1
+                   cross_profiles_maxi  = cross_profiles_maxi  + 1
+                   cross_profiles_char(MIN( crmax, cross_profiles_count )) =  &
+                                                      TRIM( data_output_pr(i) )
+                   cross_profiles_numb(MIN( crmax, cross_profiles_count )) =  &
+                                                      cross_profiles_maxi
+                ENDIF
+
+             ENDDO
+          ENDDO
+
+          IF ( cross_profiles_count >= crmax )  THEN
+             message_string = 'It is not allowed to arrange more than '     &
+                              // '100 profiles with & cross_profiles. Apart'&
+                              // ' from that, all profiles are saved & to ' &
+                              // 'the netCDF file.'
+             CALL message( 'define_netcdf_header', 'PA0354', 0, 0, 0, 6, 0 )
+          ENDIF
+
+!
+!--       Writing cross_profiles to netcdf header. This information can be 
+!--       used by palmplot. Each profile is separated by ",", each cross is 
+!--       separated by ";".
+          char_cross_profiles = ';'
+          id_last = 1
+          cross_profiles_count = MIN( cross_profiles_count, crmax )
+
+          DO  i = 1, cross_profiles_count
+
+             IF ( cross_profiles_numb(i) /= 999999 )  THEN
+                IF ( TRIM( char_cross_profiles ) == ';' )  THEN
+                   char_cross_profiles = TRIM( char_cross_profiles ) // &
+                                         TRIM( cross_profiles_char(i) )
+                ELSEIF ( id_last == cross_profiles_numb(i) )  THEN
+                   char_cross_profiles = TRIM( char_cross_profiles ) // &
+                                         ',' // TRIM( cross_profiles_char(i) )
+                ELSE
+                   char_cross_profiles = TRIM( char_cross_profiles ) // &
+                                         ';' // TRIM( cross_profiles_char(i) )
+                ENDIF
+                id_last = cross_profiles_numb(i)
+             ENDIF
+
+          ENDDO
+
+          char_cross_profiles = TRIM( char_cross_profiles ) // ';'
+
+          nc_stat = NF90_PUT_ATT( id_set_pr, NF90_GLOBAL, 'cross_profiles',   &
+                                  TRIM( char_cross_profiles ) )
+          CALL netcdf_handle_error( 'netcdf_define_header', 521 )
+
+!
+!--       Define time coordinate for profiles (unlimited dimension)
+          CALL netcdf_create_dim( id_set_pr, 'time', NF90_UNLIMITED,           &
+                                  id_dim_time_pr, 220 )
+          CALL netcdf_create_var( id_set_pr, (/ id_dim_time_pr /), 'time',     &
+                                  NF90_DOUBLE, id_var_time_pr, 'seconds', '',  &
+                                  221, 222, 000 )
+!
+!--       Define the variables
+          var_list = ';'
+          DO  i = 1, dopr_n
+
+             IF ( statistic_regions == 0 )  THEN
+
+!
+!--             Define the z-axes (each variable gets its own z-axis)
+                CALL netcdf_create_dim( id_set_pr,                             &
+                                        'z' // TRIM( data_output_pr(i) ),      &
+                                        nzt+2-nzb, id_dim_z_pr(i,0), 223 )
+                CALL netcdf_create_var( id_set_pr, (/ id_dim_z_pr(i,0) /),     &
+                                        'z' // TRIM( data_output_pr(i) ),      &
+                                       NF90_DOUBLE, id_var_z_pr(i,0),          &
+                                       'meters', '', 224, 225, 000 )
+!
+!--             Define the variable
+                CALL netcdf_create_var( id_set_pr, (/ id_dim_z_pr(i,0),        &
+                                        id_dim_time_pr /), data_output_pr(i),  &
+                                        nc_precision(5), id_var_dopr(i,0),     &
+                                        TRIM( dopr_unit(i) ),                  &
+                                        TRIM( data_output_pr(i) ), 226, 227,   &
+                                        228 )
+
+                var_list = TRIM( var_list ) // TRIM( data_output_pr(i) ) //  ';'
+
+             ELSE
+!
+!--             If statistic regions are defined, add suffix _SR+#SR to the
+!--             names
+                DO  j = 0, statistic_regions
+                   WRITE ( suffix, '(''_'',I1)' )  j
+
+!
+!--                Define the z-axes (each variable gets it own z-axis)
+                   CALL netcdf_create_dim( id_set_pr, 'z' //                   &
+                                           TRIM(data_output_pr(i)) // suffix,  &
+                                           nzt+2-nzb, id_dim_z_pr(i,j), 229 )
+                   CALL netcdf_create_var( id_set_pr, (/ id_dim_z_pr(i,j) /),  &
+                                           'z' // TRIM(data_output_pr(i)) //   &
+                                           suffix, NF90_DOUBLE,                &
+                                           id_var_z_pr(i,j), 'meters', '',     &
+                                           230, 231, 000 )
+!
+!--                Define the variable
+                   CALL netcdf_create_var( id_set_pr, (/ id_dim_z_pr(i,j),     &
+                                           id_dim_time_pr /),                  &
+                                           TRIM(data_output_pr(i)) // suffix,  &
+                                           nc_precision(5), id_var_dopr(i,j),  &
+                                           TRIM( dopr_unit(i) ),               &
+                                           TRIM( data_output_pr(i) ) //        &
+                                           ' SR ', 232, 233, 234 )
+
+                   var_list = TRIM( var_list ) // TRIM( data_output_pr(i) ) // &
+                              suffix // ';'
+
+                ENDDO
+
+             ENDIF
+
+          ENDDO
+
+!
+!--       Write the list of variables as global attribute (this is used by
+!--       restart runs)
+          nc_stat = NF90_PUT_ATT( id_set_pr, NF90_GLOBAL, 'VAR_LIST', var_list )
+          CALL netcdf_handle_error( 'netcdf_define_header', 235 )
+
+!
+!--       Define normalization variables (as time series)
+          DO  i = 1, dopr_norm_num
+
+             CALL netcdf_create_var( id_set_pr, (/ id_dim_time_pr /),          &
+                                     'NORM_' // TRIM( dopr_norm_names(i) ),    &
+                                     nc_precision(5), id_var_norm_dopr(i),     &
+                                     '', TRIM( dopr_norm_longnames(i) ), 236,  &
+                                     000, 237 )
+
+          ENDDO
+
+!
+!--       Leave netCDF define mode
+          nc_stat = NF90_ENDDEF( id_set_pr )
+          CALL netcdf_handle_error( 'netcdf_define_header', 238 )
+
+!
+!--       Write z-axes data
+          DO  i = 1, dopr_n
+             DO  j = 0, statistic_regions
+
+                nc_stat = NF90_PUT_VAR( id_set_pr, id_var_z_pr(i,j),      &
+                                        hom(nzb:nzt+1,2,dopr_index(i),0), &
+                                        start = (/ 1 /),                  &
+                                        count = (/ nzt-nzb+2 /) )
+                CALL netcdf_handle_error( 'netcdf_define_header', 239 )
+
+             ENDDO
+          ENDDO
+
+
+       CASE ( 'pr_ext' )
+
+!
+!--       Get the list of variables and compare with the actual run.
+!--       First var_list_old has to be reset, since GET_ATT does not assign
+!--       trailing blanks.
+          var_list_old = ' '
+          nc_stat = NF90_GET_ATT( id_set_pr, NF90_GLOBAL, 'VAR_LIST', &
+                                  var_list_old )
+          CALL netcdf_handle_error( 'netcdf_define_header', 240 )
+
+          var_list = ';'
+          DO  i = 1, dopr_n
+
+             IF ( statistic_regions == 0 )  THEN
+                var_list = TRIM( var_list ) // TRIM( data_output_pr(i) ) // ';'
+             ELSE
+                DO  j = 0, statistic_regions
+                   WRITE ( suffix, '(''_'',I1)' )  j
+                   var_list = TRIM( var_list ) // TRIM( data_output_pr(i) ) // &
+                              suffix // ';'
+                ENDDO
+             ENDIF
+
+          ENDDO
+
+          IF ( TRIM( var_list ) /= TRIM( var_list_old ) )  THEN
+             message_string = 'netCDF file for vertical profiles ' //        &
+                              'from previous run found,' //                  &
+                              '& but this file cannot be extended due to' // &
+                              ' variable mismatch.' //                       &
+                              '&New file is created instead.'
+             CALL message( 'define_netcdf_header', 'PA0254', 0, 1, 0, 6, 0 )
+             extend = .FALSE.
+             RETURN
+          ENDIF
+
+!
+!--       Get the id of the time coordinate (unlimited coordinate) and its
+!--       last index on the file. The next time level is dopr..count+1.
+!--       The current time must be larger than the last output time
+!--       on the file.
+          nc_stat = NF90_INQ_VARID( id_set_pr, 'time', id_var_time_pr )
+          CALL netcdf_handle_error( 'netcdf_define_header', 241 )
+
+          nc_stat = NF90_INQUIRE_VARIABLE( id_set_pr, id_var_time_pr, &
+                                           dimids = id_dim_time_old )
+          CALL netcdf_handle_error( 'netcdf_define_header', 242 )
+          id_dim_time_pr = id_dim_time_old(1)
+
+          nc_stat = NF90_INQUIRE_DIMENSION( id_set_pr, id_dim_time_pr, &
+                                            len = dopr_time_count )
+          CALL netcdf_handle_error( 'netcdf_define_header', 243 )
+
+          nc_stat = NF90_GET_VAR( id_set_pr, id_var_time_pr,        &
+                                  last_time_coordinate,             &
+                                  start = (/ dopr_time_count /), &
+                                  count = (/ 1 /) )
+          CALL netcdf_handle_error( 'netcdf_define_header', 244 )
+
+          IF ( last_time_coordinate(1) >= simulated_time )  THEN
+             message_string = 'netCDF file for vertical profiles ' //       &
+                              'from previous run found,' //                 &
+                              '&but this file cannot be extended becaus' // &
+                              'e the current output time' //                &
+                              '&is less or equal than the last output t' // &
+                              'ime on this file.' //                        &
+                              '&New file is created instead.'
+             CALL message( 'define_netcdf_header', 'PA0255', 0, 1, 0, 6, 0 )
+             dopr_time_count = 0
+             extend = .FALSE.
+             RETURN
+          ENDIF
+
+!
+!--       Dataset seems to be extendable.
+!--       Now get the variable ids.
+          i = 1
+          DO  i = 1, dopr_n
+ 
+             IF ( statistic_regions == 0 )  THEN
+                nc_stat = NF90_INQ_VARID( id_set_pr, data_output_pr(i), &
+                                          id_var_dopr(i,0) )
+                CALL netcdf_handle_error( 'netcdf_define_header', 245 )
+             ELSE
+                DO  j = 0, statistic_regions
+                   WRITE ( suffix, '(''_'',I1)' )  j
+                   netcdf_var_name = TRIM( data_output_pr(i) ) // suffix
+                   nc_stat = NF90_INQ_VARID( id_set_pr, netcdf_var_name, &
+                                             id_var_dopr(i,j) )
+                   CALL netcdf_handle_error( 'netcdf_define_header', 246 )
+                ENDDO
+             ENDIF
+
+          ENDDO
+
+!
+!--       Get ids of the normalization variables
+          DO  i = 1, dopr_norm_num
+             nc_stat = NF90_INQ_VARID( id_set_pr,                             &
+                                       'NORM_' // TRIM( dopr_norm_names(i) ), &
+                                       id_var_norm_dopr(i) )
+             CALL netcdf_handle_error( 'netcdf_define_header', 247 )
+          ENDDO
+
+!
+!--       Update the title attribute on file
+!--       In order to avoid 'data mode' errors if updated attributes are larger 
+!--       than their original size, NF90_PUT_ATT is called in 'define mode' 
+!--       enclosed by NF90_REDEF and NF90_ENDDEF calls. This implies a possible 
+!--       performance loss due to data copying; an alternative strategy would be 
+!--       to ensure equal attribute size in a job chain. Maybe revise later.
+          IF ( averaging_interval_pr == 0.0_wp )  THEN
+             time_average_text = ' '
+          ELSE
+             WRITE (time_average_text, '('', '',F7.1,'' s average'')') &
+                                                            averaging_interval_pr
+          ENDIF
+          nc_stat = NF90_REDEF( id_set_pr )
+          CALL netcdf_handle_error( 'netcdf_define_header', 437 )
+          nc_stat = NF90_PUT_ATT( id_set_pr, NF90_GLOBAL, 'title', &
+                                  TRIM( run_description_header ) //    &
+                                  TRIM( time_average_text ) )
+          CALL netcdf_handle_error( 'netcdf_define_header', 248 )
+
+          nc_stat = NF90_ENDDEF( id_set_pr )
+          CALL netcdf_handle_error( 'netcdf_define_header', 438 )
+          message_string = 'netCDF file for vertical profiles ' // &
+                           'from previous run found.' //           &
+                           '&This file will be extended.'
+          CALL message( 'define_netcdf_header', 'PA0256', 0, 0, 0, 6, 0 )
+
+
+       CASE ( 'ts_new' )
+
+!
+!--       Define some global attributes of the dataset
+          nc_stat = NF90_PUT_ATT( id_set_ts, NF90_GLOBAL, 'title', &
+                                  TRIM( run_description_header ) )
+          CALL netcdf_handle_error( 'netcdf_define_header', 249 )
+
+!
+!--       Define time coordinate for time series (unlimited dimension)
+          CALL netcdf_create_dim( id_set_ts, 'time', NF90_UNLIMITED,           &
+                                  id_dim_time_ts, 250 )
+          CALL netcdf_create_var( id_set_ts, (/ id_dim_time_ts /), 'time',     &
+                                  NF90_DOUBLE, id_var_time_ts, 'seconds', '',  &
+                                  251, 252, 000 )
+!
+!--       Define the variables
+          var_list = ';'
+          DO  i = 1, dots_num
+
+             IF ( statistic_regions == 0 )  THEN
+
+                CALL netcdf_create_var( id_set_ts, (/ id_dim_time_ts /),       &
+                                        dots_label(i), nc_precision(6),        &
+                                        id_var_dots(i,0),                      &
+                                        TRIM( dots_unit(i) ),                  &
+                                        TRIM( dots_label(i) ), 253, 254, 255 )
+
+             ELSE
+!
+!--             If statistic regions are defined, add suffix _SR+#SR to the
+!--             names
+                DO  j = 0, statistic_regions
+                   WRITE ( suffix, '(''_'',I1)' )  j
+
+                   CALL netcdf_create_var( id_set_ts, (/ id_dim_time_ts /),    &
+                                           TRIM( dots_label(i) ) // suffix,    &
+                                           nc_precision(6), id_var_dots(i,j),  &
+                                           TRIM( dots_unit(i) ),               &
+                                           TRIM( dots_label(i) ) // ' SR ' //  &
+                                           suffix(2:2), 256, 257, 347)
+
+                ENDDO
+
+             ENDIF
+
+          ENDDO
+
+!
+!--       Write the list of variables as global attribute (this is used by
+!--       restart runs)
+          nc_stat = NF90_PUT_ATT( id_set_ts, NF90_GLOBAL, 'VAR_LIST', var_list )
+          CALL netcdf_handle_error( 'netcdf_define_header', 258 )
+
+!
+!--       Leave netCDF define mode
+          nc_stat = NF90_ENDDEF( id_set_ts )
+          CALL netcdf_handle_error( 'netcdf_define_header', 259 )
+
+
+       CASE ( 'ts_ext' )
+
+!
+!--       Get the list of variables and compare with the actual run.
+!--       First var_list_old has to be reset, since GET_ATT does not assign
+!--       trailing blanks.
+          var_list_old = ' '
+          nc_stat = NF90_GET_ATT( id_set_ts, NF90_GLOBAL, 'VAR_LIST', &
+                                  var_list_old )
+          CALL netcdf_handle_error( 'netcdf_define_header', 260 )
+
+          var_list = ';'
+          i = 1
+          DO  i = 1, dots_num
+
+             IF ( statistic_regions == 0 )  THEN
+                var_list = TRIM( var_list ) // TRIM( dots_label(i) ) // ';'
+             ELSE
+                DO  j = 0, statistic_regions
+                   WRITE ( suffix, '(''_'',I1)' )  j
+                   var_list = TRIM( var_list ) // TRIM( dots_label(i) ) // &
+                              suffix // ';'
+                ENDDO
+             ENDIF
+
+          ENDDO
+
+          IF ( TRIM( var_list ) /= TRIM( var_list_old ) )  THEN
+             message_string = 'netCDF file for time series ' //              &
+                              'from previous run found,' //                  &
+                              '& but this file cannot be extended due to' // &
+                              ' variable mismatch.' //                       &
+                              '&New file is created instead.'
+             CALL message( 'define_netcdf_header', 'PA0257', 0, 1, 0, 6, 0 )
+             extend = .FALSE.
+             RETURN
+          ENDIF
+
+!
+!--       Get the id of the time coordinate (unlimited coordinate) and its
+!--       last index on the file. The next time level is dots..count+1.
+!--       The current time must be larger than the last output time
+!--       on the file.
+          nc_stat = NF90_INQ_VARID( id_set_ts, 'time', id_var_time_ts )
+          CALL netcdf_handle_error( 'netcdf_define_header', 261 )
+
+          nc_stat = NF90_INQUIRE_VARIABLE( id_set_ts, id_var_time_ts, &
+                                           dimids = id_dim_time_old )
+          CALL netcdf_handle_error( 'netcdf_define_header', 262 )
+          id_dim_time_ts = id_dim_time_old(1)
+
+          nc_stat = NF90_INQUIRE_DIMENSION( id_set_ts, id_dim_time_ts, &
+                                            len = dots_time_count )
+          CALL netcdf_handle_error( 'netcdf_define_header', 263 )
+
+          nc_stat = NF90_GET_VAR( id_set_ts, id_var_time_ts,        &
+                                  last_time_coordinate,             &
+                                  start = (/ dots_time_count /), &
+                                  count = (/ 1 /) )
+          CALL netcdf_handle_error( 'netcdf_define_header', 264 )
+
+          IF ( last_time_coordinate(1) >= simulated_time )  THEN
+             message_string = 'netCDF file for time series ' //             &
+                              'from previous run found,' //                 &
+                              '&but this file cannot be extended becaus' // &
+                              'e the current output time' //                &
+                              '&is less or equal than the last output t' // &
+                              'ime on this file.' //                        &
+                              '&New file is created instead.'
+             CALL message( 'define_netcdf_header', 'PA0258', 0, 1, 0, 6, 0 )
+             dots_time_count = 0
+             extend = .FALSE.
+             RETURN
+          ENDIF
+
+!
+!--       Dataset seems to be extendable.
+!--       Now get the variable ids
+          i = 1
+          DO  i = 1, dots_num
+ 
+             IF ( statistic_regions == 0 )  THEN
+                nc_stat = NF90_INQ_VARID( id_set_ts, dots_label(i), &
+                                          id_var_dots(i,0) )
+                CALL netcdf_handle_error( 'netcdf_define_header', 265 )
+             ELSE
+                DO  j = 0, statistic_regions
+                   WRITE ( suffix, '(''_'',I1)' )  j
+                   netcdf_var_name = TRIM( dots_label(i) ) // suffix
+                   nc_stat = NF90_INQ_VARID( id_set_ts, netcdf_var_name, &
+                                             id_var_dots(i,j) )
+                   CALL netcdf_handle_error( 'netcdf_define_header', 266 )
+                ENDDO
+             ENDIF
+
+          ENDDO
+
+!
+!--       Update the title attribute on file
+!--       In order to avoid 'data mode' errors if updated attributes are larger 
+!--       than their original size, NF90_PUT_ATT is called in 'define mode' 
+!--       enclosed by NF90_REDEF and NF90_ENDDEF calls. This implies a possible 
+!--       performance loss due to data copying; an alternative strategy would be 
+!--       to ensure equal attribute size in a job chain. Maybe revise later.
+          nc_stat = NF90_REDEF( id_set_ts )
+          CALL netcdf_handle_error( 'netcdf_define_header', 439 )
+          nc_stat = NF90_PUT_ATT( id_set_ts, NF90_GLOBAL, 'title', &
+                                  TRIM( run_description_header ) )
+          CALL netcdf_handle_error( 'netcdf_define_header', 267 )
+          nc_stat = NF90_ENDDEF( id_set_ts )
+          CALL netcdf_handle_error( 'netcdf_define_header', 440 )
+          message_string = 'netCDF file for time series ' // &
+                           'from previous run found.' //     &
+                           '&This file will be extended.'
+          CALL message( 'define_netcdf_header', 'PA0259', 0, 0, 0, 6, 0 )
+
+
+       CASE ( 'sp_new' )
+
+!
+!--       Define some global attributes of the dataset
+          IF ( averaging_interval_sp /= 0.0_wp )  THEN
+             WRITE (time_average_text,'('', '',F7.1,'' s average'')') &
+                                                            averaging_interval_sp
+             nc_stat = NF90_PUT_ATT( id_set_sp, NF90_GLOBAL, 'title',  &
+                                     TRIM( run_description_header ) // &
+                                     TRIM( time_average_text ) )
+             CALL netcdf_handle_error( 'netcdf_define_header', 268 )
+
+             WRITE ( time_average_text,'(F7.1,'' s avg'')' )  averaging_interval_sp
+             nc_stat = NF90_PUT_ATT( id_set_sp, NF90_GLOBAL, 'time_avg', &
+                                     TRIM( time_average_text ) )
+          ELSE
+             nc_stat = NF90_PUT_ATT( id_set_sp, NF90_GLOBAL, 'title', &
+                                     TRIM( run_description_header ) )
+          ENDIF
+          CALL netcdf_handle_error( 'netcdf_define_header', 269 )
+
+!
+!--       Define time coordinate for spectra (unlimited dimension)
+          CALL netcdf_create_dim( id_set_sp, 'time', NF90_UNLIMITED,           &
+                                  id_dim_time_sp, 270 )
+          CALL netcdf_create_var( id_set_sp, (/ id_dim_time_sp /), 'time',     &
+                                  NF90_DOUBLE, id_var_time_sp, 'seconds', '',  &
+                                  271, 272, 000 )
+!
+!--       Define the spatial dimensions and coordinates for spectra.
+!--       First, determine the number of vertical levels for which spectra
+!--       are to be output.
+          ns = 1
+          DO WHILE ( comp_spectra_level(ns) /= 999999  .AND.  ns <= 100 )
+             ns = ns + 1
+          ENDDO
+          ns = ns - 1
+
+!
+!--       Define vertical coordinate grid (zu grid)
+          CALL netcdf_create_dim( id_set_sp, 'zu_sp', ns, id_dim_zu_sp, 273 )
+          CALL netcdf_create_var( id_set_sp, (/ id_dim_zu_sp /), 'zu_sp',      &
+                                  NF90_DOUBLE, id_var_zu_sp, 'meters', '',     &
+                                  274, 275, 000 )
+!
+!--       Define vertical coordinate grid (zw grid)
+          CALL netcdf_create_dim( id_set_sp, 'zw_sp', ns, id_dim_zw_sp, 276 )
+          CALL netcdf_create_var( id_set_sp, (/ id_dim_zw_sp /), 'zw_sp',      &
+                                  NF90_DOUBLE, id_var_zw_sp, 'meters', '',     &
+                                  277, 278, 000 )
+!
+!--       Define x-axis
+          CALL netcdf_create_dim( id_set_sp, 'k_x', nx/2, id_dim_x_sp, 279 )
+          CALL netcdf_create_var( id_set_sp, (/ id_dim_x_sp /), 'k_x',         &
+                                  NF90_DOUBLE, id_var_x_sp, 'm-1', '', 280,    &
+                                  281, 000 )
+!
+!--       Define y-axis
+          CALL netcdf_create_dim(id_set_sp, 'k_y', ny/2, id_dim_y_sp, 282 )
+          CALL netcdf_create_var( id_set_sp, (/ id_dim_y_sp /), 'k_y',         &
+                                  NF90_DOUBLE, id_var_y_sp, 'm-1', '', 283,    &
+                                  284, 000 )
+!
+!--       Define the variables
+          var_list = ';'
+          i = 1
+          DO WHILE ( data_output_sp(i) /= ' '  .AND.  i <= 10 )
+!
+!--          First check for the vertical grid
+             found = .TRUE.
+             SELECT CASE ( data_output_sp(i) )
+!
+!--             Most variables are defined on the zu levels
+                CASE ( 'e', 'lpt', 'nr', 'p', 'pc', 'pr', 'prr', 'pt', 'q',   &
+                       'qc', 'ql', 'ql_c', 'ql_v', 'ql_vp', 'qr', 'qv', 'rho',&
+                       's', 'sa', 'u', 'v', 'vpt' )
+
+                   grid_z = 'zu'
+!
+!--             zw levels
+                CASE ( 'w' )
+
+                   grid_z = 'zw'
+
+                CASE DEFAULT
+!
+!--                Check for user-defined quantities (found, grid_x and grid_y
+!--                are dummies)
+                   CALL user_define_netcdf_grid( data_output_sp(i), found,  &
+                                                 grid_x, grid_y, grid_z )
+
+             END SELECT
+
+             IF ( INDEX( spectra_direction(i), 'x' ) /= 0 )  THEN
+
+!
+!--             Define the variable
+                netcdf_var_name = TRIM( data_output_sp(i) ) // '_x'
+                IF ( TRIM( grid_z ) == 'zw' )  THEN
+                   CALL netcdf_create_var( id_set_sp, (/ id_dim_x_sp,          &
+                                           id_dim_zw_sp, id_dim_time_sp /),    &
+                                           netcdf_var_name, nc_precision(7),   &
+                                           id_var_dospx(i), 'unknown',         &
+                                           netcdf_var_name, 285, 286, 287 )
+                ELSE
+                   CALL netcdf_create_var( id_set_sp, (/ id_dim_x_sp,          &
+                                           id_dim_zu_sp, id_dim_time_sp /),    &
+                                           netcdf_var_name, nc_precision(7),   &
+                                           id_var_dospx(i), 'unknown',         &
+                                           netcdf_var_name, 285, 286, 287 )
+                ENDIF
+
+                var_list = TRIM( var_list ) // TRIM( netcdf_var_name ) // ';'
+
+             ENDIF
+
+             IF ( INDEX( spectra_direction(i), 'y' ) /= 0 )  THEN
+
+!
+!--             Define the variable
+                netcdf_var_name = TRIM( data_output_sp(i) ) // '_y'
+                IF ( TRIM( grid_z ) == 'zw' )  THEN
+                   CALL netcdf_create_var( id_set_sp, (/ id_dim_y_sp,          &
+                                           id_dim_zw_sp, id_dim_time_sp /),    &
+                                           netcdf_var_name, nc_precision(7),   &
+                                           id_var_dospy(i), 'unknown',         &
+                                           netcdf_var_name, 288, 289, 290 )
+                ELSE
+                   CALL netcdf_create_var( id_set_sp, (/ id_dim_y_sp,          &
+                                           id_dim_zu_sp, id_dim_time_sp /),    &
+                                           netcdf_var_name, nc_precision(7),   &
+                                           id_var_dospy(i), 'unknown',         &
+                                           netcdf_var_name, 288, 289, 290 )
+                ENDIF
+
+                var_list = TRIM( var_list ) // TRIM( netcdf_var_name ) // ';'
+
+             ENDIF
+
+             i = i + 1
+
+          ENDDO
+
+!
+!--       Write the list of variables as global attribute (this is used by
+!--       restart runs)
+          nc_stat = NF90_PUT_ATT( id_set_sp, NF90_GLOBAL, 'VAR_LIST', var_list )
+          CALL netcdf_handle_error( 'netcdf_define_header', 291 )
+
+!
+!--       Leave netCDF define mode
+          nc_stat = NF90_ENDDEF( id_set_sp )
+          CALL netcdf_handle_error( 'netcdf_define_header', 292 )
+
+!
+!--       Write axis data: zu_sp, zw_sp, k_x, k_y
+          ALLOCATE( netcdf_data(1:ns) )
+
+!
+!--       Write zu data
+          netcdf_data(1:ns) = zu( comp_spectra_level(1:ns) )
+          nc_stat = NF90_PUT_VAR( id_set_sp, id_var_zu_sp, netcdf_data, &
+                                  start = (/ 1 /), count = (/ ns /) )
+          CALL netcdf_handle_error( 'netcdf_define_header', 293 )
+
+!
+!--       Write zw data
+          netcdf_data(1:ns) = zw( comp_spectra_level(1:ns) )
+          nc_stat = NF90_PUT_VAR( id_set_sp, id_var_zw_sp, netcdf_data, &
+                                  start = (/ 1 /), count = (/ ns /) )
+          CALL netcdf_handle_error( 'netcdf_define_header', 294 )
+
+          DEALLOCATE( netcdf_data )
+
+!
+!--       Write data for x and y axis (wavenumbers)
+          ALLOCATE( netcdf_data(nx/2) )
+          DO  i = 1, nx/2
+             netcdf_data(i) = 2.0_wp * pi * i / ( dx * ( nx + 1 ) )
+          ENDDO
+
+          nc_stat = NF90_PUT_VAR( id_set_sp, id_var_x_sp, netcdf_data, &
+                                  start = (/ 1 /), count = (/ nx/2 /) )
+          CALL netcdf_handle_error( 'netcdf_define_header', 295 )
+
+          DEALLOCATE( netcdf_data )
+
+          ALLOCATE( netcdf_data(ny/2) )
+          DO  i = 1, ny/2
+             netcdf_data(i) = 2.0_wp * pi * i / ( dy * ( ny + 1 ) )
+          ENDDO
+
+          nc_stat = NF90_PUT_VAR( id_set_sp, id_var_y_sp, netcdf_data, &
+                                  start = (/ 1 /), count = (/ ny/2 /) )
+          CALL netcdf_handle_error( 'netcdf_define_header', 296 )
+
+          DEALLOCATE( netcdf_data )
+
+
+       CASE ( 'sp_ext' )
+
+!
+!--       Get the list of variables and compare with the actual run.
+!--       First var_list_old has to be reset, since GET_ATT does not assign
+!--       trailing blanks.
+          var_list_old = ' '
+          nc_stat = NF90_GET_ATT( id_set_sp, NF90_GLOBAL, 'VAR_LIST', &
+                                  var_list_old )
+          CALL netcdf_handle_error( 'netcdf_define_header', 297 )
+          var_list = ';'
+          i = 1
+          DO WHILE ( data_output_sp(i) /= ' '  .AND.  i <= 10 )
+
+             IF ( INDEX( spectra_direction(i), 'x' ) /= 0 )  THEN
+                netcdf_var_name = TRIM( data_output_sp(i) ) // '_x'
+                var_list = TRIM( var_list ) // TRIM( netcdf_var_name ) // ';'
+             ENDIF
+
+             IF ( INDEX( spectra_direction(i), 'y' ) /= 0 )  THEN
+                netcdf_var_name = TRIM( data_output_sp(i) ) // '_y'
+                var_list = TRIM( var_list ) // TRIM( netcdf_var_name ) // ';'
+             ENDIF
+
+             i = i + 1
+
+          ENDDO
+
+          IF ( TRIM( var_list ) /= TRIM( var_list_old ) )  THEN
+             message_string = 'netCDF file for spectra  ' //                 &
+                              'from previous run found,' //                  &
+                              '& but this file cannot be extended due to' // &
+                              ' variable mismatch.' //                       &
+                              '&New file is created instead.'
+             CALL message( 'define_netcdf_header', 'PA0260', 0, 1, 0, 6, 0 )
+             extend = .FALSE.
+             RETURN
+          ENDIF
+
+!
+!--       Determine the number of current vertical levels for which spectra
+!--       shall be output
+          ns = 1
+          DO WHILE ( comp_spectra_level(ns) /= 999999  .AND.  ns <= 100 )
+             ns = ns + 1
+          ENDDO
+          ns = ns - 1
+
+!
+!--       Get and compare the number of vertical levels
+          nc_stat = NF90_INQ_VARID( id_set_sp, 'zu_sp', id_var_zu_sp )
+          CALL netcdf_handle_error( 'netcdf_define_header', 298 )
+
+          nc_stat = NF90_INQUIRE_VARIABLE( id_set_sp, id_var_zu_sp, &
+                                           dimids = id_dim_zu_sp_old )
+          CALL netcdf_handle_error( 'netcdf_define_header', 299 )
+          id_dim_zu_sp = id_dim_zu_sp_old(1)
+
+          nc_stat = NF90_INQUIRE_DIMENSION( id_set_sp, id_dim_zu_sp, &
+                                            len = ns_old )
+          CALL netcdf_handle_error( 'netcdf_define_header', 300 )
+
+          IF ( ns /= ns_old )  THEN
+             message_string = 'netCDF file for spectra ' //                 &
+                              ' from previous run found,' //                &
+                              '&but this file cannot be extended due to' // &
+                              ' mismatch in number of' //                   &
+                              '&vertical levels.' //                        &
+                              '&New file is created instead.'
+             CALL message( 'define_netcdf_header', 'PA0261', 0, 1, 0, 6, 0 )
+             extend = .FALSE.
+             RETURN
+          ENDIF
+
+!
+!--       Get and compare the heights of the cross sections
+          ALLOCATE( netcdf_data(1:ns_old) )
+
+          nc_stat = NF90_GET_VAR( id_set_sp, id_var_zu_sp, netcdf_data )
+          CALL netcdf_handle_error( 'netcdf_define_header', 301 )
+
+          DO  i = 1, ns
+             IF ( zu(comp_spectra_level(i)) /= netcdf_data(i) )  THEN
+                message_string = 'netCDF file for spectra ' //                 &
+                                 ' from previous run found,' //                &
+                                 '&but this file cannot be extended due to' // &
+                                 ' mismatch in heights of' //                  &
+                                 '&vertical levels.' //                        &
+                                 '&New file is created instead.'
+                CALL message( 'define_netcdf_header', 'PA0262', 0, 1, 0, 6, 0 )
+                extend = .FALSE.
+                RETURN
+             ENDIF
+          ENDDO
+
+          DEALLOCATE( netcdf_data )
+
+!
+!--       Get the id of the time coordinate (unlimited coordinate) and its
+!--       last index on the file. The next time level is plsp..count+1.
+!--       The current time must be larger than the last output time
+!--       on the file.
+          nc_stat = NF90_INQ_VARID( id_set_sp, 'time', id_var_time_sp )
+          CALL netcdf_handle_error( 'netcdf_define_header', 302 )
+
+          nc_stat = NF90_INQUIRE_VARIABLE( id_set_sp, id_var_time_sp, &
+                                           dimids = id_dim_time_old )
+          CALL netcdf_handle_error( 'netcdf_define_header', 303 )
+          id_dim_time_sp = id_dim_time_old(1)
+
+          nc_stat = NF90_INQUIRE_DIMENSION( id_set_sp, id_dim_time_sp, &
+                                            len = dosp_time_count )
+          CALL netcdf_handle_error( 'netcdf_define_header', 304 )
+
+          nc_stat = NF90_GET_VAR( id_set_sp, id_var_time_sp,        &
+                                  last_time_coordinate,             &
+                                  start = (/ dosp_time_count /), &
+                                  count = (/ 1 /) )
+          CALL netcdf_handle_error( 'netcdf_define_header', 305 )
+
+          IF ( last_time_coordinate(1) >= simulated_time )  THEN
+             message_string = 'netCDF file for spectra ' //                 &
+                              'from previous run found,' //                 &
+                              '&but this file cannot be extended becaus' // &
+                              'e the current output time' //                & 
+                              '&is less or equal than the last output t' // &
+                              'ime on this file.' //                        &
+                              '&New file is created instead.'
+             CALL message( 'define_netcdf_header', 'PA0263', 0, 1, 0, 6, 0 )
+             dosp_time_count = 0
+             extend = .FALSE.
+             RETURN
+          ENDIF
+
+!
+!--       Dataset seems to be extendable.
+!--       Now get the variable ids.
+          i = 1
+          DO WHILE ( data_output_sp(i) /= ' '  .AND.  i <= 10 )
+
+             IF ( INDEX( spectra_direction(i), 'x' ) /= 0 )  THEN
+                netcdf_var_name = TRIM( data_output_sp(i) ) // '_x'
+                nc_stat = NF90_INQ_VARID( id_set_sp, netcdf_var_name, &
+                                          id_var_dospx(i) )
+                CALL netcdf_handle_error( 'netcdf_define_header', 306 )
+             ENDIF
+
+             IF ( INDEX( spectra_direction(i), 'y' ) /= 0 )  THEN
+                netcdf_var_name = TRIM( data_output_sp(i) ) // '_y'
+                nc_stat = NF90_INQ_VARID( id_set_sp, netcdf_var_name, &
+                                          id_var_dospy(i) )
+                CALL netcdf_handle_error( 'netcdf_define_header', 307 )
+             ENDIF
+
+             i = i + 1
+
+          ENDDO
+
+!
+!--       Update the title attribute on file
+!--       In order to avoid 'data mode' errors if updated attributes are larger 
+!--       than their original size, NF90_PUT_ATT is called in 'define mode' 
+!--       enclosed by NF90_REDEF and NF90_ENDDEF calls. This implies a possible 
+!--       performance loss due to data copying; an alternative strategy would be 
+!--       to ensure equal attribute size in a job chain. Maybe revise later.
+          nc_stat = NF90_REDEF( id_set_sp )
+          CALL netcdf_handle_error( 'netcdf_define_header', 441 )
+          IF ( averaging_interval_sp /= 0.0_wp )  THEN
+             WRITE (time_average_text,'('', '',F7.1,'' s average'')') &
+                                                           averaging_interval_sp
+             nc_stat = NF90_PUT_ATT( id_set_sp, NF90_GLOBAL, 'title',  &
+                                     TRIM( run_description_header ) // &
+                                     TRIM( time_average_text ) )
+             CALL netcdf_handle_error( 'netcdf_define_header', 308 )
+
+             WRITE ( time_average_text,'(F7.1,'' s avg'')' )  averaging_interval_sp
+             nc_stat = NF90_PUT_ATT( id_set_sp, NF90_GLOBAL, 'time_avg', &
+                                     TRIM( time_average_text ) )
+          ELSE
+             nc_stat = NF90_PUT_ATT( id_set_sp, NF90_GLOBAL, 'title', &
+                                     TRIM( run_description_header ) )
+          ENDIF
+          CALL netcdf_handle_error( 'netcdf_define_header', 309 )
+          nc_stat = NF90_ENDDEF( id_set_sp )
+          CALL netcdf_handle_error( 'netcdf_define_header', 442 )
+          message_string = 'netCDF file for spectra ' //     &
+                           'from previous run found.' //     &
+                           '&This file will be extended.'
+          CALL message( 'define_netcdf_header', 'PA0264', 0, 0, 0, 6, 0 )
+
+
+       CASE ( 'pt_new' )
+
+!
+!--       Define some global attributes of the dataset
+          nc_stat = NF90_PUT_ATT( id_set_prt, NF90_GLOBAL, 'title', &
+                                  TRIM( run_description_header ) )
+          CALL netcdf_handle_error( 'netcdf_define_header', 310 )
+
+!
+!--       Define time coordinate for particles (unlimited dimension)
+          CALL netcdf_create_dim( id_set_prt, 'time', NF90_UNLIMITED,          &
+                                  id_dim_time_prt, 311 )
+          CALL netcdf_create_var( id_set_prt, (/ id_dim_time_prt /), 'time',   &
+                                  NF90_DOUBLE, id_var_time_prt, 'seconds', '', &
+                                  312, 313, 000 )
+!
+!--       Define particle coordinate (maximum particle number)
+          IF ( netcdf_data_format < 3 )  THEN
+             CALL netcdf_create_dim( id_set_prt, 'particle_number',            &
+                                     maximum_number_of_particles,              &
+                                     id_dim_prtnum, 314 )
+          ELSE
+!
+!--          netCDF4 allows more than one unlimited dimension
+             CALL netcdf_create_dim( id_set_prt, 'particle_number',            &
+                                     NF90_UNLIMITED, id_dim_prtnum, 314 )
+          ENDIF
+
+          CALL netcdf_create_var( id_set_prt, (/ id_dim_prtnum /),             &
+                                  'particle_number', NF90_DOUBLE,              &
+                                  id_var_prtnum, 'particle number', '', 315,   &
+                                  316, 000 )
+!
+!--       Define variable which contains the real number of particles in use
+          CALL netcdf_create_var( id_set_prt, (/ id_dim_time_prt /),           &
+                                  'real_num_of_prt', NF90_DOUBLE,              &
+                                  id_var_rnop_prt, 'particle number', '', 317, &
+                                  318, 000 )
+!
+!--       Define the variables
+          DO  i = 1, 17
+
+             CALL netcdf_create_var( id_set_prt, (/ id_dim_prtnum,             &
+                                     id_dim_time_prt /), prt_var_names(i),     &
+                                     nc_precision(8), id_var_prt(i),           &
+                                     TRIM( prt_var_units(i) ),                 &
+                                     TRIM( prt_var_names(i) ), 319, 320, 321 )
+
+          ENDDO
+
+!
+!--       Leave netCDF define mode
+          nc_stat = NF90_ENDDEF( id_set_prt )
+          CALL netcdf_handle_error( 'netcdf_define_header', 322 )
+
+
+       CASE ( 'pt_ext' )
+
+!
+!--       Get the id of the time coordinate (unlimited coordinate) and its
+!--       last index on the file. The next time level is prt..count+1.
+!--       The current time must be larger than the last output time
+!--       on the file.
+          nc_stat = NF90_INQ_VARID( id_set_prt, 'time', id_var_time_prt )
+          CALL netcdf_handle_error( 'netcdf_define_header', 323 )
+
+          nc_stat = NF90_INQUIRE_VARIABLE( id_set_prt, id_var_time_prt, &
+                                           dimids = id_dim_time_old )
+          CALL netcdf_handle_error( 'netcdf_define_header', 324 )
+          id_dim_time_prt = id_dim_time_old(1)
+
+          nc_stat = NF90_INQUIRE_DIMENSION( id_set_prt, id_dim_time_prt, &
+                                            len = prt_time_count )
+          CALL netcdf_handle_error( 'netcdf_define_header', 325 )
+
+          nc_stat = NF90_GET_VAR( id_set_prt, id_var_time_prt,  &
+                                  last_time_coordinate,         &
+                                  start = (/ prt_time_count /), &
+                                  count = (/ 1 /) )
+          CALL netcdf_handle_error( 'netcdf_define_header', 326 )
+
+          IF ( last_time_coordinate(1) >= simulated_time )  THEN
+             message_string = 'netCDF file for particles ' //               &
+                              'from previous run found,' //                 &
+                              '&but this file cannot be extended becaus' // &
+                              'e the current output time' //                &
+                              '&is less or equal than the last output t' // &
+                              'ime on this file.' //                        &
+                              '&New file is created instead.'
+             CALL message( 'define_netcdf_header', 'PA0265', 0, 1, 0, 6, 0 )
+             prt_time_count = 0
+             extend = .FALSE.
+             RETURN
+          ENDIF
+
+!
+!--       Dataset seems to be extendable.
+!--       Now get the variable ids.
+          nc_stat = NF90_INQ_VARID( id_set_prt, 'real_num_of_prt', &
+                                    id_var_rnop_prt )
+          CALL netcdf_handle_error( 'netcdf_define_header', 327 )
+
+          DO  i = 1, 17
+
+             nc_stat = NF90_INQ_VARID( id_set_prt, prt_var_names(i), &
+                                       id_var_prt(i) )
+             CALL netcdf_handle_error( 'netcdf_define_header', 328 )
+
+          ENDDO
+
+          message_string = 'netCDF file for particles ' // &
+                           'from previous run found.' //   &
+                           '&This file will be extended.'
+          CALL message( 'define_netcdf_header', 'PA0266', 0, 0, 0, 6, 0 )
+        
+
+
+       CASE ( 'ps_new' )
+
+!
+!--       Define some global attributes of the dataset
+          nc_stat = NF90_PUT_ATT( id_set_pts, NF90_GLOBAL, 'title', &
+                                  TRIM( run_description_header ) )
+          CALL netcdf_handle_error( 'netcdf_define_header', 396 )
+
+!
+!--       Define time coordinate for particle time series (unlimited dimension)
+          CALL netcdf_create_dim( id_set_pts, 'time', NF90_UNLIMITED,          &
+                                  id_dim_time_pts, 397 )
+          CALL netcdf_create_var( id_set_pts, (/ id_dim_time_pts /), 'time',   &
+                                  NF90_DOUBLE, id_var_time_pts, 'seconds', '', &
+                                  398, 399, 000 )
+!
+!--       Define the variables. If more than one particle group is defined,
+!--       define seperate variables for each group
+          var_list = ';'
+          DO  i = 1, dopts_num
+
+             DO  j = 0, number_of_particle_groups
+
+                IF ( j == 0 )  THEN
+                   suffix1 = ''
+                ELSE
+                   WRITE ( suffix1, '(''_'',I2.2)' )  j
+                ENDIF
+
+                IF ( j == 0 )  THEN
+                   CALL netcdf_create_var( id_set_pts, (/ id_dim_time_pts /),  &
+                                           TRIM( dopts_label(i) ) // suffix1,  &
+                                           nc_precision(6), id_var_dopts(i,j), &
+                                           TRIM( dopts_unit(i) ),              &
+                                           TRIM( dopts_label(i) ), 400, 401,   &
+                                           402 )
+                ELSE
+                   CALL netcdf_create_var( id_set_pts, (/ id_dim_time_pts /),  &
+                                           TRIM( dopts_label(i) ) // suffix1,  &
+                                           nc_precision(6), id_var_dopts(i,j), &
+                                           TRIM( dopts_unit(i) ),              &
+                                           TRIM( dopts_label(i) ) // ' PG ' // &
+                                           suffix1(2:3), 400, 401, 402 )
+                ENDIF
+
+                var_list = TRIM( var_list ) // TRIM( dopts_label(i) ) // &
+                           suffix1 // ';'
+
+                IF ( number_of_particle_groups == 1 )  EXIT
+
+             ENDDO
+
+          ENDDO
+
+!
+!--       Write the list of variables as global attribute (this is used by
+!--       restart runs)
+          nc_stat = NF90_PUT_ATT( id_set_pts, NF90_GLOBAL, 'VAR_LIST', &
+                                  var_list )
+          CALL netcdf_handle_error( 'netcdf_define_header', 403 )
+
+
+!
+!--       Leave netCDF define mode
+          nc_stat = NF90_ENDDEF( id_set_pts )
+          CALL netcdf_handle_error( 'netcdf_define_header', 404 )
+
+
+       CASE ( 'ps_ext' )
+
+!
+!--       Get the list of variables and compare with the actual run.
+!--       First var_list_old has to be reset, since GET_ATT does not assign
+!--       trailing blanks.
+          var_list_old = ' '
+          nc_stat = NF90_GET_ATT( id_set_pts, NF90_GLOBAL, 'VAR_LIST', &
+                                  var_list_old )
+          CALL netcdf_handle_error( 'netcdf_define_header', 405 )
+
+          var_list = ';'
+          i = 1
+          DO  i = 1, dopts_num
+
+             DO  j = 0, number_of_particle_groups
+
+                IF ( j == 0 )  THEN
+                   suffix1 = ''
+                ELSE
+                   WRITE ( suffix1, '(''_'',I2.2)' )  j
+                ENDIF
+
+                var_list = TRIM( var_list ) // TRIM( dopts_label(i) ) // &
+                           suffix1 // ';'
+
+                IF ( number_of_particle_groups == 1 )  EXIT
+
+             ENDDO
+
+          ENDDO
+
+          IF ( TRIM( var_list ) /= TRIM( var_list_old ) )  THEN
+             message_string = 'netCDF file for particle time series ' //     &
+                              'from previous run found,' //                  &
+                              '& but this file cannot be extended due to' // &
+                              ' variable mismatch.' //                       &
+                              '&New file is created instead.'
+             CALL message( 'define_netcdf_header', 'PA0267', 0, 1, 0, 6, 0 )
+             extend = .FALSE.
+             RETURN
+          ENDIF
+
+!
+!--       Get the id of the time coordinate (unlimited coordinate) and its
+!--       last index on the file. The next time level is dots..count+1.
+!--       The current time must be larger than the last output time
+!--       on the file.
+          nc_stat = NF90_INQ_VARID( id_set_pts, 'time', id_var_time_pts )
+          CALL netcdf_handle_error( 'netcdf_define_header', 406 )
+
+          nc_stat = NF90_INQUIRE_VARIABLE( id_set_pts, id_var_time_pts, &
+                                           dimids = id_dim_time_old )
+          CALL netcdf_handle_error( 'netcdf_define_header', 407 )
+          id_dim_time_pts = id_dim_time_old(1)
+
+          nc_stat = NF90_INQUIRE_DIMENSION( id_set_pts, id_dim_time_pts, &
+                                            len = dopts_time_count )
+          CALL netcdf_handle_error( 'netcdf_define_header', 408 )
+
+          nc_stat = NF90_GET_VAR( id_set_pts, id_var_time_pts,    &
+                                  last_time_coordinate,           &
+                                  start = (/ dopts_time_count /), &
+                                  count = (/ 1 /) )
+          CALL netcdf_handle_error( 'netcdf_define_header', 409 )
+
+          IF ( last_time_coordinate(1) >= simulated_time )  THEN
+             message_string = 'netCDF file for particle time series ' //    &
+                              'from previous run found,' //                 &
+                              '&but this file cannot be extended becaus' // &
+                              'e the current output time' //                &
+                              '&is less or equal than the last output t' // &
+                              'ime on this file.' //                        &
+                              '&New file is created instead.'
+             CALL message( 'define_netcdf_header', 'PA0268', 0, 1, 0, 6, 0 )
+             dopts_time_count = 0
+             extend = .FALSE.
+             RETURN
+          ENDIF
+
+!
+!--       Dataset seems to be extendable.
+!--       Now get the variable ids
+          i = 1
+          DO  i = 1, dopts_num
+ 
+             DO  j = 0, number_of_particle_groups
+
+                IF ( j == 0 )  THEN
+                   suffix1 = ''
+                ELSE
+                   WRITE ( suffix1, '(''_'',I2.2)' )  j
+                ENDIF
+
+                netcdf_var_name = TRIM( dopts_label(i) ) // suffix1
+
+                nc_stat = NF90_INQ_VARID( id_set_pts, netcdf_var_name, &
+                                          id_var_dopts(i,j) )
+                CALL netcdf_handle_error( 'netcdf_define_header', 410 )
+
+                IF ( number_of_particle_groups == 1 )  EXIT
+
+             ENDDO
+
+          ENDDO
+
+!
+!--       Update the title attribute on file
+!--       In order to avoid 'data mode' errors if updated attributes are larger 
+!--       than their original size, NF90_PUT_ATT is called in 'define mode' 
+!--       enclosed by NF90_REDEF and NF90_ENDDEF calls. This implies a possible 
+!--       performance loss due to data copying; an alternative strategy would be 
+!--       to ensure equal attribute size in a job chain. Maybe revise later.
+          nc_stat = NF90_REDEF( id_set_pts )
+          CALL netcdf_handle_error( 'netcdf_define_header', 443 )
+          nc_stat = NF90_PUT_ATT( id_set_pts, NF90_GLOBAL, 'title', &
+                                  TRIM( run_description_header ) )
+          CALL netcdf_handle_error( 'netcdf_define_header', 411 )
+          nc_stat = NF90_ENDDEF( id_set_pts )
+          CALL netcdf_handle_error( 'netcdf_define_header', 444 )
+          message_string = 'netCDF file for particle time series ' // &
+                           'from previous run found.' //              &
+                           '&This file will be extended.'
+          CALL message( 'netcdf_define_header', 'PA0269', 0, 0, 0, 6, 0 )
+
+
+       CASE DEFAULT
+
+          message_string = 'mode "' // TRIM( mode) // '" not supported'
+          CALL message( 'netcdf_define_header', 'PA0270', 0, 0, 0, 6, 0 )
+
+    END SELECT
+
+#endif
+ END SUBROUTINE netcdf_define_header
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Creates a netCDF file and give back the id. The parallel flag has to be TRUE
+!> for parallel netCDF output support.
+!------------------------------------------------------------------------------!
+ 
+ SUBROUTINE netcdf_create_file( filename , id, parallel, errno )
+#if defined( __netcdf )
+
+    USE pegrid
+
+    IMPLICIT NONE
+
+    CHARACTER (LEN=*), INTENT(IN) :: filename
+    INTEGER, INTENT(IN)           :: errno
+    INTEGER, INTENT(OUT)          :: id
+    LOGICAL, INTENT(IN)           :: parallel
+
+
+!
+!-- Create a new netCDF output file with requested netCDF format
+    IF ( netcdf_data_format == 1 )  THEN
+!
+!--    Classic netCDF format
+       nc_stat = NF90_CREATE( filename, NF90_NOCLOBBER, id )
+
+    ELSEIF ( netcdf_data_format == 2 )  THEN
+!
+!--    64bit-offset format
+       nc_stat = NF90_CREATE( filename,                                        &
+                              IOR( NF90_NOCLOBBER, NF90_64BIT_OFFSET ), id )
+
+#if defined( __netcdf4 )
+    ELSEIF ( netcdf_data_format == 3  .OR.                                     &
+             ( .NOT. parallel  .AND.  netcdf_data_format == 5 ) )  THEN
+!
+!--    netCDF4/HDF5 format
+       nc_stat = NF90_CREATE( filename, IOR( NF90_NOCLOBBER, NF90_NETCDF4 ), id )
+
+    ELSEIF ( netcdf_data_format == 4  .OR.                                     &
+             ( .NOT. parallel  .AND.  netcdf_data_format == 6 ) )  THEN
+!
+!--    netCDF4/HDF5 format with classic model flag
+       nc_stat = NF90_CREATE( filename,                                        &
+                              IOR( NF90_NOCLOBBER,                             &
+                              IOR( NF90_CLASSIC_MODEL, NF90_HDF5 ) ), id )
+
+#if defined( __netcdf4_parallel )
+    ELSEIF ( netcdf_data_format == 5  .AND.  parallel )  THEN
+!
+!--    netCDF4/HDF5 format, parallel
+       nc_stat = NF90_CREATE( filename,                                        &
+                              IOR( NF90_NOCLOBBER,                             &
+                              IOR( NF90_NETCDF4, NF90_MPIIO ) ),               &
+                              id, COMM = comm2d, INFO = MPI_INFO_NULL )
+
+    ELSEIF ( netcdf_data_format == 6  .AND.  parallel )  THEN
+!
+!--    netCDF4/HDF5 format with classic model flag, parallel
+       nc_stat = NF90_CREATE( filename,                                        &
+                              IOR( NF90_NOCLOBBER,                             &
+                              IOR( NF90_MPIIO,                                 &
+                              IOR( NF90_CLASSIC_MODEL, NF90_HDF5 ) ) ),        &
+                              id, COMM = comm2d, INFO = MPI_INFO_NULL )
+
+#endif
+#endif
+    ENDIF
+
+    CALL netcdf_handle_error( 'netcdf_create_file', errno )
+#endif
+ END SUBROUTINE netcdf_create_file
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Opens an existing netCDF file for writing and gives back the id.
+!> The parallel flag has to be TRUE for parallel netCDF output support.
+!------------------------------------------------------------------------------!
+ 
+ SUBROUTINE netcdf_open_write_file( filename, id, parallel, errno )
+#if defined( __netcdf )
+
+    USE pegrid
+
+    IMPLICIT NONE
+
+    CHARACTER (LEN=*), INTENT(IN) :: filename
+    INTEGER, INTENT(IN)           :: errno
+    INTEGER, INTENT(OUT)          :: id
+    LOGICAL, INTENT(IN)           :: parallel
+
+
+    IF ( netcdf_data_format < 5  .OR.  .NOT. parallel )  THEN
+       nc_stat = NF90_OPEN( filename, NF90_WRITE, id )
+#if defined( __netcdf4 )
+#if defined( __netcdf4_parallel )
+    ELSEIF ( netcdf_data_format > 4  .AND.  parallel )  THEN
+       nc_stat = NF90_OPEN( filename, IOR( NF90_WRITE, NF90_MPIIO ), id,  &
+                            COMM = comm2d, INFO = MPI_INFO_NULL )
+#endif
+#endif
+    ENDIF
+
+    CALL netcdf_handle_error( 'netcdf_open_write_file', errno )
+#endif
+ END SUBROUTINE netcdf_open_write_file
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Prints out a text message corresponding to the current status.
+!------------------------------------------------------------------------------!
+ 
+ SUBROUTINE netcdf_handle_error( routine_name, errno )
+#if defined( __netcdf )
+
+
+    USE control_parameters,                                                    &
+        ONLY:  message_string
+
+    IMPLICIT NONE
+
+    CHARACTER(LEN=6) ::  message_identifier
+    CHARACTER(LEN=*) ::  routine_name
+
+    INTEGER(iwp) ::  errno
+
+    IF ( nc_stat /= NF90_NOERR )  THEN
+
+       WRITE( message_identifier, '(''NC'',I4.4)' )  errno
+       message_string = TRIM( NF90_STRERROR( nc_stat ) )
+
+       CALL message( routine_name, message_identifier, 2, 2, 0, 6, 1 )
+
+    ENDIF
+
+#endif
+ END SUBROUTINE netcdf_handle_error
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Create a dimension in NetCDF file
+!------------------------------------------------------------------------------!
+
+ SUBROUTINE netcdf_create_dim(ncid, dim_name, ncdim_type, ncdim_id, error_no)
+
+#if defined( __netcdf )
+
+    USE kinds
+
+    IMPLICIT NONE
+
+    CHARACTER(LEN=*), INTENT(IN) ::  dim_name
+
+    INTEGER, INTENT(IN)  ::  error_no
+    INTEGER, INTENT(IN)  ::  ncid
+    INTEGER, INTENT(OUT) ::  ncdim_id
+    INTEGER, INTENT(IN)  ::  ncdim_type
+
+!
+!-- Define time coordinate for volume data (unlimited dimension)
+    nc_stat = NF90_DEF_DIM( ncid, dim_name, ncdim_type, ncdim_id )
+    CALL netcdf_handle_error( 'netcdf_create_dim', error_no )
+
+#endif
+
+ END SUBROUTINE netcdf_create_dim
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Create a one dimensional variable in specific units in NetCDF file
+!------------------------------------------------------------------------------!
+
+ SUBROUTINE netcdf_create_var( ncid, dim_id, var_name, var_type, var_id,       &
+                               unit_name, long_name, error_no1, error_no2,     &
+                               error_no3 )
+
+#if defined( __netcdf )
+    IMPLICIT NONE
+
+    CHARACTER(LEN=*), INTENT(IN) ::  long_name
+    CHARACTER(LEN=*), INTENT(IN) ::  unit_name
+    CHARACTER(LEN=*), INTENT(IN) ::  var_name
+
+    INTEGER, INTENT(IN)  ::  error_no1
+    INTEGER, INTENT(IN)  ::  error_no2
+    INTEGER, INTENT(IN)  ::  error_no3
+    INTEGER, INTENT(IN)  ::  ncid
+    INTEGER, INTENT(OUT) ::  var_id
+    INTEGER, INTENT(IN)  ::  var_type
+
+    INTEGER, DIMENSION(:), INTENT(IN) ::  dim_id
+
+!
+!-- Define variable
+    nc_stat = NF90_DEF_VAR( ncid, var_name, var_type, dim_id, var_id )
+    CALL netcdf_handle_error( 'netcdf_create_var', error_no1 )
+
+#if defined( __netcdf4 )
+!
+!-- Check if variable should be deflate (including shuffling)
+!-- and if it is possible (only NetCDF4 with HDF5 supports compression)
+    IF ( netcdf_data_format > 2  .AND.  netcdf_deflate > 0 )  THEN
+       nc_stat = NF90_DEF_VAR_DEFLATE( ncid, var_id, 1, 1, netcdf_deflate )
+       CALL netcdf_handle_error( 'netcdf_create_var_deflate', error_no1 )
+    ENDIF
+#endif
+!
+!-- Set unit name if set
+    IF ( unit_name /= '' )  THEN
+       nc_stat = NF90_PUT_ATT( ncid, var_id, 'units', unit_name )
+       CALL netcdf_handle_error( 'netcdf_create_var', error_no2 )
+    ENDIF
+
+!
+!-- Set long name if set
+    IF ( long_name /= '' )  THEN
+       nc_stat = NF90_PUT_ATT( ncid, var_id, 'long_name', long_name )
+       CALL netcdf_handle_error( 'netcdf_create_var', error_no3 )
+    ENDIF
+
+#endif
+ END SUBROUTINE netcdf_create_var
+
+ END MODULE netcdf_interface
Index: lm/trunk/SOURCE/nudging.f90
===================================================================
--- /palm/trunk/SOURCE/nudging.f90	(revision 1849)
+++ 	(revision )
@@ -1,619 +1,0 @@
-!> @file nudging.f90
-!--------------------------------------------------------------------------------!
-! This file is part of PALM.
-!
-! PALM is free software: you can redistribute it and/or modify it under the terms
-! of the GNU General Public License as published by the Free Software Foundation,
-! either version 3 of the License, or (at your option) any later version.
-!
-! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
-! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
-! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along with
-! PALM. If not, see <http://www.gnu.org/licenses/>.
-!
-! Copyright 1997-2016 Leibniz Universitaet Hannover
-!--------------------------------------------------------------------------------!
-!
-! Current revisions:
-! ------------------
-! 
-! 
-! Former revisions:
-! -----------------
-! $Id$
-!
-! 1757 2016-02-22 15:49:32Z maronga
-! Bugfix: allow for using higher vertical resolution in nudging file than grid
-! spacing in the LES model
-! 
-! 1682 2015-10-07 23:56:08Z knoop
-! Code annotations made doxygen readable 
-! 
-! 1398 2014-05-07 11:15:00Z heinze
-! Subroutine nudge_ref is extended to set u_init and v_init to the current 
-! nudging profiles
-! 
-! 1382 2014-04-30 12:15:41Z boeske
-! Changed the weighting factor that is used in the summation of nudging 
-! tendencies for profile data output from weight_pres to weight_substep,
-! added Neumann boundary conditions for profile data output of nudging terms at
-! nzt+1
-! 
-! 1380 2014-04-28 12:40:45Z heinze
-! Subroutine nudge_ref added to account for proper upper scalar boundary 
-! conditions in case of nudging
-! 
-! 1365 2014-04-22 15:03:56Z boeske
-! Variable t renamed nt, variable currtnudge renamed tmp_tnudge,
-! summation of nudging tendencies for data output added
-! +sums_ls_l, tmp_tend
-! Added new subroutine calc_tnudge, which calculates the current nudging time 
-! scale at each time step
-! 
-! 1355 2014-04-10 10:21:29Z heinze
-! Error message specified.
-! 
-! 1353 2014-04-08 15:21:23Z heinze
-! REAL constants provided with KIND-attribute 
-!
-! 1320 2014-03-20 08:40:49Z raasch
-! ONLY-attribute added to USE-statements,
-! kind-parameters added to all INTEGER and REAL declaration statements,
-! kinds are defined in new module kinds,
-! old module precision_kind is removed,
-! revision history before 2012 removed,
-! comment fields (!:) to be used for variable explanations added to
-! all variable declaration statements
-!
-! 1318 2014-03-17 13:35:16Z raasch
-! module interfaces removed
-!
-! 1268 2013-12-12 09:47:53Z heinze
-! bugfix: argument of calc_mean_profile corrected
-!
-! 1251 2013-11-07 08:14:30Z heinze
-! bugfix: calculate dtm and dtp also in vector version
-!
-! 1249 2013-11-06 10:45:47Z heinze
-! remove call of user module
-! reformatting
-!
-! 1241 2013-10-30 11:36:58Z heinze
-! Initial revision
-!
-! Description:
-! ------------
-!> Nudges u, v, pt and q to given profiles on a relaxation timescale tnudge. 
-!> Profiles are read in from NUDGIN_DATA. Code is based on Neggers et al. (2012) 
-!> and also part of DALES and UCLA-LES.
-!--------------------------------------------------------------------------------!
- MODULE nudge_mod
- 
-
-    PRIVATE
-    PUBLIC init_nudge, calc_tnudge, nudge, nudge_ref
-    SAVE
-
-    INTERFACE nudge
-       MODULE PROCEDURE nudge
-       MODULE PROCEDURE nudge_ij
-    END INTERFACE nudge
-
- CONTAINS
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> @todo Missing subroutine description.
-!------------------------------------------------------------------------------!
-    SUBROUTINE init_nudge
-
-       USE arrays_3d,                                                          &
-           ONLY:  ptnudge, qnudge, timenudge, tmp_tnudge, tnudge, unudge,      &
-                  vnudge, wnudge, zu
-
-       USE control_parameters,                                                 &
-           ONLY:  dt_3d, lptnudge, lqnudge, lunudge, lvnudge, lwnudge,         &
-                   message_string, ntnudge
-
-       USE indices,                                                            &
-           ONLY:  nzb, nzt
-
-       USE kinds
-
-       IMPLICIT NONE
-
-
-       INTEGER(iwp) ::  finput = 90  !<
-       INTEGER(iwp) ::  ierrn        !<
-       INTEGER(iwp) ::  k            !<
-       INTEGER(iwp) ::  nt            !<
-
-       CHARACTER(1) ::  hash     !<
-
-       REAL(wp) ::  highheight   !<
-       REAL(wp) ::  highqnudge   !<
-       REAL(wp) ::  highptnudge  !<
-       REAL(wp) ::  highunudge   !<
-       REAL(wp) ::  highvnudge   !<
-       REAL(wp) ::  highwnudge   !<
-       REAL(wp) ::  hightnudge   !<
-
-       REAL(wp) ::  lowheight    !<
-       REAL(wp) ::  lowqnudge    !<
-       REAL(wp) ::  lowptnudge   !<
-       REAL(wp) ::  lowunudge    !<
-       REAL(wp) ::  lowvnudge    !<
-       REAL(wp) ::  lowwnudge    !<
-       REAL(wp) ::  lowtnudge    !<
-
-       REAL(wp) ::  fac          !<
-
-       ALLOCATE( ptnudge(nzb:nzt+1,1:ntnudge), qnudge(nzb:nzt+1,1:ntnudge), &
-                 tnudge(nzb:nzt+1,1:ntnudge), unudge(nzb:nzt+1,1:ntnudge),  &
-                 vnudge(nzb:nzt+1,1:ntnudge), wnudge(nzb:nzt+1,1:ntnudge)  )
-
-       ALLOCATE( tmp_tnudge(nzb:nzt) )
-
-       ALLOCATE( timenudge(0:ntnudge) )
-
-       ptnudge = 0.0_wp; qnudge = 0.0_wp; tnudge = 0.0_wp; unudge = 0.0_wp
-       vnudge = 0.0_wp; wnudge = 0.0_wp; timenudge = 0.0_wp
-!
-!--    Initialize array tmp_nudge with a current nudging time scale of 6 hours
-       tmp_tnudge = 21600.0_wp
-
-       nt = 0
-       OPEN ( finput, FILE='NUDGING_DATA', STATUS='OLD', &
-              FORM='FORMATTED', IOSTAT=ierrn )
-
-       IF ( ierrn /= 0 )  THEN
-          message_string = 'file NUDGING_DATA does not exist'
-          CALL message( 'nudging', 'PA0365', 1, 2, 0, 6, 0 )
-       ENDIF
-
-       ierrn = 0
-
- rloop:DO
-          nt = nt + 1
-          hash = "#"
-          ierrn = 1 ! not zero
-!
-!--       Search for the next line consisting of "# time", 
-!--       from there onwards the profiles will be read
-          DO WHILE ( .NOT. ( hash == "#" .AND. ierrn == 0 ) ) 
-          
-            READ ( finput, *, IOSTAT=ierrn ) hash, timenudge(nt)
-            IF ( ierrn < 0 )  EXIT rloop
-
-          ENDDO
-
-          ierrn = 0
-          READ ( finput, *, IOSTAT=ierrn ) lowheight, lowtnudge, lowunudge,   &
-                                           lowvnudge, lowwnudge , lowptnudge, &
-                                           lowqnudge
-
-          IF ( ierrn /= 0 )  THEN
-             message_string = 'errors in file NUDGING_DATA'
-             CALL message( 'nudging', 'PA0366', 1, 2, 0, 6, 0 )
-          ENDIF
-
-          ierrn = 0
-          READ ( finput, *, IOSTAT=ierrn ) highheight, hightnudge, highunudge,   &
-                                           highvnudge, highwnudge , highptnudge, &
-                                           highqnudge
-
-          IF ( ierrn /= 0 )  THEN
-             message_string = 'errors in file NUDGING_DATA'
-             CALL message( 'nudging', 'PA0366', 1, 2, 0, 6, 0 )
-          ENDIF
-
-          DO  k = nzb, nzt+1
-             DO WHILE ( highheight < zu(k) )
-                lowheight  = highheight
-                lowtnudge  = hightnudge
-                lowunudge  = highunudge
-                lowvnudge  = highvnudge
-                lowwnudge  = highwnudge
-                lowptnudge = highptnudge
-                lowqnudge  = highqnudge
- 
-                ierrn = 0
-                READ ( finput, *, IOSTAT=ierrn )  highheight , hightnudge , &
-                                                  highunudge , highvnudge , &
-                                                  highwnudge , highptnudge, &
-                                                  highqnudge
-                IF (ierrn /= 0 )  THEN
-                   WRITE( message_string, * ) 'zu(nzt+1) = ', zu(nzt+1), 'm is ',&
-                        'higher than the maximum height in NUDING_DATA which ',  &
-                        'is ', lowheight, 'm. Interpolation on PALM ',           &
-                        'grid is not possible.'
-                   CALL message( 'nudging', 'PA0364', 1, 2, 0, 6, 0 )
-                ENDIF
-             ENDDO
-
-!
-!--          Interpolation of prescribed profiles in space 
-
-             fac = ( highheight - zu(k) ) / ( highheight - lowheight )
-
-             tnudge(k,nt)  = fac * lowtnudge  + ( 1.0_wp - fac ) * hightnudge
-             unudge(k,nt)  = fac * lowunudge  + ( 1.0_wp - fac ) * highunudge
-             vnudge(k,nt)  = fac * lowvnudge  + ( 1.0_wp - fac ) * highvnudge
-             wnudge(k,nt)  = fac * lowwnudge  + ( 1.0_wp - fac ) * highwnudge
-             ptnudge(k,nt) = fac * lowptnudge + ( 1.0_wp - fac ) * highptnudge
-             qnudge(k,nt)  = fac * lowqnudge  + ( 1.0_wp - fac ) * highqnudge
-          ENDDO
-
-       ENDDO rloop
-
-       CLOSE ( finput )
-
-!
-!--    Prevent nudging if nudging profiles exhibt too small values
-!--    not used so far
-       lptnudge  = ANY( ABS( ptnudge ) > 1.0e-8_wp )
-       lqnudge   = ANY( ABS( qnudge )  > 1.0e-8_wp )
-       lunudge   = ANY( ABS( unudge )  > 1.0e-8_wp )
-       lvnudge   = ANY( ABS( vnudge )  > 1.0e-8_wp )
-       lwnudge   = ANY( ABS( wnudge )  > 1.0e-8_wp )
-
-    END SUBROUTINE init_nudge
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> @todo Missing subroutine description.
-!------------------------------------------------------------------------------!
-    SUBROUTINE calc_tnudge ( time )
-
-       USE arrays_3d,                                                          &
-           ONLY:  timenudge, tmp_tnudge, tnudge
-
-       USE control_parameters,                                                 &
-           ONLY:  dt_3d 
-
-       USE indices,                                                            &
-           ONLY:  nzb, nzt
-
-       USE kinds
-
-       IMPLICIT NONE
-
-
-       REAL(wp) ::  dtm         !<
-       REAL(wp) ::  dtp         !<
-       REAL(wp) ::  time        !<
-
-       INTEGER(iwp) ::  k   !<
-       INTEGER(iwp) ::  nt  !<
-
-       nt = 1
-       DO WHILE ( time > timenudge(nt) )
-         nt = nt+1
-       ENDDO
-       IF ( time /= timenudge(1) ) THEN
-         nt = nt-1
-       ENDIF
-
-       dtm = ( time - timenudge(nt) ) / ( timenudge(nt+1) - timenudge(nt) )
-       dtp = ( timenudge(nt+1) - time ) / ( timenudge(nt+1) - timenudge(nt) )
-
-       DO  k = nzb, nzt
-          tmp_tnudge(k) = MAX( dt_3d, tnudge(k,nt) * dtp + tnudge(k,nt+1) * dtm )
-       ENDDO
-
-    END SUBROUTINE calc_tnudge
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Call for all grid points
-!------------------------------------------------------------------------------!
-    SUBROUTINE nudge ( time, prog_var )
-
-       USE arrays_3d,                                                          &
-           ONLY:  pt, ptnudge, q, qnudge, tend, timenudge, tmp_tnudge, tnudge, &
-                  u, unudge, v, vnudge
-
-       USE control_parameters,                                                 &
-           ONLY:  dt_3d, intermediate_timestep_count, message_string
-
-       USE indices,                                                            &
-           ONLY:  nxl, nxr, nys, nyn, nzb, nzb_u_inner, nzt
-
-       USE kinds
-
-       USE statistics,                                                         &
-           ONLY:  hom, sums_ls_l, weight_substep
-
-       IMPLICIT NONE
-
-       CHARACTER (LEN=*) ::  prog_var  !<
-
-       REAL(wp) ::  tmp_tend    !<
-       REAL(wp) ::  dtm         !<
-       REAL(wp) ::  dtp         !<
-       REAL(wp) ::  time        !<
-
-       INTEGER(iwp) ::  i  !<
-       INTEGER(iwp) ::  j  !<
-       INTEGER(iwp) ::  k  !<
-       INTEGER(iwp) ::  nt  !<
-
-
-       nt = 1
-       DO WHILE ( time > timenudge(nt) )
-         nt = nt+1
-       ENDDO
-       IF ( time /= timenudge(1) ) THEN
-         nt = nt-1
-       ENDIF
-
-       dtm = ( time - timenudge(nt) ) / ( timenudge(nt+1) - timenudge(nt) )
-       dtp = ( timenudge(nt+1) - time ) / ( timenudge(nt+1) - timenudge(nt) )
-
-       SELECT CASE ( prog_var )
-
-          CASE ( 'u' )
-
-             DO  i = nxl, nxr
-                DO  j = nys, nyn
-
-                   DO  k = nzb_u_inner(j,i)+1, nzt
-
-                      tmp_tend = - ( hom(k,1,1,0) - ( unudge(k,nt) * dtp +     &
-                                     unudge(k,nt+1) * dtm ) ) / tmp_tnudge(k)
-
-                      tend(k,j,i) = tend(k,j,i) + tmp_tend
-
-                      sums_ls_l(k,6) = sums_ls_l(k,6) + tmp_tend *             &
-                                     weight_substep(intermediate_timestep_count)
-                   ENDDO
-                  
-                   sums_ls_l(nzt+1,6) = sums_ls_l(nzt,6)
- 
-                ENDDO
-            ENDDO
-
-          CASE ( 'v' )
-
-             DO  i = nxl, nxr
-                DO  j = nys, nyn
-
-                   DO  k = nzb_u_inner(j,i)+1, nzt
-
-                      tmp_tend = - ( hom(k,1,2,0) - ( vnudge(k,nt) * dtp +     &
-                                     vnudge(k,nt+1) * dtm ) ) / tmp_tnudge(k)
-
-                      tend(k,j,i) = tend(k,j,i) + tmp_tend
-
-                      sums_ls_l(k,7) = sums_ls_l(k,7) + tmp_tend *             &
-                                     weight_substep(intermediate_timestep_count)
-                   ENDDO
-                  
-                   sums_ls_l(nzt+1,7) = sums_ls_l(nzt,7)
-
-                ENDDO
-            ENDDO
-
-          CASE ( 'pt' )
-
-             DO  i = nxl, nxr
-                DO  j = nys, nyn
-
-                   DO  k = nzb_u_inner(j,i)+1, nzt
-
-                      tmp_tend = - ( hom(k,1,4,0) - ( ptnudge(k,nt) * dtp +    &
-                                     ptnudge(k,nt+1) * dtm ) ) / tmp_tnudge(k)
-
-                      tend(k,j,i) = tend(k,j,i) + tmp_tend
-
-                      sums_ls_l(k,4) = sums_ls_l(k,4) + tmp_tend *             &
-                                     weight_substep(intermediate_timestep_count)
-                   ENDDO
-
-                   sums_ls_l(nzt+1,4) = sums_ls_l(nzt,4)
-
-                ENDDO
-            ENDDO
-
-          CASE ( 'q' )
-
-             DO  i = nxl, nxr
-                DO  j = nys, nyn
-
-                   DO  k = nzb_u_inner(j,i)+1, nzt
-
-                      tmp_tend = - ( hom(k,1,41,0) - ( qnudge(k,nt) * dtp +    &
-                                     qnudge(k,nt+1) * dtm ) ) / tmp_tnudge(k)
-
-                      tend(k,j,i) = tend(k,j,i) + tmp_tend
-
-                      sums_ls_l(k,5) = sums_ls_l(k,5) + tmp_tend *             &
-                                     weight_substep(intermediate_timestep_count)
-                   ENDDO
-                  
-                   sums_ls_l(nzt+1,5) = sums_ls_l(nzt,5)
-
-                ENDDO
-            ENDDO
-
-          CASE DEFAULT
-             message_string = 'unknown prognostic variable "' // prog_var // '"'
-             CALL message( 'nudge', 'PA0367', 1, 2, 0, 6, 0 )
-
-       END SELECT
-
-    END SUBROUTINE nudge
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Call for grid point i,j
-!------------------------------------------------------------------------------!
-
-    SUBROUTINE nudge_ij( i, j, time, prog_var )
-
-       USE arrays_3d,                                                          &
-           ONLY:  pt, ptnudge, q, qnudge, tend, timenudge, tmp_tnudge, tnudge, &
-                  u, unudge, v, vnudge
-
-       USE control_parameters,                                                 &
-           ONLY:  dt_3d, intermediate_timestep_count, message_string
-
-       USE indices,                                                            &
-           ONLY:  nxl, nxr, nys, nyn, nzb, nzb_u_inner, nzt
-
-       USE kinds
-
-       USE statistics,                                                         &
-           ONLY:  hom, sums_ls_l, weight_substep
-
-       IMPLICIT NONE
-
-
-       CHARACTER (LEN=*) ::  prog_var  !<
-
-       REAL(wp) ::  tmp_tend    !<
-       REAL(wp) ::  dtm         !<
-       REAL(wp) ::  dtp         !<
-       REAL(wp) ::  time        !<
-
-       INTEGER(iwp) ::  i  !<
-       INTEGER(iwp) ::  j  !<
-       INTEGER(iwp) ::  k  !<
-       INTEGER(iwp) ::  nt  !<
-
-
-       nt = 1
-       DO WHILE ( time > timenudge(nt) )
-         nt = nt+1
-       ENDDO
-       IF ( time /= timenudge(1) )  THEN
-         nt = nt-1
-       ENDIF
-
-       dtm = ( time - timenudge(nt) ) / ( timenudge(nt+1) - timenudge(nt) )
-       dtp = ( timenudge(nt+1) - time ) / ( timenudge(nt+1) - timenudge(nt) )
-
-       SELECT CASE ( prog_var )
-
-          CASE ( 'u' )
-
-             DO  k = nzb_u_inner(j,i)+1, nzt
-
-                tmp_tend = - ( hom(k,1,1,0) - ( unudge(k,nt) * dtp +           &
-                               unudge(k,nt+1) * dtm ) ) / tmp_tnudge(k)
-
-                tend(k,j,i) = tend(k,j,i) + tmp_tend
-
-                sums_ls_l(k,6) = sums_ls_l(k,6) + tmp_tend                     &
-                                 * weight_substep(intermediate_timestep_count)
-             ENDDO
-
-             sums_ls_l(nzt+1,6) = sums_ls_l(nzt,6)
-
-          CASE ( 'v' )
-
-             DO  k = nzb_u_inner(j,i)+1, nzt
-
-                tmp_tend = - ( hom(k,1,2,0) - ( vnudge(k,nt) * dtp +           &
-                               vnudge(k,nt+1) * dtm ) ) / tmp_tnudge(k)
-
-                tend(k,j,i) = tend(k,j,i) + tmp_tend
-
-                sums_ls_l(k,7) = sums_ls_l(k,7) + tmp_tend                     &
-                                 * weight_substep(intermediate_timestep_count)
-             ENDDO
-
-             sums_ls_l(nzt+1,7) = sums_ls_l(nzt,7)
-
-          CASE ( 'pt' )
-
-             DO  k = nzb_u_inner(j,i)+1, nzt
-
-                tmp_tend = - ( hom(k,1,4,0) - ( ptnudge(k,nt) * dtp +          &
-                               ptnudge(k,nt+1) * dtm ) ) / tmp_tnudge(k)
-
-                tend(k,j,i) = tend(k,j,i) + tmp_tend
-
-                sums_ls_l(k,4) = sums_ls_l(k,4) + tmp_tend                     &
-                                 * weight_substep(intermediate_timestep_count)
-             ENDDO
-
-             sums_ls_l(nzt+1,4) = sums_ls_l(nzt,4)
-
-
-          CASE ( 'q' )
-
-             DO  k = nzb_u_inner(j,i)+1, nzt
-
-                tmp_tend = - ( hom(k,1,41,0) - ( qnudge(k,nt) * dtp +          &
-                               qnudge(k,nt+1) * dtm ) ) / tmp_tnudge(k)
-
-                tend(k,j,i) = tend(k,j,i) + tmp_tend
-
-                sums_ls_l(k,5) = sums_ls_l(k,5) + tmp_tend                     &
-                                 * weight_substep(intermediate_timestep_count)
-             ENDDO
-
-             sums_ls_l(nzt+1,5) = sums_ls_l(nzt,5)
-
-          CASE DEFAULT
-             message_string = 'unknown prognostic variable "' // prog_var // '"'
-             CALL message( 'nudge', 'PA0367', 1, 2, 0, 6, 0 )
-
-       END SELECT
-
-
-    END SUBROUTINE nudge_ij
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> @todo Missing subroutine description.
-!------------------------------------------------------------------------------!
-    SUBROUTINE nudge_ref ( time )
-
-       USE arrays_3d,                                                          &
-           ONLY:  time_vert, ptnudge, pt_init, qnudge, q_init, unudge, u_init, &
-                  vnudge, v_init
-
-       USE kinds
-
-
-       IMPLICIT NONE
-
-       INTEGER(iwp) ::  nt                    !<
-
-       REAL(wp)             ::  fac           !<
-       REAL(wp), INTENT(in) ::  time          !<
-
-!
-!--    Interpolation in time of NUDGING_DATA for pt_init and q_init. This is 
-!--    needed for correct upper boundary conditions for pt and q and in case that 
-!      large scale subsidence as well as scalar Rayleigh-damping are used
-       nt = 1
-       DO WHILE ( time > time_vert(nt) )
-          nt = nt + 1
-       ENDDO
-       IF ( time /= time_vert(nt) )  THEN
-        nt = nt - 1
-       ENDIF
-
-       fac = ( time-time_vert(nt) ) / ( time_vert(nt+1)-time_vert(nt) )
-
-       pt_init = ptnudge(:,nt) + fac * ( ptnudge(:,nt+1) - ptnudge(:,nt) )
-       q_init  = qnudge(:,nt) + fac * ( qnudge(:,nt+1) - qnudge(:,nt) )
-       u_init  = unudge(:,nt) + fac * ( unudge(:,nt+1) - unudge(:,nt) )
-       v_init  = vnudge(:,nt) + fac * ( vnudge(:,nt+1) - vnudge(:,nt) )
-
-    END SUBROUTINE nudge_ref
-
- END MODULE nudge_mod
Index: /palm/trunk/SOURCE/nudging_mod.f90
===================================================================
--- /palm/trunk/SOURCE/nudging_mod.f90	(revision 1850)
+++ /palm/trunk/SOURCE/nudging_mod.f90	(revision 1850)
@@ -0,0 +1,620 @@
+!> @file nudging_mod.f90
+!--------------------------------------------------------------------------------!
+! This file is part of PALM.
+!
+! PALM is free software: you can redistribute it and/or modify it under the terms
+! of the GNU General Public License as published by the Free Software Foundation,
+! either version 3 of the License, or (at your option) any later version.
+!
+! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
+! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
+! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along with
+! PALM. If not, see <http://www.gnu.org/licenses/>.
+!
+! Copyright 1997-2016 Leibniz Universitaet Hannover
+!--------------------------------------------------------------------------------!
+!
+! Current revisions:
+! ------------------
+! Module renamed
+! 
+! 
+! Former revisions:
+! -----------------
+! $Id$
+!
+! 1757 2016-02-22 15:49:32Z maronga
+! Bugfix: allow for using higher vertical resolution in nudging file than grid
+! spacing in the LES model
+! 
+! 1682 2015-10-07 23:56:08Z knoop
+! Code annotations made doxygen readable 
+! 
+! 1398 2014-05-07 11:15:00Z heinze
+! Subroutine nudge_ref is extended to set u_init and v_init to the current 
+! nudging profiles
+! 
+! 1382 2014-04-30 12:15:41Z boeske
+! Changed the weighting factor that is used in the summation of nudging 
+! tendencies for profile data output from weight_pres to weight_substep,
+! added Neumann boundary conditions for profile data output of nudging terms at
+! nzt+1
+! 
+! 1380 2014-04-28 12:40:45Z heinze
+! Subroutine nudge_ref added to account for proper upper scalar boundary 
+! conditions in case of nudging
+! 
+! 1365 2014-04-22 15:03:56Z boeske
+! Variable t renamed nt, variable currtnudge renamed tmp_tnudge,
+! summation of nudging tendencies for data output added
+! +sums_ls_l, tmp_tend
+! Added new subroutine calc_tnudge, which calculates the current nudging time 
+! scale at each time step
+! 
+! 1355 2014-04-10 10:21:29Z heinze
+! Error message specified.
+! 
+! 1353 2014-04-08 15:21:23Z heinze
+! REAL constants provided with KIND-attribute 
+!
+! 1320 2014-03-20 08:40:49Z raasch
+! ONLY-attribute added to USE-statements,
+! kind-parameters added to all INTEGER and REAL declaration statements,
+! kinds are defined in new module kinds,
+! old module precision_kind is removed,
+! revision history before 2012 removed,
+! comment fields (!:) to be used for variable explanations added to
+! all variable declaration statements
+!
+! 1318 2014-03-17 13:35:16Z raasch
+! module interfaces removed
+!
+! 1268 2013-12-12 09:47:53Z heinze
+! bugfix: argument of calc_mean_profile corrected
+!
+! 1251 2013-11-07 08:14:30Z heinze
+! bugfix: calculate dtm and dtp also in vector version
+!
+! 1249 2013-11-06 10:45:47Z heinze
+! remove call of user module
+! reformatting
+!
+! 1241 2013-10-30 11:36:58Z heinze
+! Initial revision
+!
+! Description:
+! ------------
+!> Nudges u, v, pt and q to given profiles on a relaxation timescale tnudge. 
+!> Profiles are read in from NUDGIN_DATA. Code is based on Neggers et al. (2012) 
+!> and also part of DALES and UCLA-LES.
+!--------------------------------------------------------------------------------!
+ MODULE nudge_mod
+ 
+
+    PRIVATE
+    PUBLIC init_nudge, calc_tnudge, nudge, nudge_ref
+    SAVE
+
+    INTERFACE nudge
+       MODULE PROCEDURE nudge
+       MODULE PROCEDURE nudge_ij
+    END INTERFACE nudge
+
+ CONTAINS
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> @todo Missing subroutine description.
+!------------------------------------------------------------------------------!
+    SUBROUTINE init_nudge
+
+       USE arrays_3d,                                                          &
+           ONLY:  ptnudge, qnudge, timenudge, tmp_tnudge, tnudge, unudge,      &
+                  vnudge, wnudge, zu
+
+       USE control_parameters,                                                 &
+           ONLY:  dt_3d, lptnudge, lqnudge, lunudge, lvnudge, lwnudge,         &
+                   message_string, ntnudge
+
+       USE indices,                                                            &
+           ONLY:  nzb, nzt
+
+       USE kinds
+
+       IMPLICIT NONE
+
+
+       INTEGER(iwp) ::  finput = 90  !<
+       INTEGER(iwp) ::  ierrn        !<
+       INTEGER(iwp) ::  k            !<
+       INTEGER(iwp) ::  nt            !<
+
+       CHARACTER(1) ::  hash     !<
+
+       REAL(wp) ::  highheight   !<
+       REAL(wp) ::  highqnudge   !<
+       REAL(wp) ::  highptnudge  !<
+       REAL(wp) ::  highunudge   !<
+       REAL(wp) ::  highvnudge   !<
+       REAL(wp) ::  highwnudge   !<
+       REAL(wp) ::  hightnudge   !<
+
+       REAL(wp) ::  lowheight    !<
+       REAL(wp) ::  lowqnudge    !<
+       REAL(wp) ::  lowptnudge   !<
+       REAL(wp) ::  lowunudge    !<
+       REAL(wp) ::  lowvnudge    !<
+       REAL(wp) ::  lowwnudge    !<
+       REAL(wp) ::  lowtnudge    !<
+
+       REAL(wp) ::  fac          !<
+
+       ALLOCATE( ptnudge(nzb:nzt+1,1:ntnudge), qnudge(nzb:nzt+1,1:ntnudge), &
+                 tnudge(nzb:nzt+1,1:ntnudge), unudge(nzb:nzt+1,1:ntnudge),  &
+                 vnudge(nzb:nzt+1,1:ntnudge), wnudge(nzb:nzt+1,1:ntnudge)  )
+
+       ALLOCATE( tmp_tnudge(nzb:nzt) )
+
+       ALLOCATE( timenudge(0:ntnudge) )
+
+       ptnudge = 0.0_wp; qnudge = 0.0_wp; tnudge = 0.0_wp; unudge = 0.0_wp
+       vnudge = 0.0_wp; wnudge = 0.0_wp; timenudge = 0.0_wp
+!
+!--    Initialize array tmp_nudge with a current nudging time scale of 6 hours
+       tmp_tnudge = 21600.0_wp
+
+       nt = 0
+       OPEN ( finput, FILE='NUDGING_DATA', STATUS='OLD', &
+              FORM='FORMATTED', IOSTAT=ierrn )
+
+       IF ( ierrn /= 0 )  THEN
+          message_string = 'file NUDGING_DATA does not exist'
+          CALL message( 'nudging', 'PA0365', 1, 2, 0, 6, 0 )
+       ENDIF
+
+       ierrn = 0
+
+ rloop:DO
+          nt = nt + 1
+          hash = "#"
+          ierrn = 1 ! not zero
+!
+!--       Search for the next line consisting of "# time", 
+!--       from there onwards the profiles will be read
+          DO WHILE ( .NOT. ( hash == "#" .AND. ierrn == 0 ) ) 
+          
+            READ ( finput, *, IOSTAT=ierrn ) hash, timenudge(nt)
+            IF ( ierrn < 0 )  EXIT rloop
+
+          ENDDO
+
+          ierrn = 0
+          READ ( finput, *, IOSTAT=ierrn ) lowheight, lowtnudge, lowunudge,   &
+                                           lowvnudge, lowwnudge , lowptnudge, &
+                                           lowqnudge
+
+          IF ( ierrn /= 0 )  THEN
+             message_string = 'errors in file NUDGING_DATA'
+             CALL message( 'nudging', 'PA0366', 1, 2, 0, 6, 0 )
+          ENDIF
+
+          ierrn = 0
+          READ ( finput, *, IOSTAT=ierrn ) highheight, hightnudge, highunudge,   &
+                                           highvnudge, highwnudge , highptnudge, &
+                                           highqnudge
+
+          IF ( ierrn /= 0 )  THEN
+             message_string = 'errors in file NUDGING_DATA'
+             CALL message( 'nudging', 'PA0366', 1, 2, 0, 6, 0 )
+          ENDIF
+
+          DO  k = nzb, nzt+1
+             DO WHILE ( highheight < zu(k) )
+                lowheight  = highheight
+                lowtnudge  = hightnudge
+                lowunudge  = highunudge
+                lowvnudge  = highvnudge
+                lowwnudge  = highwnudge
+                lowptnudge = highptnudge
+                lowqnudge  = highqnudge
+ 
+                ierrn = 0
+                READ ( finput, *, IOSTAT=ierrn )  highheight , hightnudge , &
+                                                  highunudge , highvnudge , &
+                                                  highwnudge , highptnudge, &
+                                                  highqnudge
+                IF (ierrn /= 0 )  THEN
+                   WRITE( message_string, * ) 'zu(nzt+1) = ', zu(nzt+1), 'm is ',&
+                        'higher than the maximum height in NUDING_DATA which ',  &
+                        'is ', lowheight, 'm. Interpolation on PALM ',           &
+                        'grid is not possible.'
+                   CALL message( 'nudging', 'PA0364', 1, 2, 0, 6, 0 )
+                ENDIF
+             ENDDO
+
+!
+!--          Interpolation of prescribed profiles in space 
+
+             fac = ( highheight - zu(k) ) / ( highheight - lowheight )
+
+             tnudge(k,nt)  = fac * lowtnudge  + ( 1.0_wp - fac ) * hightnudge
+             unudge(k,nt)  = fac * lowunudge  + ( 1.0_wp - fac ) * highunudge
+             vnudge(k,nt)  = fac * lowvnudge  + ( 1.0_wp - fac ) * highvnudge
+             wnudge(k,nt)  = fac * lowwnudge  + ( 1.0_wp - fac ) * highwnudge
+             ptnudge(k,nt) = fac * lowptnudge + ( 1.0_wp - fac ) * highptnudge
+             qnudge(k,nt)  = fac * lowqnudge  + ( 1.0_wp - fac ) * highqnudge
+          ENDDO
+
+       ENDDO rloop
+
+       CLOSE ( finput )
+
+!
+!--    Prevent nudging if nudging profiles exhibt too small values
+!--    not used so far
+       lptnudge  = ANY( ABS( ptnudge ) > 1.0e-8_wp )
+       lqnudge   = ANY( ABS( qnudge )  > 1.0e-8_wp )
+       lunudge   = ANY( ABS( unudge )  > 1.0e-8_wp )
+       lvnudge   = ANY( ABS( vnudge )  > 1.0e-8_wp )
+       lwnudge   = ANY( ABS( wnudge )  > 1.0e-8_wp )
+
+    END SUBROUTINE init_nudge
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> @todo Missing subroutine description.
+!------------------------------------------------------------------------------!
+    SUBROUTINE calc_tnudge ( time )
+
+       USE arrays_3d,                                                          &
+           ONLY:  timenudge, tmp_tnudge, tnudge
+
+       USE control_parameters,                                                 &
+           ONLY:  dt_3d 
+
+       USE indices,                                                            &
+           ONLY:  nzb, nzt
+
+       USE kinds
+
+       IMPLICIT NONE
+
+
+       REAL(wp) ::  dtm         !<
+       REAL(wp) ::  dtp         !<
+       REAL(wp) ::  time        !<
+
+       INTEGER(iwp) ::  k   !<
+       INTEGER(iwp) ::  nt  !<
+
+       nt = 1
+       DO WHILE ( time > timenudge(nt) )
+         nt = nt+1
+       ENDDO
+       IF ( time /= timenudge(1) ) THEN
+         nt = nt-1
+       ENDIF
+
+       dtm = ( time - timenudge(nt) ) / ( timenudge(nt+1) - timenudge(nt) )
+       dtp = ( timenudge(nt+1) - time ) / ( timenudge(nt+1) - timenudge(nt) )
+
+       DO  k = nzb, nzt
+          tmp_tnudge(k) = MAX( dt_3d, tnudge(k,nt) * dtp + tnudge(k,nt+1) * dtm )
+       ENDDO
+
+    END SUBROUTINE calc_tnudge
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Call for all grid points
+!------------------------------------------------------------------------------!
+    SUBROUTINE nudge ( time, prog_var )
+
+       USE arrays_3d,                                                          &
+           ONLY:  pt, ptnudge, q, qnudge, tend, timenudge, tmp_tnudge, tnudge, &
+                  u, unudge, v, vnudge
+
+       USE control_parameters,                                                 &
+           ONLY:  dt_3d, intermediate_timestep_count, message_string
+
+       USE indices,                                                            &
+           ONLY:  nxl, nxr, nys, nyn, nzb, nzb_u_inner, nzt
+
+       USE kinds
+
+       USE statistics,                                                         &
+           ONLY:  hom, sums_ls_l, weight_substep
+
+       IMPLICIT NONE
+
+       CHARACTER (LEN=*) ::  prog_var  !<
+
+       REAL(wp) ::  tmp_tend    !<
+       REAL(wp) ::  dtm         !<
+       REAL(wp) ::  dtp         !<
+       REAL(wp) ::  time        !<
+
+       INTEGER(iwp) ::  i  !<
+       INTEGER(iwp) ::  j  !<
+       INTEGER(iwp) ::  k  !<
+       INTEGER(iwp) ::  nt  !<
+
+
+       nt = 1
+       DO WHILE ( time > timenudge(nt) )
+         nt = nt+1
+       ENDDO
+       IF ( time /= timenudge(1) ) THEN
+         nt = nt-1
+       ENDIF
+
+       dtm = ( time - timenudge(nt) ) / ( timenudge(nt+1) - timenudge(nt) )
+       dtp = ( timenudge(nt+1) - time ) / ( timenudge(nt+1) - timenudge(nt) )
+
+       SELECT CASE ( prog_var )
+
+          CASE ( 'u' )
+
+             DO  i = nxl, nxr
+                DO  j = nys, nyn
+
+                   DO  k = nzb_u_inner(j,i)+1, nzt
+
+                      tmp_tend = - ( hom(k,1,1,0) - ( unudge(k,nt) * dtp +     &
+                                     unudge(k,nt+1) * dtm ) ) / tmp_tnudge(k)
+
+                      tend(k,j,i) = tend(k,j,i) + tmp_tend
+
+                      sums_ls_l(k,6) = sums_ls_l(k,6) + tmp_tend *             &
+                                     weight_substep(intermediate_timestep_count)
+                   ENDDO
+                  
+                   sums_ls_l(nzt+1,6) = sums_ls_l(nzt,6)
+ 
+                ENDDO
+            ENDDO
+
+          CASE ( 'v' )
+
+             DO  i = nxl, nxr
+                DO  j = nys, nyn
+
+                   DO  k = nzb_u_inner(j,i)+1, nzt
+
+                      tmp_tend = - ( hom(k,1,2,0) - ( vnudge(k,nt) * dtp +     &
+                                     vnudge(k,nt+1) * dtm ) ) / tmp_tnudge(k)
+
+                      tend(k,j,i) = tend(k,j,i) + tmp_tend
+
+                      sums_ls_l(k,7) = sums_ls_l(k,7) + tmp_tend *             &
+                                     weight_substep(intermediate_timestep_count)
+                   ENDDO
+                  
+                   sums_ls_l(nzt+1,7) = sums_ls_l(nzt,7)
+
+                ENDDO
+            ENDDO
+
+          CASE ( 'pt' )
+
+             DO  i = nxl, nxr
+                DO  j = nys, nyn
+
+                   DO  k = nzb_u_inner(j,i)+1, nzt
+
+                      tmp_tend = - ( hom(k,1,4,0) - ( ptnudge(k,nt) * dtp +    &
+                                     ptnudge(k,nt+1) * dtm ) ) / tmp_tnudge(k)
+
+                      tend(k,j,i) = tend(k,j,i) + tmp_tend
+
+                      sums_ls_l(k,4) = sums_ls_l(k,4) + tmp_tend *             &
+                                     weight_substep(intermediate_timestep_count)
+                   ENDDO
+
+                   sums_ls_l(nzt+1,4) = sums_ls_l(nzt,4)
+
+                ENDDO
+            ENDDO
+
+          CASE ( 'q' )
+
+             DO  i = nxl, nxr
+                DO  j = nys, nyn
+
+                   DO  k = nzb_u_inner(j,i)+1, nzt
+
+                      tmp_tend = - ( hom(k,1,41,0) - ( qnudge(k,nt) * dtp +    &
+                                     qnudge(k,nt+1) * dtm ) ) / tmp_tnudge(k)
+
+                      tend(k,j,i) = tend(k,j,i) + tmp_tend
+
+                      sums_ls_l(k,5) = sums_ls_l(k,5) + tmp_tend *             &
+                                     weight_substep(intermediate_timestep_count)
+                   ENDDO
+                  
+                   sums_ls_l(nzt+1,5) = sums_ls_l(nzt,5)
+
+                ENDDO
+            ENDDO
+
+          CASE DEFAULT
+             message_string = 'unknown prognostic variable "' // prog_var // '"'
+             CALL message( 'nudge', 'PA0367', 1, 2, 0, 6, 0 )
+
+       END SELECT
+
+    END SUBROUTINE nudge
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Call for grid point i,j
+!------------------------------------------------------------------------------!
+
+    SUBROUTINE nudge_ij( i, j, time, prog_var )
+
+       USE arrays_3d,                                                          &
+           ONLY:  pt, ptnudge, q, qnudge, tend, timenudge, tmp_tnudge, tnudge, &
+                  u, unudge, v, vnudge
+
+       USE control_parameters,                                                 &
+           ONLY:  dt_3d, intermediate_timestep_count, message_string
+
+       USE indices,                                                            &
+           ONLY:  nxl, nxr, nys, nyn, nzb, nzb_u_inner, nzt
+
+       USE kinds
+
+       USE statistics,                                                         &
+           ONLY:  hom, sums_ls_l, weight_substep
+
+       IMPLICIT NONE
+
+
+       CHARACTER (LEN=*) ::  prog_var  !<
+
+       REAL(wp) ::  tmp_tend    !<
+       REAL(wp) ::  dtm         !<
+       REAL(wp) ::  dtp         !<
+       REAL(wp) ::  time        !<
+
+       INTEGER(iwp) ::  i  !<
+       INTEGER(iwp) ::  j  !<
+       INTEGER(iwp) ::  k  !<
+       INTEGER(iwp) ::  nt  !<
+
+
+       nt = 1
+       DO WHILE ( time > timenudge(nt) )
+         nt = nt+1
+       ENDDO
+       IF ( time /= timenudge(1) )  THEN
+         nt = nt-1
+       ENDIF
+
+       dtm = ( time - timenudge(nt) ) / ( timenudge(nt+1) - timenudge(nt) )
+       dtp = ( timenudge(nt+1) - time ) / ( timenudge(nt+1) - timenudge(nt) )
+
+       SELECT CASE ( prog_var )
+
+          CASE ( 'u' )
+
+             DO  k = nzb_u_inner(j,i)+1, nzt
+
+                tmp_tend = - ( hom(k,1,1,0) - ( unudge(k,nt) * dtp +           &
+                               unudge(k,nt+1) * dtm ) ) / tmp_tnudge(k)
+
+                tend(k,j,i) = tend(k,j,i) + tmp_tend
+
+                sums_ls_l(k,6) = sums_ls_l(k,6) + tmp_tend                     &
+                                 * weight_substep(intermediate_timestep_count)
+             ENDDO
+
+             sums_ls_l(nzt+1,6) = sums_ls_l(nzt,6)
+
+          CASE ( 'v' )
+
+             DO  k = nzb_u_inner(j,i)+1, nzt
+
+                tmp_tend = - ( hom(k,1,2,0) - ( vnudge(k,nt) * dtp +           &
+                               vnudge(k,nt+1) * dtm ) ) / tmp_tnudge(k)
+
+                tend(k,j,i) = tend(k,j,i) + tmp_tend
+
+                sums_ls_l(k,7) = sums_ls_l(k,7) + tmp_tend                     &
+                                 * weight_substep(intermediate_timestep_count)
+             ENDDO
+
+             sums_ls_l(nzt+1,7) = sums_ls_l(nzt,7)
+
+          CASE ( 'pt' )
+
+             DO  k = nzb_u_inner(j,i)+1, nzt
+
+                tmp_tend = - ( hom(k,1,4,0) - ( ptnudge(k,nt) * dtp +          &
+                               ptnudge(k,nt+1) * dtm ) ) / tmp_tnudge(k)
+
+                tend(k,j,i) = tend(k,j,i) + tmp_tend
+
+                sums_ls_l(k,4) = sums_ls_l(k,4) + tmp_tend                     &
+                                 * weight_substep(intermediate_timestep_count)
+             ENDDO
+
+             sums_ls_l(nzt+1,4) = sums_ls_l(nzt,4)
+
+
+          CASE ( 'q' )
+
+             DO  k = nzb_u_inner(j,i)+1, nzt
+
+                tmp_tend = - ( hom(k,1,41,0) - ( qnudge(k,nt) * dtp +          &
+                               qnudge(k,nt+1) * dtm ) ) / tmp_tnudge(k)
+
+                tend(k,j,i) = tend(k,j,i) + tmp_tend
+
+                sums_ls_l(k,5) = sums_ls_l(k,5) + tmp_tend                     &
+                                 * weight_substep(intermediate_timestep_count)
+             ENDDO
+
+             sums_ls_l(nzt+1,5) = sums_ls_l(nzt,5)
+
+          CASE DEFAULT
+             message_string = 'unknown prognostic variable "' // prog_var // '"'
+             CALL message( 'nudge', 'PA0367', 1, 2, 0, 6, 0 )
+
+       END SELECT
+
+
+    END SUBROUTINE nudge_ij
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> @todo Missing subroutine description.
+!------------------------------------------------------------------------------!
+    SUBROUTINE nudge_ref ( time )
+
+       USE arrays_3d,                                                          &
+           ONLY:  time_vert, ptnudge, pt_init, qnudge, q_init, unudge, u_init, &
+                  vnudge, v_init
+
+       USE kinds
+
+
+       IMPLICIT NONE
+
+       INTEGER(iwp) ::  nt                    !<
+
+       REAL(wp)             ::  fac           !<
+       REAL(wp), INTENT(in) ::  time          !<
+
+!
+!--    Interpolation in time of NUDGING_DATA for pt_init and q_init. This is 
+!--    needed for correct upper boundary conditions for pt and q and in case that 
+!      large scale subsidence as well as scalar Rayleigh-damping are used
+       nt = 1
+       DO WHILE ( time > time_vert(nt) )
+          nt = nt + 1
+       ENDDO
+       IF ( time /= time_vert(nt) )  THEN
+        nt = nt - 1
+       ENDIF
+
+       fac = ( time-time_vert(nt) ) / ( time_vert(nt+1)-time_vert(nt) )
+
+       pt_init = ptnudge(:,nt) + fac * ( ptnudge(:,nt+1) - ptnudge(:,nt) )
+       q_init  = qnudge(:,nt) + fac * ( qnudge(:,nt+1) - qnudge(:,nt) )
+       u_init  = unudge(:,nt) + fac * ( unudge(:,nt+1) - unudge(:,nt) )
+       v_init  = vnudge(:,nt) + fac * ( vnudge(:,nt+1) - vnudge(:,nt) )
+
+    END SUBROUTINE nudge_ref
+
+ END MODULE nudge_mod
Index: lm/trunk/SOURCE/pmc_client.f90
===================================================================
--- /palm/trunk/SOURCE/pmc_client.f90	(revision 1849)
+++ 	(revision )
@@ -1,704 +1,0 @@
-MODULE pmc_client
-
-!--------------------------------------------------------------------------------!
-! This file is part of PALM.
-!
-! PALM is free software: you can redistribute it and/or modify it under the terms
-! of the GNU General Public License as published by the Free Software Foundation,
-! either version 3 of the License, or (at your option) any later version.
-!
-! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
-! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
-! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along with
-! PALM. If not, see <http://www.gnu.org/licenses/>.
-!
-! Copyright 1997-2016 Leibniz Universitaet Hannover
-!--------------------------------------------------------------------------------!
-!
-! Current revisions:
-! ------------------
-! 
-! 
-! Former revisions:
-! -----------------
-! $Id$
-!
-! 1833 2016-04-07 14:23:03Z raasch
-! gfortran requires pointer attributes for some array declarations,
-! long line wrapped
-!
-! 1808 2016-04-05 19:44:00Z raasch
-! MPI module used by default on all machines
-!
-! 1797 2016-03-21 16:50:28Z raasch
-! introduction of different datatransfer modes
-!
-! 1791 2016-03-11 10:41:25Z raasch
-! Debug write-statement commented out
-!
-! 1786 2016-03-08 05:49:27Z raasch
-! change in client-server data transfer: server now gets data from client
-! instead that client put's it to the server
-!
-! 1783 2016-03-06 18:36:17Z raasch
-! Bugfix: wrong data-type in MPI_WIN_CREATE replaced
-!
-! 1779 2016-03-03 08:01:28Z raasch
-! kind=dp replaced by wp, dim_order removed
-! array management changed from linked list to sequential loop
-!
-! 1764 2016-02-28 12:45:19Z raasch
-! cpp-statement added (nesting can only be used in parallel mode),
-! all kinds given in PALM style
-!
-! 1762 2016-02-25 12:31:13Z hellstea
-! Initial revision by K. Ketelsen
-!
-! Description:
-! ------------
-!
-! Client part of Palm Model Coupler
-!------------------------------------------------------------------------------!
-
-#if defined( __parallel )
-
-    use, intrinsic :: iso_c_binding
-
-#if defined( __mpifh )
-    INCLUDE "mpif.h"
-#else
-    USE MPI
-#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_MAX_ARRAY
-    USE  PMC_handle_communicator,   ONLY: m_model_comm,m_model_rank,m_model_npes, m_to_server_comm
-    USE  PMC_MPI_wrapper,           ONLY: PMC_Send_to_Server, PMC_Recv_from_Server, PMC_Time,                     &
-                                              PMC_Bcast, PMC_Inter_Bcast, PMC_Alloc_mem
-    IMPLICIT none
-    PRIVATE
-    SAVE
-
-    Type(ClientDef)                       :: me
-
-    INTEGER                               :: next_array_in_list = 0
-    INTEGER                               :: myIndex = 0                !Counter and unique number for Data Arrays
-
-    ! INTERFACE section
-
-    INTERFACE PMC_ClientInit
-        MODULE procedure PMC_ClientInit
-    END INTERFACE PMC_ClientInit
-
-    INTERFACE PMC_Set_DataArray_Name
-        MODULE procedure PMC_Set_DataArray_Name
-        MODULE procedure PMC_Set_DataArray_Name_LastEntry
-    END INTERFACE PMC_Set_DataArray_Name
-
-    INTERFACE PMC_C_Get_2D_index_list
-        MODULE procedure PMC_C_Get_2D_index_list
-    END INTERFACE PMC_C_Get_2D_index_list
-
-    INTERFACE PMC_C_clear_next_array_list
-        MODULE procedure PMC_C_clear_next_array_list
-    END INTERFACE PMC_C_clear_next_array_list
-
-    INTERFACE PMC_C_GetNextArray
-        MODULE procedure PMC_C_GetNextArray
-    END INTERFACE PMC_C_GetNextArray
-
-    INTERFACE PMC_C_Set_DataArray
-        MODULE procedure PMC_C_Set_DataArray_2d
-        MODULE procedure PMC_C_Set_DataArray_3d
-    END INTERFACE PMC_C_Set_DataArray
-
-    INTERFACE PMC_C_setInd_and_AllocMem
-        MODULE procedure PMC_C_setInd_and_AllocMem
-    END INTERFACE PMC_C_setInd_and_AllocMem
-
-    INTERFACE PMC_C_GetBuffer
-        MODULE procedure PMC_C_GetBuffer
-    END INTERFACE PMC_C_GetBuffer
-
-    INTERFACE PMC_C_PutBuffer
-        MODULE procedure PMC_C_PutBuffer
-    END INTERFACE PMC_C_PutBuffer
-
-    ! Public section
-
-    PUBLIC PMC_ClientInit , PMC_Set_DataArray_Name, PMC_C_Get_2D_index_list
-    PUBLIC PMC_C_GetNextArray, PMC_C_Set_DataArray, PMC_C_clear_next_array_list
-    PUBLIC PMC_C_setInd_and_AllocMem , PMC_C_GetBuffer, PMC_C_PutBuffer
-
-CONTAINS
-
-    SUBROUTINE PMC_ClientInit
-        IMPLICIT none
-
-        INTEGER                       :: i
-        INTEGER                       :: istat
-
-
-        ! Tailor MPI environment
-
-        me%model_comm = m_model_comm
-        me%inter_comm = m_to_server_comm
-
-        ! Get rank and size
-        CALL MPI_Comm_rank (me%model_comm, me%model_rank, istat);
-        CALL MPI_Comm_size (me%model_comm, me%model_npes, istat);
-        CALL MPI_Comm_remote_size (me%inter_comm, me%inter_npes, istat);
-
-        ! intra communicater is used for MPI_Get
-        CALL MPI_Intercomm_merge (me%inter_comm, .true., me%intra_comm, istat);
-        CALL MPI_Comm_rank (me%intra_comm, me%intra_rank, istat);
-        ALLOCATE (me%PEs(me%inter_npes))
-
-!
-!--     Allocate for all Server PEs an array of TYPE ArrayDef to store information of transfer array
-        do i=1,me%inter_npes
-           ALLOCATE(me%PEs(i)%array_list(PMC_MAX_ARRAY))
-        end do
-
-!        if(me%model_rank == 0) write(0,'(a,5i6)') 'PMC_ClientInit ',me%model_rank,me%model_npes,me%inter_npes,me%intra_rank
-
-        return
-    END SUBROUTINE PMC_ClientInit
-
-    SUBROUTINE PMC_Set_DataArray_Name (ServerArrayDesc, ServerArrayName, ClientArrayDesc, ClientArrayName, istat)
-        IMPLICIT none
-        character(len=*),INTENT(IN)           :: ServerArrayName
-        character(len=*),INTENT(IN)           :: ServerArrayDesc
-        character(len=*),INTENT(IN)           :: ClientArrayName
-        character(len=*),INTENT(IN)           :: ClientArrayDesc
-        INTEGER,INTENT(OUT)                   :: istat
-
-        !-- local variables
-        type(DA_NameDef)                      :: myName
-        INTEGER                               :: myPe
-        INTEGER                               :: my_AddiArray=0
-
-        istat = PMC_STATUS_OK
-        if(len(trim(ServerArrayName)) > DA_Namelen .or.                                         &
-            len(trim(ClientArrayName)) > DA_Namelen)  then !Name too long
-            istat = PMC_DA_NAME_ERR
-        end if
-
-        if(m_model_rank == 0) then
-            myIndex = myIndex+1
-            myName%couple_index  = myIndex
-            myName%ServerDesc    = trim(ServerArrayDesc)
-            myName%NameOnServer  = trim(ServerArrayName)
-            myName%ClientDesc    = trim(ClientArrayDesc)
-            myName%NameOnClient  = trim(ClientArrayName)
-        end if
-
-        !   Broadcat to all Client PEs
-
-        CALL PMC_Bcast ( myName%couple_index,  0,   comm=m_model_comm)
-        CALL PMC_Bcast ( myName%ServerDesc, 0,      comm=m_model_comm)
-        CALL PMC_Bcast ( myName%NameOnServer,    0, comm=m_model_comm)
-        CALL PMC_Bcast ( myName%ClientDesc, 0,      comm=m_model_comm)
-        CALL PMC_Bcast ( myName%NameOnClient,    0, comm=m_model_comm)
-
-        !   Broadcat to all Server PEs
-
-        if(m_model_rank == 0) then
-            myPE = MPI_ROOT
-        else
-            myPE = MPI_PROC_NULL
-        endif
-        CALL PMC_Bcast ( myName%couple_index, myPE, comm=m_to_server_comm)
-        CALL PMC_Bcast ( myName%ServerDesc,   myPE, comm=m_to_server_comm)
-        CALL PMC_Bcast ( myName%NameOnServer, myPE, comm=m_to_server_comm)
-        CALL PMC_Bcast ( myName%ClientDesc,   myPE, comm=m_to_server_comm)
-        CALL PMC_Bcast ( myName%NameOnClient, myPE, comm=m_to_server_comm)
-
-        CALL PMC_G_SetName (me, myName%couple_index, myName%NameOnClient)
-
-        return
-    END SUBROUTINE PMC_Set_DataArray_Name
-
-    SUBROUTINE PMC_Set_DataArray_Name_LastEntry (LastEntry)
-        IMPLICIT none
-        LOGICAL,INTENT(IN),optional           :: LastEntry
-
-        !-- local variables
-        type(DA_NameDef)                      :: myName
-        INTEGER                               :: myPe
-
-        myName%couple_index  = -1
-
-        if(m_model_rank == 0) then
-            myPE = MPI_ROOT
-        else
-            myPE = MPI_PROC_NULL
-        endif
-        CALL PMC_Bcast ( myName%couple_index,  myPE, comm=m_to_server_comm)
-
-        return
-    END SUBROUTINE PMC_Set_DataArray_Name_LastEntry
-
-    SUBROUTINE PMC_C_Get_2D_index_list
-       IMPLICIT none
-
-       INTEGER                                 :: i,j,i2,nr,ierr
-       INTEGER                                 :: dummy
-       INTEGER                                 :: indWin          !: MPI window object
-       INTEGER                                 :: indWin2         !: MPI window object
-       INTEGER(KIND=MPI_ADDRESS_KIND)          :: win_size        !: Size of MPI window 1 (in bytes)
-       INTEGER(KIND=MPI_ADDRESS_KIND)          :: disp            !: Displacement Unit (Integer = 4, floating poit = 8
-       INTEGER,DIMENSION(me%inter_npes*2)      :: NrEle           !: Number of Elements of a horizontal slice
-       TYPE(PeDef),POINTER                     :: aPE             !: Pointer to PeDef structure
-       INTEGER(KIND=MPI_ADDRESS_KIND)          :: WinSize         !: Size of MPI window 2 (in bytes)
-       INTEGER,DIMENSION(:),POINTER            :: myInd
-
-!      CALL PMC_C_CGet_Rem_index_list
-
-       win_size = c_sizeof(dummy)
-       CALL MPI_Win_create (dummy, win_size, iwp, MPI_INFO_NULL, me%intra_comm, indWin, ierr);
-       CALL MPI_Win_fence (0, indWin, ierr)                ! Open Window on Server side
-       CALL MPI_Win_fence (0, indWin, ierr)                ! Close Window on Server Side and opem on Client side
-
-       do i=1,me%inter_npes
-          disp = me%model_rank*2
-          CALL MPI_Get (NrEle((i-1)*2+1),2,MPI_INTEGER,i-1,disp,2,MPI_INTEGER,indWin, ierr)
-       end do
-       CALL MPI_Win_fence (0, indWin, ierr)    ! MPI_get is Non-blocking -> data in NrEle is not available until MPI_fence CALL
-
-       WinSize = 0
-       do i=1,me%inter_npes                         !Allocate memory for index array
-         aPE => me%PEs(i)
-         i2 = (i-1)*2+1
-         nr = NrEle(i2+1)
-         if(nr > 0)  then
-            ALLOCATE(aPE%locInd(nr))
-         else
-            NULLIFY (aPE%locInd)
-         endif
-         WinSize = max(nr,WinSize)                  !Maximum window size
-       end do
-
-       ALLOCATE(myInd(2*WinSize))
-       WinSize = 1
-
-!      local Buffer used in MPI_Get can but must not be inside the MPI Window
-!      Here, we use a dummy for MPI Window because the server PEs do not access the RMA window via MPI_get or MPI_Put
-
-       CALL MPI_Win_create (dummy, WinSize, iwp, MPI_INFO_NULL, me%intra_comm, indWin2, ierr);
-
-       CALL MPI_Win_fence (0, indWin2, ierr)    ! MPI_get is Non-blocking -> data in NrEle is not available until MPI_fence CALL
-       CALL MPI_Win_fence (0, indWin2, ierr)    ! MPI_get is Non-blocking -> data in NrEle is not available until MPI_fence CALL
-
-       do i=1,me%inter_npes
-          aPE => me%PEs(i)
-          nr = NrEle(i*2)
-          if(nr > 0 )  then
-             disp = NrEle(2*(i-1)+1)
-             CALL MPI_Win_lock (MPI_LOCK_SHARED , i-1, 0, indWin2, ierr)
-             CALL MPI_Get (myInd,2*nr,MPI_INTEGER,i-1,disp,2*nr,MPI_INTEGER,indWin2, ierr)
-             CALL MPI_Win_unlock (i-1, indWin2, ierr)
-             do j=1,nr
-                aPE%locInd(j)%i = myInd(2*j-1)
-                aPE%locInd(j)%j = myInd(2*j)
-             end do
-             aPE%NrEle = nr
-          else
-             aPE%NrEle = -1
-          end if
-       end do
-
-       CALL MPI_Barrier(me%intra_comm, ierr)   ! Dont know why, but this barrier is necessary before we can free the windows
-
-       CALL MPI_Win_free(indWin, ierr);
-       CALL MPI_Win_free(indWin2, ierr);
-       DEALLOCATE (myInd)
-
-       return
-    END SUBROUTINE PMC_C_Get_2D_index_list
-
-    SUBROUTINE PMC_C_clear_next_array_list
-       IMPLICIT none
-
-       next_array_in_list = 0
-
-       return
-    END SUBROUTINE PMC_C_clear_next_array_list
-
-!   List handling is still required to get minimal interaction with pmc_interface
-    LOGICAL function PMC_C_GetNextArray (myName)
-        character(len=*),INTENT(OUT)               :: myName
-
-        !-- local variables
-       TYPE(PeDef),POINTER          :: aPE
-       TYPE(ArrayDef),POINTER       :: ar
-
-       next_array_in_list = next_array_in_list+1
-
-!--    Array Names are the same on all client PE, so take first PE to get the name
-       aPE => me%PEs(1)
-
-       if(next_array_in_list > aPE%Nr_arrays) then
-          PMC_C_GetNextArray = .false.             !all arrays done
-          return
-       end if
-
-       ar  => aPE%array_list(next_array_in_list)
-
-       myName = ar%name
-
-       PMC_C_GetNextArray =  .true.                ! Return true if legal array
-       return
-    END function PMC_C_GetNextArray
-
-    SUBROUTINE PMC_C_Set_DataArray_2d (array)
-
-       IMPLICIT none
-
-       REAL(wp), INTENT(IN) ,DIMENSION(:,:), POINTER ::  array
-
-       INTEGER                              :: NrDims
-       INTEGER,DIMENSION (4)                :: dims
-       TYPE(c_ptr)                          :: array_adr
-       INTEGER                              :: i
-       TYPE(PeDef),POINTER                  :: aPE
-       TYPE(ArrayDef),POINTER               :: ar
-
-
-       dims = 1
-
-       NrDims    = 2
-       dims(1)   = size(array,1)
-       dims(2)   = size(array,2)
-
-       array_adr = c_loc(array)
-
-       do i=1,me%inter_npes
-          aPE => me%PEs(i)
-          ar  => aPE%array_list(next_array_in_list)
-          ar%NrDims    = NrDims
-          ar%A_dim     = dims
-          ar%data      = array_adr
-       end do
-
-       return
-    END SUBROUTINE PMC_C_Set_DataArray_2d
-
-    SUBROUTINE PMC_C_Set_DataArray_3d (array)
-
-       IMPLICIT none
-
-       REAL(wp),INTENT(IN),DIMENSION(:,:,:), POINTER ::  array
-
-       INTEGER                              ::  NrDims
-       INTEGER,DIMENSION (4)                ::  dims
-       TYPE(c_ptr)                          ::  array_adr
-       INTEGER                              ::  i
-       TYPE(PeDef),POINTER                  ::  aPE
-       TYPE(ArrayDef),POINTER               ::  ar
-
-       dims = 1
-
-       NrDims    = 3
-       dims(1)   = size(array,1)
-       dims(2)   = size(array,2)
-       dims(3)   = size(array,3)
-
-       array_adr = c_loc(array)
-
-       do i=1,me%inter_npes
-          aPE => me%PEs(i)
-          ar  => aPE%array_list(next_array_in_list)
-          ar%NrDims    = NrDims
-          ar%A_dim     = dims
-          ar%data      = array_adr
-       end do
-
-       return
-    END SUBROUTINE PMC_C_Set_DataArray_3d
-
-   SUBROUTINE PMC_C_setInd_and_AllocMem
-
-      IMPLICIT none
-
-!--   naming convention:  appending       _sc  -> server to client transfer
-!--                                       _cs  -> client to server transfer
-!--                                       Recv -> server to client transfer
-!--                                       Send -> client to server transfer
-
-      INTEGER                                 :: i, istat, ierr, j
-      INTEGER,PARAMETER                       :: NoINdex=-1
-      INTEGER                                 :: rcount
-      INTEGER                                 :: arlen, myIndex, tag
-      INTEGER(idp)                            :: bufsize                   ! Size of MPI data Window
-      TYPE(PeDef),POINTER                     :: aPE
-      TYPE(ArrayDef),POINTER                  :: ar
-      INTEGER,DIMENSION(1024)                 :: req
-      character(len=DA_Namelen)               :: myName
-      Type(c_ptr)                             :: base_ptr
-      REAL(kind=wp),DIMENSION(:),POINTER,save :: base_array_sc             !Base array
-      REAL(kind=wp),DIMENSION(:),POINTER,save :: base_array_cs             !Base array
-      INTEGER(KIND=MPI_ADDRESS_KIND)          :: WinSize
-
-      myIndex = 0
-      bufsize = 8
-
-!--   Server to client direction
-
-!--   First stride, Compute size and set index
-
-      do i=1,me%inter_npes
-         aPE => me%PEs(i)
-         tag = 200
-
-         do j=1,aPE%Nr_arrays
-            ar  => aPE%array_list(j)
-
-            ! Receive Index from client
-            tag = tag+1
-            CALL MPI_Recv (myIndex, 1, MPI_INTEGER, i-1, tag, me%inter_comm, MPI_STATUS_IGNORE, ierr)
-
-            if(ar%NrDims == 3) then
-               bufsize = max(bufsize,ar%A_dim(1)*ar%A_dim(2)*ar%A_dim(3))    ! determine max, because client buffer is allocated only once
-            else
-               bufsize = max(bufsize,ar%A_dim(1)*ar%A_dim(2))
-            end if
-            ar%RecvIndex = myIndex
-
-           end do
-      end do
-
-
-!--   Create RMA (One Sided Communication) data buffer
-!--   The buffer for MPI_Get can be PE local, i.e. it can but must not be part of the MPI RMA window
-
-      CALL PMC_Alloc_mem (base_array_sc, bufsize, base_ptr)
-      me%TotalBufferSize = bufsize*wp                          ! Total buffer size in Byte
-
-!--   Second stride, Set Buffer pointer
-
-      do i=1,me%inter_npes
-         aPE => me%PEs(i)
-
-         do j=1,aPE%Nr_arrays
-            ar  => aPE%array_list(j)
-            ar%RecvBuf = base_ptr
-         end do
-      end do
-
-!--   Client to server direction
-
-      myIndex = 1
-      rCount  = 0
-      bufsize = 8
-
-      do i=1,me%inter_npes
-         aPE => me%PEs(i)
-         tag = 300
-         do j=1,aPE%Nr_arrays
-            ar  => aPE%array_list(j)
-            if(ar%NrDims == 2) then
-               arlen     = aPE%NrEle                        ! 2D
-            else if(ar%NrDims == 3) then
-               arlen     = aPE%NrEle*ar%A_dim(1)            ! 3D
-            end if
-
-            tag    = tag+1
-            rCount = rCount+1
-            if(aPE%NrEle > 0)  then
-               CALL MPI_Isend (myIndex, 1, MPI_INTEGER, i-1, tag, me%inter_comm, req(rCount),ierr)
-               ar%SendIndex = myIndex
-            else
-               CALL MPI_Isend (NoIndex, 1, MPI_INTEGER, i-1, tag, me%inter_comm, req(rCount),ierr)
-               ar%SendIndex = NoIndex
-            end if
-
-            if(rCount == 1024) then                                  ! Maximum of 1024 outstanding requests
-               CALL MPI_Waitall (rCount, req, MPI_STATUSES_IGNORE, ierr)
-               rCount = 0;
-            end if
-
-            if(aPE%NrEle > 0)  then
-               ar%SendSize  = arlen
-               myIndex     = myIndex+arlen
-               bufsize     = bufsize+arlen
-            end if
-          end do
-         if(rCount > 0) then                                          ! Wait for all send completed
-            CALL MPI_Waitall (rCount, req, MPI_STATUSES_IGNORE, ierr)
-         end if
-      end do
-
-!--   Create RMA (One Sided Communication) window for data buffer client to server transfer
-!--   The buffer of MPI_Get (counter part of transfer) can be PE-local, i.e. it can but must not be part of the MPI RMA window
-!--   Only one RMA window is required to prepare the data for server -> client transfer on the server side and
-!--                                                       for client -> server transfer on the client side
-
-      CALL PMC_Alloc_mem (base_array_cs, bufsize)
-      me%TotalBufferSize = bufsize*wp                          !Total buffer size in Byte
-
-      WinSize = me%TotalBufferSize
-      CALL MPI_Win_create (base_array_cs, WinSize, wp, MPI_INFO_NULL, me%intra_comm, me%win_server_client, ierr);
-      CALL MPI_Win_fence (0, me%win_server_client, ierr);                    !  Open Window to set data
-      CALL MPI_Barrier(me%intra_comm, ierr)
-
-!--   Second stride, Set Buffer pointer
-
-      do i=1,me%inter_npes
-         aPE => me%PEs(i)
-
-         do j=1,aPE%Nr_arrays
-            ar  => aPE%array_list(j)
-            if(aPE%NrEle > 0)  then
-              ar%SendBuf = c_loc(base_array_cs(ar%SendIndex))
-              if(ar%SendIndex+ar%SendSize > bufsize) then
-                 write(0,'(a,i4,4i7,1x,a)') 'Client Buffer too small ',i,      &
-                     ar%SendIndex,ar%SendSize,ar%SendIndex+ar%SendSize,bufsize,trim(ar%name)
-                 CALL MPI_Abort (MPI_COMM_WORLD, istat, ierr)
-              end if
-            end if
-         end do
-      end do
-
-      return
-   END SUBROUTINE PMC_C_setInd_and_AllocMem
-
-   SUBROUTINE PMC_C_GetBuffer (WaitTime)
-
-      IMPLICIT none
-
-      REAL(wp), INTENT(OUT), optional   ::  WaitTime
-
-      !-- local variables
-      INTEGER                           ::  ip, ij, ierr, j
-      INTEGER                           ::  nr  ! Number of Elements to getb from server
-      INTEGER                           ::  myIndex
-      REAL(wp)                          ::  t1,t2
-      TYPE(PeDef),POINTER               ::  aPE
-      TYPE(ArrayDef),POINTER            ::  ar
-      INTEGER,DIMENSION(1)              ::  buf_shape
-      REAL(wp),POINTER,DIMENSION(:)     ::  buf
-      REAL(wp),POINTER,DIMENSION(:,:)   ::  data_2d
-      REAL(wp),POINTER,DIMENSION(:,:,:) ::  data_3d
-      character(len=DA_Namelen)         ::  myName
-      INTEGER(kind=MPI_ADDRESS_KIND)    ::  target_disp
-
-!
-!--   Synchronization of the model is done in pmci_client_synchronize and pmci_server_synchronize
-!--   Therefor the RMA window can be filled without sychronization at this point and a barrier
-!--   is not necessary
-!--   Please note that WaitTime has to be set in PMC_S_FillBuffer AND PMC_C_GetBuffer
-      if(present(WaitTime))  then
-         t1 = PMC_Time()
-         CALL MPI_Barrier(me%intra_comm, ierr)
-         t2 = PMC_Time()
-         WaitTime = t2-t1
-      end if
-
-      CALL MPI_Barrier(me%intra_comm, ierr)                         ! Wait for buffer is filled
-
-      do ip=1,me%inter_npes
-         aPE => me%PEs(ip)
-
-         do j=1,aPE%Nr_arrays
-            ar  => aPE%array_list(j)
-            if(ar%NrDims == 2) then
-               nr = aPE%NrEle
-            else if(ar%NrDims == 3) then
-               nr = aPE%NrEle*ar%A_dim(1)
-            end if
-
-            buf_shape(1) = nr
-            CALL c_f_pointer(ar%RecvBuf, buf, buf_shape)
-!
-!--         MPI passive target RMA
-            if(nr > 0)   then
-               target_disp = (ar%RecvIndex-1)
-               CALL MPI_Win_lock (MPI_LOCK_SHARED , ip-1, 0, me%win_server_client, ierr)
-               CALL MPI_Get (buf, nr, MPI_REAL, ip-1, target_disp, nr, MPI_REAL, me%win_server_client, ierr)
-               CALL MPI_Win_unlock (ip-1, me%win_server_client, ierr)
-            end if
-
-            myIndex = 1
-            if(ar%NrDims == 2) then
-
-               CALL c_f_pointer(ar%data, data_2d, ar%A_dim(1:2))
-               do ij=1,aPE%NrEle
-                  data_2d(aPE%locInd(ij)%j,aPE%locInd(ij)%i) = buf(myIndex)
-                  myIndex = myIndex+1
-               end do
-            else if(ar%NrDims == 3) then
-               CALL c_f_pointer(ar%data, data_3d, ar%A_dim(1:3))
-               do ij=1,aPE%NrEle
-                  data_3d(:,aPE%locInd(ij)%j,aPE%locInd(ij)%i) = buf(myIndex:myIndex+ar%A_dim(1)-1)
-                  myIndex = myIndex+ar%A_dim(1)
-               end do
-            end if
-
-         end do
-      end do
-      return
-   END SUBROUTINE PMC_C_GetBuffer
-
-   SUBROUTINE PMC_C_PutBuffer (WaitTime)
-
-      IMPLICIT none
-
-      REAL(wp), INTENT(OUT), optional   :: WaitTime
-
-      !-- local variables
-      INTEGER                           ::  ip, ij, ierr, j
-      INTEGER                           ::  nr  ! Number of Elements to getb from server
-      INTEGER                           ::  myIndex
-      REAL(wp)                          ::  t1,t2
-      TYPE(PeDef),POINTER               ::  aPE
-      TYPE(ArrayDef),POINTER            ::  ar
-      INTEGER,DIMENSION(1)              ::  buf_shape
-      REAL(wp),POINTER,DIMENSION(:)     ::  buf
-      REAL(wp),POINTER,DIMENSION(:,:)   ::  data_2d
-      REAL(wp),POINTER,DIMENSION(:,:,:) ::  data_3d
-      character(len=DA_Namelen)         ::  myName
-      INTEGER(kind=MPI_ADDRESS_KIND)    ::  target_disp
-
-      t1 = PMC_Time()
-      CALL MPI_Barrier(me%intra_comm, ierr)              ! Wait for empty buffer
-      t2 = PMC_Time()
-      if(present(WaitTime)) WaitTime = t2-t1
-
-      do ip=1,me%inter_npes
-         aPE => me%PEs(ip)
-
-         do j=1,aPE%Nr_arrays
-            ar  => aPE%array_list(j)
-            myIndex=1
-            if(ar%NrDims == 2) then
-               buf_shape(1) = aPE%NrEle
-               CALL c_f_pointer(ar%SendBuf, buf, buf_shape)
-               CALL c_f_pointer(ar%data, data_2d, ar%A_dim(1:2))
-               do ij=1,aPE%NrEle
-                  buf(myIndex) = data_2d(aPE%locInd(ij)%j,aPE%locInd(ij)%i)
-                  myIndex = myIndex+1
-               end do
-            else if(ar%NrDims == 3) then
-               buf_shape(1) = aPE%NrEle*ar%A_dim(1)
-               CALL c_f_pointer(ar%SendBuf, buf, buf_shape)
-               CALL c_f_pointer(ar%data, data_3d, ar%A_dim(1:3))
-               do ij=1,aPE%NrEle
-                  buf(myIndex:myIndex+ar%A_dim(1)-1) = data_3d(:,aPE%locInd(ij)%j,aPE%locInd(ij)%i)
-                  myIndex = myIndex+ar%A_dim(1)
-               end do
-            end if
-          end do
-      end do
-
-
-!      CALL MPI_Win_fence (0, me%win_server_client, ierr)      ! Fence might do it, test later
-      CALL MPI_Barrier(me%intra_comm, ierr)                   ! buffer is filled
-
-      return
-    END SUBROUTINE PMC_C_PutBuffer
-
-#endif
-END MODULE pmc_client
Index: /palm/trunk/SOURCE/pmc_client_mod.f90
===================================================================
--- /palm/trunk/SOURCE/pmc_client_mod.f90	(revision 1850)
+++ /palm/trunk/SOURCE/pmc_client_mod.f90	(revision 1850)
@@ -0,0 +1,705 @@
+MODULE pmc_client
+
+!--------------------------------------------------------------------------------!
+! This file is part of PALM.
+!
+! PALM is free software: you can redistribute it and/or modify it under the terms
+! of the GNU General Public License as published by the Free Software Foundation,
+! either version 3 of the License, or (at your option) any later version.
+!
+! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
+! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
+! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along with
+! PALM. If not, see <http://www.gnu.org/licenses/>.
+!
+! Copyright 1997-2016 Leibniz Universitaet Hannover
+!--------------------------------------------------------------------------------!
+!
+! Current revisions:
+! ------------------
+! Module renamed
+! 
+! 
+! Former revisions:
+! -----------------
+! $Id$
+!
+! 1833 2016-04-07 14:23:03Z raasch
+! gfortran requires pointer attributes for some array declarations,
+! long line wrapped
+!
+! 1808 2016-04-05 19:44:00Z raasch
+! MPI module used by default on all machines
+!
+! 1797 2016-03-21 16:50:28Z raasch
+! introduction of different datatransfer modes
+!
+! 1791 2016-03-11 10:41:25Z raasch
+! Debug write-statement commented out
+!
+! 1786 2016-03-08 05:49:27Z raasch
+! change in client-server data transfer: server now gets data from client
+! instead that client put's it to the server
+!
+! 1783 2016-03-06 18:36:17Z raasch
+! Bugfix: wrong data-type in MPI_WIN_CREATE replaced
+!
+! 1779 2016-03-03 08:01:28Z raasch
+! kind=dp replaced by wp, dim_order removed
+! array management changed from linked list to sequential loop
+!
+! 1764 2016-02-28 12:45:19Z raasch
+! cpp-statement added (nesting can only be used in parallel mode),
+! all kinds given in PALM style
+!
+! 1762 2016-02-25 12:31:13Z hellstea
+! Initial revision by K. Ketelsen
+!
+! Description:
+! ------------
+!
+! Client part of Palm Model Coupler
+!------------------------------------------------------------------------------!
+
+#if defined( __parallel )
+
+    use, intrinsic :: iso_c_binding
+
+#if defined( __mpifh )
+    INCLUDE "mpif.h"
+#else
+    USE MPI
+#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_MAX_ARRAY
+    USE  PMC_handle_communicator,   ONLY: m_model_comm,m_model_rank,m_model_npes, m_to_server_comm
+    USE  PMC_MPI_wrapper,           ONLY: PMC_Send_to_Server, PMC_Recv_from_Server, PMC_Time,                     &
+                                              PMC_Bcast, PMC_Inter_Bcast, PMC_Alloc_mem
+    IMPLICIT none
+    PRIVATE
+    SAVE
+
+    Type(ClientDef)                       :: me
+
+    INTEGER                               :: next_array_in_list = 0
+    INTEGER                               :: myIndex = 0                !Counter and unique number for Data Arrays
+
+    ! INTERFACE section
+
+    INTERFACE PMC_ClientInit
+        MODULE procedure PMC_ClientInit
+    END INTERFACE PMC_ClientInit
+
+    INTERFACE PMC_Set_DataArray_Name
+        MODULE procedure PMC_Set_DataArray_Name
+        MODULE procedure PMC_Set_DataArray_Name_LastEntry
+    END INTERFACE PMC_Set_DataArray_Name
+
+    INTERFACE PMC_C_Get_2D_index_list
+        MODULE procedure PMC_C_Get_2D_index_list
+    END INTERFACE PMC_C_Get_2D_index_list
+
+    INTERFACE PMC_C_clear_next_array_list
+        MODULE procedure PMC_C_clear_next_array_list
+    END INTERFACE PMC_C_clear_next_array_list
+
+    INTERFACE PMC_C_GetNextArray
+        MODULE procedure PMC_C_GetNextArray
+    END INTERFACE PMC_C_GetNextArray
+
+    INTERFACE PMC_C_Set_DataArray
+        MODULE procedure PMC_C_Set_DataArray_2d
+        MODULE procedure PMC_C_Set_DataArray_3d
+    END INTERFACE PMC_C_Set_DataArray
+
+    INTERFACE PMC_C_setInd_and_AllocMem
+        MODULE procedure PMC_C_setInd_and_AllocMem
+    END INTERFACE PMC_C_setInd_and_AllocMem
+
+    INTERFACE PMC_C_GetBuffer
+        MODULE procedure PMC_C_GetBuffer
+    END INTERFACE PMC_C_GetBuffer
+
+    INTERFACE PMC_C_PutBuffer
+        MODULE procedure PMC_C_PutBuffer
+    END INTERFACE PMC_C_PutBuffer
+
+    ! Public section
+
+    PUBLIC PMC_ClientInit , PMC_Set_DataArray_Name, PMC_C_Get_2D_index_list
+    PUBLIC PMC_C_GetNextArray, PMC_C_Set_DataArray, PMC_C_clear_next_array_list
+    PUBLIC PMC_C_setInd_and_AllocMem , PMC_C_GetBuffer, PMC_C_PutBuffer
+
+CONTAINS
+
+    SUBROUTINE PMC_ClientInit
+        IMPLICIT none
+
+        INTEGER                       :: i
+        INTEGER                       :: istat
+
+
+        ! Tailor MPI environment
+
+        me%model_comm = m_model_comm
+        me%inter_comm = m_to_server_comm
+
+        ! Get rank and size
+        CALL MPI_Comm_rank (me%model_comm, me%model_rank, istat);
+        CALL MPI_Comm_size (me%model_comm, me%model_npes, istat);
+        CALL MPI_Comm_remote_size (me%inter_comm, me%inter_npes, istat);
+
+        ! intra communicater is used for MPI_Get
+        CALL MPI_Intercomm_merge (me%inter_comm, .true., me%intra_comm, istat);
+        CALL MPI_Comm_rank (me%intra_comm, me%intra_rank, istat);
+        ALLOCATE (me%PEs(me%inter_npes))
+
+!
+!--     Allocate for all Server PEs an array of TYPE ArrayDef to store information of transfer array
+        do i=1,me%inter_npes
+           ALLOCATE(me%PEs(i)%array_list(PMC_MAX_ARRAY))
+        end do
+
+!        if(me%model_rank == 0) write(0,'(a,5i6)') 'PMC_ClientInit ',me%model_rank,me%model_npes,me%inter_npes,me%intra_rank
+
+        return
+    END SUBROUTINE PMC_ClientInit
+
+    SUBROUTINE PMC_Set_DataArray_Name (ServerArrayDesc, ServerArrayName, ClientArrayDesc, ClientArrayName, istat)
+        IMPLICIT none
+        character(len=*),INTENT(IN)           :: ServerArrayName
+        character(len=*),INTENT(IN)           :: ServerArrayDesc
+        character(len=*),INTENT(IN)           :: ClientArrayName
+        character(len=*),INTENT(IN)           :: ClientArrayDesc
+        INTEGER,INTENT(OUT)                   :: istat
+
+        !-- local variables
+        type(DA_NameDef)                      :: myName
+        INTEGER                               :: myPe
+        INTEGER                               :: my_AddiArray=0
+
+        istat = PMC_STATUS_OK
+        if(len(trim(ServerArrayName)) > DA_Namelen .or.                                         &
+            len(trim(ClientArrayName)) > DA_Namelen)  then !Name too long
+            istat = PMC_DA_NAME_ERR
+        end if
+
+        if(m_model_rank == 0) then
+            myIndex = myIndex+1
+            myName%couple_index  = myIndex
+            myName%ServerDesc    = trim(ServerArrayDesc)
+            myName%NameOnServer  = trim(ServerArrayName)
+            myName%ClientDesc    = trim(ClientArrayDesc)
+            myName%NameOnClient  = trim(ClientArrayName)
+        end if
+
+        !   Broadcat to all Client PEs
+
+        CALL PMC_Bcast ( myName%couple_index,  0,   comm=m_model_comm)
+        CALL PMC_Bcast ( myName%ServerDesc, 0,      comm=m_model_comm)
+        CALL PMC_Bcast ( myName%NameOnServer,    0, comm=m_model_comm)
+        CALL PMC_Bcast ( myName%ClientDesc, 0,      comm=m_model_comm)
+        CALL PMC_Bcast ( myName%NameOnClient,    0, comm=m_model_comm)
+
+        !   Broadcat to all Server PEs
+
+        if(m_model_rank == 0) then
+            myPE = MPI_ROOT
+        else
+            myPE = MPI_PROC_NULL
+        endif
+        CALL PMC_Bcast ( myName%couple_index, myPE, comm=m_to_server_comm)
+        CALL PMC_Bcast ( myName%ServerDesc,   myPE, comm=m_to_server_comm)
+        CALL PMC_Bcast ( myName%NameOnServer, myPE, comm=m_to_server_comm)
+        CALL PMC_Bcast ( myName%ClientDesc,   myPE, comm=m_to_server_comm)
+        CALL PMC_Bcast ( myName%NameOnClient, myPE, comm=m_to_server_comm)
+
+        CALL PMC_G_SetName (me, myName%couple_index, myName%NameOnClient)
+
+        return
+    END SUBROUTINE PMC_Set_DataArray_Name
+
+    SUBROUTINE PMC_Set_DataArray_Name_LastEntry (LastEntry)
+        IMPLICIT none
+        LOGICAL,INTENT(IN),optional           :: LastEntry
+
+        !-- local variables
+        type(DA_NameDef)                      :: myName
+        INTEGER                               :: myPe
+
+        myName%couple_index  = -1
+
+        if(m_model_rank == 0) then
+            myPE = MPI_ROOT
+        else
+            myPE = MPI_PROC_NULL
+        endif
+        CALL PMC_Bcast ( myName%couple_index,  myPE, comm=m_to_server_comm)
+
+        return
+    END SUBROUTINE PMC_Set_DataArray_Name_LastEntry
+
+    SUBROUTINE PMC_C_Get_2D_index_list
+       IMPLICIT none
+
+       INTEGER                                 :: i,j,i2,nr,ierr
+       INTEGER                                 :: dummy
+       INTEGER                                 :: indWin          !: MPI window object
+       INTEGER                                 :: indWin2         !: MPI window object
+       INTEGER(KIND=MPI_ADDRESS_KIND)          :: win_size        !: Size of MPI window 1 (in bytes)
+       INTEGER(KIND=MPI_ADDRESS_KIND)          :: disp            !: Displacement Unit (Integer = 4, floating poit = 8
+       INTEGER,DIMENSION(me%inter_npes*2)      :: NrEle           !: Number of Elements of a horizontal slice
+       TYPE(PeDef),POINTER                     :: aPE             !: Pointer to PeDef structure
+       INTEGER(KIND=MPI_ADDRESS_KIND)          :: WinSize         !: Size of MPI window 2 (in bytes)
+       INTEGER,DIMENSION(:),POINTER            :: myInd
+
+!      CALL PMC_C_CGet_Rem_index_list
+
+       win_size = c_sizeof(dummy)
+       CALL MPI_Win_create (dummy, win_size, iwp, MPI_INFO_NULL, me%intra_comm, indWin, ierr);
+       CALL MPI_Win_fence (0, indWin, ierr)                ! Open Window on Server side
+       CALL MPI_Win_fence (0, indWin, ierr)                ! Close Window on Server Side and opem on Client side
+
+       do i=1,me%inter_npes
+          disp = me%model_rank*2
+          CALL MPI_Get (NrEle((i-1)*2+1),2,MPI_INTEGER,i-1,disp,2,MPI_INTEGER,indWin, ierr)
+       end do
+       CALL MPI_Win_fence (0, indWin, ierr)    ! MPI_get is Non-blocking -> data in NrEle is not available until MPI_fence CALL
+
+       WinSize = 0
+       do i=1,me%inter_npes                         !Allocate memory for index array
+         aPE => me%PEs(i)
+         i2 = (i-1)*2+1
+         nr = NrEle(i2+1)
+         if(nr > 0)  then
+            ALLOCATE(aPE%locInd(nr))
+         else
+            NULLIFY (aPE%locInd)
+         endif
+         WinSize = max(nr,WinSize)                  !Maximum window size
+       end do
+
+       ALLOCATE(myInd(2*WinSize))
+       WinSize = 1
+
+!      local Buffer used in MPI_Get can but must not be inside the MPI Window
+!      Here, we use a dummy for MPI Window because the server PEs do not access the RMA window via MPI_get or MPI_Put
+
+       CALL MPI_Win_create (dummy, WinSize, iwp, MPI_INFO_NULL, me%intra_comm, indWin2, ierr);
+
+       CALL MPI_Win_fence (0, indWin2, ierr)    ! MPI_get is Non-blocking -> data in NrEle is not available until MPI_fence CALL
+       CALL MPI_Win_fence (0, indWin2, ierr)    ! MPI_get is Non-blocking -> data in NrEle is not available until MPI_fence CALL
+
+       do i=1,me%inter_npes
+          aPE => me%PEs(i)
+          nr = NrEle(i*2)
+          if(nr > 0 )  then
+             disp = NrEle(2*(i-1)+1)
+             CALL MPI_Win_lock (MPI_LOCK_SHARED , i-1, 0, indWin2, ierr)
+             CALL MPI_Get (myInd,2*nr,MPI_INTEGER,i-1,disp,2*nr,MPI_INTEGER,indWin2, ierr)
+             CALL MPI_Win_unlock (i-1, indWin2, ierr)
+             do j=1,nr
+                aPE%locInd(j)%i = myInd(2*j-1)
+                aPE%locInd(j)%j = myInd(2*j)
+             end do
+             aPE%NrEle = nr
+          else
+             aPE%NrEle = -1
+          end if
+       end do
+
+       CALL MPI_Barrier(me%intra_comm, ierr)   ! Dont know why, but this barrier is necessary before we can free the windows
+
+       CALL MPI_Win_free(indWin, ierr);
+       CALL MPI_Win_free(indWin2, ierr);
+       DEALLOCATE (myInd)
+
+       return
+    END SUBROUTINE PMC_C_Get_2D_index_list
+
+    SUBROUTINE PMC_C_clear_next_array_list
+       IMPLICIT none
+
+       next_array_in_list = 0
+
+       return
+    END SUBROUTINE PMC_C_clear_next_array_list
+
+!   List handling is still required to get minimal interaction with pmc_interface
+    LOGICAL function PMC_C_GetNextArray (myName)
+        character(len=*),INTENT(OUT)               :: myName
+
+        !-- local variables
+       TYPE(PeDef),POINTER          :: aPE
+       TYPE(ArrayDef),POINTER       :: ar
+
+       next_array_in_list = next_array_in_list+1
+
+!--    Array Names are the same on all client PE, so take first PE to get the name
+       aPE => me%PEs(1)
+
+       if(next_array_in_list > aPE%Nr_arrays) then
+          PMC_C_GetNextArray = .false.             !all arrays done
+          return
+       end if
+
+       ar  => aPE%array_list(next_array_in_list)
+
+       myName = ar%name
+
+       PMC_C_GetNextArray =  .true.                ! Return true if legal array
+       return
+    END function PMC_C_GetNextArray
+
+    SUBROUTINE PMC_C_Set_DataArray_2d (array)
+
+       IMPLICIT none
+
+       REAL(wp), INTENT(IN) ,DIMENSION(:,:), POINTER ::  array
+
+       INTEGER                              :: NrDims
+       INTEGER,DIMENSION (4)                :: dims
+       TYPE(c_ptr)                          :: array_adr
+       INTEGER                              :: i
+       TYPE(PeDef),POINTER                  :: aPE
+       TYPE(ArrayDef),POINTER               :: ar
+
+
+       dims = 1
+
+       NrDims    = 2
+       dims(1)   = size(array,1)
+       dims(2)   = size(array,2)
+
+       array_adr = c_loc(array)
+
+       do i=1,me%inter_npes
+          aPE => me%PEs(i)
+          ar  => aPE%array_list(next_array_in_list)
+          ar%NrDims    = NrDims
+          ar%A_dim     = dims
+          ar%data      = array_adr
+       end do
+
+       return
+    END SUBROUTINE PMC_C_Set_DataArray_2d
+
+    SUBROUTINE PMC_C_Set_DataArray_3d (array)
+
+       IMPLICIT none
+
+       REAL(wp),INTENT(IN),DIMENSION(:,:,:), POINTER ::  array
+
+       INTEGER                              ::  NrDims
+       INTEGER,DIMENSION (4)                ::  dims
+       TYPE(c_ptr)                          ::  array_adr
+       INTEGER                              ::  i
+       TYPE(PeDef),POINTER                  ::  aPE
+       TYPE(ArrayDef),POINTER               ::  ar
+
+       dims = 1
+
+       NrDims    = 3
+       dims(1)   = size(array,1)
+       dims(2)   = size(array,2)
+       dims(3)   = size(array,3)
+
+       array_adr = c_loc(array)
+
+       do i=1,me%inter_npes
+          aPE => me%PEs(i)
+          ar  => aPE%array_list(next_array_in_list)
+          ar%NrDims    = NrDims
+          ar%A_dim     = dims
+          ar%data      = array_adr
+       end do
+
+       return
+    END SUBROUTINE PMC_C_Set_DataArray_3d
+
+   SUBROUTINE PMC_C_setInd_and_AllocMem
+
+      IMPLICIT none
+
+!--   naming convention:  appending       _sc  -> server to client transfer
+!--                                       _cs  -> client to server transfer
+!--                                       Recv -> server to client transfer
+!--                                       Send -> client to server transfer
+
+      INTEGER                                 :: i, istat, ierr, j
+      INTEGER,PARAMETER                       :: NoINdex=-1
+      INTEGER                                 :: rcount
+      INTEGER                                 :: arlen, myIndex, tag
+      INTEGER(idp)                            :: bufsize                   ! Size of MPI data Window
+      TYPE(PeDef),POINTER                     :: aPE
+      TYPE(ArrayDef),POINTER                  :: ar
+      INTEGER,DIMENSION(1024)                 :: req
+      character(len=DA_Namelen)               :: myName
+      Type(c_ptr)                             :: base_ptr
+      REAL(kind=wp),DIMENSION(:),POINTER,save :: base_array_sc             !Base array
+      REAL(kind=wp),DIMENSION(:),POINTER,save :: base_array_cs             !Base array
+      INTEGER(KIND=MPI_ADDRESS_KIND)          :: WinSize
+
+      myIndex = 0
+      bufsize = 8
+
+!--   Server to client direction
+
+!--   First stride, Compute size and set index
+
+      do i=1,me%inter_npes
+         aPE => me%PEs(i)
+         tag = 200
+
+         do j=1,aPE%Nr_arrays
+            ar  => aPE%array_list(j)
+
+            ! Receive Index from client
+            tag = tag+1
+            CALL MPI_Recv (myIndex, 1, MPI_INTEGER, i-1, tag, me%inter_comm, MPI_STATUS_IGNORE, ierr)
+
+            if(ar%NrDims == 3) then
+               bufsize = max(bufsize,ar%A_dim(1)*ar%A_dim(2)*ar%A_dim(3))    ! determine max, because client buffer is allocated only once
+            else
+               bufsize = max(bufsize,ar%A_dim(1)*ar%A_dim(2))
+            end if
+            ar%RecvIndex = myIndex
+
+           end do
+      end do
+
+
+!--   Create RMA (One Sided Communication) data buffer
+!--   The buffer for MPI_Get can be PE local, i.e. it can but must not be part of the MPI RMA window
+
+      CALL PMC_Alloc_mem (base_array_sc, bufsize, base_ptr)
+      me%TotalBufferSize = bufsize*wp                          ! Total buffer size in Byte
+
+!--   Second stride, Set Buffer pointer
+
+      do i=1,me%inter_npes
+         aPE => me%PEs(i)
+
+         do j=1,aPE%Nr_arrays
+            ar  => aPE%array_list(j)
+            ar%RecvBuf = base_ptr
+         end do
+      end do
+
+!--   Client to server direction
+
+      myIndex = 1
+      rCount  = 0
+      bufsize = 8
+
+      do i=1,me%inter_npes
+         aPE => me%PEs(i)
+         tag = 300
+         do j=1,aPE%Nr_arrays
+            ar  => aPE%array_list(j)
+            if(ar%NrDims == 2) then
+               arlen     = aPE%NrEle                        ! 2D
+            else if(ar%NrDims == 3) then
+               arlen     = aPE%NrEle*ar%A_dim(1)            ! 3D
+            end if
+
+            tag    = tag+1
+            rCount = rCount+1
+            if(aPE%NrEle > 0)  then
+               CALL MPI_Isend (myIndex, 1, MPI_INTEGER, i-1, tag, me%inter_comm, req(rCount),ierr)
+               ar%SendIndex = myIndex
+            else
+               CALL MPI_Isend (NoIndex, 1, MPI_INTEGER, i-1, tag, me%inter_comm, req(rCount),ierr)
+               ar%SendIndex = NoIndex
+            end if
+
+            if(rCount == 1024) then                                  ! Maximum of 1024 outstanding requests
+               CALL MPI_Waitall (rCount, req, MPI_STATUSES_IGNORE, ierr)
+               rCount = 0;
+            end if
+
+            if(aPE%NrEle > 0)  then
+               ar%SendSize  = arlen
+               myIndex     = myIndex+arlen
+               bufsize     = bufsize+arlen
+            end if
+          end do
+         if(rCount > 0) then                                          ! Wait for all send completed
+            CALL MPI_Waitall (rCount, req, MPI_STATUSES_IGNORE, ierr)
+         end if
+      end do
+
+!--   Create RMA (One Sided Communication) window for data buffer client to server transfer
+!--   The buffer of MPI_Get (counter part of transfer) can be PE-local, i.e. it can but must not be part of the MPI RMA window
+!--   Only one RMA window is required to prepare the data for server -> client transfer on the server side and
+!--                                                       for client -> server transfer on the client side
+
+      CALL PMC_Alloc_mem (base_array_cs, bufsize)
+      me%TotalBufferSize = bufsize*wp                          !Total buffer size in Byte
+
+      WinSize = me%TotalBufferSize
+      CALL MPI_Win_create (base_array_cs, WinSize, wp, MPI_INFO_NULL, me%intra_comm, me%win_server_client, ierr);
+      CALL MPI_Win_fence (0, me%win_server_client, ierr);                    !  Open Window to set data
+      CALL MPI_Barrier(me%intra_comm, ierr)
+
+!--   Second stride, Set Buffer pointer
+
+      do i=1,me%inter_npes
+         aPE => me%PEs(i)
+
+         do j=1,aPE%Nr_arrays
+            ar  => aPE%array_list(j)
+            if(aPE%NrEle > 0)  then
+              ar%SendBuf = c_loc(base_array_cs(ar%SendIndex))
+              if(ar%SendIndex+ar%SendSize > bufsize) then
+                 write(0,'(a,i4,4i7,1x,a)') 'Client Buffer too small ',i,      &
+                     ar%SendIndex,ar%SendSize,ar%SendIndex+ar%SendSize,bufsize,trim(ar%name)
+                 CALL MPI_Abort (MPI_COMM_WORLD, istat, ierr)
+              end if
+            end if
+         end do
+      end do
+
+      return
+   END SUBROUTINE PMC_C_setInd_and_AllocMem
+
+   SUBROUTINE PMC_C_GetBuffer (WaitTime)
+
+      IMPLICIT none
+
+      REAL(wp), INTENT(OUT), optional   ::  WaitTime
+
+      !-- local variables
+      INTEGER                           ::  ip, ij, ierr, j
+      INTEGER                           ::  nr  ! Number of Elements to getb from server
+      INTEGER                           ::  myIndex
+      REAL(wp)                          ::  t1,t2
+      TYPE(PeDef),POINTER               ::  aPE
+      TYPE(ArrayDef),POINTER            ::  ar
+      INTEGER,DIMENSION(1)              ::  buf_shape
+      REAL(wp),POINTER,DIMENSION(:)     ::  buf
+      REAL(wp),POINTER,DIMENSION(:,:)   ::  data_2d
+      REAL(wp),POINTER,DIMENSION(:,:,:) ::  data_3d
+      character(len=DA_Namelen)         ::  myName
+      INTEGER(kind=MPI_ADDRESS_KIND)    ::  target_disp
+
+!
+!--   Synchronization of the model is done in pmci_client_synchronize and pmci_server_synchronize
+!--   Therefor the RMA window can be filled without sychronization at this point and a barrier
+!--   is not necessary
+!--   Please note that WaitTime has to be set in PMC_S_FillBuffer AND PMC_C_GetBuffer
+      if(present(WaitTime))  then
+         t1 = PMC_Time()
+         CALL MPI_Barrier(me%intra_comm, ierr)
+         t2 = PMC_Time()
+         WaitTime = t2-t1
+      end if
+
+      CALL MPI_Barrier(me%intra_comm, ierr)                         ! Wait for buffer is filled
+
+      do ip=1,me%inter_npes
+         aPE => me%PEs(ip)
+
+         do j=1,aPE%Nr_arrays
+            ar  => aPE%array_list(j)
+            if(ar%NrDims == 2) then
+               nr = aPE%NrEle
+            else if(ar%NrDims == 3) then
+               nr = aPE%NrEle*ar%A_dim(1)
+            end if
+
+            buf_shape(1) = nr
+            CALL c_f_pointer(ar%RecvBuf, buf, buf_shape)
+!
+!--         MPI passive target RMA
+            if(nr > 0)   then
+               target_disp = (ar%RecvIndex-1)
+               CALL MPI_Win_lock (MPI_LOCK_SHARED , ip-1, 0, me%win_server_client, ierr)
+               CALL MPI_Get (buf, nr, MPI_REAL, ip-1, target_disp, nr, MPI_REAL, me%win_server_client, ierr)
+               CALL MPI_Win_unlock (ip-1, me%win_server_client, ierr)
+            end if
+
+            myIndex = 1
+            if(ar%NrDims == 2) then
+
+               CALL c_f_pointer(ar%data, data_2d, ar%A_dim(1:2))
+               do ij=1,aPE%NrEle
+                  data_2d(aPE%locInd(ij)%j,aPE%locInd(ij)%i) = buf(myIndex)
+                  myIndex = myIndex+1
+               end do
+            else if(ar%NrDims == 3) then
+               CALL c_f_pointer(ar%data, data_3d, ar%A_dim(1:3))
+               do ij=1,aPE%NrEle
+                  data_3d(:,aPE%locInd(ij)%j,aPE%locInd(ij)%i) = buf(myIndex:myIndex+ar%A_dim(1)-1)
+                  myIndex = myIndex+ar%A_dim(1)
+               end do
+            end if
+
+         end do
+      end do
+      return
+   END SUBROUTINE PMC_C_GetBuffer
+
+   SUBROUTINE PMC_C_PutBuffer (WaitTime)
+
+      IMPLICIT none
+
+      REAL(wp), INTENT(OUT), optional   :: WaitTime
+
+      !-- local variables
+      INTEGER                           ::  ip, ij, ierr, j
+      INTEGER                           ::  nr  ! Number of Elements to getb from server
+      INTEGER                           ::  myIndex
+      REAL(wp)                          ::  t1,t2
+      TYPE(PeDef),POINTER               ::  aPE
+      TYPE(ArrayDef),POINTER            ::  ar
+      INTEGER,DIMENSION(1)              ::  buf_shape
+      REAL(wp),POINTER,DIMENSION(:)     ::  buf
+      REAL(wp),POINTER,DIMENSION(:,:)   ::  data_2d
+      REAL(wp),POINTER,DIMENSION(:,:,:) ::  data_3d
+      character(len=DA_Namelen)         ::  myName
+      INTEGER(kind=MPI_ADDRESS_KIND)    ::  target_disp
+
+      t1 = PMC_Time()
+      CALL MPI_Barrier(me%intra_comm, ierr)              ! Wait for empty buffer
+      t2 = PMC_Time()
+      if(present(WaitTime)) WaitTime = t2-t1
+
+      do ip=1,me%inter_npes
+         aPE => me%PEs(ip)
+
+         do j=1,aPE%Nr_arrays
+            ar  => aPE%array_list(j)
+            myIndex=1
+            if(ar%NrDims == 2) then
+               buf_shape(1) = aPE%NrEle
+               CALL c_f_pointer(ar%SendBuf, buf, buf_shape)
+               CALL c_f_pointer(ar%data, data_2d, ar%A_dim(1:2))
+               do ij=1,aPE%NrEle
+                  buf(myIndex) = data_2d(aPE%locInd(ij)%j,aPE%locInd(ij)%i)
+                  myIndex = myIndex+1
+               end do
+            else if(ar%NrDims == 3) then
+               buf_shape(1) = aPE%NrEle*ar%A_dim(1)
+               CALL c_f_pointer(ar%SendBuf, buf, buf_shape)
+               CALL c_f_pointer(ar%data, data_3d, ar%A_dim(1:3))
+               do ij=1,aPE%NrEle
+                  buf(myIndex:myIndex+ar%A_dim(1)-1) = data_3d(:,aPE%locInd(ij)%j,aPE%locInd(ij)%i)
+                  myIndex = myIndex+ar%A_dim(1)
+               end do
+            end if
+          end do
+      end do
+
+
+!      CALL MPI_Win_fence (0, me%win_server_client, ierr)      ! Fence might do it, test later
+      CALL MPI_Barrier(me%intra_comm, ierr)                   ! buffer is filled
+
+      return
+    END SUBROUTINE PMC_C_PutBuffer
+
+#endif
+END MODULE pmc_client
Index: lm/trunk/SOURCE/pmc_handle_communicator.f90
===================================================================
--- /palm/trunk/SOURCE/pmc_handle_communicator.f90	(revision 1849)
+++ 	(revision )
@@ -1,492 +1,0 @@
- MODULE PMC_handle_communicator
-
-!--------------------------------------------------------------------------------!
-! This file is part of PALM.
-!
-! PALM is free software: you can redistribute it and/or modify it under the terms
-! of the GNU General Public License as published by the Free Software Foundation,
-! either version 3 of the License, or (at your option) any later version.
-!
-! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
-! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
-! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along with
-! PALM. If not, see <http://www.gnu.org/licenses/>.
-!
-! Copyright 1997-2016 Leibniz Universitaet Hannover
-!--------------------------------------------------------------------------------!
-!
-! Current revisions:
-! ------------------
-!
-!
-! Former revisions:
-! -----------------
-! $Id$
-!
-! 1808 2016-04-05 19:44:00Z raasch
-! MPI module used by default on all machines
-!
-! 1797 2016-03-21 16:50:28Z raasch
-! introduction of different datatransfer modes,
-! export of comm_world_nesting
-!
-! 1791 2016-03-11 10:41:25Z raasch
-! m_nrofcpl renamed m_ncpl,
-! pmc_get_local_model_info renamed pmc_get_model_info, some keywords also
-! renamed and some added,
-! debug write-statements commented out
-!
-! 1786 2016-03-08 05:49:27Z raasch
-! Bugfix: nesting_mode is broadcast now
-!
-! 1779 2016-03-03 08:01:28Z raasch
-! only the total number of PEs is given in the nestpar-NAMELIST,
-! additional comments included
-!
-! 1764 2016-02-28 12:45:19Z raasch
-! 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
-!
-! 1762 2016-02-25 12:31:13Z hellstea
-! Initial revision by K. Ketelsen
-!
-! Description:
-! ------------
-! Handle MPI communicator in PALM model coupler
-!------------------------------------------------------------------------------!
-
-#if defined( __parallel )
-    USE kinds
-
-#if defined( __mpifh )
-    INCLUDE "mpif.h"
-#else
-    USE MPI
-#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_total
-
-      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
-
-   INTEGER                                    :: m_world_comm !global nesting communicator
-   INTEGER                                    :: m_my_CPL_id  !Coupler id of this model
-   INTEGER                                    :: m_Parent_id  !Coupler id of parent of this model
-   INTEGER                                    :: m_ncpl       !Number of Couplers in layout file
-
-   TYPE(PMC_layout),DIMENSION(PMC_MAX_MODELL) :: m_couplers   !Information of all couplers
-
-   ! MPI settings
-
-   INTEGER,PUBLIC                    :: m_model_comm          !Communicator of this model
-   INTEGER,PUBLIC                    :: m_to_server_comm      !Communicator to the server
-   INTEGER,DIMENSION(PMC_MAX_MODELL) :: m_to_client_comm      !Communicator to the client(s)
-   INTEGER,PUBLIC                    :: m_world_rank
-   INTEGER                           :: m_world_npes
-   INTEGER,PUBLIC                    :: m_model_rank
-   INTEGER,PUBLIC                    :: m_model_npes
-   INTEGER                           :: m_server_remote_size  !Number of Server PE's
-
-   PUBLIC m_to_client_comm
-
-   !Indicates this PE is server for Cleint NR
-
-   INTEGER,DIMENSION(:),POINTER,PUBLIC :: PMC_Server_for_Client
-
-   INTERFACE pmc_is_rootmodel
-      MODULE PROCEDURE pmc_is_rootmodel
-   END INTERFACE pmc_is_rootmodel
-
-   INTERFACE pmc_get_model_info
-      MODULE PROCEDURE pmc_get_model_info
-   END INTERFACE pmc_get_model_info
-
-   PUBLIC pmc_get_model_info, pmc_init_model, pmc_is_rootmodel
-
- CONTAINS
-
-   SUBROUTINE pmc_init_model( comm, nesting_datatransfer_mode, nesting_mode,   &
-                              pmc_status )
-
-      USE control_parameters,                                                  &
-          ONLY:  message_string
-
-      USE pegrid,                                                              &
-          ONLY:  myid
-
-      IMPLICIT NONE
-
-      CHARACTER(LEN=7), INTENT(OUT) ::  nesting_mode
-      CHARACTER(LEN=7), INTENT(OUT) ::  nesting_datatransfer_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_world_comm = MPI_COMM_WORLD
-      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_datatransfer_mode, 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_ncpl+1
-               start_pe(i) = start_pe(i-1) + m_couplers(i-1)%npe_total
-            ENDDO
-
-!
-!--         The number of cores provided with the run must be the same as the
-!--         total sum of cores required by all nest domains
-            IF ( start_pe(m_ncpl+1) /= m_world_npes )  THEN
-               WRITE ( message_string, '(A,I6,A,I6,A)' )                       &
-                               'nesting-setup requires more MPI procs (',      &
-                               start_pe(m_ncpl+1), ') than provided (',        &
-                               m_world_npes,')'
-               CALL message( 'pmc_init_model', 'PA0229', 3, 2, 0, 6, 0 )
-            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_ncpl,          1, MPI_INTEGER, 0, MPI_COMM_WORLD, istat)
-      CALL MPI_BCAST( start_pe, m_ncpl+1, MPI_INTEGER, 0, MPI_COMM_WORLD, istat)
-
-!
-!--   Broadcast coupling layout
-      DO  i = 1, m_ncpl
-         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_total,    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 )
-!--      TO_DO: the next two calls can and should probably moved outside this loop
-         CALL MPI_BCAST( nesting_mode, LEN( nesting_mode ), MPI_CHARACTER, 0, MPI_COMM_WORLD, istat )
-         CALL MPI_BCAST( nesting_datatransfer_mode, LEN(nesting_datatransfer_mode), MPI_CHARACTER, 0, MPI_COMM_WORLD, istat )
-      ENDDO
-
-!
-!--   Assign global MPI processes to individual models by setting the couple id
-      DO  i = 1, m_ncpl
-         IF ( m_world_rank >= start_pe(i)  .AND.  m_world_rank < start_pe(i+1) ) &
-         THEN
-            m_my_cpl_id = i
-            EXIT
-         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 )
-!
-!--   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_ncpl
-         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
-
-!
-!--   Save the current model communicator for PMC internal use
-      m_model_comm = comm
-
-!
-!--   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_ncpl
-
-         IF ( m_couplers(i)%parent_id == m_my_cpl_id )  THEN
-!
-!--         Collect server PEs.
-!--         Every model exept the root model has a parent model which acts as
-!--         server model. Create an intercommunicator to connect current PE to
-!--         all client PEs
-            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.
-!--         Every model exept the root model has a paremt model which acts as
-!--         server model. Create an intercommunicator to connect current PE to
-!--         all server 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 )
-         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_ncpl
-         IF ( activeserver(i) == 1 )  THEN
-            clientcount = clientcount + 1
-            pmc_server_for_client(clientcount) = i
-         ENDIF
-      ENDDO
-!
-!--   Get the 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
-!
-!--      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
-
-
-!
-!-- Provide module private variables of the pmc for PALM
-    SUBROUTINE pmc_get_model_info( comm_world_nesting, cpl_id, cpl_name,       &
-                                   cpl_parent_id, lower_left_x, lower_left_y,  &
-                                   ncpl, npe_total, request_for_cpl_id )
-
-      USE kinds
-
-      IMPLICIT NONE
-
-      CHARACTER(LEN=*), INTENT(OUT), OPTIONAL ::  cpl_name
-
-      INTEGER, INTENT(IN), OPTIONAL ::  request_for_cpl_id
-
-      INTEGER, INTENT(OUT), OPTIONAL ::  comm_world_nesting
-      INTEGER, INTENT(OUT), OPTIONAL ::  cpl_id
-      INTEGER, INTENT(OUT), OPTIONAL ::  cpl_parent_id
-      INTEGER, INTENT(OUT), OPTIONAL ::  ncpl
-      INTEGER, INTENT(OUT), OPTIONAL ::  npe_total
-
-      INTEGER ::  requested_cpl_id
-
-      REAL(wp), INTENT(OUT), OPTIONAL ::  lower_left_x
-      REAL(wp), INTENT(OUT), OPTIONAL ::  lower_left_y
-
-!
-!--   Set the requested coupler id
-      IF ( PRESENT( request_for_cpl_id ) )  THEN
-         requested_cpl_id = request_for_cpl_id
-!
-!--      Check for allowed range of values
-         IF ( requested_cpl_id < 1 .OR. requested_cpl_id > m_ncpl )  RETURN
-      ELSE
-         requested_cpl_id = m_my_cpl_id
-      ENDIF
-
-!
-!--   Return the requested information
-      IF ( PRESENT( comm_world_nesting )  )  THEN
-         comm_world_nesting = m_world_comm
-      ENDIF
-      IF ( PRESENT( cpl_id )        )  THEN
-         cpl_id = requested_cpl_id
-      ENDIF
-      IF ( PRESENT( cpl_parent_id ) )  THEN
-         cpl_parent_id = m_couplers(requested_cpl_id)%parent_id
-      ENDIF
-      IF ( PRESENT( cpl_name )      )  THEN
-         cpl_name = m_couplers(requested_cpl_id)%name
-      ENDIF
-      IF ( PRESENT( ncpl )          )  THEN
-         ncpl = m_ncpl
-      ENDIF
-      IF ( PRESENT( npe_total )     )  THEN
-         npe_total = m_couplers(requested_cpl_id)%npe_total
-      ENDIF
-      IF ( PRESENT( lower_left_x )  )  THEN
-         lower_left_x = m_couplers(requested_cpl_id)%lower_left_x
-      ENDIF
-      IF ( PRESENT( lower_left_y )  )  THEN
-         lower_left_y = m_couplers(requested_cpl_id)%lower_left_y
-      ENDIF
-
-   END SUBROUTINE pmc_get_model_info
-
-
-
-   LOGICAL function pmc_is_rootmodel( )
-
-      IMPLICIT NONE
-
-      pmc_is_rootmodel = ( m_my_cpl_id == 1 )
-
-   END FUNCTION pmc_is_rootmodel
-
-
-
- SUBROUTINE read_coupling_layout( nesting_datatransfer_mode, nesting_mode,     &
-                                  pmc_status )
-
-    IMPLICIT NONE
-
-    CHARACTER(LEN=7), INTENT(INOUT) ::  nesting_mode
-    CHARACTER(LEN=7), INTENT(INOUT) ::  nesting_datatransfer_mode
-
-    INTEGER, INTENT(INOUT) ::  pmc_status
-    INTEGER                ::  i, istat
-
-    TYPE(pmc_layout), DIMENSION(pmc_max_modell) ::  domain_layouts
-
-
-    NAMELIST /nestpar/  domain_layouts, nesting_datatransfer_mode, nesting_mode
-
-!
-!-- Initialize some coupling variables
-    domain_layouts(1:pmc_max_modell)%id = -1
-    m_ncpl =   0
-
-    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
-
-    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
-!
-!--    When id=-1 is found for the first time, the list of domains is finished
-       IF ( m_couplers(i)%id == -1  .OR.  i == pmc_max_modell )  THEN
-          IF ( m_couplers(i)%id == -1 )  THEN
-             m_ncpl = i - 1
-             EXIT
-          ELSE
-             m_ncpl = pmc_max_modell
-          ENDIF
-       ENDIF
-
-    ENDDO
-
- END SUBROUTINE read_coupling_layout
-
-#endif
- END MODULE pmc_handle_communicator
Index: /palm/trunk/SOURCE/pmc_handle_communicator_mod.f90
===================================================================
--- /palm/trunk/SOURCE/pmc_handle_communicator_mod.f90	(revision 1850)
+++ /palm/trunk/SOURCE/pmc_handle_communicator_mod.f90	(revision 1850)
@@ -0,0 +1,493 @@
+ MODULE PMC_handle_communicator
+
+!--------------------------------------------------------------------------------!
+! This file is part of PALM.
+!
+! PALM is free software: you can redistribute it and/or modify it under the terms
+! of the GNU General Public License as published by the Free Software Foundation,
+! either version 3 of the License, or (at your option) any later version.
+!
+! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
+! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
+! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along with
+! PALM. If not, see <http://www.gnu.org/licenses/>.
+!
+! Copyright 1997-2016 Leibniz Universitaet Hannover
+!--------------------------------------------------------------------------------!
+!
+! Current revisions:
+! ------------------
+! Module renamed
+!
+!
+! Former revisions:
+! -----------------
+! $Id$
+!
+! 1808 2016-04-05 19:44:00Z raasch
+! MPI module used by default on all machines
+!
+! 1797 2016-03-21 16:50:28Z raasch
+! introduction of different datatransfer modes,
+! export of comm_world_nesting
+!
+! 1791 2016-03-11 10:41:25Z raasch
+! m_nrofcpl renamed m_ncpl,
+! pmc_get_local_model_info renamed pmc_get_model_info, some keywords also
+! renamed and some added,
+! debug write-statements commented out
+!
+! 1786 2016-03-08 05:49:27Z raasch
+! Bugfix: nesting_mode is broadcast now
+!
+! 1779 2016-03-03 08:01:28Z raasch
+! only the total number of PEs is given in the nestpar-NAMELIST,
+! additional comments included
+!
+! 1764 2016-02-28 12:45:19Z raasch
+! 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
+!
+! 1762 2016-02-25 12:31:13Z hellstea
+! Initial revision by K. Ketelsen
+!
+! Description:
+! ------------
+! Handle MPI communicator in PALM model coupler
+!------------------------------------------------------------------------------!
+
+#if defined( __parallel )
+    USE kinds
+
+#if defined( __mpifh )
+    INCLUDE "mpif.h"
+#else
+    USE MPI
+#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_total
+
+      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
+
+   INTEGER                                    :: m_world_comm !global nesting communicator
+   INTEGER                                    :: m_my_CPL_id  !Coupler id of this model
+   INTEGER                                    :: m_Parent_id  !Coupler id of parent of this model
+   INTEGER                                    :: m_ncpl       !Number of Couplers in layout file
+
+   TYPE(PMC_layout),DIMENSION(PMC_MAX_MODELL) :: m_couplers   !Information of all couplers
+
+   ! MPI settings
+
+   INTEGER,PUBLIC                    :: m_model_comm          !Communicator of this model
+   INTEGER,PUBLIC                    :: m_to_server_comm      !Communicator to the server
+   INTEGER,DIMENSION(PMC_MAX_MODELL) :: m_to_client_comm      !Communicator to the client(s)
+   INTEGER,PUBLIC                    :: m_world_rank
+   INTEGER                           :: m_world_npes
+   INTEGER,PUBLIC                    :: m_model_rank
+   INTEGER,PUBLIC                    :: m_model_npes
+   INTEGER                           :: m_server_remote_size  !Number of Server PE's
+
+   PUBLIC m_to_client_comm
+
+   !Indicates this PE is server for Cleint NR
+
+   INTEGER,DIMENSION(:),POINTER,PUBLIC :: PMC_Server_for_Client
+
+   INTERFACE pmc_is_rootmodel
+      MODULE PROCEDURE pmc_is_rootmodel
+   END INTERFACE pmc_is_rootmodel
+
+   INTERFACE pmc_get_model_info
+      MODULE PROCEDURE pmc_get_model_info
+   END INTERFACE pmc_get_model_info
+
+   PUBLIC pmc_get_model_info, pmc_init_model, pmc_is_rootmodel
+
+ CONTAINS
+
+   SUBROUTINE pmc_init_model( comm, nesting_datatransfer_mode, nesting_mode,   &
+                              pmc_status )
+
+      USE control_parameters,                                                  &
+          ONLY:  message_string
+
+      USE pegrid,                                                              &
+          ONLY:  myid
+
+      IMPLICIT NONE
+
+      CHARACTER(LEN=7), INTENT(OUT) ::  nesting_mode
+      CHARACTER(LEN=7), INTENT(OUT) ::  nesting_datatransfer_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_world_comm = MPI_COMM_WORLD
+      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_datatransfer_mode, 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_ncpl+1
+               start_pe(i) = start_pe(i-1) + m_couplers(i-1)%npe_total
+            ENDDO
+
+!
+!--         The number of cores provided with the run must be the same as the
+!--         total sum of cores required by all nest domains
+            IF ( start_pe(m_ncpl+1) /= m_world_npes )  THEN
+               WRITE ( message_string, '(A,I6,A,I6,A)' )                       &
+                               'nesting-setup requires more MPI procs (',      &
+                               start_pe(m_ncpl+1), ') than provided (',        &
+                               m_world_npes,')'
+               CALL message( 'pmc_init_model', 'PA0229', 3, 2, 0, 6, 0 )
+            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_ncpl,          1, MPI_INTEGER, 0, MPI_COMM_WORLD, istat)
+      CALL MPI_BCAST( start_pe, m_ncpl+1, MPI_INTEGER, 0, MPI_COMM_WORLD, istat)
+
+!
+!--   Broadcast coupling layout
+      DO  i = 1, m_ncpl
+         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_total,    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 )
+!--      TO_DO: the next two calls can and should probably moved outside this loop
+         CALL MPI_BCAST( nesting_mode, LEN( nesting_mode ), MPI_CHARACTER, 0, MPI_COMM_WORLD, istat )
+         CALL MPI_BCAST( nesting_datatransfer_mode, LEN(nesting_datatransfer_mode), MPI_CHARACTER, 0, MPI_COMM_WORLD, istat )
+      ENDDO
+
+!
+!--   Assign global MPI processes to individual models by setting the couple id
+      DO  i = 1, m_ncpl
+         IF ( m_world_rank >= start_pe(i)  .AND.  m_world_rank < start_pe(i+1) ) &
+         THEN
+            m_my_cpl_id = i
+            EXIT
+         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 )
+!
+!--   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_ncpl
+         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
+
+!
+!--   Save the current model communicator for PMC internal use
+      m_model_comm = comm
+
+!
+!--   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_ncpl
+
+         IF ( m_couplers(i)%parent_id == m_my_cpl_id )  THEN
+!
+!--         Collect server PEs.
+!--         Every model exept the root model has a parent model which acts as
+!--         server model. Create an intercommunicator to connect current PE to
+!--         all client PEs
+            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.
+!--         Every model exept the root model has a paremt model which acts as
+!--         server model. Create an intercommunicator to connect current PE to
+!--         all server 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 )
+         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_ncpl
+         IF ( activeserver(i) == 1 )  THEN
+            clientcount = clientcount + 1
+            pmc_server_for_client(clientcount) = i
+         ENDIF
+      ENDDO
+!
+!--   Get the 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
+!
+!--      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
+
+
+!
+!-- Provide module private variables of the pmc for PALM
+    SUBROUTINE pmc_get_model_info( comm_world_nesting, cpl_id, cpl_name,       &
+                                   cpl_parent_id, lower_left_x, lower_left_y,  &
+                                   ncpl, npe_total, request_for_cpl_id )
+
+      USE kinds
+
+      IMPLICIT NONE
+
+      CHARACTER(LEN=*), INTENT(OUT), OPTIONAL ::  cpl_name
+
+      INTEGER, INTENT(IN), OPTIONAL ::  request_for_cpl_id
+
+      INTEGER, INTENT(OUT), OPTIONAL ::  comm_world_nesting
+      INTEGER, INTENT(OUT), OPTIONAL ::  cpl_id
+      INTEGER, INTENT(OUT), OPTIONAL ::  cpl_parent_id
+      INTEGER, INTENT(OUT), OPTIONAL ::  ncpl
+      INTEGER, INTENT(OUT), OPTIONAL ::  npe_total
+
+      INTEGER ::  requested_cpl_id
+
+      REAL(wp), INTENT(OUT), OPTIONAL ::  lower_left_x
+      REAL(wp), INTENT(OUT), OPTIONAL ::  lower_left_y
+
+!
+!--   Set the requested coupler id
+      IF ( PRESENT( request_for_cpl_id ) )  THEN
+         requested_cpl_id = request_for_cpl_id
+!
+!--      Check for allowed range of values
+         IF ( requested_cpl_id < 1 .OR. requested_cpl_id > m_ncpl )  RETURN
+      ELSE
+         requested_cpl_id = m_my_cpl_id
+      ENDIF
+
+!
+!--   Return the requested information
+      IF ( PRESENT( comm_world_nesting )  )  THEN
+         comm_world_nesting = m_world_comm
+      ENDIF
+      IF ( PRESENT( cpl_id )        )  THEN
+         cpl_id = requested_cpl_id
+      ENDIF
+      IF ( PRESENT( cpl_parent_id ) )  THEN
+         cpl_parent_id = m_couplers(requested_cpl_id)%parent_id
+      ENDIF
+      IF ( PRESENT( cpl_name )      )  THEN
+         cpl_name = m_couplers(requested_cpl_id)%name
+      ENDIF
+      IF ( PRESENT( ncpl )          )  THEN
+         ncpl = m_ncpl
+      ENDIF
+      IF ( PRESENT( npe_total )     )  THEN
+         npe_total = m_couplers(requested_cpl_id)%npe_total
+      ENDIF
+      IF ( PRESENT( lower_left_x )  )  THEN
+         lower_left_x = m_couplers(requested_cpl_id)%lower_left_x
+      ENDIF
+      IF ( PRESENT( lower_left_y )  )  THEN
+         lower_left_y = m_couplers(requested_cpl_id)%lower_left_y
+      ENDIF
+
+   END SUBROUTINE pmc_get_model_info
+
+
+
+   LOGICAL function pmc_is_rootmodel( )
+
+      IMPLICIT NONE
+
+      pmc_is_rootmodel = ( m_my_cpl_id == 1 )
+
+   END FUNCTION pmc_is_rootmodel
+
+
+
+ SUBROUTINE read_coupling_layout( nesting_datatransfer_mode, nesting_mode,     &
+                                  pmc_status )
+
+    IMPLICIT NONE
+
+    CHARACTER(LEN=7), INTENT(INOUT) ::  nesting_mode
+    CHARACTER(LEN=7), INTENT(INOUT) ::  nesting_datatransfer_mode
+
+    INTEGER, INTENT(INOUT) ::  pmc_status
+    INTEGER                ::  i, istat
+
+    TYPE(pmc_layout), DIMENSION(pmc_max_modell) ::  domain_layouts
+
+
+    NAMELIST /nestpar/  domain_layouts, nesting_datatransfer_mode, nesting_mode
+
+!
+!-- Initialize some coupling variables
+    domain_layouts(1:pmc_max_modell)%id = -1
+    m_ncpl =   0
+
+    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
+
+    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
+!
+!--    When id=-1 is found for the first time, the list of domains is finished
+       IF ( m_couplers(i)%id == -1  .OR.  i == pmc_max_modell )  THEN
+          IF ( m_couplers(i)%id == -1 )  THEN
+             m_ncpl = i - 1
+             EXIT
+          ELSE
+             m_ncpl = pmc_max_modell
+          ENDIF
+       ENDIF
+
+    ENDDO
+
+ END SUBROUTINE read_coupling_layout
+
+#endif
+ END MODULE pmc_handle_communicator
Index: lm/trunk/SOURCE/pmc_interface.f90
===================================================================
--- /palm/trunk/SOURCE/pmc_interface.f90	(revision 1849)
+++ 	(revision )
@@ -1,4309 +1,0 @@
-MODULE pmc_interface
-
-!--------------------------------------------------------------------------------!
-! This file is part of PALM.
-!
-! PALM is free software: you can redistribute it and/or modify it under the terms
-! of the GNU General Public License as published by the Free Software Foundation,
-! either version 3 of the License, or (at your option) any later version.
-!
-! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
-! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
-! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along with
-! PALM. If not, see <http://www.gnu.org/licenses/>.
-!
-! Copyright 1997-2016 Leibniz Universitaet Hannover
-!--------------------------------------------------------------------------------!
-!
-! Current revisions:
-! ------------------
-!
-!
-! Former revisions:
-! -----------------
-! $Id$
-!
-! 1808 2016-04-05 19:44:00Z raasch
-! MPI module used by default on all machines
-!
-! 1801 2016-04-05 13:12:47Z raasch
-! bugfix for r1797: zero setting of temperature within topography does not work
-! and has been disabled
-!
-! 1797 2016-03-21 16:50:28Z raasch
-! introduction of different datatransfer modes,
-! further formatting cleanup, parameter checks added (including mismatches
-! between root and client model settings),
-! +routine pmci_check_setting_mismatches
-! comm_world_nesting introduced
-!
-! 1791 2016-03-11 10:41:25Z raasch
-! routine pmci_update_new removed,
-! pmc_get_local_model_info renamed pmc_get_model_info, some keywords also
-! renamed,
-! filling up redundant ghost points introduced,
-! some index bound variables renamed,
-! further formatting cleanup
-!
-! 1783 2016-03-06 18:36:17Z raasch
-! calculation of nest top area simplified,
-! interpolation and anterpolation moved to seperate wrapper subroutines
-!
-! 1781 2016-03-03 15:12:23Z raasch
-! _p arrays are set zero within buildings too, t.._m arrays and respective
-! settings within buildings completely removed
-!
-! 1779 2016-03-03 08:01:28Z raasch
-! only the total number of PEs is given for the domains, npe_x and npe_y
-! replaced by npe_total, two unused elements removed from array
-! define_coarse_grid_real,
-! array management changed from linked list to sequential loop
-!
-! 1766 2016-02-29 08:37:15Z raasch
-! modifications to allow for using PALM's pointer version,
-! +new routine pmci_set_swaplevel
-!
-! 1764 2016-02-28 12:45:19Z raasch
-! +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
-!
-! 1762 2016-02-25 12:31:13Z hellstea
-! Initial revision by A. Hellsten
-!
-! Description:
-! ------------
-! Domain nesting interface routines. The low-level inter-domain communication   
-! is conducted by the PMC-library routines.
-!------------------------------------------------------------------------------!
-
-#if defined( __nopointer )
-    USE arrays_3d,                                                             &
-        ONLY:  dzu, dzw, e, e_p, pt, pt_p, q, q_p, u, u_p, v, v_p, w, w_p, zu, &
-               zw, z0
-#else
-   USE arrays_3d,                                                              &
-        ONLY:  dzu, dzw, e, e_p, e_1, e_2, pt, pt_p, pt_1, pt_2, q, q_p, q_1,  &
-               q_2, u, u_p, u_1, u_2, v, v_p, v_1, v_2, w, w_p, w_1, w_2, zu,  &
-               zw, z0
-#endif
-
-    USE control_parameters,                                                    &
-        ONLY:  coupling_char, dt_3d, dz, humidity, message_string,             &
-               nest_bound_l, nest_bound_r, nest_bound_s, nest_bound_n,         &
-               nest_domain, 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
-
-#if defined( __parallel )
-#if defined( __mpifh )
-    INCLUDE "mpif.h"
-#else
-    USE MPI
-#endif
-
-    USE pegrid,                                                                &
-        ONLY:  collective_wait, comm1dx, comm1dy, comm2d, myid, myidx, myidy,  &
-               numprocs
-
-    USE pmc_client,                                                            &
-        ONLY:  pmc_clientinit, pmc_c_clear_next_array_list,                    &
-               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_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_clear_next_array_list, pmc_s_fillbuffer,  &
-               pmc_s_getdata_from_buffer, pmc_s_getnextarray,                  &
-               pmc_s_setind_and_allocmem, pmc_s_set_active_data_array,         &
-               pmc_s_set_dataarray, pmc_s_set_2d_index_list
-
-#endif
-
-    IMPLICIT NONE
-
-    PRIVATE
-
-!
-!-- Constants
-    INTEGER(iwp), PARAMETER ::  client_to_server = 2   !:
-    INTEGER(iwp), PARAMETER ::  server_to_client = 1   !:
-
-!
-!-- Coupler setup
-    INTEGER(iwp), SAVE      ::  comm_world_nesting     !:
-    INTEGER(iwp), SAVE      ::  cpl_id  = 1            !:
-    CHARACTER(LEN=32), SAVE ::  cpl_name               !:
-    INTEGER(iwp), SAVE      ::  cpl_npe_total          !:
-    INTEGER(iwp), SAVE      ::  cpl_parent_id          !:
-
-!
-!-- Control parameters, will be made input parameters later
-    CHARACTER(LEN=7), SAVE ::  nesting_datatransfer_mode = 'mixed'  !: steering
-                                                         !: parameter for data-
-                                                         !: transfer mode
-    CHARACTER(LEN=7), SAVE ::  nesting_mode = 'two-way'  !: steering parameter
-                                                         !: for 1- or 2-way nesting
-
-    LOGICAL, SAVE ::  nested_run = .FALSE.  !: general switch
-
-    REAL(wp), SAVE ::  anterp_relax_length_l = -1.0_wp   !:
-    REAL(wp), SAVE ::  anterp_relax_length_r = -1.0_wp   !:
-    REAL(wp), SAVE ::  anterp_relax_length_s = -1.0_wp   !:
-    REAL(wp), SAVE ::  anterp_relax_length_n = -1.0_wp   !:
-    REAL(wp), SAVE ::  anterp_relax_length_t = -1.0_wp   !:
-
-!
-!-- Geometry
-    REAL(wp), SAVE                            ::  area_t               !:
-    REAL(wp), SAVE, DIMENSION(:), ALLOCATABLE ::  coord_x              !:
-    REAL(wp), SAVE, DIMENSION(:), ALLOCATABLE ::  coord_y              !:
-    REAL(wp), SAVE                            ::  lower_left_coord_x   !:
-    REAL(wp), SAVE                            ::  lower_left_coord_y   !:
-
-!
-!-- Client coarse data arrays
-    INTEGER(iwp), DIMENSION(5)                  ::  coarse_bound   !:
-
-    REAL(wp), SAVE                              ::  xexl           !:
-    REAL(wp), SAVE                              ::  xexr           !:
-    REAL(wp), SAVE                              ::  yexs           !:
-    REAL(wp), SAVE                              ::  yexn           !:
-    REAL(wp), SAVE, DIMENSION(:,:), ALLOCATABLE ::  tkefactor_l    !:
-    REAL(wp), SAVE, DIMENSION(:,:), ALLOCATABLE ::  tkefactor_n    !:
-    REAL(wp), SAVE, DIMENSION(:,:), ALLOCATABLE ::  tkefactor_r    !:
-    REAL(wp), SAVE, DIMENSION(:,:), ALLOCATABLE ::  tkefactor_s    !:
-    REAL(wp), SAVE, DIMENSION(:,:), ALLOCATABLE ::  tkefactor_t    !:
-
-    REAL(wp), SAVE, DIMENSION(:,:,:), ALLOCATABLE, TARGET ::  ec   !:
-    REAL(wp), SAVE, DIMENSION(:,:,:), ALLOCATABLE, TARGET ::  ptc  !:
-    REAL(wp), SAVE, DIMENSION(:,:,:), ALLOCATABLE, TARGET ::  uc   !:
-    REAL(wp), SAVE, DIMENSION(:,:,:), ALLOCATABLE, TARGET ::  vc   !:
-    REAL(wp), SAVE, DIMENSION(:,:,:), ALLOCATABLE, TARGET ::  wc   !:
-    REAL(wp), SAVE, DIMENSION(:,:,:), ALLOCATABLE, TARGET ::  qc   !:
-
-!
-!-- Client interpolation coefficients and client-array indices to be precomputed
-!-- and stored.
-    INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:) ::  ico    !:
-    INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:) ::  icu    !:
-    INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:) ::  jco    !:
-    INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:) ::  jcv    !:
-    INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:) ::  kco    !:
-    INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:) ::  kcw    !:
-    REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:)     ::  r1xo   !:
-    REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:)     ::  r2xo   !:
-    REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:)     ::  r1xu   !:
-    REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:)     ::  r2xu   !:
-    REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:)     ::  r1yo   !:
-    REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:)     ::  r2yo   !:
-    REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:)     ::  r1yv   !:
-    REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:)     ::  r2yv   !:
-    REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:)     ::  r1zo   !:
-    REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:)     ::  r2zo   !:
-    REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:)     ::  r1zw   !:
-    REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:)     ::  r2zw   !:
-
-!
-!-- Client index arrays and log-ratio arrays for the log-law near-wall
-!-- corrections. These are not truly 3-D arrays but multiple 2-D arrays.
-    INTEGER(iwp), SAVE :: ncorr  !: 4th dimension of the log_ratio-arrays
-    INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:,:,:) ::  logc_u_l   !:
-    INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:,:,:) ::  logc_u_n   !:
-    INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:,:,:) ::  logc_u_r   !:
-    INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:,:,:) ::  logc_u_s   !:
-    INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:,:,:) ::  logc_v_l   !:
-    INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:,:,:) ::  logc_v_n   !:
-    INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:,:,:) ::  logc_v_r   !:
-    INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:,:,:) ::  logc_v_s   !:
-    INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:,:,:) ::  logc_w_l   !:
-    INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:,:,:) ::  logc_w_n   !:
-    INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:,:,:) ::  logc_w_r   !:
-    INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:,:,:) ::  logc_w_s   !:
-    REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:,:,:)   ::  logc_ratio_u_l   !:
-    REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:,:,:)   ::  logc_ratio_u_n   !:
-    REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:,:,:)   ::  logc_ratio_u_r   !:
-    REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:,:,:)   ::  logc_ratio_u_s   !:
-    REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:,:,:)   ::  logc_ratio_v_l   !:
-    REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:,:,:)   ::  logc_ratio_v_n   !:
-    REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:,:,:)   ::  logc_ratio_v_r   !:
-    REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:,:,:)   ::  logc_ratio_v_s   !:
-    REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:,:,:)   ::  logc_ratio_w_l   !:
-    REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:,:,:)   ::  logc_ratio_w_n   !:
-    REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:,:,:)   ::  logc_ratio_w_r   !:
-    REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:,:,:)   ::  logc_ratio_w_s   !:
-
-!
-!-- Upper bounds for k in anterpolation.
-    INTEGER(iwp), SAVE ::  kctu   !:
-    INTEGER(iwp), SAVE ::  kctw   !:
-
-!
-!-- Upper bound for k in log-law correction in interpolation.
-    INTEGER(iwp), SAVE ::  nzt_topo_nestbc_l   !:
-    INTEGER(iwp), SAVE ::  nzt_topo_nestbc_n   !:
-    INTEGER(iwp), SAVE ::  nzt_topo_nestbc_r   !:
-    INTEGER(iwp), SAVE ::  nzt_topo_nestbc_s   !:
-
-!
-!-- Number of ghost nodes in coarse-grid arrays for i and j in anterpolation.
-    INTEGER(iwp), SAVE ::  nhll   !:
-    INTEGER(iwp), SAVE ::  nhlr   !:
-    INTEGER(iwp), SAVE ::  nhls   !:
-    INTEGER(iwp), SAVE ::  nhln   !:
-
-!
-!-- Spatial under-relaxation coefficients for anterpolation.
-    REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:) ::  frax   !:
-    REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:) ::  fray   !:
-    REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:) ::  fraz   !:
-
-!
-!-- Client-array indices to be precomputed and stored for anterpolation.
-    INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:) ::  iflu   !:
-    INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:) ::  ifuu   !:
-    INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:) ::  iflo   !:
-    INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:) ::  ifuo   !:
-    INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:) ::  jflv   !:
-    INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:) ::  jfuv   !:
-    INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:) ::  jflo   !:
-    INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:) ::  jfuo   !:
-    INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:) ::  kflw   !:
-    INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:) ::  kfuw   !:
-    INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:) ::  kflo   !:
-    INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:) ::  kfuo   !:
-
-    INTEGER(iwp), DIMENSION(3)          ::  define_coarse_grid_int    !:
-    REAL(wp), DIMENSION(7)              ::  define_coarse_grid_real   !:
-
-    TYPE coarsegrid_def
-       INTEGER(iwp)                        ::  nx
-       INTEGER(iwp)                        ::  ny
-       INTEGER(iwp)                        ::  nz
-       REAL(wp)                            ::  dx
-       REAL(wp)                            ::  dy
-       REAL(wp)                            ::  dz
-       REAL(wp)                            ::  lower_left_coord_x
-       REAL(wp)                            ::  lower_left_coord_y
-       REAL(wp)                            ::  xend
-       REAL(wp)                            ::  yend
-       REAL(wp), DIMENSION(:), ALLOCATABLE ::  coord_x
-       REAL(wp), DIMENSION(:), ALLOCATABLE ::  coord_y
-       REAL(wp), DIMENSION(:), ALLOCATABLE ::  dzu       
-       REAL(wp), DIMENSION(:), ALLOCATABLE ::  dzw       
-       REAL(wp), DIMENSION(:), ALLOCATABLE ::  zu        
-       REAL(wp), DIMENSION(:), ALLOCATABLE ::  zw        
-    END TYPE coarsegrid_def
-                                          
-    TYPE(coarsegrid_def), SAVE ::  cg   !:
-
-
-    INTERFACE pmci_check_setting_mismatches
-       MODULE PROCEDURE pmci_check_setting_mismatches
-    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_datatrans
-       MODULE PROCEDURE pmci_datatrans
-    END INTERFACE pmci_datatrans
-
-    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_set_swaplevel
-       MODULE PROCEDURE pmci_set_swaplevel
-    END INTERFACE pmci_set_swaplevel
-
-    PUBLIC anterp_relax_length_l, anterp_relax_length_r,                       &
-           anterp_relax_length_s, anterp_relax_length_n,                       &
-           anterp_relax_length_t, client_to_server, comm_world_nesting,        &
-           cpl_id, nested_run, nesting_datatransfer_mode, nesting_mode,        &
-           server_to_client
-    PUBLIC pmci_client_initialize
-    PUBLIC pmci_client_synchronize
-    PUBLIC pmci_datatrans
-    PUBLIC pmci_ensure_nest_mass_conservation
-    PUBLIC pmci_init
-    PUBLIC pmci_modelconfiguration
-    PUBLIC pmci_server_initialize
-    PUBLIC pmci_server_synchronize
-    PUBLIC pmci_set_swaplevel
-
-
- CONTAINS
-
-
- SUBROUTINE pmci_init( world_comm )
-
-    USE control_parameters,                                                  &
-        ONLY:  message_string
-
-    IMPLICIT NONE
-
-    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_datatransfer_mode, nesting_mode,  &
-                         pmc_status )
-
-    IF ( pmc_status == pmc_no_namelist_found )  THEN
-!
-!--    This is not a nested run
-       world_comm = MPI_COMM_WORLD
-       cpl_id     = 1
-       cpl_name   = ""
-
-       RETURN
-
-    ENDIF
-
-!
-!-- Check steering parameter values
-    IF ( TRIM( nesting_mode ) /= 'one-way'  .AND.                              &
-         TRIM( nesting_mode ) /= 'two-way' )                                   &
-    THEN
-       message_string = 'illegal nesting mode: ' // TRIM( nesting_mode )
-       CALL message( 'pmci_init', 'PA0417', 3, 2, 0, 6, 0 )
-    ENDIF
-
-    IF ( TRIM( nesting_datatransfer_mode ) /= 'cascade'  .AND.                 &
-         TRIM( nesting_datatransfer_mode ) /= 'mixed'    .AND.                 &
-         TRIM( nesting_datatransfer_mode ) /= 'overlap' )                      &
-    THEN
-       message_string = 'illegal nesting datatransfer mode: '                  &
-                        // TRIM( nesting_datatransfer_mode )
-       CALL message( 'pmci_init', 'PA0418', 3, 2, 0, 6, 0 )
-    ENDIF
-
-!
-!-- Set the general steering switch which tells PALM that its a nested run
-    nested_run = .TRUE.
-
-!
-!-- Get some variables required by the pmc-interface (and in some cases in the
-!-- PALM code out of the pmci) out of the pmc-core
-    CALL pmc_get_model_info( comm_world_nesting = comm_world_nesting,          &
-                             cpl_id = cpl_id, cpl_parent_id = cpl_parent_id,   &
-                             cpl_name = cpl_name, npe_total = cpl_npe_total,   &
-                             lower_left_x = lower_left_coord_x,                &
-                             lower_left_y = lower_left_coord_y )
-!
-!-- Set the steering switch which tells the models that they are nested (of
-!-- course the root domain (cpl_id = 1) is not nested)
-    IF ( cpl_id >= 2 )  THEN
-       nest_domain = .TRUE.
-       WRITE( coupling_char, '(A1,I2.2)') '_', cpl_id
-    ENDIF
-
-!
-!-- 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
-!
-!-- 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
-    nested_run = .FALSE.
-    world_comm = 1
-#endif
-
- END SUBROUTINE pmci_init
-
-
-
- SUBROUTINE pmci_modelconfiguration
-
-    IMPLICIT NONE
-
-    CALL location_message( 'setup the nested model configuration', .FALSE. )
-!
-!-- Compute absolute coordinates for all models
-    CALL pmci_setup_coordinates
-!
-!-- Initialize the client (must be called before pmc_setup_server)
-    CALL pmci_setup_client
-!
-!-- Initialize PMC Server
-    CALL pmci_setup_server
-!
-!-- Check for mismatches between settings of master and client variables
-!-- (e.g., all clients have to follow the end_time settings of the root master)
-    CALL pmci_check_setting_mismatches
-
-    CALL location_message( 'finished', .TRUE. )
-
- END SUBROUTINE pmci_modelconfiguration
-
-
-
- SUBROUTINE pmci_setup_server
-
-#if defined( __parallel )
-    IMPLICIT NONE
-
-    CHARACTER(LEN=32) ::  myname
-
-    INTEGER(iwp) ::  client_id        !:
-    INTEGER(iwp) ::  ierr             !:
-    INTEGER(iwp) ::  i                !:
-    INTEGER(iwp) ::  j                !:
-    INTEGER(iwp) ::  k                !:
-    INTEGER(iwp) ::  m                !:
-    INTEGER(iwp) ::  nomatch          !:
-    INTEGER(iwp) ::  nx_cl            !:
-    INTEGER(iwp) ::  ny_cl            !:
-    INTEGER(iwp) ::  nz_cl            !:
-
-    INTEGER(iwp), DIMENSION(5) ::  val    !:
-
-    REAL(wp) ::  dx_cl            !:
-    REAL(wp) ::  dy_cl            !:
-    REAL(wp) ::  xez              !:
-    REAL(wp) ::  yez              !:
-
-    REAL(wp), DIMENSION(1) ::  fval             !:
-
-    REAL(wp), DIMENSION(:), ALLOCATABLE ::  cl_coord_x   !:
-    REAL(wp), DIMENSION(:), ALLOCATABLE ::  cl_coord_y   !:
-    
-
-!
-!   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)
-       IF ( myid == 0 )  THEN        
-
-          CALL pmc_recv_from_client( client_id, val,  size(val),  0, 123, ierr )
-          CALL pmc_recv_from_client( client_id, fval, size(fval), 0, 124, ierr )
-         
-          nx_cl = val(1)
-          ny_cl = val(2)
-          dx_cl = val(4)
-          dy_cl = val(5)
-
-          nz_cl = nz
-
-!
-!--       Find the highest client level in the coarse grid for the reduced z
-!--       transfer
-          DO  k = 1, nz                 
-             IF ( zw(k) > fval(1) )  THEN
-                nz_cl = k
-                EXIT
-             ENDIF
-          ENDDO
-
-!    
-!--       Get absolute coordinates from the client
-          ALLOCATE( cl_coord_x(-nbgp:nx_cl+nbgp) )
-          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 )
-!          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) = dx
-          define_coarse_grid_real(4) = dy
-          define_coarse_grid_real(5) = lower_left_coord_x + ( nx + 1 ) * dx
-          define_coarse_grid_real(6) = lower_left_coord_y + ( ny + 1 ) * dy
-          define_coarse_grid_real(7) = dz
-
-          define_coarse_grid_int(1)  = nx
-          define_coarse_grid_int(2)  = ny
-          define_coarse_grid_int(3)  = nz_cl
-
-!
-!--       Check that the client domain is completely inside the server domain. 
-          nomatch = 0
-          xez = ( nbgp + 1 ) * dx 
-          yez = ( nbgp + 1 ) * dy 
-          IF ( ( cl_coord_x(0) < define_coarse_grid_real(1) + xez )       .OR. &
-               ( cl_coord_x(nx_cl+1) > define_coarse_grid_real(5) - xez ) .OR. &
-               ( cl_coord_y(0) < define_coarse_grid_real(2) + yez )       .OR. &
-               ( cl_coord_y(ny_cl+1) > define_coarse_grid_real(6) - yez ) )    &
-          THEN
-             nomatch = 1
-          ENDIF
-
-          DEALLOCATE( cl_coord_x )
-          DEALLOCATE( cl_coord_y )
-
-!
-!--       Send coarse grid information to client
-          CALL pmc_send_to_client( client_id, define_coarse_grid_real,         &
-                                   SIZE( define_coarse_grid_real ), 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
-          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 )
-          CALL pmc_send_to_client( client_id, zu,  nz_cl+2, 0, 28, ierr )
-          CALL pmc_send_to_client( client_id, zw,  nz_cl+2, 0, 29, ierr )
-
-       ENDIF
-
-       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'
-          CALL message( 'pmc_palm_setup_server', 'PA0XYZ', 1, 2, 0, 6, 0 )
-       ENDIF
-      
-       CALL MPI_BCAST( nz_cl, 1, MPI_INTEGER, 0, comm2d, ierr )
-
-!
-!--    TO_DO: Klaus: please give a comment what is done here
-       CALL pmci_create_index_list
-
-!
-!--    Include couple arrays into server content
-!--    TO_DO: Klaus: please give a more meaningful comment
-       CALL pmc_s_clear_next_array_list
-       DO  WHILE ( pmc_s_getnextarray( client_id, myname ) )
-          CALL pmci_set_array_pointer( myname, client_id = client_id,          &
-                                       nz_cl = nz_cl )
-       ENDDO
-       CALL pmc_s_setind_and_allocmem( client_id )
-    ENDDO
-
- CONTAINS
-
-
-   SUBROUTINE pmci_create_index_list
-
-       IMPLICIT NONE
-
-       INTEGER(iwp) ::  i                  !:
-       INTEGER(iwp) ::  ic                 !:
-       INTEGER(iwp) ::  ierr               !:
-       INTEGER(iwp) ::  j                  !:
-       INTEGER(iwp) ::  k                  !:
-       INTEGER(iwp) ::  m                  !:
-       INTEGER(iwp) ::  n                  !:
-       INTEGER(iwp) ::  npx                !:
-       INTEGER(iwp) ::  npy                !:
-       INTEGER(iwp) ::  nrx                !:
-       INTEGER(iwp) ::  nry                !:
-       INTEGER(iwp) ::  px                 !:
-       INTEGER(iwp) ::  py                 !:
-       INTEGER(iwp) ::  server_pe          !:
-
-       INTEGER(iwp), DIMENSION(2) ::  scoord             !:
-       INTEGER(iwp), DIMENSION(2) ::  size_of_array      !:
-
-       INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE  ::  coarse_bound_all   !:
-       INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE  ::  index_list         !:
-
-       IF ( myid == 0 )  THEN
-!--       TO_DO: Klaus: give more specific comment what size_of_array stands for
-          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 )
-
-!
-!--       Compute size of index_list.
-          ic = 0
-          DO  k = 1, size_of_array(2)
-             DO  j = coarse_bound_all(3,k), coarse_bound_all(4,k)
-                DO  i = coarse_bound_all(1,k), coarse_bound_all(2,k)
-                   ic = ic + 1
-                ENDDO
-             ENDDO
-          ENDDO
-
-          ALLOCATE( index_list(6,ic) )
-
-          CALL MPI_COMM_SIZE( comm1dx, npx, ierr )
-          CALL MPI_COMM_SIZE( comm1dy, npy, ierr )
-!
-!--       The +1 in index is because PALM starts with nx=0
-          nrx = nxr - nxl + 1
-          nry = nyn - nys + 1
-          ic  = 0
-!
-!--       Loop over all client PEs
-          DO  k = 1, size_of_array(2)
-!
-!--          Area along y required by actual client PE
-             DO  j = coarse_bound_all(3,k), coarse_bound_all(4,k)
-!
-!--             Area along x required by actual client PE
-                DO  i = coarse_bound_all(1,k), coarse_bound_all(2,k)
-
-                   px = i / nrx
-                   py = j / nry
-                   scoord(1) = px
-                   scoord(2) = py
-                   CALL MPI_CART_RANK( comm2d, scoord, server_pe, ierr )
-                  
-                   ic = ic + 1
-!
-!--                First index in server array
-                   index_list(1,ic) = i - ( px * nrx ) + 1 + nbgp
-!
-!--                Second index in server array
-                   index_list(2,ic) = j - ( py * nry ) + 1 + nbgp
-!
-!--                x index of client coarse grid
-                   index_list(3,ic) = i - coarse_bound_all(1,k) + 1
-!
-!--                y index of client coarse grid
-                   index_list(4,ic) = j - coarse_bound_all(3,k) + 1
-!
-!--                PE number of client
-                   index_list(5,ic) = k - 1
-!
-!--                PE number of server
-                   index_list(6,ic) = server_pe
-
-                ENDDO
-             ENDDO
-          ENDDO
-!
-!--       TO_DO: Klaus: comment what is done here
-          CALL pmc_s_set_2d_index_list( client_id, index_list(:,1:ic) )
-
-       ELSE
-!
-!--       TO_DO: Klaus: comment why this dummy allocation is required
-          ALLOCATE( index_list(6,1) )
-          CALL pmc_s_set_2d_index_list( client_id, index_list )
-       ENDIF
-
-       DEALLOCATE(index_list)
-
-     END SUBROUTINE pmci_create_index_list
-
-#endif
- END SUBROUTINE pmci_setup_server
-
-
-
- SUBROUTINE pmci_setup_client
-
-#if defined( __parallel )
-    IMPLICIT NONE
-
-    CHARACTER(LEN=da_namelen) ::  myname     !:
-
-    INTEGER(iwp) ::  i          !:
-    INTEGER(iwp) ::  ierr       !:
-    INTEGER(iwp) ::  icl        !:
-    INTEGER(iwp) ::  icr        !:
-    INTEGER(iwp) ::  j          !:
-    INTEGER(iwp) ::  jcn        !:
-    INTEGER(iwp) ::  jcs        !:
-
-    INTEGER(iwp), DIMENSION(5) ::  val        !:
-    
-    REAL(wp) ::  xcs        !:
-    REAL(wp) ::  xce        !:
-    REAL(wp) ::  ycs        !:
-    REAL(wp) ::  yce        !:
-
-    REAL(wp), DIMENSION(1) ::  fval       !:
-                                             
-!
-!-- 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
-!
-!--    Here and only here the arrays are defined, which actualy will be
-!--    exchanged between client and server.
-!--    Please check, if the arrays are in the list of possible exchange arrays
-!--    in subroutines:
-!--    pmci_set_array_pointer (for server arrays)
-!--    pmci_create_client_arrays (for client arrays)
-       CALL pmc_set_dataarray_name( 'coarse', 'u'  ,'fine', 'u',  ierr )
-       CALL pmc_set_dataarray_name( 'coarse', 'v'  ,'fine', 'v',  ierr )
-       CALL pmc_set_dataarray_name( 'coarse', 'w'  ,'fine', 'w',  ierr )
-       CALL pmc_set_dataarray_name( 'coarse', 'e'  ,'fine', 'e',  ierr )
-       CALL pmc_set_dataarray_name( 'coarse', 'pt' ,'fine', 'pt', ierr )
-       IF ( humidity  .OR.  passive_scalar )  THEN
-          CALL pmc_set_dataarray_name( 'coarse', 'q'  ,'fine', 'q',  ierr )
-       ENDIF
-
-!
-!--    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
-       val(3)  = nz
-       val(4)  = dx
-       val(5)  = dy
-       fval(1) = zw(nzt+1)
-
-       IF ( myid == 0 )  THEN
-
-          CALL pmc_send_to_server( val, SIZE( val ), 0, 123, ierr )
-          CALL pmc_send_to_server( fval, SIZE( fval ), 0, 124, ierr )
-          CALL pmc_send_to_server( coord_x, nx + 1 + 2 * nbgp, 0, 11, ierr )
-          CALL pmc_send_to_server( coord_y, ny + 1 + 2 * nbgp, 0, 12, ierr )
-
-!
-!--       Receive Coarse grid information.
-!--       TO_DO: find shorter and more meaningful name for  define_coarse_grid_real
-          CALL pmc_recv_from_server( define_coarse_grid_real,                  &
-                                     SIZE(define_coarse_grid_real), 0, 21, ierr )
-          CALL pmc_recv_from_server( define_coarse_grid_int,  3, 0, 22, ierr )
-!
-!--        Debug-printouts - keep them
-!          WRITE(0,*) 'Coarse grid from Server '
-!          WRITE(0,*) 'startx_tot    = ',define_coarse_grid_real(1)
-!          WRITE(0,*) 'starty_tot    = ',define_coarse_grid_real(2)
-!          WRITE(0,*) 'endx_tot      = ',define_coarse_grid_real(5)
-!          WRITE(0,*) 'endy_tot      = ',define_coarse_grid_real(6)
-!          WRITE(0,*) 'dx            = ',define_coarse_grid_real(3)
-!          WRITE(0,*) 'dy            = ',define_coarse_grid_real(4)
-!          WRITE(0,*) 'dz            = ',define_coarse_grid_real(7)
-!          WRITE(0,*) 'nx_coarse     = ',define_coarse_grid_int(1)
-!          WRITE(0,*) 'ny_coarse     = ',define_coarse_grid_int(2)
-!          WRITE(0,*) 'nz_coarse     = ',define_coarse_grid_int(3)
-       ENDIF
-
-       CALL MPI_BCAST( define_coarse_grid_real, SIZE(define_coarse_grid_real), &
-                       MPI_REAL, 0, comm2d, ierr )
-       CALL MPI_BCAST( define_coarse_grid_int, 3, MPI_INTEGER, 0, comm2d, ierr )
-
-       cg%dx = define_coarse_grid_real(3)
-       cg%dy = define_coarse_grid_real(4)
-       cg%dz = define_coarse_grid_real(7)
-       cg%nx = define_coarse_grid_int(1)
-       cg%ny = define_coarse_grid_int(2)
-       cg%nz = define_coarse_grid_int(3)
-
-!
-!--    Get server coordinates on coarse grid
-       ALLOCATE( cg%coord_x(-nbgp:cg%nx+nbgp) )
-       ALLOCATE( cg%coord_y(-nbgp:cg%ny+nbgp) )
-      
-       ALLOCATE( cg%dzu(1:cg%nz+1) )
-       ALLOCATE( cg%dzw(1:cg%nz+1) )
-       ALLOCATE( cg%zu(0:cg%nz+1) )
-       ALLOCATE( cg%zw(0:cg%nz+1) )
-
-!
-!--    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%dzu, cg%nz + 1, 0, 26, ierr )
-          CALL pmc_recv_from_server( cg%dzw, cg%nz + 1, 0, 27, ierr )
-          CALL pmc_recv_from_server( cg%zu, cg%nz + 2, 0, 28, ierr )
-          CALL pmc_recv_from_server( cg%zw, cg%nz + 2, 0, 29, ierr )
-
-       ENDIF
-
-!
-!--    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 )
-       
-!
-!--    Find the index bounds for the nest domain in the coarse-grid index space
-       CALL pmci_map_fine_to_coarse_grid
-!
-!--    TO_DO: Klaus give a comment what is happening here
-       CALL pmc_c_get_2d_index_list
-
-!
-!--    Include couple arrays into client content
-!--    TO_DO: Klaus: better explain the above comment (what is client content?)
-       CALL  pmc_c_clear_next_array_list
-       DO  WHILE ( pmc_c_getnextarray( myname ) )
-!--       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
-       CALL pmci_init_interp_tril
-
-!
-!--    Precompute the log-law correction index- and ratio-arrays 
-       CALL pmci_init_loglaw_correction 
-
-!
-!--    Define the SGS-TKE scaling factor based on the grid-spacing ratio
-       CALL pmci_init_tkefactor
-
-!
-!--    Two-way coupling.
-!--    Precompute the index arrays and relaxation functions for the
-!--    anterpolation
-       IF ( nesting_mode == 'two-way' )  THEN
-          CALL pmci_init_anterp_tophat
-       ENDIF
-
-!
-!--    Finally, compute the total area of the top-boundary face of the domain.
-!--    This is needed in the pmc_ensure_nest_mass_conservation      
-       area_t = ( nx + 1 ) * (ny + 1 ) * dx * dy
-
-    ENDIF
-
- CONTAINS
-
-    SUBROUTINE pmci_map_fine_to_coarse_grid
-!
-!--    Determine index bounds of interpolation/anterpolation area in the coarse
-!--    grid index space
-       IMPLICIT NONE
-
-       INTEGER(iwp), DIMENSION(5,numprocs) ::  coarse_bound_all   !:
-       INTEGER(iwp), DIMENSION(2)          ::  size_of_array      !:
-                                              
-       REAL(wp) ::  loffset     !:
-       REAL(wp) ::  noffset     !:
-       REAL(wp) ::  roffset     !:
-       REAL(wp) ::  soffset     !:
-
-!
-!--    If the fine- and coarse grid nodes do not match:
-       loffset = MOD( coord_x(nxl), cg%dx )
-       xexl    = cg%dx + loffset
-!
-!--    This is needed in the anterpolation phase
-       nhll = CEILING( xexl / cg%dx )
-       xcs  = coord_x(nxl) - xexl
-       DO  i = 0, cg%nx
-          IF ( cg%coord_x(i) > xcs )  THEN
-             icl = MAX( -1, i-1 )
-             EXIT
-          ENDIF
-       ENDDO
-!
-!--    If the fine- and coarse grid nodes do not match
-       roffset = MOD( coord_x(nxr+1), cg%dx )
-       xexr    = cg%dx + roffset
-!
-!--    This is needed in the anterpolation phase
-       nhlr = CEILING( xexr / cg%dx )
-       xce  = coord_x(nxr) + xexr
-       DO  i = cg%nx, 0 , -1
-          IF ( cg%coord_x(i) < xce )  THEN
-             icr = MIN( cg%nx+1, i+1 )
-             EXIT
-          ENDIF
-       ENDDO
-!
-!--    If the fine- and coarse grid nodes do not match
-       soffset = MOD( coord_y(nys), cg%dy )
-       yexs    = cg%dy + soffset
-!
-!--    This is needed in the anterpolation phase
-       nhls = CEILING( yexs / cg%dy )
-       ycs  = coord_y(nys) - yexs
-       DO  j = 0, cg%ny
-          IF ( cg%coord_y(j) > ycs )  THEN
-             jcs = MAX( -nbgp, j-1 )
-             EXIT
-          ENDIF
-       ENDDO
-!
-!--    If the fine- and coarse grid nodes do not match
-       noffset = MOD( coord_y(nyn+1), cg%dy )
-       yexn    = cg%dy + noffset
-!
-!--    This is needed in the anterpolation phase
-       nhln = CEILING( yexn / cg%dy )
-       yce  = coord_y(nyn) + yexn
-       DO  j = cg%ny, 0, -1
-          IF ( cg%coord_y(j) < yce )  THEN
-             jcn = MIN( cg%ny + nbgp, j+1 )
-             EXIT
-          ENDIF
-       ENDDO
-
-       coarse_bound(1) = icl
-       coarse_bound(2) = icr
-       coarse_bound(3) = jcs
-       coarse_bound(4) = jcn
-       coarse_bound(5) = myid
-!
-!--    Note that MPI_Gather receives data from all processes in the rank order
-!--    TO_DO: refer to the line where this fact becomes important
-       CALL MPI_GATHER( coarse_bound, 5, MPI_INTEGER, coarse_bound_all, 5, &
-                        MPI_INTEGER, 0, comm2d, ierr )
-
-       IF ( myid == 0 )  THEN
-          size_of_array(1) = SIZE( coarse_bound_all, 1 )
-          size_of_array(2) = SIZE( coarse_bound_all, 2 )
-          CALL pmc_send_to_server( size_of_array, 2, 0, 40, ierr )
-          CALL pmc_send_to_server( coarse_bound_all, SIZE( coarse_bound_all ), &
-                                   0, 41, ierr )
-       ENDIF
-
-    END SUBROUTINE pmci_map_fine_to_coarse_grid
-
-
-
-    SUBROUTINE pmci_init_interp_tril
-!
-!--    Precomputation of the interpolation coefficients and client-array indices
-!--    to be used by the interpolation routines interp_tril_lr, interp_tril_ns
-!--    and interp_tril_t.
-
-       IMPLICIT NONE
-
-       INTEGER(iwp) ::  i       !:
-       INTEGER(iwp) ::  i1      !:
-       INTEGER(iwp) ::  j       !:
-       INTEGER(iwp) ::  j1      !:
-       INTEGER(iwp) ::  k       !:
-       INTEGER(iwp) ::  kc      !:
-
-       REAL(wp) ::  xb          !:
-       REAL(wp) ::  xcsu        !:
-       REAL(wp) ::  xfso        !:
-       REAL(wp) ::  xcso        !:
-       REAL(wp) ::  xfsu        !:
-       REAL(wp) ::  yb          !:
-       REAL(wp) ::  ycso        !:
-       REAL(wp) ::  ycsv        !:
-       REAL(wp) ::  yfso        !:
-       REAL(wp) ::  yfsv        !:
-       REAL(wp) ::  zcso        !:
-       REAL(wp) ::  zcsw        !:
-       REAL(wp) ::  zfso        !:
-       REAL(wp) ::  zfsw        !:
-      
-
-       xb = nxl * dx
-       yb = nys * dy
-      
-       ALLOCATE( icu(nxlg:nxrg) )
-       ALLOCATE( ico(nxlg:nxrg) )
-       ALLOCATE( jcv(nysg:nyng) )
-       ALLOCATE( jco(nysg:nyng) )
-       ALLOCATE( kcw(nzb:nzt+1) )
-       ALLOCATE( kco(nzb:nzt+1) )
-       ALLOCATE( r1xu(nxlg:nxrg) )
-       ALLOCATE( r2xu(nxlg:nxrg) )
-       ALLOCATE( r1xo(nxlg:nxrg) )
-       ALLOCATE( r2xo(nxlg:nxrg) )
-       ALLOCATE( r1yv(nysg:nyng) )
-       ALLOCATE( r2yv(nysg:nyng) )
-       ALLOCATE( r1yo(nysg:nyng) )
-       ALLOCATE( r2yo(nysg:nyng) )
-       ALLOCATE( r1zw(nzb:nzt+1) )
-       ALLOCATE( r2zw(nzb:nzt+1) )
-       ALLOCATE( r1zo(nzb:nzt+1) )
-       ALLOCATE( r2zo(nzb:nzt+1) )
-
-!
-!--    Note that the node coordinates xfs... and xcs... are relative to the
-!--    lower-left-bottom corner of the fc-array, not the actual client domain
-!--    corner
-       DO  i = nxlg, nxrg
-          xfsu    = coord_x(i) - ( lower_left_coord_x + xb - xexl )
-          xfso    = coord_x(i) + 0.5_wp * dx - ( lower_left_coord_x + xb - xexl )
-          icu(i)  = icl + FLOOR( xfsu / cg%dx )
-          ico(i)  = icl + FLOOR( ( xfso - 0.5_wp * cg%dx ) / cg%dx )
-          xcsu    = ( icu(i) - icl ) * cg%dx
-          xcso    = ( ico(i) - icl ) * cg%dx + 0.5_wp * cg%dx
-          r2xu(i) = ( xfsu - xcsu ) / cg%dx
-          r2xo(i) = ( xfso - xcso ) / cg%dx
-          r1xu(i) = 1.0_wp - r2xu(i)
-          r1xo(i) = 1.0_wp - r2xo(i)
-       ENDDO
-
-       DO  j = nysg, nyng
-          yfsv    = coord_y(j) - ( lower_left_coord_y + yb - yexs )
-          yfso    = coord_y(j) + 0.5_wp * dy - ( lower_left_coord_y + yb - yexs )
-          jcv(j)  = jcs + FLOOR( yfsv / cg%dy )
-          jco(j)  = jcs + FLOOR( ( yfso -0.5_wp * cg%dy ) / cg%dy )
-          ycsv    = ( jcv(j) - jcs ) * cg%dy
-          ycso    = ( jco(j) - jcs ) * cg%dy + 0.5_wp * cg%dy
-          r2yv(j) = ( yfsv - ycsv ) / cg%dy
-          r2yo(j) = ( yfso - ycso ) / cg%dy
-          r1yv(j) = 1.0_wp - r2yv(j)
-          r1yo(j) = 1.0_wp - r2yo(j)
-       ENDDO
-
-       DO  k = nzb, nzt + 1
-          zfsw = zw(k)
-          zfso = zu(k)
-
-          kc = 0
-          DO  WHILE ( cg%zw(kc) <= zfsw )
-             kc = kc + 1
-          ENDDO
-          kcw(k) = kc - 1
-         
-          kc = 0
-          DO  WHILE ( cg%zu(kc) <= zfso )
-             kc = kc + 1
-          ENDDO
-          kco(k) = kc - 1
-
-          zcsw    = cg%zw(kcw(k))
-          zcso    = cg%zu(kco(k))
-          r2zw(k) = ( zfsw - zcsw ) / cg%dzw(kcw(k)+1)
-          r2zo(k) = ( zfso - zcso ) / cg%dzu(kco(k)+1)
-          r1zw(k) = 1.0_wp - r2zw(k)
-          r1zo(k) = 1.0_wp - r2zo(k)
-       ENDDO
-      
-    END SUBROUTINE pmci_init_interp_tril
-
-
-
-    SUBROUTINE pmci_init_loglaw_correction
-!
-!--    Precomputation of the index and log-ratio arrays for the log-law
-!--    corrections for near-wall nodes after the nest-BC interpolation.
-!--    These are used by the interpolation routines interp_tril_lr and
-!--    interp_tril_ns.
-
-       IMPLICIT NONE
-
-       INTEGER(iwp) ::  direction    !:  Wall normal index: 1=k, 2=j, 3=i.
-       INTEGER(iwp) ::  i            !:
-       INTEGER(iwp) ::  icorr        !:
-       INTEGER(iwp) ::  inc          !:  Wall outward-normal index increment -1
-                                     !: or 1, for direction=1, inc=1 always
-       INTEGER(iwp) ::  iw           !:
-       INTEGER(iwp) ::  j            !:
-       INTEGER(iwp) ::  jcorr        !:
-       INTEGER(iwp) ::  jw           !:
-       INTEGER(iwp) ::  k            !:
-       INTEGER(iwp) ::  kb           !:
-       INTEGER(iwp) ::  kcorr        !:
-       INTEGER(iwp) ::  lc           !:
-       INTEGER(iwp) ::  ni           !:
-       INTEGER(iwp) ::  nj           !:
-       INTEGER(iwp) ::  nk           !:
-       INTEGER(iwp) ::  nzt_topo_max !:
-       INTEGER(iwp) ::  wall_index   !:  Index of the wall-node coordinate
-
-       REAL(wp), ALLOCATABLE, DIMENSION(:) ::  lcr   !:
-
-!
-!--    First determine the maximum k-index needed for the near-wall corrections.
-!--    This maximum is individual for each boundary to minimize the storage
-!--    requirements and to minimize the corresponding loop k-range in the
-!--    interpolation routines.
-       nzt_topo_nestbc_l = nzb
-       IF ( nest_bound_l )  THEN
-          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) )
-             ENDDO
-          ENDDO
-          nzt_topo_nestbc_l = nzt_topo_nestbc_l + 1
-       ENDIF
-      
-       nzt_topo_nestbc_r = nzb
-       IF ( nest_bound_r )  THEN
-          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) )
-          ENDDO
-          nzt_topo_nestbc_r = nzt_topo_nestbc_r + 1
-       ENDIF
-
-       nzt_topo_nestbc_s = nzb
-       IF ( nest_bound_s )  THEN
-          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) )
-             ENDDO
-          ENDDO
-          nzt_topo_nestbc_s = nzt_topo_nestbc_s + 1
-       ENDIF
-
-       nzt_topo_nestbc_n = nzb
-       IF ( nest_bound_n )  THEN
-          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) )
-          ENDDO
-          nzt_topo_nestbc_n = nzt_topo_nestbc_n + 1
-       ENDIF
-
-!
-!--    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
-          nk = MAX( nk, CEILING( cg%dzu(k) / dzu(k) ) )
-       ENDDO
-       nk = nk / 2   !  Note that this must be integer division.
-       ncorr =  MAX( ni, nj, nk )
-
-       ALLOCATE( lcr(0:ncorr-1) )
-       lcr = 1.0_wp
-
-!
-!--    First horizontal walls
-!--    Left boundary
-       IF ( nest_bound_l )  THEN
-
-          ALLOCATE( logc_u_l(nzb:nzt_topo_nestbc_l,nys:nyn,1:2) )
-          ALLOCATE( logc_v_l(nzb:nzt_topo_nestbc_l,nys:nyn,1:2) )
-          ALLOCATE( logc_ratio_u_l(nzb:nzt_topo_nestbc_l,nys:nyn,1:2,0:ncorr-1) )
-          ALLOCATE( logc_ratio_v_l(nzb:nzt_topo_nestbc_l,nys:nyn,1:2,0:ncorr-1) )
-          logc_u_l       = 0
-          logc_v_l       = 0
-          logc_ratio_u_l = 1.0_wp
-          logc_ratio_v_l = 1.0_wp
-          direction      = 1
-          inc            = 1
-
-          DO  j = nys, nyn
-!
-!--          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 )
-             logc_u_l(k,j,1) = lc
-             logc_ratio_u_l(k,j,1,0:ncorr-1) = lcr(0:ncorr-1)
-             lcr(0:ncorr-1) = 1.0_wp
-!
-!--          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 )
-             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
-       IF ( nest_bound_r )  THEN
-
-          ALLOCATE( logc_u_r(nzb:nzt_topo_nestbc_r,nys:nyn,1:2) )
-          ALLOCATE( logc_v_r(nzb:nzt_topo_nestbc_r,nys:nyn,1:2) )
-          ALLOCATE( logc_ratio_u_r(nzb:nzt_topo_nestbc_r,nys:nyn,1:2,0:ncorr-1) )
-          ALLOCATE( logc_ratio_v_r(nzb:nzt_topo_nestbc_r,nys:nyn,1:2,0:ncorr-1) )
-          logc_u_r       = 0
-          logc_v_r       = 0
-          logc_ratio_u_r = 1.0_wp
-          logc_ratio_v_r = 1.0_wp
-          direction      = 1
-          inc            = 1
-          DO  j = nys, nyn
-!
-!--          Right boundary for u
-             i   = nxr + 1
-             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 )
-             logc_u_r(k,j,1) = lc
-             logc_ratio_u_r(k,j,1,0:ncorr-1) = lcr(0:ncorr-1)
-             lcr(0:ncorr-1) = 1.0_wp
-!
-!--          Right boundary for v
-             i   = nxr + 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 )
-             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
-       IF ( nest_bound_s )  THEN
-
-          ALLOCATE( logc_u_s(nzb:nzt_topo_nestbc_s,nxl:nxr,1:2) )
-          ALLOCATE( logc_v_s(nzb:nzt_topo_nestbc_s,nxl:nxr,1:2) )
-          ALLOCATE( logc_ratio_u_s(nzb:nzt_topo_nestbc_s,nxl:nxr,1:2,0:ncorr-1) )
-          ALLOCATE( logc_ratio_v_s(nzb:nzt_topo_nestbc_s,nxl:nxr,1:2,0:ncorr-1) )
-          logc_u_s       = 0
-          logc_v_s       = 0
-          logc_ratio_u_s = 1.0_wp
-          logc_ratio_v_s = 1.0_wp
-          direction      = 1
-          inc            = 1
-
-          DO  i = nxl, nxr
-!
-!--          South boundary for u
-             j   = -1
-             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 )
-             logc_u_s(k,i,1) = lc
-             logc_ratio_u_s(k,i,1,0:ncorr-1) = lcr(0:ncorr-1)
-             lcr(0:ncorr-1) = 1.0_wp
-!
-!--          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 )
-             logc_v_s(k,i,1) = lc
-             logc_ratio_v_s(k,i,1,0:ncorr-1) = lcr(0:ncorr-1)
-             lcr(0:ncorr-1) = 1.0_wp
-
-          ENDDO
-
-       ENDIF
-
-!
-!--    North boundary
-       IF ( nest_bound_n )  THEN
-
-          ALLOCATE( logc_u_n(nzb:nzt_topo_nestbc_n,nxl:nxr,1:2) )
-          ALLOCATE( logc_v_n(nzb:nzt_topo_nestbc_n,nxl:nxr,1:2) )
-          ALLOCATE( logc_ratio_u_n(nzb:nzt_topo_nestbc_n,nxl:nxr,1:2,0:ncorr-1) )
-          ALLOCATE( logc_ratio_v_n(nzb:nzt_topo_nestbc_n,nxl:nxr,1:2,0:ncorr-1) )
-          logc_u_n       = 0
-          logc_v_n       = 0
-          logc_ratio_u_n = 1.0_wp
-          logc_ratio_v_n = 1.0_wp
-          direction      = 1
-          inc            = 1
-
-          DO  i = nxl, nxr
-!
-!--          North boundary for u
-             j   = nyn + 1
-             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 )
-             logc_u_n(k,i,1) = lc
-             logc_ratio_u_n(k,i,1,0:ncorr-1) = lcr(0:ncorr-1)
-             lcr(0:ncorr-1) = 1.0_wp
-!
-!--          North boundary for v
-             j   = nyn + 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 )
-             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
-
-!       
-!--    Then vertical walls and corners if necessary
-       IF ( topography /= 'flat' )  THEN
-
-          kb = 0       ! kb is not used when direction > 1
-!        
-!--       Left boundary
-          IF ( nest_bound_l )  THEN
-
-             ALLOCATE( logc_w_l(nzb:nzt_topo_nestbc_l,nys:nyn,1:2) )
-             ALLOCATE( logc_ratio_w_l(nzb:nzt_topo_nestbc_l,nys:nyn,1:2,       &
-                                      0:ncorr-1) )
-             logc_w_l       = 0
-             logc_ratio_w_l = 1.0_wp
-             direction      = 2
-             DO  j = nys, nyn
-                DO  k = nzb, nzt_topo_nestbc_l
-!
-!--                Wall for u on the south side, but not on the north side
-                   i  = 0
-                   IF ( ( nzb_u_outer(j,i) > nzb_u_outer(j+1,i) ) .AND.        &
-                        ( nzb_u_outer(j,i) == nzb_u_outer(j-1,i) ) )           &
-                   THEN
-                      inc        =  1
-                      wall_index =  j
-                      CALL pmci_define_loglaw_correction_parameters( lc, lcr,  &
-                          k, j, inc, wall_index, z0(j,i), kb, direction, ncorr )
-!
-!--                   The direction of the wall-normal index is stored as the
-!--                   sign of the logc-element.
-                      logc_u_l(k,j,2) = inc * lc
-                      logc_ratio_u_l(k,j,2,0:ncorr-1) = lcr(0:ncorr-1)
-                      lcr(0:ncorr-1) = 1.0_wp
-                   ENDIF
-
-!
-!--                Wall for u on the north side, but not on the south side
-                   i  = 0
-                   IF ( ( nzb_u_outer(j,i) > nzb_u_outer(j-1,i) ) .AND.        &
-                        ( nzb_u_outer(j,i) == nzb_u_outer(j+1,i) ) )  THEN
-                      inc        = -1
-                      wall_index =  j + 1
-                      CALL pmci_define_loglaw_correction_parameters( lc, lcr,  &
-                          k, j, inc, wall_index, z0(j,i), kb, direction, ncorr )
-!
-!--                   The direction of the wall-normal index is stored as the
-!--                   sign of the logc-element.
-                      logc_u_l(k,j,2) = inc * lc
-                      logc_ratio_u_l(k,j,2,0:ncorr-1) = lcr(0:ncorr-1)
-                      lcr(0:ncorr-1) = 1.0_wp
-                   ENDIF
-
-!
-!--                Wall for w on the south side, but not on the north side.
-                   i  = -1
-                   IF ( ( nzb_w_outer(j,i) > nzb_w_outer(j+1,i) )  .AND.       &
-                        ( nzb_w_outer(j,i) == nzb_w_outer(j-1,i) ) )  THEN
-                      inc        =  1
-                      wall_index =  j
-                      CALL pmci_define_loglaw_correction_parameters( lc, lcr,  &
-                          k, j, inc, wall_index, z0(j,i), kb, direction, ncorr )
-!
-!--                   The direction of the wall-normal index is stored as the
-!--                   sign of the logc-element.
-                      logc_w_l(k,j,2) = inc * lc
-                      logc_ratio_w_l(k,j,2,0:ncorr-1) = lcr(0:ncorr-1)
-                      lcr(0:ncorr-1) = 1.0_wp
-                   ENDIF
-
-!
-!--                Wall for w on the north side, but not on the south side.
-                   i  = -1
-                   IF ( ( nzb_w_outer(j,i) > nzb_w_outer(j-1,i) )  .AND.       &
-                        ( nzb_w_outer(j,i) == nzb_w_outer(j+1,i) ) )  THEN
-                      inc        = -1
-                      wall_index =  j+1
-                      CALL pmci_define_loglaw_correction_parameters( lc, lcr,  &
-                          k, j, inc, wall_index, z0(j,i), kb, direction, ncorr )
-!
-!--                   The direction of the wall-normal index is stored as the
-!--                   sign of the logc-element.
-                      logc_w_l(k,j,2) = inc * lc
-                      logc_ratio_w_l(k,j,2,0:ncorr-1) = lcr(0:ncorr-1)
-                      lcr(0:ncorr-1) = 1.0_wp
-                   ENDIF
-
-                ENDDO
-             ENDDO
-
-          ENDIF   !  IF ( nest_bound_l )
-
-!        
-!--       Right boundary
-          IF ( nest_bound_r )  THEN
-
-             ALLOCATE( logc_w_r(nzb:nzt_topo_nestbc_r,nys:nyn,1:2) )
-             ALLOCATE( logc_ratio_w_r(nzb:nzt_topo_nestbc_r,nys:nyn,1:2,       &
-                                      0:ncorr-1) )
-             logc_w_r       = 0
-             logc_ratio_w_r = 1.0_wp
-             direction      = 2
-             i  = nxr + 1
-
-             DO  j = nys, nyn
-                DO  k = nzb, nzt_topo_nestbc_r
-!
-!--                Wall for u on the south side, but not on the north side
-                   IF ( ( nzb_u_outer(j,i) > nzb_u_outer(j+1,i) )  .AND.       &
-                        ( nzb_u_outer(j,i) == nzb_u_outer(j-1,i) ) )  THEN
-                      inc        = 1
-                      wall_index = j
-                      CALL pmci_define_loglaw_correction_parameters( lc, lcr,  &
-                          k, j, inc, wall_index, z0(j,i), kb, direction, ncorr )
-!
-!--                   The direction of the wall-normal index is stored as the
-!--                   sign of the logc-element.
-                      logc_u_r(k,j,2) = inc * lc
-                      logc_ratio_u_r(k,j,2,0:ncorr-1) = lcr(0:ncorr-1)
-                      lcr(0:ncorr-1) = 1.0_wp
-                   ENDIF
-
-!
-!--                Wall for u on the north side, but not on the south side
-                   IF ( ( nzb_u_outer(j,i) > nzb_u_outer(j-1,i) )  .AND.       &
-                        ( nzb_u_outer(j,i) == nzb_u_outer(j+1,i) ) )  THEN
-                      inc        = -1
-                      wall_index =  j+1
-                      CALL pmci_define_loglaw_correction_parameters( lc, lcr,  &
-                          k, j, inc, wall_index, z0(j,i), kb, direction, ncorr )
-!
-!--                   The direction of the wall-normal index is stored as the
-!--                   sign of the logc-element.
-                      logc_u_r(k,j,2) = inc * lc
-                      logc_ratio_u_r(k,j,2,0:ncorr-1) = lcr(0:ncorr-1)
-                      lcr(0:ncorr-1) = 1.0_wp
-                   ENDIF
-
-!
-!--                Wall for w on the south side, but not on the north side
-                   IF ( ( nzb_w_outer(j,i) > nzb_w_outer(j+1,i) )  .AND.       &
-                        ( nzb_w_outer(j,i) == nzb_w_outer(j-1,i) ) )  THEN
-                      inc        =  1
-                      wall_index =  j
-                      CALL pmci_define_loglaw_correction_parameters( lc, lcr,  &
-                          k, j, inc, wall_index, z0(j,i), kb, direction, ncorr )
-!
-!--                   The direction of the wall-normal index is stored as the
-!--                   sign of the logc-element.
-                      logc_w_r(k,j,2) = inc * lc
-                      logc_ratio_w_r(k,j,2,0:ncorr-1) = lcr(0:ncorr-1)
-                      lcr(0:ncorr-1) = 1.0_wp
-                   ENDIF
-
-!
-!--                Wall for w on the north side, but not on the south side
-                   IF ( ( nzb_w_outer(j,i) > nzb_w_outer(j-1,i) )  .AND.       &
-                        ( nzb_w_outer(j,i) == nzb_w_outer(j+1,i) ) )  THEN
-                      inc        = -1
-                      wall_index =  j+1
-                      CALL pmci_define_loglaw_correction_parameters( lc, lcr,  &
-                          k, j, inc, wall_index, z0(j,i), kb, direction, ncorr )
-
-!
-!--                   The direction of the wall-normal index is stored as the
-!--                   sign of the logc-element.
-                      logc_w_r(k,j,2) = inc * lc
-                      logc_ratio_w_r(k,j,2,0:ncorr-1) = lcr(0:ncorr-1)
-                      lcr(0:ncorr-1) = 1.0_wp
-                   ENDIF
-
-                ENDDO
-             ENDDO
-
-          ENDIF   !  IF ( nest_bound_r )
-
-!        
-!--       South boundary
-          IF ( nest_bound_s )  THEN
-
-             ALLOCATE( logc_w_s(nzb:nzt_topo_nestbc_s, nxl:nxr, 1:2) )
-             ALLOCATE( logc_ratio_w_s(nzb:nzt_topo_nestbc_s,nxl:nxr,1:2,       &
-                                      0:ncorr-1) )
-             logc_w_s       = 0
-             logc_ratio_w_s = 1.0_wp
-             direction      = 3
-
-             DO  i = nxl, nxr
-                DO  k = nzb, nzt_topo_nestbc_s
-!
-!--                Wall for v on the left side, but not on the right side
-                   j  = 0
-                   IF ( ( nzb_v_outer(j,i) > nzb_v_outer(j,i+1) )  .AND.       &
-                        ( nzb_v_outer(j,i) == nzb_v_outer(j,i-1) ) )  THEN
-                      inc        =  1
-                      wall_index =  i
-                      CALL pmci_define_loglaw_correction_parameters( lc, lcr,  &
-                          k, i, inc, wall_index, z0(j,i), kb, direction, ncorr )
-!
-!--                   The direction of the wall-normal index is stored as the
-!--                   sign of the logc-element.
-                      logc_v_s(k,i,2) = inc * lc
-                      logc_ratio_v_s(k,i,2,0:ncorr-1) = lcr(0:ncorr-1)
-                      lcr(0:ncorr-1) = 1.0_wp
-                   ENDIF
-
-!
-!--                Wall for v on the right side, but not on the left side
-                   j  = 0
-                   IF ( ( nzb_v_outer(j,i) > nzb_v_outer(j,i-1) )  .AND.       &
-                        ( nzb_v_outer(j,i) == nzb_v_outer(j,i+1) ) )  THEN
-                      inc        = -1
-                      wall_index =  i+1
-                      CALL pmci_define_loglaw_correction_parameters( lc, lcr,  &
-                          k, i, inc, wall_index, z0(j,i), kb, direction, ncorr )
-!
-!--                   The direction of the wall-normal index is stored as the
-!--                   sign of the logc-element.
-                      logc_v_s(k,i,2) = inc * lc
-                      logc_ratio_v_s(k,i,2,0:ncorr-1) = lcr(0:ncorr-1)
-                      lcr(0:ncorr-1) = 1.0_wp
-                   ENDIF
-
-!
-!--                Wall for w on the left side, but not on the right side
-                   j  = -1
-                   IF ( ( nzb_w_outer(j,i) > nzb_w_outer(j,i+1) )  .AND.       &
-                        ( nzb_w_outer(j,i) == nzb_w_outer(j,i-1) ) )  THEN
-                      inc        =  1
-                      wall_index =  i
-                      CALL pmci_define_loglaw_correction_parameters( lc, lcr,  &
-                          k, i, inc, wall_index, z0(j,i), kb, direction, ncorr )
-!
-!--                   The direction of the wall-normal index is stored as the
-!--                   sign of the logc-element.
-                      logc_w_s(k,i,2) = inc * lc
-                      logc_ratio_w_s(k,i,2,0:ncorr - 1) = lcr(0:ncorr-1)
-                      lcr(0:ncorr-1) = 1.0_wp
-                   ENDIF
-
-!
-!--                Wall for w on the right side, but not on the left side
-                   j  = -1
-                   IF ( ( nzb_w_outer(j,i) > nzb_w_outer(j,i-1) )  .AND.       &
-                        ( nzb_w_outer(j,i) == nzb_w_outer(j,i+1) ) )  THEN
-                      inc        = -1
-                      wall_index =  i+1
-                      CALL pmci_define_loglaw_correction_parameters( lc, lcr,  &
-                          k, i, inc, wall_index, z0(j,i), kb, direction, ncorr )
-!
-!--                   The direction of the wall-normal index is stored as the
-!--                   sign of the logc-element.
-                      logc_w_s(k,i,2) = inc * lc
-                      logc_ratio_w_s(k,i,2,0:ncorr-1) = lcr(0:ncorr-1)
-                      lcr(0:ncorr-1) = 1.0_wp
-                   ENDIF
-
-                ENDDO
-             ENDDO
-
-          ENDIF   !  IF (nest_bound_s )
-
-!        
-!--       North boundary
-          IF ( nest_bound_n )  THEN
-
-             ALLOCATE( logc_w_n(nzb:nzt_topo_nestbc_n, nxl:nxr, 1:2) )
-             ALLOCATE( logc_ratio_w_n(nzb:nzt_topo_nestbc_n,nxl:nxr,1:2,       &
-                                      0:ncorr-1) )
-             logc_w_n       = 0
-             logc_ratio_w_n = 1.0_wp
-             direction      = 3
-             j  = nyn + 1
-
-             DO  i = nxl, nxr
-                DO  k = nzb, nzt_topo_nestbc_n
-!
-!--                Wall for v on the left side, but not on the right side
-                   IF ( ( nzb_v_outer(j,i) > nzb_v_outer(j,i+1) )  .AND.       &
-                        ( nzb_v_outer(j,i) == nzb_v_outer(j,i-1) ) )  THEN
-                      inc        = 1
-                      wall_index = i
-                      CALL pmci_define_loglaw_correction_parameters( lc, lcr,  &
-                          k, i, inc, wall_index, z0(j,i), kb, direction, ncorr )
-!
-!--                   The direction of the wall-normal index is stored as the
-!--                   sign of the logc-element.
-                      logc_v_n(k,i,2) = inc * lc
-                      logc_ratio_v_n(k,i,2,0:ncorr-1) = lcr(0:ncorr-1)
-                      lcr(0:ncorr-1) = 1.0_wp
-                   ENDIF
-
-!
-!--                Wall for v on the right side, but not on the left side
-                   IF ( ( nzb_v_outer(j,i) > nzb_v_outer(j,i-1) )  .AND.       &
-                        ( nzb_v_outer(j,i) == nzb_v_outer(j,i+1) ) )  THEN
-                      inc        = -1
-                      wall_index =  i + 1
-                      CALL pmci_define_loglaw_correction_parameters( lc, lcr,  &
-                          k, i, inc, wall_index, z0(j,i), kb, direction, ncorr )
-!
-!--                   The direction of the wall-normal index is stored as the
-!--                   sign of the logc-element.
-                      logc_v_n(k,i,2) = inc * lc
-                      logc_ratio_v_n(k,i,2,0:ncorr-1) = lcr(0:ncorr-1)
-                      lcr(0:ncorr-1) = 1.0_wp
-                   ENDIF
-
-!
-!--                Wall for w on the left side, but not on the right side
-                   IF ( ( nzb_w_outer(j,i) > nzb_w_outer(j,i+1) )  .AND.       &
-                        ( nzb_w_outer(j,i) == nzb_w_outer(j,i-1) ) )  THEN
-                      inc        = 1
-                      wall_index = i
-                      CALL pmci_define_loglaw_correction_parameters( lc, lcr,  &
-                          k, i, inc, wall_index, z0(j,i), kb, direction, ncorr )
-!
-!--                   The direction of the wall-normal index is stored as the
-!--                   sign of the logc-element.
-                      logc_w_n(k,i,2) = inc * lc
-                      logc_ratio_w_n(k,i,2,0:ncorr-1) = lcr(0:ncorr-1)
-                      lcr(0:ncorr-1) = 1.0_wp
-                   ENDIF
-
-!
-!--                Wall for w on the right side, but not on the left side
-                   IF ( ( nzb_w_outer(j,i) > nzb_w_outer(j,i-1) )  .AND.       &
-                        ( nzb_w_outer(j,i) == nzb_w_outer(j,i+1) ) )  THEN
-                      inc        = -1
-                      wall_index =  i+1
-                      CALL pmci_define_loglaw_correction_parameters( lc, lcr,  &
-                          k, i, inc, wall_index, z0(j,i), kb, direction, ncorr )
-!
-!--                   The direction of the wall-normal index is stored as the
-!--                   sign of the logc-element.
-                      logc_w_n(k,i,2) = inc * lc
-                      logc_ratio_w_n(k,i,2,0:ncorr-1) = lcr(0:ncorr-1)
-                      lcr(0:ncorr-1) = 1.0_wp
-                   ENDIF
-
-                ENDDO
-             ENDDO
-
-          ENDIF   !  IF ( nest_bound_n )
-
-       ENDIF   !  IF ( topography /= 'flat' )
-
-    END SUBROUTINE pmci_init_loglaw_correction
-
-
-
-    SUBROUTINE pmci_define_loglaw_correction_parameters( lc, lcr, k, ij, inc,  &
-                                        wall_index, z0_l, kb, direction, ncorr )
-
-       IMPLICIT NONE
-
-       INTEGER(iwp), INTENT(IN)  ::  direction                 !:
-       INTEGER(iwp), INTENT(IN)  ::  ij                        !:
-       INTEGER(iwp), INTENT(IN)  ::  inc                       !:
-       INTEGER(iwp), INTENT(IN)  ::  k                         !:
-       INTEGER(iwp), INTENT(IN)  ::  kb                        !:
-       INTEGER(iwp), INTENT(OUT) ::  lc                        !:
-       INTEGER(iwp), INTENT(IN)  ::  ncorr                     !:
-       INTEGER(iwp), INTENT(IN)  ::  wall_index                !:
-
-       INTEGER(iwp) ::  alcorr       !:
-       INTEGER(iwp) ::  corr_index   !:
-       INTEGER(iwp) ::  lcorr        !:
-
-       LOGICAL      ::  more         !:
-
-       REAL(wp), DIMENSION(0:ncorr-1), INTENT(OUT) ::  lcr     !:
-       REAL(wp), INTENT(IN)      ::  z0_l                      !:
-      
-       REAL(wp)     ::  logvelc1     !:
-      
-
-       SELECT CASE ( direction )
-
-          CASE (1)   !  k
-             more = .TRUE.
-             lcorr = 0
-             DO  WHILE ( more .AND. lcorr <= ncorr-1 )
-                corr_index = k + lcorr
-                IF ( lcorr == 0 )  THEN
-                   CALL pmci_find_logc_pivot_k( lc, logvelc1, z0_l, kb )
-                ENDIF
-               
-                IF ( corr_index < lc )  THEN
-                   lcr(lcorr) = LOG( ( zu(k) - zw(kb) ) / z0_l ) / logvelc1
-                   more = .TRUE.
-                ELSE
-                   lcr(lcorr) = 1.0
-                   more = .FALSE.
-                ENDIF
-                lcorr = lcorr + 1
-             ENDDO
-
-          CASE (2)   !  j
-             more = .TRUE.
-             lcorr  = 0
-             alcorr = 0
-             DO  WHILE ( more  .AND.  alcorr <= ncorr-1 )
-                corr_index = ij + lcorr   ! In this case (direction = 2) ij is j
-                IF ( lcorr == 0 )  THEN
-                   CALL pmci_find_logc_pivot_j( lc, logvelc1, ij, wall_index,  &
-                                                z0_l, inc )
-                ENDIF
-
-!
-!--             The role of inc here is to make the comparison operation "<"
-!--             valid in both directions
-                IF ( inc * corr_index < inc * lc )  THEN
-                   lcr(alcorr) = LOG( ABS( coord_y(corr_index) + 0.5_wp * dy   &
-                                         - coord_y(wall_index) ) / z0_l )      &
-                                 / logvelc1
-                   more = .TRUE.
-                ELSE
-                   lcr(alcorr) = 1.0_wp
-                   more = .FALSE.
-                ENDIF
-                lcorr  = lcorr + inc
-                alcorr = ABS( lcorr )
-             ENDDO
-
-          CASE (3)   !  i
-             more = .TRUE.
-             lcorr  = 0
-             alcorr = 0
-             DO  WHILE ( more  .AND.  alcorr <= ncorr-1 )
-                corr_index = ij + lcorr   ! In this case (direction = 3) ij is i
-                IF ( lcorr == 0 )  THEN
-                   CALL pmci_find_logc_pivot_i( lc, logvelc1, ij, wall_index,  &
-                                                z0_l, inc )
-                ENDIF
-!
-!--             The role of inc here is to make the comparison operation "<"
-!--             valid in both directions
-                IF ( inc * corr_index < inc * lc )  THEN
-                   lcr(alcorr) = LOG( ABS( coord_x(corr_index) + 0.5_wp * dx   &
-                                         - coord_x(wall_index) ) / z0_l )      &
-                                 / logvelc1
-                   more = .TRUE.
-                ELSE
-                   lcr(alcorr) = 1.0_wp
-                   more = .FALSE.
-                ENDIF
-                lcorr  = lcorr + inc
-                alcorr = ABS( lcorr )
-             ENDDO
-
-       END SELECT
-
-    END SUBROUTINE pmci_define_loglaw_correction_parameters
-
-
-
-    SUBROUTINE pmci_find_logc_pivot_k( lc, logzc1, z0_l, kb )
-!
-!--    Finds the pivot node and te log-law factor for near-wall nodes for
-!--    which the wall-parallel velocity components will be log-law corrected
-!--    after interpolation. This subroutine is only for horizontal walls.
-
-       IMPLICIT NONE
-
-       INTEGER(iwp), INTENT(IN)  ::  kb   !:
-       INTEGER(iwp), INTENT(OUT) ::  lc   !:
-
-       INTEGER(iwp) ::  kbc    !:
-       INTEGER(iwp) ::  k1     !:
-
-       REAL(wp),INTENT(OUT) ::  logzc1     !:
-       REAL(wp), INTENT(IN) ::  z0_l       !:
-
-       REAL(wp) ::  zuc1   !:
-
-
-       kbc = nzb + 1
-!
-!--    kbc is the first coarse-grid point above the surface
-       DO  WHILE ( cg%zu(kbc) < zu(kb) )
-          kbc = kbc + 1
-       ENDDO
-       zuc1  = cg%zu(kbc)
-       k1    = kb + 1
-       DO  WHILE ( zu(k1) < zuc1 )  !  Important: must be <, not <=
-          k1 = k1 + 1
-       ENDDO
-       logzc1 = LOG( (zu(k1) - zw(kb) ) / z0_l )
-       lc = k1
-
-    END SUBROUTINE pmci_find_logc_pivot_k
-
-
-
-    SUBROUTINE pmci_find_logc_pivot_j( lc, logyc1, j, jw, z0_l, inc )
-!
-!--    Finds the pivot node and te log-law factor for near-wall nodes for
-!--    which the wall-parallel velocity components will be log-law corrected
-!--    after interpolation. This subroutine is only for vertical walls on
-!--    south/north sides of the node.
-
-       IMPLICIT NONE
-
-       INTEGER(iwp), INTENT(IN)  ::  inc    !:  increment must be 1 or -1.
-       INTEGER(iwp), INTENT(IN)  ::  j      !:
-       INTEGER(iwp), INTENT(IN)  ::  jw     !:
-       INTEGER(iwp), INTENT(OUT) ::  lc     !:
-
-       INTEGER(iwp) ::  j1       !:
-
-       REAL(wp), INTENT(IN) ::  z0_l   !:
-
-       REAL(wp) ::  logyc1   !:
-       REAL(wp) ::  yc1      !:
-
-!
-!--    yc1 is the y-coordinate of the first coarse-grid u- and w-nodes out from
-!--    the wall
-       yc1  = coord_y(jw) + 0.5_wp * inc * cg%dy
-!
-!--    j1 is the first fine-grid index further away from the wall than yc1
-       j1 = j
-!
-!--    Important: must be <, not <=
-       DO  WHILE ( inc * ( coord_y(j1) + 0.5_wp * dy ) < inc * yc1 )
-          j1 = j1 + inc
-       ENDDO
-
-       logyc1 = LOG( ABS( coord_y(j1) + 0.5_wp * dy - coord_y(jw) ) / z0_l )
-       lc = j1
-
-    END SUBROUTINE pmci_find_logc_pivot_j
-
-
-
-    SUBROUTINE pmci_find_logc_pivot_i( lc, logxc1, i, iw, z0_l, inc )
-!
-!--    Finds the pivot node and the log-law factor for near-wall nodes for
-!--    which the wall-parallel velocity components will be log-law corrected
-!--    after interpolation. This subroutine is only for vertical walls on
-!--    south/north sides of the node.
-
-       IMPLICIT NONE
-
-       INTEGER(iwp), INTENT(IN)  ::  i      !:
-       INTEGER(iwp), INTENT(IN)  ::  inc    !: increment must be 1 or -1.
-       INTEGER(iwp), INTENT(IN)  ::  iw     !:
-       INTEGER(iwp), INTENT(OUT) ::  lc     !:
-
-       INTEGER(iwp) ::  i1       !:
-
-       REAL(wp), INTENT(IN) ::  z0_l   !:
-
-       REAL(wp) ::  logxc1   !:
-       REAL(wp) ::  xc1      !:
-
-!
-!--    xc1 is the x-coordinate of the first coarse-grid v- and w-nodes out from
-!--    the wall
-       xc1  = coord_x(iw) + 0.5_wp * inc * cg%dx
-!
-!--    i1 is the first fine-grid index futher away from the wall than xc1.
-       i1 = i
-!
-!--    Important: must be <, not <=
-       DO  WHILE ( inc * ( coord_x(i1) + 0.5_wp *dx ) < inc * xc1 )
-          i1 = i1 + inc
-       ENDDO
-      
-       logxc1 = LOG( ABS( coord_x(i1) + 0.5_wp*dx - coord_x(iw) ) / z0_l )
-       lc = i1
-
-    END SUBROUTINE pmci_find_logc_pivot_i
-
-
-
-
-    SUBROUTINE pmci_init_anterp_tophat
-!
-!--    Precomputation of the client-array indices for
-!--    corresponding coarse-grid array index and the
-!--    Under-relaxation coefficients to be used by anterp_tophat.
-
-       IMPLICIT NONE
-
-       INTEGER(iwp) ::  i        !: Fine-grid index
-       INTEGER(iwp) ::  ii       !: Coarse-grid index
-       INTEGER(iwp) ::  istart   !:
-       INTEGER(iwp) ::  j        !: Fine-grid index
-       INTEGER(iwp) ::  jj       !: Coarse-grid index
-       INTEGER(iwp) ::  jstart   !:
-       INTEGER(iwp) ::  k        !: Fine-grid index
-       INTEGER(iwp) ::  kk       !: Coarse-grid index
-       INTEGER(iwp) ::  kstart   !:
-       REAL(wp)     ::  xi       !:
-       REAL(wp)     ::  eta      !:
-       REAL(wp)     ::  zeta     !:
-     
-!
-!--    Default values:
-       IF ( anterp_relax_length_l < 0.0_wp )  THEN
-          anterp_relax_length_l = 0.1_wp * ( nx + 1 ) * dx
-       ENDIF
-       IF ( anterp_relax_length_r < 0.0_wp )  THEN
-          anterp_relax_length_r = 0.1_wp * ( nx + 1 ) * dx
-       ENDIF
-       IF ( anterp_relax_length_s < 0.0_wp )  THEN
-          anterp_relax_length_s = 0.1_wp * ( ny + 1 ) * dy
-       ENDIF
-       IF ( anterp_relax_length_n < 0.0_wp )  THEN
-          anterp_relax_length_n = 0.1_wp * ( ny + 1 ) * dy
-       ENDIF
-       IF ( anterp_relax_length_t < 0.0_wp )  THEN
-          anterp_relax_length_t = 0.1_wp * zu(nzt)
-       ENDIF
-
-!
-!--    First determine kctu and kctw that are the coarse-grid upper bounds for
-!--    index k
-       kk = 0
-       DO  WHILE ( cg%zu(kk) < zu(nzt) )
-          kk = kk + 1
-       ENDDO
-       kctu = kk - 1
-
-       kk = 0
-       DO  WHILE ( cg%zw(kk) < zw(nzt-1) )
-          kk = kk + 1
-       ENDDO
-       kctw = kk - 1
-
-       ALLOCATE( iflu(icl:icr) )
-       ALLOCATE( iflo(icl:icr) )
-       ALLOCATE( ifuu(icl:icr) )
-       ALLOCATE( ifuo(icl:icr) )
-       ALLOCATE( jflv(jcs:jcn) )
-       ALLOCATE( jflo(jcs:jcn) )
-       ALLOCATE( jfuv(jcs:jcn) )
-       ALLOCATE( jfuo(jcs:jcn) )
-       ALLOCATE( kflw(0:kctw) )
-       ALLOCATE( kflo(0:kctu) )
-       ALLOCATE( kfuw(0:kctw) )
-       ALLOCATE( kfuo(0:kctu) )
-
-!
-!--    i-indices of u for each ii-index value
-       istart = nxlg
-       DO  ii = icl, icr
-          i = istart
-          DO  WHILE ( ( coord_x(i) < cg%coord_x(ii) - 0.5_wp * cg%dx )  .AND.  &
-                      ( i < nxrg ) )
-             i = i + 1
-          ENDDO
-          iflu(ii) = MIN( MAX( i, nxlg ), nxrg )
-          DO  WHILE ( ( coord_x(i) < cg%coord_x(ii) + 0.5_wp * cg%dx )  .AND.  &
-                      ( i < nxrg ) )
-             i = i + 1
-          ENDDO
-          ifuu(ii) = MIN( MAX( i, nxlg ), nxrg )
-          istart = iflu(ii)
-       ENDDO
-
-!
-!--    i-indices of others for each ii-index value
-       istart = nxlg
-       DO  ii = icl, icr
-          i = istart
-          DO  WHILE ( ( coord_x(i) + 0.5_wp * dx < cg%coord_x(ii) )  .AND.     &
-                      ( i < nxrg ) )
-             i = i + 1
-          ENDDO
-          iflo(ii) = MIN( MAX( i, nxlg ), nxrg )
-          DO  WHILE ( ( coord_x(i) + 0.5_wp * dx < cg%coord_x(ii) + cg%dx )    &
-                      .AND.  ( i < nxrg ) )
-             i = i + 1
-          ENDDO
-          ifuo(ii) = MIN(MAX(i,nxlg),nxrg)
-          istart = iflo(ii)
-       ENDDO
-
-!
-!--    j-indices of v for each jj-index value
-       jstart = nysg
-       DO  jj = jcs, jcn
-          j = jstart
-          DO  WHILE ( ( coord_y(j) < cg%coord_y(jj) - 0.5_wp * cg%dy )  .AND.  &
-                      ( j < nyng ) )
-             j = j + 1
-          ENDDO
-          jflv(jj) = MIN( MAX( j, nysg ), nyng )
-          DO  WHILE ( ( coord_y(j) < cg%coord_y(jj) + 0.5_wp * cg%dy )  .AND.  &
-                      ( j < nyng ) )
-             j = j + 1
-          ENDDO
-          jfuv(jj) = MIN( MAX( j, nysg ), nyng )
-          jstart = jflv(jj)
-       ENDDO
-
-!
-!--    j-indices of others for each jj-index value
-       jstart = nysg
-       DO  jj = jcs, jcn
-          j = jstart
-          DO  WHILE ( ( coord_y(j) + 0.5_wp * dy < cg%coord_y(jj) )  .AND.     &
-                      ( j < nyng ) )
-             j = j + 1
-          ENDDO
-          jflo(jj) = MIN( MAX( j, nysg ), nyng )
-          DO  WHILE ( ( coord_y(j) + 0.5_wp * dy < cg%coord_y(jj) + cg%dy )    &
-                      .AND.  ( j < nyng ) )
-             j = j + 1
-          ENDDO
-          jfuo(jj) = MIN( MAX( j, nysg ), nyng )
-          jstart = jflv(jj)
-       ENDDO
-
-!
-!--    k-indices of w for each kk-index value
-       kstart  = 0
-       kflw(0) = 0
-       kfuw(0) = 0
-       DO  kk = 1, kctw
-          k = kstart
-          DO  WHILE ( ( zw(k) < cg%zw(kk) - 0.5_wp * cg%dzw(kk) )  .AND.       &
-                      ( k < nzt ) )
-             k = k + 1
-          ENDDO
-          kflw(kk) = MIN( MAX( k, 1 ), nzt + 1 )
-          DO  WHILE ( ( zw(k) < cg%zw(kk) + 0.5_wp * cg%dzw(kk+1) )  .AND.     &
-                      ( k < nzt ) )
-             k = k + 1
-          ENDDO
-          kfuw(kk) = MIN( MAX( k, 1 ), nzt + 1 )
-          kstart = kflw(kk)
-       ENDDO
-
-!
-!--    k-indices of others for each kk-index value
-       kstart  = 0
-       kflo(0) = 0
-       kfuo(0) = 0
-       DO  kk = 1, kctu
-          k = kstart
-          DO  WHILE ( ( zu(k) < cg%zu(kk) - 0.5_wp * cg%dzu(kk) )  .AND.       &
-                      ( k < nzt ) )
-             k = k + 1
-          ENDDO
-          kflo(kk) = MIN( MAX( k, 1 ), nzt + 1 )
-          DO  WHILE ( ( zu(k) < cg%zu(kk) + 0.5_wp * cg%dzu(kk+1) )  .AND.     &
-                      ( k < nzt ) )
-             k = k + 1
-          ENDDO
-          kfuo(kk) = MIN( MAX( k-1, 1 ), nzt + 1 )
-          kstart = kflo(kk)
-       ENDDO
-     
-!
-!--    Spatial under-relaxation coefficients
-       ALLOCATE( frax(icl:icr) )
-
-       DO  ii = icl, icr
-          IF ( nest_bound_l )  THEN
-             xi = ( MAX( 0.0_wp, ( cg%coord_x(ii) - lower_left_coord_x ) ) /   &
-                    anterp_relax_length_l )**4
-          ELSEIF ( nest_bound_r )  THEN
-             xi = ( MAX( 0.0_wp, ( lower_left_coord_x + ( nx + 1 ) * dx -      &
-                                   cg%coord_x(ii) ) ) /                        &
-                    anterp_relax_length_r )**4
-          ELSE
-             xi = 999999.9_wp
-          ENDIF
-          frax(ii) = xi / ( 1.0_wp + xi )
-       ENDDO
-
-       ALLOCATE( fray(jcs:jcn) )
-
-       DO  jj = jcs, jcn
-          IF ( nest_bound_s )  THEN
-             eta = ( MAX( 0.0_wp, ( cg%coord_y(jj) - lower_left_coord_y ) ) /  &
-                     anterp_relax_length_s )**4
-          ELSEIF ( nest_bound_n )  THEN
-             eta = ( MAX( 0.0_wp, ( lower_left_coord_y + ( ny + 1 ) * dy -     &
-                                    cg%coord_y(jj)) ) /                        &
-                     anterp_relax_length_n )**4
-          ELSE
-             eta = 999999.9_wp
-          ENDIF
-          fray(jj) = eta / ( 1.0_wp + eta )
-       ENDDO
-      
-       ALLOCATE( fraz(0:kctu) )
-       DO  kk = 0, kctu
-          zeta = ( ( zu(nzt) - cg%zu(kk) ) / anterp_relax_length_t )**4
-          fraz(kk) = zeta / ( 1.0_wp + zeta )
-       ENDDO
-
-    END SUBROUTINE pmci_init_anterp_tophat
-
-
-
-    SUBROUTINE pmci_init_tkefactor
-
-!
-!--    Computes the scaling factor for the SGS TKE from coarse grid to be used
-!--    as BC for the fine grid. Based on the Kolmogorov energy spectrum
-!--    for the inertial subrange and assumption of sharp cut-off of the resolved
-!--    energy spectrum. Near the surface, the reduction of TKE is made
-!--    smaller than further away from the surface.
-
-       IMPLICIT NONE
-       REAL(wp), PARAMETER ::  cfw = 0.2_wp          !:
-       REAL(wp), PARAMETER ::  c_tkef = 0.6_wp       !:
-       REAL(wp)            ::  fw                    !:
-       REAL(wp), PARAMETER ::  fw0 = 0.9_wp          !:
-       REAL(wp)            ::  glsf                  !:
-       REAL(wp)            ::  glsc                  !:
-       REAL(wp)            ::  height                !:
-       REAL(wp), PARAMETER ::  p13 = 1.0_wp/3.0_wp   !:
-       REAL(wp), PARAMETER ::  p23 = 2.0_wp/3.0_wp   !:
-       INTEGER(iwp)        ::  k                     !:
-       INTEGER(iwp)        ::  kc                    !:
-        
-
-       IF ( nest_bound_l )  THEN
-          ALLOCATE( tkefactor_l(nzb:nzt+1,nysg:nyng) )
-          tkefactor_l = 0.0_wp
-          i = nxl - 1
-          DO  j = nysg, nyng
-             DO  k = nzb_s_inner(j,i) + 1, nzt
-                kc     = kco(k+1)
-                glsf   = ( dx * dy * dzu(k) )**p13
-                glsc   = ( cg%dx * cg%dy *cg%dzu(kc) )**p13
-                height = zu(k) - zu(nzb_s_inner(j,i))
-                fw     = EXP( -cfw * height / glsf )
-                tkefactor_l(k,j) = c_tkef * ( fw0 * fw + ( 1.0_wp - fw ) *     &
-                                              ( glsf / glsc )**p23 )
-             ENDDO
-             tkefactor_l(nzb_s_inner(j,i),j) = c_tkef * fw0
-          ENDDO
-       ENDIF
-
-       IF ( nest_bound_r )  THEN
-          ALLOCATE( tkefactor_r(nzb:nzt+1,nysg:nyng) )
-          tkefactor_r = 0.0_wp
-          i = nxr + 1
-          DO  j = nysg, nyng
-             DO  k = nzb_s_inner(j,i) + 1, nzt
-                kc     = kco(k+1)
-                glsf   = ( dx * dy * dzu(k) )**p13
-                glsc   = ( cg%dx * cg%dy * cg%dzu(kc) )**p13
-                height = zu(k) - zu(nzb_s_inner(j,i))
-                fw     = EXP( -cfw * height / glsf )
-                tkefactor_r(k,j) = c_tkef * ( fw0 * fw + ( 1.0_wp - fw ) *     &
-                                              ( glsf / glsc )**p23 )
-             ENDDO
-             tkefactor_r(nzb_s_inner(j,i),j) = c_tkef * fw0
-          ENDDO
-       ENDIF
-
-      IF ( nest_bound_s )  THEN
-          ALLOCATE( tkefactor_s(nzb:nzt+1,nxlg:nxrg) )
-          tkefactor_s = 0.0_wp
-          j = nys - 1
-          DO  i = nxlg, nxrg
-             DO  k = nzb_s_inner(j,i) + 1, nzt
-                kc     = kco(k+1)
-                glsf   = ( dx * dy * dzu(k) )**p13
-                glsc   = ( cg%dx * cg%dy * cg%dzu(kc) ) ** p13
-                height = zu(k) - zu(nzb_s_inner(j,i))
-                fw     = EXP( -cfw*height / glsf )
-                tkefactor_s(k,i) = c_tkef * ( fw0 * fw + ( 1.0_wp - fw ) *     &
-                                              ( glsf / glsc )**p23 )
-             ENDDO
-             tkefactor_s(nzb_s_inner(j,i),i) = c_tkef * fw0
-          ENDDO
-       ENDIF
-
-       IF ( nest_bound_n )  THEN
-          ALLOCATE( tkefactor_n(nzb:nzt+1,nxlg:nxrg) )
-          tkefactor_n = 0.0_wp
-          j = nyn + 1
-          DO  i = nxlg, nxrg
-             DO  k = nzb_s_inner(j,i)+1, nzt
-                kc     = kco(k+1)
-                glsf   = ( dx * dy * dzu(k) )**p13
-                glsc   = ( cg%dx * cg%dy * cg%dzu(kc) )**p13
-                height = zu(k) - zu(nzb_s_inner(j,i))
-                fw     = EXP( -cfw * height / glsf )
-                tkefactor_n(k,i) = c_tkef * ( fw0 * fw + ( 1.0_wp - fw ) *     &
-                                              ( glsf / glsc )**p23 )
-             ENDDO
-             tkefactor_n(nzb_s_inner(j,i),i) = c_tkef * fw0
-          ENDDO
-       ENDIF
-
-       ALLOCATE( tkefactor_t(nysg:nyng,nxlg:nxrg) )
-       k = nzt
-       DO  i = nxlg, nxrg
-          DO  j = nysg, nyng
-             kc     = kco(k+1)
-             glsf   = ( dx * dy * dzu(k) )**p13
-             glsc   = ( cg%dx * cg%dy * cg%dzu(kc) )**p13
-             height = zu(k) - zu(nzb_s_inner(j,i))
-             fw     = EXP( -cfw * height / glsf )
-             tkefactor_t(j,i) = c_tkef * ( fw0 * fw + ( 1.0_wp - fw ) *        &
-                                           ( glsf / glsc )**p23 )
-          ENDDO
-       ENDDO
-      
-    END SUBROUTINE pmci_init_tkefactor
-
-#endif
- END SUBROUTINE pmci_setup_client
-
-
-
- SUBROUTINE pmci_setup_coordinates
-
-#if defined( __parallel )
-    IMPLICIT NONE
-
-    INTEGER(iwp) ::  i   !:
-    INTEGER(iwp) ::  j   !:
-
-!
-!-- Create coordinate arrays.
-    ALLOCATE( coord_x(-nbgp:nx+nbgp) )
-    ALLOCATE( coord_y(-nbgp:ny+nbgp) )
-     
-    DO  i = -nbgp, nx + nbgp
-       coord_x(i) = lower_left_coord_x + i * dx
-    ENDDO
-     
-    DO  j = -nbgp, ny + nbgp
-       coord_y(j) = lower_left_coord_y + j * dy
-    ENDDO
-
-#endif
- END SUBROUTINE pmci_setup_coordinates
-
-
-
-
- SUBROUTINE pmci_set_array_pointer( name, client_id, nz_cl )
-
-    IMPLICIT NONE
-
-    INTEGER, INTENT(IN)          ::  client_id   !:
-    INTEGER, INTENT(IN)          ::  nz_cl       !:
-    CHARACTER(LEN=*), INTENT(IN) ::  name        !:
-
-#if defined( __parallel )
-    INTEGER(iwp) ::  ierr        !:
-    INTEGER(iwp) ::  istat       !:
-
-    REAL(wp), POINTER, DIMENSION(:,:)   ::  p_2d        !:
-    REAL(wp), POINTER, DIMENSION(:,:)   ::  p_2d_sec    !:
-    REAL(wp), POINTER, DIMENSION(:,:,:) ::  p_3d        !:
-    REAL(wp), POINTER, DIMENSION(:,:,:) ::  p_3d_sec    !:
-
-
-    NULLIFY( p_3d )
-    NULLIFY( p_2d )
-
-!
-!-- List of array names, which can be coupled.
-!-- In case of 3D please change also the second array for the pointer version
-    IF ( TRIM(name) == "u"  )  p_3d => u
-    IF ( TRIM(name) == "v"  )  p_3d => v
-    IF ( TRIM(name) == "w"  )  p_3d => w
-    IF ( TRIM(name) == "e"  )  p_3d => e
-    IF ( TRIM(name) == "pt" )  p_3d => pt
-    IF ( TRIM(name) == "q"  )  p_3d => q
-!
-!-- Next line is just an example for a 2D array (not active for coupling!)
-!-- Please note, that z0 has to be declared as TARGET array in modules.f90
-!    IF ( TRIM(name) == "z0" )    p_2d => z0
-
-#if defined( __nopointer )
-    IF ( ASSOCIATED( p_3d ) )  THEN
-       CALL pmc_s_set_dataarray( client_id, p_3d, nz_cl, nz )
-    ELSEIF ( ASSOCIATED( p_2d ) )  THEN
-       CALL pmc_s_set_dataarray( client_id, p_2d )
-    ELSE
-!
-!--    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
-#else
-    IF ( TRIM(name) == "u"  )  p_3d_sec => u_2
-    IF ( TRIM(name) == "v"  )  p_3d_sec => v_2
-    IF ( TRIM(name) == "w"  )  p_3d_sec => w_2
-    IF ( TRIM(name) == "e"  )  p_3d_sec => e_2
-    IF ( TRIM(name) == "pt" )  p_3d_sec => pt_2
-    IF ( TRIM(name) == "q"  )  p_3d_sec => q_2
-
-    IF ( ASSOCIATED( p_3d ) )  THEN
-       CALL pmc_s_set_dataarray( client_id, p_3d, nz_cl, nz, &
-                                 array_2 = p_3d_sec )
-    ELSEIF ( ASSOCIATED( p_2d ) )  THEN
-       CALL pmc_s_set_dataarray( client_id, p_2d )
-    ELSE
-!
-!--    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
-
-#endif
- END SUBROUTINE pmci_set_array_pointer
-
-
-
- SUBROUTINE pmci_create_client_arrays( name, is, ie, js, je, nzc  )
-
-    IMPLICIT NONE
-
-    CHARACTER(LEN=*), INTENT(IN) ::  name    !:
-
-    INTEGER(iwp), INTENT(IN) ::  ie      !:
-    INTEGER(iwp), INTENT(IN) ::  is      !:
-    INTEGER(iwp), INTENT(IN) ::  je      !:
-    INTEGER(iwp), INTENT(IN) ::  js      !:
-    INTEGER(iwp), INTENT(IN) ::  nzc     !:  Note that nzc is cg%nz
-
-#if defined( __parallel )
-    INTEGER(iwp) ::  ierr    !:
-    INTEGER(iwp) ::  istat   !:
-
-    REAL(wp), POINTER,DIMENSION(:,:)   ::  p_2d    !:
-    REAL(wp), POINTER,DIMENSION(:,:,:) ::  p_3d    !:
-
-
-    NULLIFY( p_3d )
-    NULLIFY( p_2d )
-
-!
-!-- List of array names, which can be coupled
-    IF ( TRIM( name ) == "u" )  THEN
-       IF ( .NOT. ALLOCATED( uc ) )  ALLOCATE( uc(0:nzc+1, js:je, is:ie) )
-       p_3d => uc
-    ELSEIF ( TRIM( name ) == "v" )  THEN
-       IF ( .NOT. ALLOCATED( vc ) )  ALLOCATE( vc(0:nzc+1, js:je, is:ie) )
-       p_3d => vc
-    ELSEIF ( TRIM( name ) == "w" )  THEN
-       IF ( .NOT. ALLOCATED( wc ) )  ALLOCATE( wc(0:nzc+1, js:je, is:ie) )
-       p_3d => wc
-    ELSEIF ( TRIM( name ) == "e" )  THEN
-       IF ( .NOT. ALLOCATED( ec ) )  ALLOCATE( ec(0:nzc+1, js:je, is:ie) )
-       p_3d => ec
-    ELSEIF ( TRIM( name ) == "pt")  THEN
-       IF ( .NOT. ALLOCATED( ptc ) ) ALLOCATE( ptc(0:nzc+1, js:je, is:ie) )
-       p_3d => ptc
-    ELSEIF ( TRIM( name ) == "q")  THEN
-       IF ( .NOT. ALLOCATED( qc ) ) ALLOCATE( qc(0:nzc+1, js:je, is:ie) )
-       p_3d => qc
-    !ELSEIF (trim(name) == "z0") then
-       !IF (.not.allocated(z0c))  allocate(z0c(js:je, is:ie))
-       !p_2d => z0c
-    ENDIF
-
-    IF ( ASSOCIATED( p_3d ) )  THEN
-       CALL pmc_c_set_dataarray( p_3d )
-    ELSEIF ( ASSOCIATED( p_2d ) )  THEN
-       CALL pmc_c_set_dataarray( p_2d )
-    ELSE
-!
-!--    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
-!
-!--       Prevent others from continuing
-          CALL MPI_BARRIER( comm2d, ierr )
-       ENDIF
-    ENDIF
-
-#endif
- END SUBROUTINE pmci_create_client_arrays
-
-
-
- SUBROUTINE pmci_server_initialize
-!-- TO_DO: add general explanations about what this subroutine does
-#if defined( __parallel )
-    IMPLICIT NONE
-
-    INTEGER(iwp) ::  client_id   !:
-    INTEGER(iwp) ::  m           !:
-
-    REAL(wp) ::  waittime    !:
-
-
-    DO  m = 1, SIZE( pmc_server_for_client ) - 1
-       client_id = pmc_server_for_client(m)
-       CALL pmc_s_fillbuffer( client_id, waittime=waittime )
-    ENDDO
-
-#endif
- END SUBROUTINE pmci_server_initialize
-
-
-
- SUBROUTINE pmci_client_initialize
-!-- TO_DO: add general explanations about what this subroutine does
-#if defined( __parallel )
-    IMPLICIT NONE
-
-    INTEGER(iwp) ::  i          !:
-    INTEGER(iwp) ::  icl        !:
-    INTEGER(iwp) ::  icr        !:
-    INTEGER(iwp) ::  j          !:
-    INTEGER(iwp) ::  jcn        !:
-    INTEGER(iwp) ::  jcs        !:
-
-    REAL(wp) ::  waittime   !:
-
-!
-!-- Root id is never a client
-    IF ( cpl_id > 1 )  THEN
-
-!
-!--    Client domain boundaries in the server index space
-       icl = coarse_bound(1)
-       icr = coarse_bound(2)
-       jcs = coarse_bound(3)
-       jcn = coarse_bound(4)
-
-!
-!--    Get data from server
-       CALL pmc_c_getbuffer( waittime = waittime )
-
-!
-!--    The interpolation.
-       CALL pmci_interp_tril_all ( u,  uc,  icu, jco, kco, r1xu, r2xu, r1yo,   &
-                                   r2yo, r1zo, r2zo, nzb_u_inner, 'u' )
-       CALL pmci_interp_tril_all ( v,  vc,  ico, jcv, kco, r1xo, r2xo, r1yv,   &
-                                   r2yv, r1zo, r2zo, nzb_v_inner, 'v' )
-       CALL pmci_interp_tril_all ( w,  wc,  ico, jco, kcw, r1xo, r2xo, r1yo,   &
-                                   r2yo, r1zw, r2zw, nzb_w_inner, 'w' )
-       CALL pmci_interp_tril_all ( e,  ec,  ico, jco, kco, r1xo, r2xo, r1yo,   &
-                                   r2yo, r1zo, r2zo, nzb_s_inner, 'e' )
-       CALL pmci_interp_tril_all ( pt, ptc, ico, jco, kco, r1xo, r2xo, r1yo,   &
-                                   r2yo, r1zo, r2zo, nzb_s_inner, 's' )
-       IF ( humidity  .OR.  passive_scalar )  THEN
-          CALL pmci_interp_tril_all ( q, qc, ico, jco, kco, r1xo, r2xo, r1yo,  &
-                                      r2yo, r1zo, r2zo, nzb_s_inner, 's' )
-       ENDIF
-
-       IF ( topography /= 'flat' )  THEN
-!
-!--       Inside buildings set velocities and TKE back to zero.
-!--       Other scalars (pt, q, s, km, kh, p, sa, ...) are ignored at present,
-!--       maybe revise later.
-          DO   i = nxlg, nxrg
-             DO   j = nysg, nyng
-                u(nzb:nzb_u_inner(j,i),j,i)   = 0.0_wp
-                v(nzb:nzb_v_inner(j,i),j,i)   = 0.0_wp
-                w(nzb:nzb_w_inner(j,i),j,i)   = 0.0_wp
-                e(nzb:nzb_s_inner(j,i),j,i)   = 0.0_wp
-                u_p(nzb:nzb_u_inner(j,i),j,i) = 0.0_wp
-                v_p(nzb:nzb_v_inner(j,i),j,i) = 0.0_wp
-                w_p(nzb:nzb_w_inner(j,i),j,i) = 0.0_wp
-                e_p(nzb:nzb_s_inner(j,i),j,i) = 0.0_wp
-             ENDDO
-          ENDDO
-       ENDIF
-    ENDIF
-
-
- CONTAINS
-
-
-    SUBROUTINE pmci_interp_tril_all( f, fc, ic, jc, kc, r1x, r2x, r1y, r2y,    &
-                                     r1z, r2z, kb, var )
-!
-!--    Interpolation of the internal values for the client-domain initialization
-!--    This subroutine is based on trilinear interpolation.
-!--    Coding based on interp_tril_lr/sn/t
-       IMPLICIT NONE
-
-       CHARACTER(LEN=1), INTENT(IN) :: var  !:
-
-       INTEGER(iwp), DIMENSION(nxlg:nxrg), INTENT(IN)           ::  ic    !:
-       INTEGER(iwp), DIMENSION(nysg:nyng), INTENT(IN)           ::  jc    !:
-       INTEGER(iwp), DIMENSION(nzb:nzt+1), INTENT(IN)           ::  kc    !:
-       INTEGER(iwp), DIMENSION(nysg:nyng,nxlg:nxrg), INTENT(IN) ::  kb    !:
-
-       INTEGER(iwp) ::  i      !:
-       INTEGER(iwp) ::  ib     !:
-       INTEGER(iwp) ::  ie     !:
-       INTEGER(iwp) ::  j      !:
-       INTEGER(iwp) ::  jb     !:
-       INTEGER(iwp) ::  je     !:
-       INTEGER(iwp) ::  k      !:
-       INTEGER(iwp) ::  k1     !:
-       INTEGER(iwp) ::  kbc    !:
-       INTEGER(iwp) ::  l      !:
-       INTEGER(iwp) ::  m      !:
-       INTEGER(iwp) ::  n      !:
-
-       REAL(wp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg), INTENT(INOUT) :: f !:
-       REAL(wp), DIMENSION(0:cg%nz+1,jcs:jcn,icl:icr), INTENT(IN) :: fc    !:
-       REAL(wp), DIMENSION(nxlg:nxrg), INTENT(IN) :: r1x   !:
-       REAL(wp), DIMENSION(nxlg:nxrg), INTENT(IN) :: r2x   !:
-       REAL(wp), DIMENSION(nysg:nyng), INTENT(IN) :: r1y   !:
-       REAL(wp), DIMENSION(nysg:nyng), INTENT(IN) :: r2y   !:
-       REAL(wp), DIMENSION(nzb:nzt+1), INTENT(IN) :: r1z   !:
-       REAL(wp), DIMENSION(nzb:nzt+1), INTENT(IN) :: r2z   !:
-
-       REAL(wp) ::  fk         !:
-       REAL(wp) ::  fkj        !:
-       REAL(wp) ::  fkjp       !:
-       REAL(wp) ::  fkp        !:
-       REAL(wp) ::  fkpj       !:
-       REAL(wp) ::  fkpjp      !:
-       REAL(wp) ::  logratio   !:
-       REAL(wp) ::  logzuc1    !:
-       REAL(wp) ::  zuc1       !:
-
-
-       ib = nxl
-       ie = nxr
-       jb = nys
-       je = nyn
-       IF ( nest_bound_l )  THEN
-          ib = nxl - 1
-!
-!--       For u, nxl is a ghost node, but not for the other variables
-          IF ( var == 'u' )  THEN
-             ib = nxl
-          ENDIF
-       ENDIF
-       IF ( nest_bound_s )  THEN
-          jb = nys - 1
-!
-!--       For v, nys is a ghost node, but not for the other variables
-          IF ( var == 'v' )  THEN
-             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, ie
-          DO  j = jb, je
-             DO  k = kb(j,i), nzt + 1
-                l = ic(i)
-                m = jc(j)
-                n = kc(k)
-                fkj      = r1x(i) * fc(n,m,l)     + r2x(i) * fc(n,m,l+1)
-                fkjp     = r1x(i) * fc(n,m+1,l)   + r2x(i) * fc(n,m+1,l+1)
-                fkpj     = r1x(i) * fc(n+1,m,l)   + r2x(i) * fc(n+1,m,l+1)
-                fkpjp    = r1x(i) * fc(n+1,m+1,l) + r2x(i) * fc(n+1,m+1,l+1)
-                fk       = r1y(j) * fkj  + r2y(j) * fkjp
-                fkp      = r1y(j) * fkpj + r2y(j) * fkpjp
-                f(k,j,i) = r1z(k) * fk   + r2z(k) * fkp
-             ENDDO
-          ENDDO
-       ENDDO
-
-!
-!--    Correct the interpolated values of u and v in near-wall nodes, i.e. in
-!--    the nodes below the coarse-grid nodes with k=1. The corrction is only
-!--    made over horizontal wall surfaces in this phase. For the nest boundary
-!--    conditions, a corresponding correction is made for all vertical walls,
-!--    too.
-       IF ( var == 'u' .OR. var == 'v' )  THEN
-          DO  i = ib, nxr
-             DO  j = jb, nyn
-                kbc = 1
-!
-!--             kbc is the first coarse-grid point above the surface
-                DO  WHILE ( cg%zu(kbc) < zu(kb(j,i)) )
-                   kbc = kbc + 1
-                ENDDO
-                zuc1 = cg%zu(kbc)
-                k1   = kb(j,i) + 1
-                DO  WHILE ( zu(k1) < zuc1 )
-                   k1 = k1 + 1
-                ENDDO
-                logzuc1 = LOG( ( zu(k1) - zu(kb(j,i)) ) / z0(j,i) )
-
-                k = kb(j,i) + 1
-                DO  WHILE ( zu(k) < zuc1 )
-                   logratio = ( LOG( ( zu(k) - zu(kb(j,i)) ) / z0(j,i)) ) / logzuc1
-                   f(k,j,i) = logratio * f(k1,j,i)
-                   k  = k + 1
-                ENDDO
-                f(kb(j,i),j,i) = 0.0_wp
-             ENDDO
-          ENDDO
-
-       ELSEIF ( var == 'w' )  THEN
-
-          DO  i = ib, nxr
-              DO  j = jb, nyn
-                f(kb(j,i),j,i) = 0.0_wp
-             ENDDO
-          ENDDO
-
-       ENDIF
-
-    END SUBROUTINE pmci_interp_tril_all
-
-#endif
- END SUBROUTINE pmci_client_initialize
-
-
-
- SUBROUTINE pmci_check_setting_mismatches
-!
-!-- Check for mismatches between settings of master and client variables
-!-- (e.g., all clients have to follow the end_time settings of the root model).
-!-- The root model overwrites variables in the other models, so these variables
-!-- only need to be set once in file PARIN.
-
-#if defined( __parallel )
-
-    USE control_parameters,                                                    &
-        ONLY:  dt_restart, end_time, message_string, restart_time, time_restart
-
-    IMPLICIT NONE
-
-    INTEGER ::  ierr
-
-    REAL(wp) ::  dt_restart_root
-    REAL(wp) ::  end_time_root
-    REAL(wp) ::  restart_time_root
-    REAL(wp) ::  time_restart_root
-
-!
-!-- Check the time to be simulated.
-!-- Here, and in the following, the root process communicates the respective
-!-- variable to all others, and its value will then be compared with the local
-!-- values.
-    IF ( pmc_is_rootmodel() )  end_time_root = end_time
-    CALL MPI_BCAST( end_time_root, 1, MPI_REAL, 0, comm_world_nesting, ierr )
-
-    IF ( .NOT. pmc_is_rootmodel() )  THEN
-       IF ( end_time /= end_time_root )  THEN
-          WRITE( message_string, * )  'mismatch between root model and ',      &
-               'client settings &   end_time(root) = ', end_time_root,         &
-               ' &   end_time(client) = ', end_time, ' & client value is set', &
-               ' to root value'
-          CALL message( 'pmci_check_setting_mismatches', 'PA0419', 0, 1, 0, 6, &
-                        0 )
-          end_time = end_time_root
-       ENDIF
-    ENDIF
-
-!
-!-- Same for restart time
-    IF ( pmc_is_rootmodel() )  restart_time_root = restart_time
-    CALL MPI_BCAST( restart_time_root, 1, MPI_REAL, 0, comm_world_nesting, ierr )
-
-    IF ( .NOT. pmc_is_rootmodel() )  THEN
-       IF ( restart_time /= restart_time_root )  THEN
-          WRITE( message_string, * )  'mismatch between root model and ',      &
-               'client settings &   restart_time(root) = ', restart_time_root, &
-               ' &   restart_time(client) = ', restart_time, ' & client ',     &
-               'value is set to root value'
-          CALL message( 'pmci_check_setting_mismatches', 'PA0419', 0, 1, 0, 6, &
-                        0 )
-          restart_time = restart_time_root
-       ENDIF
-    ENDIF
-
-!
-!-- Same for dt_restart
-    IF ( pmc_is_rootmodel() )  dt_restart_root = dt_restart
-    CALL MPI_BCAST( dt_restart_root, 1, MPI_REAL, 0, comm_world_nesting, ierr )
-
-    IF ( .NOT. pmc_is_rootmodel() )  THEN
-       IF ( dt_restart /= dt_restart_root )  THEN
-          WRITE( message_string, * )  'mismatch between root model and ',      &
-               'client settings &   dt_restart(root) = ', dt_restart_root,     &
-               ' &   dt_restart(client) = ', dt_restart, ' & client ',         &
-               'value is set to root value'
-          CALL message( 'pmci_check_setting_mismatches', 'PA0419', 0, 1, 0, 6, &
-                        0 )
-          dt_restart = dt_restart_root
-       ENDIF
-    ENDIF
-
-!
-!-- Same for time_restart
-    IF ( pmc_is_rootmodel() )  time_restart_root = time_restart
-    CALL MPI_BCAST( time_restart_root, 1, MPI_REAL, 0, comm_world_nesting, ierr )
-
-    IF ( .NOT. pmc_is_rootmodel() )  THEN
-       IF ( time_restart /= time_restart_root )  THEN
-          WRITE( message_string, * )  'mismatch between root model and ',      &
-               'client settings &   time_restart(root) = ', time_restart_root, &
-               ' &   time_restart(client) = ', time_restart, ' & client ',     &
-               'value is set to root value'
-          CALL message( 'pmci_check_setting_mismatches', 'PA0419', 0, 1, 0, 6, &
-                        0 )
-          time_restart = time_restart_root
-       ENDIF
-    ENDIF
-
-#endif
-
- END SUBROUTINE pmci_check_setting_mismatches
-
-
-
- SUBROUTINE pmci_ensure_nest_mass_conservation
-
-#if defined( __parallel )
-!
-!-- Adjust the volume-flow rate through the top boundary so that the net volume
-!-- flow through all boundaries of the current nest domain becomes zero.
-    IMPLICIT NONE
-
-    INTEGER(iwp) ::  i                          !:
-    INTEGER(iwp) ::  ierr                       !:
-    INTEGER(iwp) ::  j                          !:
-    INTEGER(iwp) ::  k                          !:
-
-    REAL(wp) ::  dxdy                            !:
-    REAL(wp) ::  innor                           !:
-    REAL(wp) ::  w_lt                            !:
-    REAL(wp), DIMENSION(1:3) ::  volume_flow_l   !:
-
-!
-!-- Sum up the volume flow through the left/right boundaries
-    volume_flow(1)   = 0.0_wp
-    volume_flow_l(1) = 0.0_wp
-
-    IF ( nest_bound_l )  THEN
-       i = 0
-       innor = dy
-       DO   j = nys, nyn
-          DO   k = nzb_u_inner(j,i)+1, nzt
-             volume_flow_l(1) = volume_flow_l(1) + innor * u(k,j,i) * dzw(k)
-          ENDDO
-       ENDDO
-    ENDIF
-
-    IF ( nest_bound_r )  THEN
-       i = nx + 1
-       innor = -dy
-       DO   j = nys, nyn
-          DO   k = nzb_u_inner(j,i)+1, nzt
-             volume_flow_l(1) = volume_flow_l(1) + innor * u(k,j,i) * dzw(k)
-          ENDDO
-       ENDDO
-    ENDIF
-
-#if defined( __parallel )
-    IF ( collective_wait )  CALL MPI_BARRIER( comm2d, ierr )
-    CALL MPI_ALLREDUCE( volume_flow_l(1), volume_flow(1), 1, MPI_REAL, &
-                        MPI_SUM, comm2d, ierr )
-#else
-    volume_flow(1) = volume_flow_l(1)
-#endif
-
-!
-!-- Sum up the volume flow through the south/north boundaries
-    volume_flow(2)   = 0.0_wp
-    volume_flow_l(2) = 0.0_wp
-
-    IF ( nest_bound_s )  THEN
-       j = 0
-       innor = dx
-       DO   i = nxl, nxr
-          DO   k = nzb_v_inner(j,i)+1, nzt
-             volume_flow_l(2) = volume_flow_l(2) + innor * v(k,j,i) * dzw(k)
-          ENDDO
-       ENDDO
-    ENDIF
-
-    IF ( nest_bound_n )  THEN
-       j = ny + 1
-       innor = -dx
-       DO   i = nxl, nxr
-          DO   k = nzb_v_inner(j,i)+1, nzt
-             volume_flow_l(2) = volume_flow_l(2) + innor * v(k,j,i) * dzw(k)
-          ENDDO
-       ENDDO
-    ENDIF
-
-#if defined( __parallel )
-    IF ( collective_wait )  CALL MPI_BARRIER( comm2d, ierr )
-    CALL MPI_ALLREDUCE( volume_flow_l(2), volume_flow(2), 1, MPI_REAL,         &
-                        MPI_SUM, comm2d, ierr )
-#else
-    volume_flow(2) = volume_flow_l(2)
-#endif
-
-!
-!-- Sum up the volume flow through the top boundary
-    volume_flow(3)   = 0.0_wp
-    volume_flow_l(3) = 0.0_wp
-    dxdy = dx * dy
-    k = nzt
-    DO   i = nxl, nxr
-       DO   j = nys, nyn
-          volume_flow_l(3) = volume_flow_l(3) - w(k,j,i) * dxdy
-       ENDDO
-    ENDDO
-
-#if defined( __parallel )
-    IF ( collective_wait )  CALL MPI_BARRIER( comm2d, ierr )
-    CALL MPI_ALLREDUCE( volume_flow_l(3), volume_flow(3), 1, MPI_REAL,         &
-                        MPI_SUM, comm2d, ierr )
-#else
-    volume_flow(3) = volume_flow_l(3)
-#endif
-
-!
-!-- Correct the top-boundary value of w
-    w_lt = (volume_flow(1) + volume_flow(2) + volume_flow(3)) / area_t
-    DO   i = nxl, nxr
-       DO   j = nys, nyn
-          DO  k = nzt, nzt + 1
-             w(k,j,i) = w(k,j,i) + w_lt
-          ENDDO
-       ENDDO
-    ENDDO
-
-#endif
- END SUBROUTINE pmci_ensure_nest_mass_conservation
-
-
-!-- TO_DO: the timestep sycnchronization could be done easier using
-!--        an MPI_ALLREDUCE with MIN over MPI_COMM_WORLD
- SUBROUTINE pmci_server_synchronize
-
-#if defined( __parallel )
-!
-!-- Unify the time steps for each model and synchronize. This is based on the
-!-- assumption that the native time step (original dt_3d) of any server is
-!-- always larger than the smallest native time step of it s clients.
-    IMPLICIT NONE
-
-    INTEGER(iwp) ::  client_id   !:
-    INTEGER(iwp) ::  ierr        !:
-    INTEGER(iwp) ::  m           !:
-
-    REAL(wp), DIMENSION(1) ::  dtc         !:
-    REAL(wp), DIMENSION(1) ::  dtl         !:
-
-
-    CALL cpu_log( log_point_s(70), 'pmc sync', 'start' )
-
-!
-!-- First find the smallest native time step of all the clients of the current
-!-- server.
-    dtl(1) = 999999.9_wp
-    DO  m = 1, SIZE( PMC_Server_for_Client )-1
-       client_id = PMC_Server_for_Client(m)
-       IF ( myid == 0 )  THEN
-          CALL pmc_recv_from_client( client_id, dtc, SIZE( dtc ), 0, 101, ierr )
-          dtl(1) = MIN( dtl(1), dtc(1) )
-          dt_3d   = dtl(1)
-       ENDIF
-    ENDDO
-
-!
-!-- Broadcast the unified time step to all server processes
-    CALL MPI_BCAST( dt_3d, 1, MPI_REAL, 0, comm2d, ierr )
-
-!
-!-- Send the new time step to all the clients of the current server
-    DO  m = 1, SIZE( PMC_Server_for_Client ) - 1
-       client_id = PMC_Server_for_Client(m)
-       IF ( myid == 0 )  THEN
-          CALL pmc_send_to_client( client_id, dtl, SIZE( dtl ), 0, 102, ierr )
-       ENDIF
-    ENDDO
-
-    CALL cpu_log( log_point_s(70), 'pmc sync', 'stop' )
-
-#endif
- END SUBROUTINE pmci_server_synchronize
-
-
-
- SUBROUTINE pmci_client_synchronize
-
-#if defined( __parallel )
-!
-!-- Unify the time steps for each model and synchronize. This is based on the
-!-- assumption that the native time step (original dt_3d) of any server is
-!-- always larger than the smallest native time step of it s clients.
-
-    IMPLICIT NONE
-
-    INTEGER(iwp) ::  ierr   !:
-
-    REAL(wp), DIMENSION(1) ::  dtl    !:
-    REAL(wp), DIMENSION(1) ::  dts    !:
-    
-
-    dtl(1) = dt_3d
-    IF ( cpl_id > 1 )  THEN
-
-       CALL cpu_log( log_point_s(70), 'pmc sync', 'start' )
-
-       IF ( myid==0 )  THEN
-          CALL pmc_send_to_server( dtl, SIZE( dtl ), 0, 101, ierr )
-          CALL pmc_recv_from_server( dts, SIZE( dts ), 0, 102, ierr )
-          dt_3d = dts(1)
-       ENDIF
-
-!
-!--    Broadcast the unified time step to all server processes
-       CALL MPI_BCAST( dt_3d, 1, MPI_REAL, 0, comm2d, ierr )
-
-       CALL cpu_log( log_point_s(70), 'pmc sync', 'stop' )
-
-    ENDIF
-
-#endif
- END SUBROUTINE pmci_client_synchronize
-                
-
-
- SUBROUTINE pmci_set_swaplevel( swaplevel )
-!
-!-- After each Runge-Kutta sub-timestep, alternately set buffer one or buffer
-!-- two active
-
-    IMPLICIT NONE
-
-    INTEGER(iwp),INTENT(IN) ::  swaplevel  !: swaplevel (1 or 2) of PALM's
-                                           !: timestep
-
-    INTEGER(iwp)            ::  client_id  !:
-    INTEGER(iwp)            ::  m          !:
-
-    DO  m = 1, SIZE( pmc_server_for_client )-1
-       client_id = pmc_server_for_client(m)
-       CALL pmc_s_set_active_data_array( client_id, swaplevel )
-    ENDDO
-
- END SUBROUTINE pmci_set_swaplevel
-
-
-
- SUBROUTINE pmci_datatrans( local_nesting_mode )
-!
-!-- Althoug nesting_mode is a variable of this model, pass it as an argument to
-!-- allow for example to force one-way initialization phase
-
-    IMPLICIT NONE
-
-    INTEGER(iwp)           ::  ierr   !:
-    INTEGER(iwp)           ::  istat  !:
-
-    CHARACTER(LEN=*),INTENT(IN) ::  local_nesting_mode
-
-    IF ( local_nesting_mode == 'one-way' )  THEN
-
-       CALL pmci_client_datatrans( server_to_client )
-       CALL pmci_server_datatrans( server_to_client )
-
-    ELSE
-
-       IF( nesting_datatransfer_mode == 'cascade' )  THEN
-
-          CALL pmci_client_datatrans( server_to_client )
-          CALL pmci_server_datatrans( server_to_client )
-
-          CALL pmci_server_datatrans( client_to_server )
-          CALL pmci_client_datatrans( client_to_server )
-
-       ELSEIF( nesting_datatransfer_mode == 'overlap')  THEN
-
-          CALL pmci_server_datatrans( server_to_client )
-          CALL pmci_client_datatrans( server_to_client )
-
-          CALL pmci_client_datatrans( client_to_server )
-          CALL pmci_server_datatrans( client_to_server )
-
-       ELSEIF( TRIM( nesting_datatransfer_mode ) == 'mixed' )  THEN
-
-          CALL pmci_server_datatrans( server_to_client )
-          CALL pmci_client_datatrans( server_to_client )
-
-          CALL pmci_server_datatrans( client_to_server )
-          CALL pmci_client_datatrans( client_to_server )
-
-       ENDIF
-
-    ENDIF
-
- END SUBROUTINE pmci_datatrans
-
-
-
-
- SUBROUTINE pmci_server_datatrans( direction )
-
-    IMPLICIT NONE
-
-    INTEGER(iwp),INTENT(IN) ::  direction   !:
-
-#if defined( __parallel )
-    INTEGER(iwp) ::  client_id   !:
-    INTEGER(iwp) ::  i           !:
-    INTEGER(iwp) ::  j           !:
-    INTEGER(iwp) ::  ierr        !:
-    INTEGER(iwp) ::  m           !:
-
-    REAL(wp)               ::  waittime    !:
-    REAL(wp), DIMENSION(1) ::  dtc         !:
-    REAL(wp), DIMENSION(1) ::  dtl         !:
-
-
-    DO  m = 1, SIZE( PMC_Server_for_Client )-1
-       client_id = PMC_Server_for_Client(m)
-       
-       IF ( direction == server_to_client )  THEN
-          CALL cpu_log( log_point_s(71), 'pmc server send', 'start' )
-          CALL pmc_s_fillbuffer( client_id )
-          CALL cpu_log( log_point_s(71), 'pmc server send', 'stop' )
-       ELSE
-!
-!--       Communication from client to server
-          CALL cpu_log( log_point_s(72), 'pmc server recv', 'start' )
-          client_id = pmc_server_for_client(m)
-          CALL pmc_s_getdata_from_buffer( client_id )
-          CALL cpu_log( log_point_s(72), 'pmc server recv', 'stop' )
-
-!
-!--       The anterpolated data is now available in u etc
-          IF ( topography /= 'flat' )  THEN
-
-!
-!--          Inside buildings/topography reset velocities and TKE back to zero.
-!--          Other scalars (pt, q, s, km, kh, p, sa, ...) are ignored at
-!--          present, maybe revise later.
-             DO   i = nxlg, nxrg
-                DO   j = nysg, nyng
-                   u(nzb:nzb_u_inner(j,i),j,i)  = 0.0_wp
-                   v(nzb:nzb_v_inner(j,i),j,i)  = 0.0_wp
-                   w(nzb:nzb_w_inner(j,i),j,i)  = 0.0_wp
-                   e(nzb:nzb_s_inner(j,i),j,i)  = 0.0_wp
-!
-!--                TO_DO: zero setting of temperature within topography creates
-!--                       wrong results
-!                   pt(nzb:nzb_s_inner(j,i),j,i) = 0.0_wp
-!                   IF ( humidity  .OR.  passive_scalar )  THEN
-!                      q(nzb:nzb_s_inner(j,i),j,i) = 0.0_wp
-!                   ENDIF
-                ENDDO
-             ENDDO
-          ENDIF
-       ENDIF
-    ENDDO
-
-#endif
- END SUBROUTINE pmci_server_datatrans
-
-
-
- SUBROUTINE pmci_client_datatrans( direction )
-
-    IMPLICIT NONE
-
-    INTEGER(iwp), INTENT(IN) ::  direction   !:
-
-#if defined( __parallel )
-    INTEGER(iwp) ::  ierr        !:
-    INTEGER(iwp) ::  icl         !:
-    INTEGER(iwp) ::  icr         !:
-    INTEGER(iwp) ::  jcs         !:
-    INTEGER(iwp) ::  jcn         !:
-    
-    REAL(wp), DIMENSION(1) ::  dtl         !:
-    REAL(wp), DIMENSION(1) ::  dts         !:
-
-
-    dtl = dt_3d
-    IF ( cpl_id > 1 )  THEN
-!
-!--    Client domain boundaries in the server indice space.
-       icl = coarse_bound(1)
-       icr = coarse_bound(2)
-       jcs = coarse_bound(3)
-       jcn = coarse_bound(4)
-
-       IF ( direction == server_to_client )  THEN
-
-          CALL cpu_log( log_point_s(73), 'pmc client recv', 'start' )
-          CALL pmc_c_getbuffer( )
-          CALL cpu_log( log_point_s(73), 'pmc client recv', 'stop' )
-
-          CALL cpu_log( log_point_s(75), 'pmc interpolation', 'start' )
-          CALL pmci_interpolation
-          CALL cpu_log( log_point_s(75), 'pmc interpolation', 'stop' )
-
-       ELSE
-!
-!--       direction == client_to_server
-          CALL cpu_log( log_point_s(76), 'pmc anterpolation', 'start' )
-          CALL pmci_anterpolation
-          CALL cpu_log( log_point_s(76), 'pmc anterpolation', 'stop' )
-
-          CALL cpu_log( log_point_s(74), 'pmc client send', 'start' )
-          CALL pmc_c_putbuffer( )
-          CALL cpu_log( log_point_s(74), 'pmc client send', 'stop' )
-
-       ENDIF
-    ENDIF
-
- CONTAINS
-
-    SUBROUTINE pmci_interpolation
-
-!
-!--    A wrapper routine for all interpolation and extrapolation actions
-       IMPLICIT NONE
-
-!
-!--    Add IF-condition here: IF not vertical nesting
-!--    Left border pe:
-       IF ( nest_bound_l )  THEN
-          CALL pmci_interp_tril_lr( u,  uc,  icu, jco, kco, r1xu, r2xu, r1yo,  &
-                                    r2yo, r1zo, r2zo, nzb_u_inner, logc_u_l,   &
-                                    logc_ratio_u_l, nzt_topo_nestbc_l, 'l',    &
-                                    'u' )
-          CALL pmci_interp_tril_lr( v,  vc,  ico, jcv, kco, r1xo, r2xo, r1yv,  &
-                                    r2yv, r1zo, r2zo, nzb_v_inner, logc_v_l,   &
-                                    logc_ratio_v_l, nzt_topo_nestbc_l, 'l',    &
-                                    'v' )
-          CALL pmci_interp_tril_lr( w,  wc,  ico, jco, kcw, r1xo, r2xo, r1yo,  &
-                                    r2yo, r1zw, r2zw, nzb_w_inner, logc_w_l,   &
-                                    logc_ratio_w_l, nzt_topo_nestbc_l, 'l',    &
-                                    'w' )
-          CALL pmci_interp_tril_lr( e,  ec,  ico, jco, kco, r1xo, r2xo, r1yo,  &
-                                    r2yo, r1zo, r2zo, nzb_s_inner, logc_u_l,   &
-                                    logc_ratio_u_l, nzt_topo_nestbc_l, 'l',    &
-                                    'e' )
-          CALL pmci_interp_tril_lr( pt, ptc, ico, jco, kco, r1xo, r2xo, r1yo,  &
-                                    r2yo, r1zo, r2zo, nzb_s_inner, logc_u_l,   &
-                                    logc_ratio_u_l, nzt_topo_nestbc_l, 'l',    &
-                                    's' )
-          IF ( humidity  .OR.  passive_scalar )  THEN
-             CALL pmci_interp_tril_lr( q, qc, ico, jco, kco, r1xo, r2xo, r1yo, &
-                                       r2yo, r1zo, r2zo, nzb_s_inner,          &
-                                       logc_u_l, logc_ratio_u_l,               &
-                                       nzt_topo_nestbc_l, 'l', 's' )
-          ENDIF
-
-          IF ( nesting_mode == 'one-way' )  THEN
-             CALL pmci_extrap_ifoutflow_lr( u, nzb_u_inner, 'l', 'u' )
-             CALL pmci_extrap_ifoutflow_lr( v, nzb_v_inner, 'l', 'v' )
-             CALL pmci_extrap_ifoutflow_lr( w, nzb_w_inner, 'l', 'w' )
-             CALL pmci_extrap_ifoutflow_lr( e, nzb_s_inner, 'l', 'e' )
-             CALL pmci_extrap_ifoutflow_lr( pt,nzb_s_inner, 'l', 's' )
-             IF ( humidity  .OR.  passive_scalar )  THEN
-                CALL pmci_extrap_ifoutflow_lr( q, nzb_s_inner, 'l', 's' )
-             ENDIF
-          ENDIF
-
-       ENDIF
-!
-!--    Right border pe
-       IF ( nest_bound_r )  THEN
-          CALL pmci_interp_tril_lr( u,  uc,  icu, jco, kco, r1xu, r2xu, r1yo,  &
-                                    r2yo, r1zo, r2zo, nzb_u_inner, logc_u_r,   &
-                                    logc_ratio_u_r, nzt_topo_nestbc_r, 'r',    &
-                                    'u' )
-          CALL pmci_interp_tril_lr( v,  vc,  ico, jcv, kco, r1xo, r2xo, r1yv,  &
-                                    r2yv, r1zo, r2zo, nzb_v_inner, logc_v_r,   &
-                                    logc_ratio_v_r, nzt_topo_nestbc_r, 'r',    &
-                                    'v' )
-          CALL pmci_interp_tril_lr( w,  wc,  ico, jco, kcw, r1xo, r2xo, r1yo,  &
-                                    r2yo, r1zw, r2zw, nzb_w_inner, logc_w_r,   &
-                                    logc_ratio_w_r, nzt_topo_nestbc_r, 'r',    &
-                                    'w' )
-          CALL pmci_interp_tril_lr( e,  ec,  ico, jco, kco, r1xo, r2xo, r1yo,  &
-                                    r2yo, r1zo, r2zo, nzb_s_inner, logc_u_r,   &
-                                    logc_ratio_u_r, nzt_topo_nestbc_r, 'r',    &
-                                    'e' )
-          CALL pmci_interp_tril_lr( pt, ptc, ico, jco, kco, r1xo, r2xo, r1yo,  &
-                                    r2yo, r1zo, r2zo, nzb_s_inner, logc_u_r,   &
-                                    logc_ratio_u_r, nzt_topo_nestbc_r, 'r',    &
-                                    's' )
-          IF ( humidity  .OR.  passive_scalar )  THEN
-             CALL pmci_interp_tril_lr( q, qc, ico, jco, kco, r1xo, r2xo, r1yo, &
-                                       r2yo, r1zo, r2zo, nzb_s_inner,          &
-                                       logc_u_r, logc_ratio_u_r,               &
-                                       nzt_topo_nestbc_r, 'r', 's' )
-          ENDIF
-
-          IF ( nesting_mode == 'one-way' )  THEN
-             CALL pmci_extrap_ifoutflow_lr( u, nzb_u_inner, 'r', 'u' )
-             CALL pmci_extrap_ifoutflow_lr( v, nzb_v_inner, 'r', 'v' )
-             CALL pmci_extrap_ifoutflow_lr( w, nzb_w_inner, 'r', 'w' )
-             CALL pmci_extrap_ifoutflow_lr( e, nzb_s_inner, 'r', 'e' )
-             CALL pmci_extrap_ifoutflow_lr( pt,nzb_s_inner, 'r', 's' )
-             IF ( humidity  .OR.  passive_scalar )  THEN
-                CALL pmci_extrap_ifoutflow_lr( q, nzb_s_inner, 'r', 's' )
-             ENDIF
-          ENDIF
-
-       ENDIF
-!
-!--    South border pe
-       IF ( nest_bound_s )  THEN
-          CALL pmci_interp_tril_sn( u,  uc,  icu, jco, kco, r1xu, r2xu, r1yo,  &
-                                    r2yo, r1zo, r2zo, nzb_u_inner, logc_u_s,   &
-                                    logc_ratio_u_s, nzt_topo_nestbc_s, 's',    &
-                                    'u' )
-          CALL pmci_interp_tril_sn( v,  vc,  ico, jcv, kco, r1xo, r2xo, r1yv,  &
-                                    r2yv, r1zo, r2zo, nzb_v_inner, logc_v_s,   &
-                                    logc_ratio_v_s, nzt_topo_nestbc_s, 's',    &
-                                    'v' )
-          CALL pmci_interp_tril_sn( w,  wc,  ico, jco, kcw, r1xo, r2xo, r1yo,  &
-                                    r2yo, r1zw, r2zw, nzb_w_inner, logc_w_s,   &
-                                    logc_ratio_w_s, nzt_topo_nestbc_s, 's',    &
-                                    'w' )
-          CALL pmci_interp_tril_sn( e,  ec,  ico, jco, kco, r1xo, r2xo, r1yo,  &
-                                    r2yo, r1zo, r2zo, nzb_s_inner, logc_u_s,   &
-                                    logc_ratio_u_s, nzt_topo_nestbc_s, 's',    &
-                                    'e' )
-          CALL pmci_interp_tril_sn( pt, ptc, ico, jco, kco, r1xo, r2xo, r1yo,  &
-                                    r2yo, r1zo, r2zo, nzb_s_inner, logc_u_s,   &
-                                    logc_ratio_u_s, nzt_topo_nestbc_s, 's',    &
-                                    's' )
-          IF ( humidity  .OR.  passive_scalar )  THEN
-             CALL pmci_interp_tril_sn( q, qc, ico, jco, kco, r1xo, r2xo, r1yo, &
-                                       r2yo, r1zo, r2zo, nzb_s_inner,          &
-                                       logc_u_s, logc_ratio_u_s,               &
-                                       nzt_topo_nestbc_s, 's', 's' )
-          ENDIF
-
-          IF ( nesting_mode == 'one-way' )  THEN
-             CALL pmci_extrap_ifoutflow_sn( u, nzb_u_inner, 's', 'u' )
-             CALL pmci_extrap_ifoutflow_sn( v, nzb_v_inner, 's', 'v' )
-             CALL pmci_extrap_ifoutflow_sn( w, nzb_w_inner, 's', 'w' )
-             CALL pmci_extrap_ifoutflow_sn( e, nzb_s_inner, 's', 'e' )
-             CALL pmci_extrap_ifoutflow_sn( pt,nzb_s_inner, 's', 's' )
-             IF ( humidity  .OR.  passive_scalar )  THEN
-                CALL pmci_extrap_ifoutflow_sn( q, nzb_s_inner, 's', 's' )
-             ENDIF
-          ENDIF
-
-       ENDIF
-!
-!--    North border pe
-       IF ( nest_bound_n )  THEN
-          CALL pmci_interp_tril_sn( u,  uc,  icu, jco, kco, r1xu, r2xu, r1yo,  &
-                                    r2yo, r1zo, r2zo, nzb_u_inner, logc_u_n,   &
-                                    logc_ratio_u_n, nzt_topo_nestbc_n, 'n',    &
-                                    'u' )
-          CALL pmci_interp_tril_sn( v,  vc,  ico, jcv, kco, r1xo, r2xo, r1yv,  &
-                                    r2yv, r1zo, r2zo, nzb_v_inner, logc_v_n,   &
-                                    logc_ratio_v_n, nzt_topo_nestbc_n, 'n',    &
-                                    'v' )
-          CALL pmci_interp_tril_sn( w,  wc,  ico, jco, kcw, r1xo, r2xo, r1yo,  &
-                                    r2yo, r1zw, r2zw, nzb_w_inner, logc_w_n,   &
-                                    logc_ratio_w_n, nzt_topo_nestbc_n, 'n',    &
-                                    'w' )
-          CALL pmci_interp_tril_sn( e,  ec,  ico, jco, kco, r1xo, r2xo, r1yo,  &
-                                    r2yo, r1zo, r2zo, nzb_s_inner, logc_u_n,   &
-                                    logc_ratio_u_n, nzt_topo_nestbc_n, 'n',    &
-                                    'e' )
-          CALL pmci_interp_tril_sn( pt, ptc, ico, jco, kco, r1xo, r2xo, r1yo,  &
-                                    r2yo, r1zo, r2zo, nzb_s_inner, logc_u_n,   &
-                                    logc_ratio_u_n, nzt_topo_nestbc_n, 'n',    &
-                                    's' )
-          IF ( humidity  .OR.  passive_scalar )  THEN
-             CALL pmci_interp_tril_sn( q, qc, ico, jco, kco, r1xo, r2xo, r1yo, &
-                                       r2yo, r1zo, r2zo, nzb_s_inner,          &
-                                       logc_u_n, logc_ratio_u_n,               &
-                                       nzt_topo_nestbc_n, 'n', 's' )
-          ENDIF
-
-          IF ( nesting_mode == 'one-way' )  THEN
-             CALL pmci_extrap_ifoutflow_sn( u, nzb_u_inner, 'n', 'u' )
-             CALL pmci_extrap_ifoutflow_sn( v, nzb_v_inner, 'n', 'v' )
-             CALL pmci_extrap_ifoutflow_sn( w, nzb_w_inner, 'n', 'w' )
-             CALL pmci_extrap_ifoutflow_sn( e, nzb_s_inner, 'n', 'e' )
-             CALL pmci_extrap_ifoutflow_sn( pt,nzb_s_inner, 'n', 's' )
-             IF ( humidity  .OR.  passive_scalar )  THEN
-                CALL pmci_extrap_ifoutflow_sn( q, nzb_s_inner, 'n', 's' )
-             ENDIF
-
-          ENDIF
-
-       ENDIF
-
-!
-!--    All PEs are top-border PEs
-       CALL pmci_interp_tril_t( u,  uc,  icu, jco, kco, r1xu, r2xu, r1yo,      &
-                                r2yo, r1zo, r2zo, 'u' )
-       CALL pmci_interp_tril_t( v,  vc,  ico, jcv, kco, r1xo, r2xo, r1yv,      &
-                                r2yv, r1zo, r2zo, 'v' )
-       CALL pmci_interp_tril_t( w,  wc,  ico, jco, kcw, r1xo, r2xo, r1yo,      &
-                                r2yo, r1zw, r2zw, 'w' )
-       CALL pmci_interp_tril_t( e,  ec,  ico, jco, kco, r1xo, r2xo, r1yo,      &
-                                r2yo, r1zo, r2zo, 'e' )
-       CALL pmci_interp_tril_t( pt, ptc, ico, jco, kco, r1xo, r2xo, r1yo,      &
-                                r2yo, r1zo, r2zo, 's' )
-       IF ( humidity .OR. passive_scalar )  THEN
-          CALL pmci_interp_tril_t( q, qc, ico, jco, kco, r1xo, r2xo, r1yo,     &
-                                   r2yo, r1zo, r2zo, 's' )
-       ENDIF
-
-       IF ( nesting_mode == 'one-way' )  THEN
-          CALL pmci_extrap_ifoutflow_t( u,  'u' )
-          CALL pmci_extrap_ifoutflow_t( v,  'v' )
-          CALL pmci_extrap_ifoutflow_t( w,  'w' )
-          CALL pmci_extrap_ifoutflow_t( e,  'e' )
-          CALL pmci_extrap_ifoutflow_t( pt, 's' )
-          IF ( humidity  .OR.  passive_scalar )  THEN
-             CALL pmci_extrap_ifoutflow_t( q, 's' )
-          ENDIF
-      ENDIF
-
-   END SUBROUTINE pmci_interpolation
-
-
-
-   SUBROUTINE pmci_anterpolation
-
-!
-!--   A wrapper routine for all anterpolation actions.
-      IMPLICIT NONE
-
-      CALL pmci_anterp_tophat( u,  uc,  kctu, iflu, ifuu, jflo, jfuo, kflo,    &
-                               kfuo, 'u' )
-      CALL pmci_anterp_tophat( v,  vc,  kctu, iflo, ifuo, jflv, jfuv, kflo,    &
-                               kfuo, 'v' )
-      CALL pmci_anterp_tophat( w,  wc,  kctw, iflo, ifuo, jflo, jfuo, kflw,    &
-                               kfuw, 'w' )
-      CALL pmci_anterp_tophat( pt, ptc, kctu, iflo, ifuo, jflo, jfuo, kflo,    &
-                               kfuo, 's' )
-      IF ( humidity  .OR.  passive_scalar )  THEN
-         CALL pmci_anterp_tophat( q, qc, kctu, iflo, ifuo, jflo, jfuo, kflo,   &
-                                  kfuo, 's' )
-      ENDIF
-
-   END SUBROUTINE pmci_anterpolation
-
-
-
-   SUBROUTINE pmci_interp_tril_lr( f, fc, ic, jc, kc, r1x, r2x, r1y, r2y, r1z, &
-                                   r2z, kb, logc, logc_ratio, nzt_topo_nestbc, &
-                                   edge, var )
-!
-!--   Interpolation of ghost-node values used as the client-domain boundary
-!--   conditions. This subroutine handles the left and right boundaries. It is
-!--   based on trilinear interpolation.
-
-      IMPLICIT NONE
-
-      REAL(wp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg),                      &
-                                      INTENT(INOUT) ::  f       !:
-      REAL(wp), DIMENSION(0:cg%nz+1,jcs:jcn,icl:icr),                          &
-                                      INTENT(IN)    ::  fc      !:
-      REAL(wp), DIMENSION(nzb:nzt_topo_nestbc,nys:nyn,1:2,0:ncorr-1),          &
-                                      INTENT(IN)    ::  logc_ratio   !:
-      REAL(wp), DIMENSION(nxlg:nxrg), INTENT(IN)    ::  r1x     !:
-      REAL(wp), DIMENSION(nxlg:nxrg), INTENT(IN)    ::  r2x     !:
-      REAL(wp), DIMENSION(nysg:nyng), INTENT(IN)    ::  r1y     !:
-      REAL(wp), DIMENSION(nysg:nyng), INTENT(IN)    ::  r2y     !:
-      REAL(wp), DIMENSION(nzb:nzt+1), INTENT(IN)    ::  r1z     !:
-      REAL(wp), DIMENSION(nzb:nzt+1), INTENT(IN)    ::  r2z     !:
-      
-      INTEGER(iwp), DIMENSION(nxlg:nxrg), INTENT(IN)           ::  ic     !:
-      INTEGER(iwp), DIMENSION(nysg:nyng), INTENT(IN)           ::  jc     !:
-      INTEGER(iwp), DIMENSION(nysg:nyng,nxlg:nxrg), INTENT(IN) ::  kb     !:
-      INTEGER(iwp), DIMENSION(nzb:nzt+1), INTENT(IN)           ::  kc     !:
-      INTEGER(iwp), DIMENSION(nzb:nzt_topo_nestbc,nys:nyn,1:2),                &
-                                          INTENT(IN)           ::  logc   !:
-      INTEGER(iwp) ::  nzt_topo_nestbc   !:
-
-      CHARACTER(LEN=1),INTENT(IN) ::  edge   !:
-      CHARACTER(LEN=1),INTENT(IN) ::  var    !:
-
-      INTEGER(iwp) ::  i       !:
-      INTEGER(iwp) ::  ib      !:
-      INTEGER(iwp) ::  ibgp    !:
-      INTEGER(iwp) ::  iw      !:
-      INTEGER(iwp) ::  j       !:
-      INTEGER(iwp) ::  jco     !:
-      INTEGER(iwp) ::  jcorr   !:
-      INTEGER(iwp) ::  jinc    !:
-      INTEGER(iwp) ::  jw      !:
-      INTEGER(iwp) ::  j1      !:
-      INTEGER(iwp) ::  k       !:
-      INTEGER(iwp) ::  kco     !:
-      INTEGER(iwp) ::  kcorr   !:
-      INTEGER(iwp) ::  k1      !:
-      INTEGER(iwp) ::  l       !:
-      INTEGER(iwp) ::  m       !:
-      INTEGER(iwp) ::  n       !:
-      INTEGER(iwp) ::  kbc     !:
-      
-      REAL(wp) ::  coarse_dx   !:
-      REAL(wp) ::  coarse_dy   !:
-      REAL(wp) ::  coarse_dz   !:
-      REAL(wp) ::  fkj         !:
-      REAL(wp) ::  fkjp        !:
-      REAL(wp) ::  fkpj        !:
-      REAL(wp) ::  fkpjp       !:
-      REAL(wp) ::  fk          !:
-      REAL(wp) ::  fkp         !:
-      
-! 
-!--   Check which edge is to be handled
-      IF ( edge == 'l' )  THEN
-!
-!--      For u, nxl is a ghost node, but not for the other variables
-         IF ( var == 'u' )  THEN
-            i  = nxl
-            ib = nxl - 1 
-         ELSE
-            i  = nxl - 1
-            ib = nxl - 2
-         ENDIF
-      ELSEIF ( edge == 'r' )  THEN
-         i  = nxr + 1
-         ib = nxr + 2
-      ENDIF
-      
-      DO  j = nys, nyn+1
-         DO  k = kb(j,i), nzt+1
-            l = ic(i)
-            m = jc(j)
-            n = kc(k)
-            fkj      = r1x(i) * fc(n,m,l)     + r2x(i) * fc(n,m,l+1)
-            fkjp     = r1x(i) * fc(n,m+1,l)   + r2x(i) * fc(n,m+1,l+1)
-            fkpj     = r1x(i) * fc(n+1,m,l)   + r2x(i) * fc(n+1,m,l+1)
-            fkpjp    = r1x(i) * fc(n+1,m+1,l) + r2x(i) * fc(n+1,m+1,l+1)
-            fk       = r1y(j) * fkj  + r2y(j) * fkjp
-            fkp      = r1y(j) * fkpj + r2y(j) * fkpjp
-            f(k,j,i) = r1z(k) * fk   + r2z(k) * fkp
-         ENDDO
-      ENDDO
-
-!
-!--   Generalized log-law-correction algorithm.
-!--   Doubly two-dimensional index arrays logc(:,:,1:2) and log-ratio arrays 
-!--   logc_ratio(:,:,1:2,0:ncorr-1) have been precomputed in subroutine
-!--   pmci_init_loglaw_correction.
-!
-!--   Solid surface below the node 
-      IF ( var == 'u' .OR. var == 'v' )  THEN           
-         DO  j = nys, nyn
-            k = kb(j,i)+1
-            IF ( ( logc(k,j,1) /= 0 )  .AND.  ( logc(k,j,2) == 0 ) )  THEN
-               k1 = logc(k,j,1)
-               DO  kcorr=0,ncorr - 1
-                  kco = k + kcorr
-                  f(kco,j,i) = logc_ratio(k,j,1,kcorr) * f(k1,j,i)
-               ENDDO
-            ENDIF
-         ENDDO
-      ENDIF
-
-!
-!--   In case of non-flat topography, also vertical walls and corners need to be
-!--   treated. Only single and double wall nodes are corrected. Triple and
-!--   higher-multiple wall nodes are not corrected as the log law would not be
-!--   valid anyway in such locations.
-      IF ( topography /= 'flat' )  THEN
-         IF ( var == 'u' .OR. var == 'w' )  THEN                 
-
-!
-!--         Solid surface only on south/north side of the node                   
-            DO  j = nys, nyn
-               DO  k = kb(j,i)+1, nzt_topo_nestbc
-                  IF ( ( logc(k,j,2) /= 0 )  .AND.  ( logc(k,j,1) == 0 ) )  THEN
-
-!
-!--                  Direction of the wall-normal index is carried in as the
-!--                  sign of logc
-                     jinc = SIGN( 1, logc(k,j,2) )
-                     j1   = ABS( logc(k,j,2) )
-                     DO  jcorr = 0, ncorr-1
-                        jco = j + jinc * jcorr
-                        f(k,jco,i) = logc_ratio(k,j,2,jcorr) * f(k,j1,i)
-                     ENDDO
-                  ENDIF
-               ENDDO
-            ENDDO
-         ENDIF
-
-!
-!--      Solid surface on both below and on south/north side of the node           
-         IF ( var == 'u' )  THEN
-            DO  j = nys, nyn
-               k = kb(j,i) + 1
-               IF ( ( logc(k,j,2) /= 0 )  .AND.  ( logc(k,j,1) /= 0 ) )  THEN
-                  k1   = logc(k,j,1)                 
-                  jinc = SIGN( 1, logc(k,j,2) )
-                  j1   = ABS( logc(k,j,2) )                 
-                  DO  jcorr = 0, ncorr-1
-                     jco = j + jinc * jcorr
-                     DO  kcorr = 0, ncorr-1
-                        kco = k + kcorr
-                        f(kco,jco,i) = 0.5_wp * ( logc_ratio(k,j,1,kcorr) *    &
-                                                  f(k1,j,i)                    &
-                                                + logc_ratio(k,j,2,jcorr) *    &
-                                                  f(k,j1,i) )
-                     ENDDO
-                  ENDDO
-               ENDIF
-            ENDDO
-         ENDIF
-
-      ENDIF  ! ( topography /= 'flat' )
-
-!
-!--   Rescale if f is the TKE.
-      IF ( var == 'e')  THEN
-         IF ( edge == 'l' )  THEN
-            DO  j = nys, nyn + 1
-               DO  k = kb(j,i), nzt + 1
-                  f(k,j,i) = tkefactor_l(k,j) * f(k,j,i)
-               ENDDO
-            ENDDO
-         ELSEIF ( edge == 'r' )  THEN           
-            DO  j = nys, nyn+1
-               DO  k = kb(j,i), nzt+1
-                  f(k,j,i) = tkefactor_r(k,j) * f(k,j,i)
-               ENDDO
-            ENDDO
-         ENDIF
-      ENDIF
-
-!
-!--   Store the boundary values also into the other redundant ghost node layers
-      IF ( edge == 'l' )  THEN
-         DO  ibgp = -nbgp, ib
-            f(0:nzt+1,nysg:nyng,ibgp) = f(0:nzt+1,nysg:nyng,i)
-         ENDDO
-      ELSEIF ( edge == 'r' )  THEN
-         DO  ibgp = ib, nx+nbgp
-            f(0:nzt+1,nysg:nyng,ibgp) = f(0:nzt+1,nysg:nyng,i)
-         ENDDO
-      ENDIF
-
-   END SUBROUTINE pmci_interp_tril_lr
-
-
-
-   SUBROUTINE pmci_interp_tril_sn( f, fc, ic, jc, kc, r1x, r2x, r1y, r2y, r1z, &
-                                   r2z, kb, logc, logc_ratio,                  &
-                                   nzt_topo_nestbc, edge, var )
-
-!
-!--   Interpolation of ghost-node values used as the client-domain boundary
-!--   conditions. This subroutine handles the south and north boundaries. 
-!--   This subroutine is based on trilinear interpolation.
-
-      IMPLICIT NONE
-
-      REAL(wp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg),                      &
-                                      INTENT(INOUT) ::  f             !:
-      REAL(wp), DIMENSION(0:cg%nz+1,jcs:jcn,icl:icr),                          &
-                                      INTENT(IN)    ::  fc            !:
-      REAL(wp), DIMENSION(nzb:nzt_topo_nestbc,nxl:nxr,1:2,0:ncorr-1),          &
-                                      INTENT(IN)    ::  logc_ratio    !:
-      REAL(wp), DIMENSION(nxlg:nxrg), INTENT(IN)    ::  r1x           !:
-      REAL(wp), DIMENSION(nxlg:nxrg), INTENT(IN)    ::  r2x           !:
-      REAL(wp), DIMENSION(nysg:nyng), INTENT(IN)    ::  r1y           !:
-      REAL(wp), DIMENSION(nysg:nyng), INTENT(IN)    ::  r2y           !:
-      REAL(wp), DIMENSION(nzb:nzt+1), INTENT(IN)    ::  r1z           !:
-      REAL(wp), DIMENSION(nzb:nzt+1), INTENT(IN)    ::  r2z           !:
-      
-      INTEGER(iwp), DIMENSION(nxlg:nxrg), INTENT(IN)           ::  ic    !:
-      INTEGER(iwp), DIMENSION(nysg:nyng), INTENT(IN)           ::  jc    !:
-      INTEGER(iwp), DIMENSION(nysg:nyng,nxlg:nxrg), INTENT(IN) ::  kb    !:
-      INTEGER(iwp), DIMENSION(nzb:nzt+1), INTENT(IN)           ::  kc    !:
-      INTEGER(iwp), DIMENSION(nzb:nzt_topo_nestbc,nxl:nxr,1:2),                &
-                                          INTENT(IN)           ::  logc  !:
-      INTEGER(iwp) ::  nzt_topo_nestbc   !:
-
-      CHARACTER(LEN=1), INTENT(IN) ::  edge   !:
-      CHARACTER(LEN=1), INTENT(IN) ::  var    !:
-      
-      INTEGER(iwp) ::  i       !:
-      INTEGER(iwp) ::  iinc    !:
-      INTEGER(iwp) ::  icorr   !:
-      INTEGER(iwp) ::  ico     !:
-      INTEGER(iwp) ::  i1      !:
-      INTEGER(iwp) ::  j       !:
-      INTEGER(iwp) ::  jb      !:
-      INTEGER(iwp) ::  jbgp    !:
-      INTEGER(iwp) ::  k       !:
-      INTEGER(iwp) ::  kcorr   !:
-      INTEGER(iwp) ::  kco     !:
-      INTEGER(iwp) ::  k1      !:
-      INTEGER(iwp) ::  l       !:
-      INTEGER(iwp) ::  m       !:
-      INTEGER(iwp) ::  n       !:
-                            
-      REAL(wp) ::  coarse_dx   !:
-      REAL(wp) ::  coarse_dy   !:
-      REAL(wp) ::  coarse_dz   !:
-      REAL(wp) ::  fk          !:
-      REAL(wp) ::  fkj         !:
-      REAL(wp) ::  fkjp        !:
-      REAL(wp) ::  fkpj        !:
-      REAL(wp) ::  fkpjp       !:
-      REAL(wp) ::  fkp         !:
-      
-!
-!--   Check which edge is to be handled: south or north
-      IF ( edge == 's' )  THEN
-!
-!--      For v, nys is a ghost node, but not for the other variables
-         IF ( var == 'v' )  THEN
-            j  = nys
-            jb = nys - 1 
-         ELSE
-            j  = nys - 1
-            jb = nys - 2
-         ENDIF
-      ELSEIF ( edge == 'n' )  THEN
-         j  = nyn + 1
-         jb = nyn + 2
-      ENDIF
-
-      DO  i = nxl, nxr+1
-         DO  k = kb(j,i), nzt+1
-            l = ic(i)
-            m = jc(j)
-            n = kc(k)              
-            fkj      = r1x(i) * fc(n,m,l)     + r2x(i) * fc(n,m,l+1)
-            fkjp     = r1x(i) * fc(n,m+1,l)   + r2x(i) * fc(n,m+1,l+1)
-            fkpj     = r1x(i) * fc(n+1,m,l)   + r2x(i) * fc(n+1,m,l+1)
-            fkpjp    = r1x(i) * fc(n+1,m+1,l) + r2x(i) * fc(n+1,m+1,l+1)
-            fk       = r1y(j) * fkj  + r2y(j) * fkjp
-            fkp      = r1y(j) * fkpj + r2y(j) * fkpjp
-            f(k,j,i) = r1z(k) * fk   + r2z(k) * fkp
-         ENDDO
-      ENDDO
-
-!
-!--   Generalized log-law-correction algorithm.
-!--   Multiply two-dimensional index arrays logc(:,:,1:2) and log-ratio arrays 
-!--   logc_ratio(:,:,1:2,0:ncorr-1) have been precomputed in subroutine
-!--   pmci_init_loglaw_correction.
-!
-!--   Solid surface below the node 
-      IF ( var == 'u'  .OR.  var == 'v' )  THEN           
-         DO  i = nxl, nxr
-            k = kb(j,i) + 1
-            IF ( ( logc(k,i,1) /= 0 )  .AND.  ( logc(k,i,2) == 0 ) )  THEN
-               k1 = logc(k,i,1)
-               DO  kcorr = 0, ncorr-1
-                  kco = k + kcorr
-                  f(kco,j,i) = logc_ratio(k,i,1,kcorr) * f(k1,j,i)
-               ENDDO
-            ENDIF
-         ENDDO
-      ENDIF
-
-!
-!--   In case of non-flat topography, also vertical walls and corners need to be
-!--   treated. Only single and double wall nodes are corrected.
-!--   Triple and higher-multiple wall nodes are not corrected as it would be
-!--   extremely complicated and the log law would not be valid anyway in such
-!--   locations.
-      IF ( topography /= 'flat' )  THEN
-         IF ( var == 'v' .OR. var == 'w' )  THEN
-            DO  i = nxl, nxr
-               DO  k = kb(j,i), nzt_topo_nestbc
-
-!
-!--               Solid surface only on left/right side of the node           
-                  IF ( ( logc(k,i,2) /= 0 )  .AND.  ( logc(k,i,1) == 0 ) )  THEN
-
-!
-!--                  Direction of the wall-normal index is carried in as the
-!--                  sign of logc
-                     iinc = SIGN( 1, logc(k,i,2) )
-                     i1  = ABS( logc(k,i,2) )
-                     DO  icorr = 0, ncorr-1
-                        ico = i + iinc * icorr
-                        f(k,j,ico) = logc_ratio(k,i,2,icorr) * f(k,j,i1)
-                     ENDDO
-                  ENDIF
-               ENDDO
-            ENDDO
-         ENDIF
-
-!
-!--      Solid surface on both below and on left/right side of the node           
-         IF ( var == 'v' )  THEN
-            DO  i = nxl, nxr
-               k = kb(j,i) + 1
-               IF ( ( logc(k,i,2) /= 0 )  .AND.  ( logc(k,i,1) /= 0 ) )  THEN
-                  k1   = logc(k,i,1)         
-                  iinc = SIGN( 1, logc(k,i,2) )
-                  i1   = ABS( logc(k,i,2) )
-                  DO  icorr = 0, ncorr-1
-                     ico = i + iinc * icorr
-                     DO  kcorr = 0, ncorr-1
-                        kco = k + kcorr
-                        f(kco,i,ico) = 0.5_wp * ( logc_ratio(k,i,1,kcorr) *    &
-                                                  f(k1,j,i)  &
-                                                + logc_ratio(k,i,2,icorr) *    &
-                                                  f(k,j,i1) )
-                     ENDDO
-                  ENDDO
-               ENDIF
-            ENDDO
-         ENDIF
-         
-      ENDIF  ! ( topography /= 'flat' )
-
-!
-!--   Rescale if f is the TKE.
-      IF ( var == 'e')  THEN
-         IF ( edge == 's' )  THEN
-            DO  i = nxl, nxr + 1
-               DO  k = kb(j,i), nzt+1
-                  f(k,j,i) = tkefactor_s(k,i) * f(k,j,i)
-               ENDDO
-            ENDDO
-         ELSEIF ( edge == 'n' )  THEN
-            DO  i = nxl, nxr + 1
-               DO  k = kb(j,i), nzt+1
-                  f(k,j,i) = tkefactor_n(k,i) * f(k,j,i)
-               ENDDO
-            ENDDO
-         ENDIF
-      ENDIF
-
-!
-!--   Store the boundary values also into the other redundant ghost node layers
-      IF ( edge == 's' )  THEN
-         DO  jbgp = -nbgp, jb
-            f(0:nzt+1,jbgp,nxlg:nxrg) = f(0:nzt+1,j,nxlg:nxrg)
-         ENDDO
-      ELSEIF ( edge == 'n' )  THEN
-         DO  jbgp = jb, ny+nbgp
-            f(0:nzt+1,jbgp,nxlg:nxrg) = f(0:nzt+1,j,nxlg:nxrg)
-         ENDDO
-      ENDIF
-
-   END SUBROUTINE pmci_interp_tril_sn
-
- 
-
-   SUBROUTINE pmci_interp_tril_t( f, fc, ic, jc, kc, r1x, r2x, r1y, r2y, r1z,  &
-                                  r2z, var )
-
-!
-!--   Interpolation of ghost-node values used as the client-domain boundary
-!--   conditions. This subroutine handles the top boundary. 
-!--   This subroutine is based on trilinear interpolation.
-
-      IMPLICIT NONE
-
-      REAL(wp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg),                      &
-                                      INTENT(INOUT) ::  f     !:
-      REAL(wp), DIMENSION(0:cg%nz+1,jcs:jcn,icl:icr),                          &
-                                      INTENT(IN)    ::  fc    !:
-      REAL(wp), DIMENSION(nxlg:nxrg), INTENT(IN)    ::  r1x   !:
-      REAL(wp), DIMENSION(nxlg:nxrg), INTENT(IN)    ::  r2x   !:
-      REAL(wp), DIMENSION(nysg:nyng), INTENT(IN)    ::  r1y   !:
-      REAL(wp), DIMENSION(nysg:nyng), INTENT(IN)    ::  r2y   !:
-      REAL(wp), DIMENSION(nzb:nzt+1), INTENT(IN)    ::  r1z   !:
-      REAL(wp), DIMENSION(nzb:nzt+1), INTENT(IN)    ::  r2z   !:
-      
-      INTEGER(iwp), DIMENSION(nxlg:nxrg), INTENT(IN) ::  ic    !:
-      INTEGER(iwp), DIMENSION(nysg:nyng), INTENT(IN) ::  jc    !:
-      INTEGER(iwp), DIMENSION(nzb:nzt+1), INTENT(IN) ::  kc    !:
-      
-      CHARACTER(LEN=1), INTENT(IN) :: var   !:
-
-      INTEGER(iwp) ::  i   !:
-      INTEGER(iwp) ::  j   !:
-      INTEGER(iwp) ::  k   !:
-      INTEGER(iwp) ::  l   !:
-      INTEGER(iwp) ::  m   !:
-      INTEGER(iwp) ::  n   !:
-      
-      REAL(wp) ::  coarse_dx   !:
-      REAL(wp) ::  coarse_dy   !:
-      REAL(wp) ::  coarse_dz   !:
-      REAL(wp) ::  fk          !:
-      REAL(wp) ::  fkj         !:
-      REAL(wp) ::  fkjp        !:
-      REAL(wp) ::  fkpj        !:
-      REAL(wp) ::  fkpjp       !:
-      REAL(wp) ::  fkp         !:
-
-      
-      IF ( var == 'w' )  THEN
-         k  = nzt
-      ELSE
-         k  = nzt + 1
-      ENDIF
-     
-      DO  i = nxl-1, nxr+1
-         DO  j = nys-1, nyn+1
-            l = ic(i)
-            m = jc(j)
-            n = kc(k)              
-            fkj      = r1x(i) * fc(n,m,l)     + r2x(i) * fc(n,m,l+1)
-            fkjp     = r1x(i) * fc(n,m+1,l)   + r2x(i) * fc(n,m+1,l+1)
-            fkpj     = r1x(i) * fc(n+1,m,l)   + r2x(i) * fc(n+1,m,l+1)
-            fkpjp    = r1x(i) * fc(n+1,m+1,l) + r2x(i) * fc(n+1,m+1,l+1)
-            fk       = r1y(j) * fkj  + r2y(j) * fkjp
-            fkp      = r1y(j) * fkpj + r2y(j) * fkpjp
-            f(k,j,i) = r1z(k) * fk   + r2z(k) * fkp
-         ENDDO
-      ENDDO
-
-!
-!--   Just fill up the second ghost-node layer for w.
-      IF ( var == 'w' )  THEN
-         f(nzt+1,:,:) = f(nzt,:,:)
-      ENDIF
-
-!
-!--   Rescale if f is the TKE.
-!--   It is assumed that the bottom surface never reaches the top boundary of a
-!--   nest domain.
-      IF ( var == 'e' )  THEN
-         DO  i = nxl, nxr
-            DO  j = nys, nyn
-               f(k,j,i) = tkefactor_t(j,i) * f(k,j,i)
-            ENDDO
-         ENDDO
-      ENDIF
-
-   END SUBROUTINE pmci_interp_tril_t
-
-
-
-    SUBROUTINE pmci_extrap_ifoutflow_lr( f, kb, edge, var )
-!
-!--    After the interpolation of ghost-node values for the client-domain
-!--    boundary conditions, this subroutine checks if there is a local outflow
-!--    through the boundary. In that case this subroutine overwrites the
-!--    interpolated values by values extrapolated from the domain. This
-!--    subroutine handles the left and right boundaries. However, this operation
-!--    is only needed in case of one-way coupling.
-
-       IMPLICIT NONE
-
-       CHARACTER(LEN=1),INTENT(IN) ::  edge   !:
-       CHARACTER(LEN=1),INTENT(IN) ::  var    !:
-
-       INTEGER(iwp) ::  i     !:
-       INTEGER(iwp) ::  ib    !:
-       INTEGER(iwp) ::  ibgp  !:
-       INTEGER(iwp) ::  ied   !:
-       INTEGER(iwp) ::  j     !:
-       INTEGER(iwp) ::  k     !:
-      
-       INTEGER(iwp), DIMENSION(nysg:nyng,nxlg:nxrg), INTENT(IN) ::  kb   !:
-
-       REAL(wp) ::  outnor    !:
-       REAL(wp) ::  vdotnor   !:
-
-       REAL(wp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg), INTENT(INOUT) :: f !:
-
-!
-!--    Check which edge is to be handled: left or right
-       IF ( edge == 'l' )  THEN
-          IF ( var == 'u' )  THEN
-             i   = nxl
-             ib  = nxl - 1
-             ied = nxl + 1
-          ELSE
-             i   = nxl - 1
-             ib  = nxl - 2
-             ied = nxl
-          ENDIF
-          outnor = -1.0_wp
-       ELSEIF ( edge == 'r' )  THEN
-          i      = nxr + 1
-          ib     = nxr + 2
-          ied    = nxr
-          outnor = 1.0_wp
-       ENDIF
-
-       DO  j = nys, nyn+1
-          DO  k = kb(j,i), nzt+1
-             vdotnor = outnor * u(k,j,ied)
-!
-!--          Local outflow
-             IF ( vdotnor > 0.0_wp )  THEN
-                f(k,j,i) = f(k,j,ied)
-             ENDIF
-          ENDDO
-          IF ( (var == 'u' )  .OR.  (var == 'v' )  .OR.  (var == 'w') )  THEN
-             f(kb(j,i),j,i) = 0.0_wp
-          ENDIF
-       ENDDO
-
-!
-!--    Store the boundary values also into the redundant ghost node layers.
-       IF ( edge == 'l' )  THEN
-          DO ibgp = -nbgp, ib
-             f(0:nzt+1,nysg:nyng,ibgp) = f(0:nzt+1,nysg:nyng,i)
-          ENDDO
-       ELSEIF ( edge == 'r' )  THEN
-          DO ibgp = ib, nx+nbgp
-             f(0:nzt+1,nysg:nyng,ibgp) = f(0:nzt+1,nysg:nyng,i)
-          ENDDO
-       ENDIF
-
-    END SUBROUTINE pmci_extrap_ifoutflow_lr
-
-
-
-    SUBROUTINE pmci_extrap_ifoutflow_sn( f, kb, edge, var )
-!
-!--    After  the interpolation of ghost-node values for the client-domain
-!--    boundary conditions, this subroutine checks if there is a local outflow
-!--    through the boundary. In that case this subroutine overwrites the
-!--    interpolated values by values extrapolated from the domain. This
-!--    subroutine handles the south and north boundaries.
-
-       IMPLICIT NONE
-
-       CHARACTER(LEN=1), INTENT(IN) ::  edge   !:
-       CHARACTER(LEN=1), INTENT(IN) ::  var    !:
-      
-       INTEGER(iwp) ::  i         !:
-       INTEGER(iwp) ::  j         !:
-       INTEGER(iwp) ::  jb        !:
-       INTEGER(iwp) ::  jbgp      !:
-       INTEGER(iwp) ::  jed       !:
-       INTEGER(iwp) ::  k         !:
-
-       INTEGER(iwp), DIMENSION(nysg:nyng,nxlg:nxrg), INTENT(IN) ::  kb   !:
-
-       REAL(wp)     ::  outnor    !:
-       REAL(wp)     ::  vdotnor   !:
-
-       REAL(wp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg), INTENT(INOUT) :: f !:
-
-!
-!--    Check which edge is to be handled: left or right
-       IF ( edge == 's' )  THEN
-          IF ( var == 'v' )  THEN
-             j   = nys
-             jb  = nys - 1
-             jed = nys + 1
-          ELSE
-             j   = nys - 1
-             jb  = nys - 2
-             jed = nys
-          ENDIF
-          outnor = -1.0_wp
-       ELSEIF ( edge == 'n' )  THEN
-          j      = nyn + 1
-          jb     = nyn + 2
-          jed    = nyn
-          outnor = 1.0_wp
-       ENDIF
-
-       DO  i = nxl, nxr+1
-          DO  k = kb(j,i), nzt+1
-             vdotnor = outnor * v(k,jed,i)
-!
-!--          Local outflow
-             IF ( vdotnor > 0.0_wp )  THEN
-                f(k,j,i) = f(k,jed,i)
-             ENDIF
-          ENDDO
-          IF ( (var == 'u' )  .OR.  (var == 'v' )  .OR.  (var == 'w') )  THEN
-             f(kb(j,i),j,i) = 0.0_wp
-          ENDIF
-       ENDDO
-
-!
-!--    Store the boundary values also into the redundant ghost node layers.
-       IF ( edge == 's' )  THEN
-          DO  jbgp = -nbgp, jb
-             f(0:nzt+1,jbgp,nxlg:nxrg) = f(0:nzt+1,j,nxlg:nxrg)
-          ENDDO
-       ELSEIF ( edge == 'n' )  THEN
-          DO  jbgp = jb, ny+nbgp
-             f(0:nzt+1,jbgp,nxlg:nxrg) = f(0:nzt+1,j,nxlg:nxrg)
-          ENDDO
-       ENDIF
-
-    END SUBROUTINE pmci_extrap_ifoutflow_sn
-
- 
-
-    SUBROUTINE pmci_extrap_ifoutflow_t( f, var )
-!
-!--    Interpolation of ghost-node values used as the client-domain boundary
-!--    conditions. This subroutine handles the top boundary. It is based on
-!--    trilinear interpolation.
-
-       IMPLICIT NONE
-
-       CHARACTER(LEN=1), INTENT(IN) ::  var   !:
-      
-       INTEGER(iwp) ::  i     !:
-       INTEGER(iwp) ::  j     !:
-       INTEGER(iwp) ::  k     !:
-       INTEGER(iwp) ::  ked   !:
-
-       REAL(wp) ::  vdotnor   !:
-
-       REAL(wp), DIMENSION(nzb:nzt+1,nys-nbgp:nyn+nbgp,nxl-nbgp:nxr+nbgp),     &
-                 INTENT(INOUT) ::  f   !:
-     
-
-       IF ( var == 'w' )  THEN
-          k    = nzt
-          ked  = nzt - 1
-       ELSE
-          k    = nzt + 1
-          ked  = nzt
-       ENDIF
-
-       DO  i = nxl, nxr
-          DO  j = nys, nyn
-             vdotnor = w(ked,j,i)
-!
-!--          Local outflow
-             IF ( vdotnor > 0.0_wp )  THEN
-                f(k,j,i) = f(ked,j,i)
-             ENDIF
-          ENDDO
-       ENDDO
-
-!
-!--    Just fill up the second ghost-node layer for w
-       IF ( var == 'w' )  THEN
-          f(nzt+1,:,:) = f(nzt,:,:)
-       ENDIF
-
-    END SUBROUTINE pmci_extrap_ifoutflow_t
-
-
-
-    SUBROUTINE pmci_anterp_tophat( f, fc, kct, ifl, ifu, jfl, jfu, kfl, kfu,   &
-                                   var )
-!
-!--    Anterpolation of internal-node values to be used as the server-domain
-!--    values. This subroutine is based on the first-order numerical
-!--    integration of the fine-grid values contained within the coarse-grid
-!--    cell.
-
-       IMPLICIT NONE
-
-       CHARACTER(LEN=1), INTENT(IN) ::  var   !:
-
-       INTEGER(iwp) ::  i         !: Fine-grid index
-       INTEGER(iwp) ::  ii        !: Coarse-grid index
-       INTEGER(iwp) ::  iclp      !:
-       INTEGER(iwp) ::  icrm      !:
-       INTEGER(iwp) ::  ifc       !:
-       INTEGER(iwp) ::  ijfc      !:
-       INTEGER(iwp) ::  j         !: Fine-grid index
-       INTEGER(iwp) ::  jj        !: Coarse-grid index
-       INTEGER(iwp) ::  jcnm      !:
-       INTEGER(iwp) ::  jcsp      !:
-       INTEGER(iwp) ::  k         !: Fine-grid index
-       INTEGER(iwp) ::  kk        !: Coarse-grid index
-       INTEGER(iwp) ::  kcb       !:
-       INTEGER(iwp) ::  nfc       !:
-
-       INTEGER(iwp), INTENT(IN) ::  kct   !:
-
-       INTEGER(iwp), DIMENSION(icl:icr), INTENT(IN) ::  ifl   !:
-       INTEGER(iwp), DIMENSION(icl:icr), INTENT(IN) ::  ifu   !:
-       INTEGER(iwp), DIMENSION(jcs:jcn), INTENT(IN) ::  jfl   !:
-       INTEGER(iwp), DIMENSION(jcs:jcn), INTENT(IN) ::  jfu   !:
-       INTEGER(iwp), DIMENSION(0:kct), INTENT(IN)   ::  kfl   !:
-       INTEGER(iwp), DIMENSION(0:kct), INTENT(IN)   ::  kfu   !:
-
-
-       REAL(wp) ::  cellsum   !:
-       REAL(wp) ::  f1f       !:
-       REAL(wp) ::  fra       !:
-
-       REAL(wp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg), INTENT(IN) ::  f   !:
-       REAL(wp), DIMENSION(0:cg%nz+1,jcs:jcn,icl:icr), INTENT(INOUT)  ::  fc  !:
-  
-
-!
-!--    Initialize the index bounds for anterpolation 
-       iclp = icl 
-       icrm = icr 
-       jcsp = jcs 
-       jcnm = jcn 
-
-!
-!--    Define the index bounds iclp, icrm, jcsp and jcnm.
-!--    Note that kcb is simply zero and kct enters here as a parameter and it is
-!--    determined in pmci_init_anterp_tophat
-       IF ( nest_bound_l )  THEN
-          IF ( var == 'u' )  THEN
-             iclp = icl + nhll + 1
-          ELSE
-             iclp = icl + nhll
-          ENDIF
-       ENDIF
-       IF ( nest_bound_r )  THEN
-          icrm = icr - nhlr
-       ENDIF
-
-       IF ( nest_bound_s )  THEN
-          IF ( var == 'v' )  THEN
-             jcsp = jcs + nhls + 1
-          ELSE
-             jcsp = jcs + nhls
-          ENDIF
-       ENDIF
-       IF ( nest_bound_n )  THEN
-          jcnm = jcn - nhln
-       ENDIF
-       kcb = 0
-
-!
-!--    Note that l,m, and n are coarse-grid indices and i,j, and k are fine-grid
-!--    indices.
-       DO  ii = iclp, icrm
-          ifc = ifu(ii) - ifl(ii) + 1
-          DO  jj = jcsp, jcnm
-             ijfc = ifc * ( jfu(jj) - jfl(jj) + 1 )
-!
-!--          For simplicity anterpolate within buildings too
-             DO  kk = kcb, kct
-                nfc =  ijfc * ( kfu(kk) - kfl(kk) + 1 )
-                cellsum = 0.0_wp
-                DO  i = ifl(ii), ifu(ii)
-                   DO  j = jfl(jj), jfu(jj)
-                      DO  k = kfl(kk), kfu(kk)
-                         cellsum = cellsum + f(k,j,i)
-                      ENDDO
-                   ENDDO
-                ENDDO
-!
-!--             Spatial under-relaxation.
-                fra  = frax(ii) * fray(jj) * fraz(kk)
-!
-!--             Block out the fine-grid corner patches from the anterpolation
-                IF ( ( ifl(ii) < nxl ) .OR. ( ifu(ii) > nxr ) )  THEN
-                   IF ( ( jfl(jj) < nys ) .OR. ( jfu(jj) > nyn ) )  THEN
-                      fra = 0.0_wp
-                   ENDIF
-                ENDIF
-!
-!--             TO DO: introduce 3-d coarse grid array for precomputed
-!--             1/REAL(nfc) values
-                fc(kk,jj,ii) = ( 1.0_wp - fra ) * fc(kk,jj,ii) +               &
-                               fra * cellsum / REAL( nfc, KIND = wp )
-
-             ENDDO
-          ENDDO
-       ENDDO
-
-    END SUBROUTINE pmci_anterp_tophat
-
-#endif
- END SUBROUTINE pmci_client_datatrans
-
-END MODULE pmc_interface
Index: /palm/trunk/SOURCE/pmc_interface_mod.f90
===================================================================
--- /palm/trunk/SOURCE/pmc_interface_mod.f90	(revision 1850)
+++ /palm/trunk/SOURCE/pmc_interface_mod.f90	(revision 1850)
@@ -0,0 +1,4310 @@
+MODULE pmc_interface
+
+!--------------------------------------------------------------------------------!
+! This file is part of PALM.
+!
+! PALM is free software: you can redistribute it and/or modify it under the terms
+! of the GNU General Public License as published by the Free Software Foundation,
+! either version 3 of the License, or (at your option) any later version.
+!
+! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
+! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
+! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along with
+! PALM. If not, see <http://www.gnu.org/licenses/>.
+!
+! Copyright 1997-2016 Leibniz Universitaet Hannover
+!--------------------------------------------------------------------------------!
+!
+! Current revisions:
+! ------------------
+! Module renamed
+!
+!
+! Former revisions:
+! -----------------
+! $Id$
+!
+! 1808 2016-04-05 19:44:00Z raasch
+! MPI module used by default on all machines
+!
+! 1801 2016-04-05 13:12:47Z raasch
+! bugfix for r1797: zero setting of temperature within topography does not work
+! and has been disabled
+!
+! 1797 2016-03-21 16:50:28Z raasch
+! introduction of different datatransfer modes,
+! further formatting cleanup, parameter checks added (including mismatches
+! between root and client model settings),
+! +routine pmci_check_setting_mismatches
+! comm_world_nesting introduced
+!
+! 1791 2016-03-11 10:41:25Z raasch
+! routine pmci_update_new removed,
+! pmc_get_local_model_info renamed pmc_get_model_info, some keywords also
+! renamed,
+! filling up redundant ghost points introduced,
+! some index bound variables renamed,
+! further formatting cleanup
+!
+! 1783 2016-03-06 18:36:17Z raasch
+! calculation of nest top area simplified,
+! interpolation and anterpolation moved to seperate wrapper subroutines
+!
+! 1781 2016-03-03 15:12:23Z raasch
+! _p arrays are set zero within buildings too, t.._m arrays and respective
+! settings within buildings completely removed
+!
+! 1779 2016-03-03 08:01:28Z raasch
+! only the total number of PEs is given for the domains, npe_x and npe_y
+! replaced by npe_total, two unused elements removed from array
+! define_coarse_grid_real,
+! array management changed from linked list to sequential loop
+!
+! 1766 2016-02-29 08:37:15Z raasch
+! modifications to allow for using PALM's pointer version,
+! +new routine pmci_set_swaplevel
+!
+! 1764 2016-02-28 12:45:19Z raasch
+! +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
+!
+! 1762 2016-02-25 12:31:13Z hellstea
+! Initial revision by A. Hellsten
+!
+! Description:
+! ------------
+! Domain nesting interface routines. The low-level inter-domain communication   
+! is conducted by the PMC-library routines.
+!------------------------------------------------------------------------------!
+
+#if defined( __nopointer )
+    USE arrays_3d,                                                             &
+        ONLY:  dzu, dzw, e, e_p, pt, pt_p, q, q_p, u, u_p, v, v_p, w, w_p, zu, &
+               zw, z0
+#else
+   USE arrays_3d,                                                              &
+        ONLY:  dzu, dzw, e, e_p, e_1, e_2, pt, pt_p, pt_1, pt_2, q, q_p, q_1,  &
+               q_2, u, u_p, u_1, u_2, v, v_p, v_1, v_2, w, w_p, w_1, w_2, zu,  &
+               zw, z0
+#endif
+
+    USE control_parameters,                                                    &
+        ONLY:  coupling_char, dt_3d, dz, humidity, message_string,             &
+               nest_bound_l, nest_bound_r, nest_bound_s, nest_bound_n,         &
+               nest_domain, 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
+
+#if defined( __parallel )
+#if defined( __mpifh )
+    INCLUDE "mpif.h"
+#else
+    USE MPI
+#endif
+
+    USE pegrid,                                                                &
+        ONLY:  collective_wait, comm1dx, comm1dy, comm2d, myid, myidx, myidy,  &
+               numprocs
+
+    USE pmc_client,                                                            &
+        ONLY:  pmc_clientinit, pmc_c_clear_next_array_list,                    &
+               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_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_clear_next_array_list, pmc_s_fillbuffer,  &
+               pmc_s_getdata_from_buffer, pmc_s_getnextarray,                  &
+               pmc_s_setind_and_allocmem, pmc_s_set_active_data_array,         &
+               pmc_s_set_dataarray, pmc_s_set_2d_index_list
+
+#endif
+
+    IMPLICIT NONE
+
+    PRIVATE
+
+!
+!-- Constants
+    INTEGER(iwp), PARAMETER ::  client_to_server = 2   !:
+    INTEGER(iwp), PARAMETER ::  server_to_client = 1   !:
+
+!
+!-- Coupler setup
+    INTEGER(iwp), SAVE      ::  comm_world_nesting     !:
+    INTEGER(iwp), SAVE      ::  cpl_id  = 1            !:
+    CHARACTER(LEN=32), SAVE ::  cpl_name               !:
+    INTEGER(iwp), SAVE      ::  cpl_npe_total          !:
+    INTEGER(iwp), SAVE      ::  cpl_parent_id          !:
+
+!
+!-- Control parameters, will be made input parameters later
+    CHARACTER(LEN=7), SAVE ::  nesting_datatransfer_mode = 'mixed'  !: steering
+                                                         !: parameter for data-
+                                                         !: transfer mode
+    CHARACTER(LEN=7), SAVE ::  nesting_mode = 'two-way'  !: steering parameter
+                                                         !: for 1- or 2-way nesting
+
+    LOGICAL, SAVE ::  nested_run = .FALSE.  !: general switch
+
+    REAL(wp), SAVE ::  anterp_relax_length_l = -1.0_wp   !:
+    REAL(wp), SAVE ::  anterp_relax_length_r = -1.0_wp   !:
+    REAL(wp), SAVE ::  anterp_relax_length_s = -1.0_wp   !:
+    REAL(wp), SAVE ::  anterp_relax_length_n = -1.0_wp   !:
+    REAL(wp), SAVE ::  anterp_relax_length_t = -1.0_wp   !:
+
+!
+!-- Geometry
+    REAL(wp), SAVE                            ::  area_t               !:
+    REAL(wp), SAVE, DIMENSION(:), ALLOCATABLE ::  coord_x              !:
+    REAL(wp), SAVE, DIMENSION(:), ALLOCATABLE ::  coord_y              !:
+    REAL(wp), SAVE                            ::  lower_left_coord_x   !:
+    REAL(wp), SAVE                            ::  lower_left_coord_y   !:
+
+!
+!-- Client coarse data arrays
+    INTEGER(iwp), DIMENSION(5)                  ::  coarse_bound   !:
+
+    REAL(wp), SAVE                              ::  xexl           !:
+    REAL(wp), SAVE                              ::  xexr           !:
+    REAL(wp), SAVE                              ::  yexs           !:
+    REAL(wp), SAVE                              ::  yexn           !:
+    REAL(wp), SAVE, DIMENSION(:,:), ALLOCATABLE ::  tkefactor_l    !:
+    REAL(wp), SAVE, DIMENSION(:,:), ALLOCATABLE ::  tkefactor_n    !:
+    REAL(wp), SAVE, DIMENSION(:,:), ALLOCATABLE ::  tkefactor_r    !:
+    REAL(wp), SAVE, DIMENSION(:,:), ALLOCATABLE ::  tkefactor_s    !:
+    REAL(wp), SAVE, DIMENSION(:,:), ALLOCATABLE ::  tkefactor_t    !:
+
+    REAL(wp), SAVE, DIMENSION(:,:,:), ALLOCATABLE, TARGET ::  ec   !:
+    REAL(wp), SAVE, DIMENSION(:,:,:), ALLOCATABLE, TARGET ::  ptc  !:
+    REAL(wp), SAVE, DIMENSION(:,:,:), ALLOCATABLE, TARGET ::  uc   !:
+    REAL(wp), SAVE, DIMENSION(:,:,:), ALLOCATABLE, TARGET ::  vc   !:
+    REAL(wp), SAVE, DIMENSION(:,:,:), ALLOCATABLE, TARGET ::  wc   !:
+    REAL(wp), SAVE, DIMENSION(:,:,:), ALLOCATABLE, TARGET ::  qc   !:
+
+!
+!-- Client interpolation coefficients and client-array indices to be precomputed
+!-- and stored.
+    INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:) ::  ico    !:
+    INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:) ::  icu    !:
+    INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:) ::  jco    !:
+    INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:) ::  jcv    !:
+    INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:) ::  kco    !:
+    INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:) ::  kcw    !:
+    REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:)     ::  r1xo   !:
+    REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:)     ::  r2xo   !:
+    REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:)     ::  r1xu   !:
+    REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:)     ::  r2xu   !:
+    REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:)     ::  r1yo   !:
+    REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:)     ::  r2yo   !:
+    REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:)     ::  r1yv   !:
+    REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:)     ::  r2yv   !:
+    REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:)     ::  r1zo   !:
+    REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:)     ::  r2zo   !:
+    REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:)     ::  r1zw   !:
+    REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:)     ::  r2zw   !:
+
+!
+!-- Client index arrays and log-ratio arrays for the log-law near-wall
+!-- corrections. These are not truly 3-D arrays but multiple 2-D arrays.
+    INTEGER(iwp), SAVE :: ncorr  !: 4th dimension of the log_ratio-arrays
+    INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:,:,:) ::  logc_u_l   !:
+    INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:,:,:) ::  logc_u_n   !:
+    INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:,:,:) ::  logc_u_r   !:
+    INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:,:,:) ::  logc_u_s   !:
+    INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:,:,:) ::  logc_v_l   !:
+    INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:,:,:) ::  logc_v_n   !:
+    INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:,:,:) ::  logc_v_r   !:
+    INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:,:,:) ::  logc_v_s   !:
+    INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:,:,:) ::  logc_w_l   !:
+    INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:,:,:) ::  logc_w_n   !:
+    INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:,:,:) ::  logc_w_r   !:
+    INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:,:,:) ::  logc_w_s   !:
+    REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:,:,:)   ::  logc_ratio_u_l   !:
+    REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:,:,:)   ::  logc_ratio_u_n   !:
+    REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:,:,:)   ::  logc_ratio_u_r   !:
+    REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:,:,:)   ::  logc_ratio_u_s   !:
+    REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:,:,:)   ::  logc_ratio_v_l   !:
+    REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:,:,:)   ::  logc_ratio_v_n   !:
+    REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:,:,:)   ::  logc_ratio_v_r   !:
+    REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:,:,:)   ::  logc_ratio_v_s   !:
+    REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:,:,:)   ::  logc_ratio_w_l   !:
+    REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:,:,:)   ::  logc_ratio_w_n   !:
+    REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:,:,:)   ::  logc_ratio_w_r   !:
+    REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:,:,:)   ::  logc_ratio_w_s   !:
+
+!
+!-- Upper bounds for k in anterpolation.
+    INTEGER(iwp), SAVE ::  kctu   !:
+    INTEGER(iwp), SAVE ::  kctw   !:
+
+!
+!-- Upper bound for k in log-law correction in interpolation.
+    INTEGER(iwp), SAVE ::  nzt_topo_nestbc_l   !:
+    INTEGER(iwp), SAVE ::  nzt_topo_nestbc_n   !:
+    INTEGER(iwp), SAVE ::  nzt_topo_nestbc_r   !:
+    INTEGER(iwp), SAVE ::  nzt_topo_nestbc_s   !:
+
+!
+!-- Number of ghost nodes in coarse-grid arrays for i and j in anterpolation.
+    INTEGER(iwp), SAVE ::  nhll   !:
+    INTEGER(iwp), SAVE ::  nhlr   !:
+    INTEGER(iwp), SAVE ::  nhls   !:
+    INTEGER(iwp), SAVE ::  nhln   !:
+
+!
+!-- Spatial under-relaxation coefficients for anterpolation.
+    REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:) ::  frax   !:
+    REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:) ::  fray   !:
+    REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:) ::  fraz   !:
+
+!
+!-- Client-array indices to be precomputed and stored for anterpolation.
+    INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:) ::  iflu   !:
+    INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:) ::  ifuu   !:
+    INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:) ::  iflo   !:
+    INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:) ::  ifuo   !:
+    INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:) ::  jflv   !:
+    INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:) ::  jfuv   !:
+    INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:) ::  jflo   !:
+    INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:) ::  jfuo   !:
+    INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:) ::  kflw   !:
+    INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:) ::  kfuw   !:
+    INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:) ::  kflo   !:
+    INTEGER(iwp), SAVE, ALLOCATABLE, DIMENSION(:) ::  kfuo   !:
+
+    INTEGER(iwp), DIMENSION(3)          ::  define_coarse_grid_int    !:
+    REAL(wp), DIMENSION(7)              ::  define_coarse_grid_real   !:
+
+    TYPE coarsegrid_def
+       INTEGER(iwp)                        ::  nx
+       INTEGER(iwp)                        ::  ny
+       INTEGER(iwp)                        ::  nz
+       REAL(wp)                            ::  dx
+       REAL(wp)                            ::  dy
+       REAL(wp)                            ::  dz
+       REAL(wp)                            ::  lower_left_coord_x
+       REAL(wp)                            ::  lower_left_coord_y
+       REAL(wp)                            ::  xend
+       REAL(wp)                            ::  yend
+       REAL(wp), DIMENSION(:), ALLOCATABLE ::  coord_x
+       REAL(wp), DIMENSION(:), ALLOCATABLE ::  coord_y
+       REAL(wp), DIMENSION(:), ALLOCATABLE ::  dzu       
+       REAL(wp), DIMENSION(:), ALLOCATABLE ::  dzw       
+       REAL(wp), DIMENSION(:), ALLOCATABLE ::  zu        
+       REAL(wp), DIMENSION(:), ALLOCATABLE ::  zw        
+    END TYPE coarsegrid_def
+                                          
+    TYPE(coarsegrid_def), SAVE ::  cg   !:
+
+
+    INTERFACE pmci_check_setting_mismatches
+       MODULE PROCEDURE pmci_check_setting_mismatches
+    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_datatrans
+       MODULE PROCEDURE pmci_datatrans
+    END INTERFACE pmci_datatrans
+
+    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_set_swaplevel
+       MODULE PROCEDURE pmci_set_swaplevel
+    END INTERFACE pmci_set_swaplevel
+
+    PUBLIC anterp_relax_length_l, anterp_relax_length_r,                       &
+           anterp_relax_length_s, anterp_relax_length_n,                       &
+           anterp_relax_length_t, client_to_server, comm_world_nesting,        &
+           cpl_id, nested_run, nesting_datatransfer_mode, nesting_mode,        &
+           server_to_client
+    PUBLIC pmci_client_initialize
+    PUBLIC pmci_client_synchronize
+    PUBLIC pmci_datatrans
+    PUBLIC pmci_ensure_nest_mass_conservation
+    PUBLIC pmci_init
+    PUBLIC pmci_modelconfiguration
+    PUBLIC pmci_server_initialize
+    PUBLIC pmci_server_synchronize
+    PUBLIC pmci_set_swaplevel
+
+
+ CONTAINS
+
+
+ SUBROUTINE pmci_init( world_comm )
+
+    USE control_parameters,                                                  &
+        ONLY:  message_string
+
+    IMPLICIT NONE
+
+    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_datatransfer_mode, nesting_mode,  &
+                         pmc_status )
+
+    IF ( pmc_status == pmc_no_namelist_found )  THEN
+!
+!--    This is not a nested run
+       world_comm = MPI_COMM_WORLD
+       cpl_id     = 1
+       cpl_name   = ""
+
+       RETURN
+
+    ENDIF
+
+!
+!-- Check steering parameter values
+    IF ( TRIM( nesting_mode ) /= 'one-way'  .AND.                              &
+         TRIM( nesting_mode ) /= 'two-way' )                                   &
+    THEN
+       message_string = 'illegal nesting mode: ' // TRIM( nesting_mode )
+       CALL message( 'pmci_init', 'PA0417', 3, 2, 0, 6, 0 )
+    ENDIF
+
+    IF ( TRIM( nesting_datatransfer_mode ) /= 'cascade'  .AND.                 &
+         TRIM( nesting_datatransfer_mode ) /= 'mixed'    .AND.                 &
+         TRIM( nesting_datatransfer_mode ) /= 'overlap' )                      &
+    THEN
+       message_string = 'illegal nesting datatransfer mode: '                  &
+                        // TRIM( nesting_datatransfer_mode )
+       CALL message( 'pmci_init', 'PA0418', 3, 2, 0, 6, 0 )
+    ENDIF
+
+!
+!-- Set the general steering switch which tells PALM that its a nested run
+    nested_run = .TRUE.
+
+!
+!-- Get some variables required by the pmc-interface (and in some cases in the
+!-- PALM code out of the pmci) out of the pmc-core
+    CALL pmc_get_model_info( comm_world_nesting = comm_world_nesting,          &
+                             cpl_id = cpl_id, cpl_parent_id = cpl_parent_id,   &
+                             cpl_name = cpl_name, npe_total = cpl_npe_total,   &
+                             lower_left_x = lower_left_coord_x,                &
+                             lower_left_y = lower_left_coord_y )
+!
+!-- Set the steering switch which tells the models that they are nested (of
+!-- course the root domain (cpl_id = 1) is not nested)
+    IF ( cpl_id >= 2 )  THEN
+       nest_domain = .TRUE.
+       WRITE( coupling_char, '(A1,I2.2)') '_', cpl_id
+    ENDIF
+
+!
+!-- 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
+!
+!-- 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
+    nested_run = .FALSE.
+    world_comm = 1
+#endif
+
+ END SUBROUTINE pmci_init
+
+
+
+ SUBROUTINE pmci_modelconfiguration
+
+    IMPLICIT NONE
+
+    CALL location_message( 'setup the nested model configuration', .FALSE. )
+!
+!-- Compute absolute coordinates for all models
+    CALL pmci_setup_coordinates
+!
+!-- Initialize the client (must be called before pmc_setup_server)
+    CALL pmci_setup_client
+!
+!-- Initialize PMC Server
+    CALL pmci_setup_server
+!
+!-- Check for mismatches between settings of master and client variables
+!-- (e.g., all clients have to follow the end_time settings of the root master)
+    CALL pmci_check_setting_mismatches
+
+    CALL location_message( 'finished', .TRUE. )
+
+ END SUBROUTINE pmci_modelconfiguration
+
+
+
+ SUBROUTINE pmci_setup_server
+
+#if defined( __parallel )
+    IMPLICIT NONE
+
+    CHARACTER(LEN=32) ::  myname
+
+    INTEGER(iwp) ::  client_id        !:
+    INTEGER(iwp) ::  ierr             !:
+    INTEGER(iwp) ::  i                !:
+    INTEGER(iwp) ::  j                !:
+    INTEGER(iwp) ::  k                !:
+    INTEGER(iwp) ::  m                !:
+    INTEGER(iwp) ::  nomatch          !:
+    INTEGER(iwp) ::  nx_cl            !:
+    INTEGER(iwp) ::  ny_cl            !:
+    INTEGER(iwp) ::  nz_cl            !:
+
+    INTEGER(iwp), DIMENSION(5) ::  val    !:
+
+    REAL(wp) ::  dx_cl            !:
+    REAL(wp) ::  dy_cl            !:
+    REAL(wp) ::  xez              !:
+    REAL(wp) ::  yez              !:
+
+    REAL(wp), DIMENSION(1) ::  fval             !:
+
+    REAL(wp), DIMENSION(:), ALLOCATABLE ::  cl_coord_x   !:
+    REAL(wp), DIMENSION(:), ALLOCATABLE ::  cl_coord_y   !:
+    
+
+!
+!   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)
+       IF ( myid == 0 )  THEN        
+
+          CALL pmc_recv_from_client( client_id, val,  size(val),  0, 123, ierr )
+          CALL pmc_recv_from_client( client_id, fval, size(fval), 0, 124, ierr )
+         
+          nx_cl = val(1)
+          ny_cl = val(2)
+          dx_cl = val(4)
+          dy_cl = val(5)
+
+          nz_cl = nz
+
+!
+!--       Find the highest client level in the coarse grid for the reduced z
+!--       transfer
+          DO  k = 1, nz                 
+             IF ( zw(k) > fval(1) )  THEN
+                nz_cl = k
+                EXIT
+             ENDIF
+          ENDDO
+
+!    
+!--       Get absolute coordinates from the client
+          ALLOCATE( cl_coord_x(-nbgp:nx_cl+nbgp) )
+          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 )
+!          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) = dx
+          define_coarse_grid_real(4) = dy
+          define_coarse_grid_real(5) = lower_left_coord_x + ( nx + 1 ) * dx
+          define_coarse_grid_real(6) = lower_left_coord_y + ( ny + 1 ) * dy
+          define_coarse_grid_real(7) = dz
+
+          define_coarse_grid_int(1)  = nx
+          define_coarse_grid_int(2)  = ny
+          define_coarse_grid_int(3)  = nz_cl
+
+!
+!--       Check that the client domain is completely inside the server domain. 
+          nomatch = 0
+          xez = ( nbgp + 1 ) * dx 
+          yez = ( nbgp + 1 ) * dy 
+          IF ( ( cl_coord_x(0) < define_coarse_grid_real(1) + xez )       .OR. &
+               ( cl_coord_x(nx_cl+1) > define_coarse_grid_real(5) - xez ) .OR. &
+               ( cl_coord_y(0) < define_coarse_grid_real(2) + yez )       .OR. &
+               ( cl_coord_y(ny_cl+1) > define_coarse_grid_real(6) - yez ) )    &
+          THEN
+             nomatch = 1
+          ENDIF
+
+          DEALLOCATE( cl_coord_x )
+          DEALLOCATE( cl_coord_y )
+
+!
+!--       Send coarse grid information to client
+          CALL pmc_send_to_client( client_id, define_coarse_grid_real,         &
+                                   SIZE( define_coarse_grid_real ), 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
+          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 )
+          CALL pmc_send_to_client( client_id, zu,  nz_cl+2, 0, 28, ierr )
+          CALL pmc_send_to_client( client_id, zw,  nz_cl+2, 0, 29, ierr )
+
+       ENDIF
+
+       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'
+          CALL message( 'pmc_palm_setup_server', 'PA0XYZ', 1, 2, 0, 6, 0 )
+       ENDIF
+      
+       CALL MPI_BCAST( nz_cl, 1, MPI_INTEGER, 0, comm2d, ierr )
+
+!
+!--    TO_DO: Klaus: please give a comment what is done here
+       CALL pmci_create_index_list
+
+!
+!--    Include couple arrays into server content
+!--    TO_DO: Klaus: please give a more meaningful comment
+       CALL pmc_s_clear_next_array_list
+       DO  WHILE ( pmc_s_getnextarray( client_id, myname ) )
+          CALL pmci_set_array_pointer( myname, client_id = client_id,          &
+                                       nz_cl = nz_cl )
+       ENDDO
+       CALL pmc_s_setind_and_allocmem( client_id )
+    ENDDO
+
+ CONTAINS
+
+
+   SUBROUTINE pmci_create_index_list
+
+       IMPLICIT NONE
+
+       INTEGER(iwp) ::  i                  !:
+       INTEGER(iwp) ::  ic                 !:
+       INTEGER(iwp) ::  ierr               !:
+       INTEGER(iwp) ::  j                  !:
+       INTEGER(iwp) ::  k                  !:
+       INTEGER(iwp) ::  m                  !:
+       INTEGER(iwp) ::  n                  !:
+       INTEGER(iwp) ::  npx                !:
+       INTEGER(iwp) ::  npy                !:
+       INTEGER(iwp) ::  nrx                !:
+       INTEGER(iwp) ::  nry                !:
+       INTEGER(iwp) ::  px                 !:
+       INTEGER(iwp) ::  py                 !:
+       INTEGER(iwp) ::  server_pe          !:
+
+       INTEGER(iwp), DIMENSION(2) ::  scoord             !:
+       INTEGER(iwp), DIMENSION(2) ::  size_of_array      !:
+
+       INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE  ::  coarse_bound_all   !:
+       INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE  ::  index_list         !:
+
+       IF ( myid == 0 )  THEN
+!--       TO_DO: Klaus: give more specific comment what size_of_array stands for
+          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 )
+
+!
+!--       Compute size of index_list.
+          ic = 0
+          DO  k = 1, size_of_array(2)
+             DO  j = coarse_bound_all(3,k), coarse_bound_all(4,k)
+                DO  i = coarse_bound_all(1,k), coarse_bound_all(2,k)
+                   ic = ic + 1
+                ENDDO
+             ENDDO
+          ENDDO
+
+          ALLOCATE( index_list(6,ic) )
+
+          CALL MPI_COMM_SIZE( comm1dx, npx, ierr )
+          CALL MPI_COMM_SIZE( comm1dy, npy, ierr )
+!
+!--       The +1 in index is because PALM starts with nx=0
+          nrx = nxr - nxl + 1
+          nry = nyn - nys + 1
+          ic  = 0
+!
+!--       Loop over all client PEs
+          DO  k = 1, size_of_array(2)
+!
+!--          Area along y required by actual client PE
+             DO  j = coarse_bound_all(3,k), coarse_bound_all(4,k)
+!
+!--             Area along x required by actual client PE
+                DO  i = coarse_bound_all(1,k), coarse_bound_all(2,k)
+
+                   px = i / nrx
+                   py = j / nry
+                   scoord(1) = px
+                   scoord(2) = py
+                   CALL MPI_CART_RANK( comm2d, scoord, server_pe, ierr )
+                  
+                   ic = ic + 1
+!
+!--                First index in server array
+                   index_list(1,ic) = i - ( px * nrx ) + 1 + nbgp
+!
+!--                Second index in server array
+                   index_list(2,ic) = j - ( py * nry ) + 1 + nbgp
+!
+!--                x index of client coarse grid
+                   index_list(3,ic) = i - coarse_bound_all(1,k) + 1
+!
+!--                y index of client coarse grid
+                   index_list(4,ic) = j - coarse_bound_all(3,k) + 1
+!
+!--                PE number of client
+                   index_list(5,ic) = k - 1
+!
+!--                PE number of server
+                   index_list(6,ic) = server_pe
+
+                ENDDO
+             ENDDO
+          ENDDO
+!
+!--       TO_DO: Klaus: comment what is done here
+          CALL pmc_s_set_2d_index_list( client_id, index_list(:,1:ic) )
+
+       ELSE
+!
+!--       TO_DO: Klaus: comment why this dummy allocation is required
+          ALLOCATE( index_list(6,1) )
+          CALL pmc_s_set_2d_index_list( client_id, index_list )
+       ENDIF
+
+       DEALLOCATE(index_list)
+
+     END SUBROUTINE pmci_create_index_list
+
+#endif
+ END SUBROUTINE pmci_setup_server
+
+
+
+ SUBROUTINE pmci_setup_client
+
+#if defined( __parallel )
+    IMPLICIT NONE
+
+    CHARACTER(LEN=da_namelen) ::  myname     !:
+
+    INTEGER(iwp) ::  i          !:
+    INTEGER(iwp) ::  ierr       !:
+    INTEGER(iwp) ::  icl        !:
+    INTEGER(iwp) ::  icr        !:
+    INTEGER(iwp) ::  j          !:
+    INTEGER(iwp) ::  jcn        !:
+    INTEGER(iwp) ::  jcs        !:
+
+    INTEGER(iwp), DIMENSION(5) ::  val        !:
+    
+    REAL(wp) ::  xcs        !:
+    REAL(wp) ::  xce        !:
+    REAL(wp) ::  ycs        !:
+    REAL(wp) ::  yce        !:
+
+    REAL(wp), DIMENSION(1) ::  fval       !:
+                                             
+!
+!-- 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
+!
+!--    Here and only here the arrays are defined, which actualy will be
+!--    exchanged between client and server.
+!--    Please check, if the arrays are in the list of possible exchange arrays
+!--    in subroutines:
+!--    pmci_set_array_pointer (for server arrays)
+!--    pmci_create_client_arrays (for client arrays)
+       CALL pmc_set_dataarray_name( 'coarse', 'u'  ,'fine', 'u',  ierr )
+       CALL pmc_set_dataarray_name( 'coarse', 'v'  ,'fine', 'v',  ierr )
+       CALL pmc_set_dataarray_name( 'coarse', 'w'  ,'fine', 'w',  ierr )
+       CALL pmc_set_dataarray_name( 'coarse', 'e'  ,'fine', 'e',  ierr )
+       CALL pmc_set_dataarray_name( 'coarse', 'pt' ,'fine', 'pt', ierr )
+       IF ( humidity  .OR.  passive_scalar )  THEN
+          CALL pmc_set_dataarray_name( 'coarse', 'q'  ,'fine', 'q',  ierr )
+       ENDIF
+
+!
+!--    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
+       val(3)  = nz
+       val(4)  = dx
+       val(5)  = dy
+       fval(1) = zw(nzt+1)
+
+       IF ( myid == 0 )  THEN
+
+          CALL pmc_send_to_server( val, SIZE( val ), 0, 123, ierr )
+          CALL pmc_send_to_server( fval, SIZE( fval ), 0, 124, ierr )
+          CALL pmc_send_to_server( coord_x, nx + 1 + 2 * nbgp, 0, 11, ierr )
+          CALL pmc_send_to_server( coord_y, ny + 1 + 2 * nbgp, 0, 12, ierr )
+
+!
+!--       Receive Coarse grid information.
+!--       TO_DO: find shorter and more meaningful name for  define_coarse_grid_real
+          CALL pmc_recv_from_server( define_coarse_grid_real,                  &
+                                     SIZE(define_coarse_grid_real), 0, 21, ierr )
+          CALL pmc_recv_from_server( define_coarse_grid_int,  3, 0, 22, ierr )
+!
+!--        Debug-printouts - keep them
+!          WRITE(0,*) 'Coarse grid from Server '
+!          WRITE(0,*) 'startx_tot    = ',define_coarse_grid_real(1)
+!          WRITE(0,*) 'starty_tot    = ',define_coarse_grid_real(2)
+!          WRITE(0,*) 'endx_tot      = ',define_coarse_grid_real(5)
+!          WRITE(0,*) 'endy_tot      = ',define_coarse_grid_real(6)
+!          WRITE(0,*) 'dx            = ',define_coarse_grid_real(3)
+!          WRITE(0,*) 'dy            = ',define_coarse_grid_real(4)
+!          WRITE(0,*) 'dz            = ',define_coarse_grid_real(7)
+!          WRITE(0,*) 'nx_coarse     = ',define_coarse_grid_int(1)
+!          WRITE(0,*) 'ny_coarse     = ',define_coarse_grid_int(2)
+!          WRITE(0,*) 'nz_coarse     = ',define_coarse_grid_int(3)
+       ENDIF
+
+       CALL MPI_BCAST( define_coarse_grid_real, SIZE(define_coarse_grid_real), &
+                       MPI_REAL, 0, comm2d, ierr )
+       CALL MPI_BCAST( define_coarse_grid_int, 3, MPI_INTEGER, 0, comm2d, ierr )
+
+       cg%dx = define_coarse_grid_real(3)
+       cg%dy = define_coarse_grid_real(4)
+       cg%dz = define_coarse_grid_real(7)
+       cg%nx = define_coarse_grid_int(1)
+       cg%ny = define_coarse_grid_int(2)
+       cg%nz = define_coarse_grid_int(3)
+
+!
+!--    Get server coordinates on coarse grid
+       ALLOCATE( cg%coord_x(-nbgp:cg%nx+nbgp) )
+       ALLOCATE( cg%coord_y(-nbgp:cg%ny+nbgp) )
+      
+       ALLOCATE( cg%dzu(1:cg%nz+1) )
+       ALLOCATE( cg%dzw(1:cg%nz+1) )
+       ALLOCATE( cg%zu(0:cg%nz+1) )
+       ALLOCATE( cg%zw(0:cg%nz+1) )
+
+!
+!--    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%dzu, cg%nz + 1, 0, 26, ierr )
+          CALL pmc_recv_from_server( cg%dzw, cg%nz + 1, 0, 27, ierr )
+          CALL pmc_recv_from_server( cg%zu, cg%nz + 2, 0, 28, ierr )
+          CALL pmc_recv_from_server( cg%zw, cg%nz + 2, 0, 29, ierr )
+
+       ENDIF
+
+!
+!--    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 )
+       
+!
+!--    Find the index bounds for the nest domain in the coarse-grid index space
+       CALL pmci_map_fine_to_coarse_grid
+!
+!--    TO_DO: Klaus give a comment what is happening here
+       CALL pmc_c_get_2d_index_list
+
+!
+!--    Include couple arrays into client content
+!--    TO_DO: Klaus: better explain the above comment (what is client content?)
+       CALL  pmc_c_clear_next_array_list
+       DO  WHILE ( pmc_c_getnextarray( myname ) )
+!--       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
+       CALL pmci_init_interp_tril
+
+!
+!--    Precompute the log-law correction index- and ratio-arrays 
+       CALL pmci_init_loglaw_correction 
+
+!
+!--    Define the SGS-TKE scaling factor based on the grid-spacing ratio
+       CALL pmci_init_tkefactor
+
+!
+!--    Two-way coupling.
+!--    Precompute the index arrays and relaxation functions for the
+!--    anterpolation
+       IF ( nesting_mode == 'two-way' )  THEN
+          CALL pmci_init_anterp_tophat
+       ENDIF
+
+!
+!--    Finally, compute the total area of the top-boundary face of the domain.
+!--    This is needed in the pmc_ensure_nest_mass_conservation      
+       area_t = ( nx + 1 ) * (ny + 1 ) * dx * dy
+
+    ENDIF
+
+ CONTAINS
+
+    SUBROUTINE pmci_map_fine_to_coarse_grid
+!
+!--    Determine index bounds of interpolation/anterpolation area in the coarse
+!--    grid index space
+       IMPLICIT NONE
+
+       INTEGER(iwp), DIMENSION(5,numprocs) ::  coarse_bound_all   !:
+       INTEGER(iwp), DIMENSION(2)          ::  size_of_array      !:
+                                              
+       REAL(wp) ::  loffset     !:
+       REAL(wp) ::  noffset     !:
+       REAL(wp) ::  roffset     !:
+       REAL(wp) ::  soffset     !:
+
+!
+!--    If the fine- and coarse grid nodes do not match:
+       loffset = MOD( coord_x(nxl), cg%dx )
+       xexl    = cg%dx + loffset
+!
+!--    This is needed in the anterpolation phase
+       nhll = CEILING( xexl / cg%dx )
+       xcs  = coord_x(nxl) - xexl
+       DO  i = 0, cg%nx
+          IF ( cg%coord_x(i) > xcs )  THEN
+             icl = MAX( -1, i-1 )
+             EXIT
+          ENDIF
+       ENDDO
+!
+!--    If the fine- and coarse grid nodes do not match
+       roffset = MOD( coord_x(nxr+1), cg%dx )
+       xexr    = cg%dx + roffset
+!
+!--    This is needed in the anterpolation phase
+       nhlr = CEILING( xexr / cg%dx )
+       xce  = coord_x(nxr) + xexr
+       DO  i = cg%nx, 0 , -1
+          IF ( cg%coord_x(i) < xce )  THEN
+             icr = MIN( cg%nx+1, i+1 )
+             EXIT
+          ENDIF
+       ENDDO
+!
+!--    If the fine- and coarse grid nodes do not match
+       soffset = MOD( coord_y(nys), cg%dy )
+       yexs    = cg%dy + soffset
+!
+!--    This is needed in the anterpolation phase
+       nhls = CEILING( yexs / cg%dy )
+       ycs  = coord_y(nys) - yexs
+       DO  j = 0, cg%ny
+          IF ( cg%coord_y(j) > ycs )  THEN
+             jcs = MAX( -nbgp, j-1 )
+             EXIT
+          ENDIF
+       ENDDO
+!
+!--    If the fine- and coarse grid nodes do not match
+       noffset = MOD( coord_y(nyn+1), cg%dy )
+       yexn    = cg%dy + noffset
+!
+!--    This is needed in the anterpolation phase
+       nhln = CEILING( yexn / cg%dy )
+       yce  = coord_y(nyn) + yexn
+       DO  j = cg%ny, 0, -1
+          IF ( cg%coord_y(j) < yce )  THEN
+             jcn = MIN( cg%ny + nbgp, j+1 )
+             EXIT
+          ENDIF
+       ENDDO
+
+       coarse_bound(1) = icl
+       coarse_bound(2) = icr
+       coarse_bound(3) = jcs
+       coarse_bound(4) = jcn
+       coarse_bound(5) = myid
+!
+!--    Note that MPI_Gather receives data from all processes in the rank order
+!--    TO_DO: refer to the line where this fact becomes important
+       CALL MPI_GATHER( coarse_bound, 5, MPI_INTEGER, coarse_bound_all, 5, &
+                        MPI_INTEGER, 0, comm2d, ierr )
+
+       IF ( myid == 0 )  THEN
+          size_of_array(1) = SIZE( coarse_bound_all, 1 )
+          size_of_array(2) = SIZE( coarse_bound_all, 2 )
+          CALL pmc_send_to_server( size_of_array, 2, 0, 40, ierr )
+          CALL pmc_send_to_server( coarse_bound_all, SIZE( coarse_bound_all ), &
+                                   0, 41, ierr )
+       ENDIF
+
+    END SUBROUTINE pmci_map_fine_to_coarse_grid
+
+
+
+    SUBROUTINE pmci_init_interp_tril
+!
+!--    Precomputation of the interpolation coefficients and client-array indices
+!--    to be used by the interpolation routines interp_tril_lr, interp_tril_ns
+!--    and interp_tril_t.
+
+       IMPLICIT NONE
+
+       INTEGER(iwp) ::  i       !:
+       INTEGER(iwp) ::  i1      !:
+       INTEGER(iwp) ::  j       !:
+       INTEGER(iwp) ::  j1      !:
+       INTEGER(iwp) ::  k       !:
+       INTEGER(iwp) ::  kc      !:
+
+       REAL(wp) ::  xb          !:
+       REAL(wp) ::  xcsu        !:
+       REAL(wp) ::  xfso        !:
+       REAL(wp) ::  xcso        !:
+       REAL(wp) ::  xfsu        !:
+       REAL(wp) ::  yb          !:
+       REAL(wp) ::  ycso        !:
+       REAL(wp) ::  ycsv        !:
+       REAL(wp) ::  yfso        !:
+       REAL(wp) ::  yfsv        !:
+       REAL(wp) ::  zcso        !:
+       REAL(wp) ::  zcsw        !:
+       REAL(wp) ::  zfso        !:
+       REAL(wp) ::  zfsw        !:
+      
+
+       xb = nxl * dx
+       yb = nys * dy
+      
+       ALLOCATE( icu(nxlg:nxrg) )
+       ALLOCATE( ico(nxlg:nxrg) )
+       ALLOCATE( jcv(nysg:nyng) )
+       ALLOCATE( jco(nysg:nyng) )
+       ALLOCATE( kcw(nzb:nzt+1) )
+       ALLOCATE( kco(nzb:nzt+1) )
+       ALLOCATE( r1xu(nxlg:nxrg) )
+       ALLOCATE( r2xu(nxlg:nxrg) )
+       ALLOCATE( r1xo(nxlg:nxrg) )
+       ALLOCATE( r2xo(nxlg:nxrg) )
+       ALLOCATE( r1yv(nysg:nyng) )
+       ALLOCATE( r2yv(nysg:nyng) )
+       ALLOCATE( r1yo(nysg:nyng) )
+       ALLOCATE( r2yo(nysg:nyng) )
+       ALLOCATE( r1zw(nzb:nzt+1) )
+       ALLOCATE( r2zw(nzb:nzt+1) )
+       ALLOCATE( r1zo(nzb:nzt+1) )
+       ALLOCATE( r2zo(nzb:nzt+1) )
+
+!
+!--    Note that the node coordinates xfs... and xcs... are relative to the
+!--    lower-left-bottom corner of the fc-array, not the actual client domain
+!--    corner
+       DO  i = nxlg, nxrg
+          xfsu    = coord_x(i) - ( lower_left_coord_x + xb - xexl )
+          xfso    = coord_x(i) + 0.5_wp * dx - ( lower_left_coord_x + xb - xexl )
+          icu(i)  = icl + FLOOR( xfsu / cg%dx )
+          ico(i)  = icl + FLOOR( ( xfso - 0.5_wp * cg%dx ) / cg%dx )
+          xcsu    = ( icu(i) - icl ) * cg%dx
+          xcso    = ( ico(i) - icl ) * cg%dx + 0.5_wp * cg%dx
+          r2xu(i) = ( xfsu - xcsu ) / cg%dx
+          r2xo(i) = ( xfso - xcso ) / cg%dx
+          r1xu(i) = 1.0_wp - r2xu(i)
+          r1xo(i) = 1.0_wp - r2xo(i)
+       ENDDO
+
+       DO  j = nysg, nyng
+          yfsv    = coord_y(j) - ( lower_left_coord_y + yb - yexs )
+          yfso    = coord_y(j) + 0.5_wp * dy - ( lower_left_coord_y + yb - yexs )
+          jcv(j)  = jcs + FLOOR( yfsv / cg%dy )
+          jco(j)  = jcs + FLOOR( ( yfso -0.5_wp * cg%dy ) / cg%dy )
+          ycsv    = ( jcv(j) - jcs ) * cg%dy
+          ycso    = ( jco(j) - jcs ) * cg%dy + 0.5_wp * cg%dy
+          r2yv(j) = ( yfsv - ycsv ) / cg%dy
+          r2yo(j) = ( yfso - ycso ) / cg%dy
+          r1yv(j) = 1.0_wp - r2yv(j)
+          r1yo(j) = 1.0_wp - r2yo(j)
+       ENDDO
+
+       DO  k = nzb, nzt + 1
+          zfsw = zw(k)
+          zfso = zu(k)
+
+          kc = 0
+          DO  WHILE ( cg%zw(kc) <= zfsw )
+             kc = kc + 1
+          ENDDO
+          kcw(k) = kc - 1
+         
+          kc = 0
+          DO  WHILE ( cg%zu(kc) <= zfso )
+             kc = kc + 1
+          ENDDO
+          kco(k) = kc - 1
+
+          zcsw    = cg%zw(kcw(k))
+          zcso    = cg%zu(kco(k))
+          r2zw(k) = ( zfsw - zcsw ) / cg%dzw(kcw(k)+1)
+          r2zo(k) = ( zfso - zcso ) / cg%dzu(kco(k)+1)
+          r1zw(k) = 1.0_wp - r2zw(k)
+          r1zo(k) = 1.0_wp - r2zo(k)
+       ENDDO
+      
+    END SUBROUTINE pmci_init_interp_tril
+
+
+
+    SUBROUTINE pmci_init_loglaw_correction
+!
+!--    Precomputation of the index and log-ratio arrays for the log-law
+!--    corrections for near-wall nodes after the nest-BC interpolation.
+!--    These are used by the interpolation routines interp_tril_lr and
+!--    interp_tril_ns.
+
+       IMPLICIT NONE
+
+       INTEGER(iwp) ::  direction    !:  Wall normal index: 1=k, 2=j, 3=i.
+       INTEGER(iwp) ::  i            !:
+       INTEGER(iwp) ::  icorr        !:
+       INTEGER(iwp) ::  inc          !:  Wall outward-normal index increment -1
+                                     !: or 1, for direction=1, inc=1 always
+       INTEGER(iwp) ::  iw           !:
+       INTEGER(iwp) ::  j            !:
+       INTEGER(iwp) ::  jcorr        !:
+       INTEGER(iwp) ::  jw           !:
+       INTEGER(iwp) ::  k            !:
+       INTEGER(iwp) ::  kb           !:
+       INTEGER(iwp) ::  kcorr        !:
+       INTEGER(iwp) ::  lc           !:
+       INTEGER(iwp) ::  ni           !:
+       INTEGER(iwp) ::  nj           !:
+       INTEGER(iwp) ::  nk           !:
+       INTEGER(iwp) ::  nzt_topo_max !:
+       INTEGER(iwp) ::  wall_index   !:  Index of the wall-node coordinate
+
+       REAL(wp), ALLOCATABLE, DIMENSION(:) ::  lcr   !:
+
+!
+!--    First determine the maximum k-index needed for the near-wall corrections.
+!--    This maximum is individual for each boundary to minimize the storage
+!--    requirements and to minimize the corresponding loop k-range in the
+!--    interpolation routines.
+       nzt_topo_nestbc_l = nzb
+       IF ( nest_bound_l )  THEN
+          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) )
+             ENDDO
+          ENDDO
+          nzt_topo_nestbc_l = nzt_topo_nestbc_l + 1
+       ENDIF
+      
+       nzt_topo_nestbc_r = nzb
+       IF ( nest_bound_r )  THEN
+          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) )
+          ENDDO
+          nzt_topo_nestbc_r = nzt_topo_nestbc_r + 1
+       ENDIF
+
+       nzt_topo_nestbc_s = nzb
+       IF ( nest_bound_s )  THEN
+          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) )
+             ENDDO
+          ENDDO
+          nzt_topo_nestbc_s = nzt_topo_nestbc_s + 1
+       ENDIF
+
+       nzt_topo_nestbc_n = nzb
+       IF ( nest_bound_n )  THEN
+          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) )
+          ENDDO
+          nzt_topo_nestbc_n = nzt_topo_nestbc_n + 1
+       ENDIF
+
+!
+!--    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
+          nk = MAX( nk, CEILING( cg%dzu(k) / dzu(k) ) )
+       ENDDO
+       nk = nk / 2   !  Note that this must be integer division.
+       ncorr =  MAX( ni, nj, nk )
+
+       ALLOCATE( lcr(0:ncorr-1) )
+       lcr = 1.0_wp
+
+!
+!--    First horizontal walls
+!--    Left boundary
+       IF ( nest_bound_l )  THEN
+
+          ALLOCATE( logc_u_l(nzb:nzt_topo_nestbc_l,nys:nyn,1:2) )
+          ALLOCATE( logc_v_l(nzb:nzt_topo_nestbc_l,nys:nyn,1:2) )
+          ALLOCATE( logc_ratio_u_l(nzb:nzt_topo_nestbc_l,nys:nyn,1:2,0:ncorr-1) )
+          ALLOCATE( logc_ratio_v_l(nzb:nzt_topo_nestbc_l,nys:nyn,1:2,0:ncorr-1) )
+          logc_u_l       = 0
+          logc_v_l       = 0
+          logc_ratio_u_l = 1.0_wp
+          logc_ratio_v_l = 1.0_wp
+          direction      = 1
+          inc            = 1
+
+          DO  j = nys, nyn
+!
+!--          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 )
+             logc_u_l(k,j,1) = lc
+             logc_ratio_u_l(k,j,1,0:ncorr-1) = lcr(0:ncorr-1)
+             lcr(0:ncorr-1) = 1.0_wp
+!
+!--          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 )
+             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
+       IF ( nest_bound_r )  THEN
+
+          ALLOCATE( logc_u_r(nzb:nzt_topo_nestbc_r,nys:nyn,1:2) )
+          ALLOCATE( logc_v_r(nzb:nzt_topo_nestbc_r,nys:nyn,1:2) )
+          ALLOCATE( logc_ratio_u_r(nzb:nzt_topo_nestbc_r,nys:nyn,1:2,0:ncorr-1) )
+          ALLOCATE( logc_ratio_v_r(nzb:nzt_topo_nestbc_r,nys:nyn,1:2,0:ncorr-1) )
+          logc_u_r       = 0
+          logc_v_r       = 0
+          logc_ratio_u_r = 1.0_wp
+          logc_ratio_v_r = 1.0_wp
+          direction      = 1
+          inc            = 1
+          DO  j = nys, nyn
+!
+!--          Right boundary for u
+             i   = nxr + 1
+             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 )
+             logc_u_r(k,j,1) = lc
+             logc_ratio_u_r(k,j,1,0:ncorr-1) = lcr(0:ncorr-1)
+             lcr(0:ncorr-1) = 1.0_wp
+!
+!--          Right boundary for v
+             i   = nxr + 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 )
+             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
+       IF ( nest_bound_s )  THEN
+
+          ALLOCATE( logc_u_s(nzb:nzt_topo_nestbc_s,nxl:nxr,1:2) )
+          ALLOCATE( logc_v_s(nzb:nzt_topo_nestbc_s,nxl:nxr,1:2) )
+          ALLOCATE( logc_ratio_u_s(nzb:nzt_topo_nestbc_s,nxl:nxr,1:2,0:ncorr-1) )
+          ALLOCATE( logc_ratio_v_s(nzb:nzt_topo_nestbc_s,nxl:nxr,1:2,0:ncorr-1) )
+          logc_u_s       = 0
+          logc_v_s       = 0
+          logc_ratio_u_s = 1.0_wp
+          logc_ratio_v_s = 1.0_wp
+          direction      = 1
+          inc            = 1
+
+          DO  i = nxl, nxr
+!
+!--          South boundary for u
+             j   = -1
+             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 )
+             logc_u_s(k,i,1) = lc
+             logc_ratio_u_s(k,i,1,0:ncorr-1) = lcr(0:ncorr-1)
+             lcr(0:ncorr-1) = 1.0_wp
+!
+!--          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 )
+             logc_v_s(k,i,1) = lc
+             logc_ratio_v_s(k,i,1,0:ncorr-1) = lcr(0:ncorr-1)
+             lcr(0:ncorr-1) = 1.0_wp
+
+          ENDDO
+
+       ENDIF
+
+!
+!--    North boundary
+       IF ( nest_bound_n )  THEN
+
+          ALLOCATE( logc_u_n(nzb:nzt_topo_nestbc_n,nxl:nxr,1:2) )
+          ALLOCATE( logc_v_n(nzb:nzt_topo_nestbc_n,nxl:nxr,1:2) )
+          ALLOCATE( logc_ratio_u_n(nzb:nzt_topo_nestbc_n,nxl:nxr,1:2,0:ncorr-1) )
+          ALLOCATE( logc_ratio_v_n(nzb:nzt_topo_nestbc_n,nxl:nxr,1:2,0:ncorr-1) )
+          logc_u_n       = 0
+          logc_v_n       = 0
+          logc_ratio_u_n = 1.0_wp
+          logc_ratio_v_n = 1.0_wp
+          direction      = 1
+          inc            = 1
+
+          DO  i = nxl, nxr
+!
+!--          North boundary for u
+             j   = nyn + 1
+             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 )
+             logc_u_n(k,i,1) = lc
+             logc_ratio_u_n(k,i,1,0:ncorr-1) = lcr(0:ncorr-1)
+             lcr(0:ncorr-1) = 1.0_wp
+!
+!--          North boundary for v
+             j   = nyn + 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 )
+             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
+
+!       
+!--    Then vertical walls and corners if necessary
+       IF ( topography /= 'flat' )  THEN
+
+          kb = 0       ! kb is not used when direction > 1
+!        
+!--       Left boundary
+          IF ( nest_bound_l )  THEN
+
+             ALLOCATE( logc_w_l(nzb:nzt_topo_nestbc_l,nys:nyn,1:2) )
+             ALLOCATE( logc_ratio_w_l(nzb:nzt_topo_nestbc_l,nys:nyn,1:2,       &
+                                      0:ncorr-1) )
+             logc_w_l       = 0
+             logc_ratio_w_l = 1.0_wp
+             direction      = 2
+             DO  j = nys, nyn
+                DO  k = nzb, nzt_topo_nestbc_l
+!
+!--                Wall for u on the south side, but not on the north side
+                   i  = 0
+                   IF ( ( nzb_u_outer(j,i) > nzb_u_outer(j+1,i) ) .AND.        &
+                        ( nzb_u_outer(j,i) == nzb_u_outer(j-1,i) ) )           &
+                   THEN
+                      inc        =  1
+                      wall_index =  j
+                      CALL pmci_define_loglaw_correction_parameters( lc, lcr,  &
+                          k, j, inc, wall_index, z0(j,i), kb, direction, ncorr )
+!
+!--                   The direction of the wall-normal index is stored as the
+!--                   sign of the logc-element.
+                      logc_u_l(k,j,2) = inc * lc
+                      logc_ratio_u_l(k,j,2,0:ncorr-1) = lcr(0:ncorr-1)
+                      lcr(0:ncorr-1) = 1.0_wp
+                   ENDIF
+
+!
+!--                Wall for u on the north side, but not on the south side
+                   i  = 0
+                   IF ( ( nzb_u_outer(j,i) > nzb_u_outer(j-1,i) ) .AND.        &
+                        ( nzb_u_outer(j,i) == nzb_u_outer(j+1,i) ) )  THEN
+                      inc        = -1
+                      wall_index =  j + 1
+                      CALL pmci_define_loglaw_correction_parameters( lc, lcr,  &
+                          k, j, inc, wall_index, z0(j,i), kb, direction, ncorr )
+!
+!--                   The direction of the wall-normal index is stored as the
+!--                   sign of the logc-element.
+                      logc_u_l(k,j,2) = inc * lc
+                      logc_ratio_u_l(k,j,2,0:ncorr-1) = lcr(0:ncorr-1)
+                      lcr(0:ncorr-1) = 1.0_wp
+                   ENDIF
+
+!
+!--                Wall for w on the south side, but not on the north side.
+                   i  = -1
+                   IF ( ( nzb_w_outer(j,i) > nzb_w_outer(j+1,i) )  .AND.       &
+                        ( nzb_w_outer(j,i) == nzb_w_outer(j-1,i) ) )  THEN
+                      inc        =  1
+                      wall_index =  j
+                      CALL pmci_define_loglaw_correction_parameters( lc, lcr,  &
+                          k, j, inc, wall_index, z0(j,i), kb, direction, ncorr )
+!
+!--                   The direction of the wall-normal index is stored as the
+!--                   sign of the logc-element.
+                      logc_w_l(k,j,2) = inc * lc
+                      logc_ratio_w_l(k,j,2,0:ncorr-1) = lcr(0:ncorr-1)
+                      lcr(0:ncorr-1) = 1.0_wp
+                   ENDIF
+
+!
+!--                Wall for w on the north side, but not on the south side.
+                   i  = -1
+                   IF ( ( nzb_w_outer(j,i) > nzb_w_outer(j-1,i) )  .AND.       &
+                        ( nzb_w_outer(j,i) == nzb_w_outer(j+1,i) ) )  THEN
+                      inc        = -1
+                      wall_index =  j+1
+                      CALL pmci_define_loglaw_correction_parameters( lc, lcr,  &
+                          k, j, inc, wall_index, z0(j,i), kb, direction, ncorr )
+!
+!--                   The direction of the wall-normal index is stored as the
+!--                   sign of the logc-element.
+                      logc_w_l(k,j,2) = inc * lc
+                      logc_ratio_w_l(k,j,2,0:ncorr-1) = lcr(0:ncorr-1)
+                      lcr(0:ncorr-1) = 1.0_wp
+                   ENDIF
+
+                ENDDO
+             ENDDO
+
+          ENDIF   !  IF ( nest_bound_l )
+
+!        
+!--       Right boundary
+          IF ( nest_bound_r )  THEN
+
+             ALLOCATE( logc_w_r(nzb:nzt_topo_nestbc_r,nys:nyn,1:2) )
+             ALLOCATE( logc_ratio_w_r(nzb:nzt_topo_nestbc_r,nys:nyn,1:2,       &
+                                      0:ncorr-1) )
+             logc_w_r       = 0
+             logc_ratio_w_r = 1.0_wp
+             direction      = 2
+             i  = nxr + 1
+
+             DO  j = nys, nyn
+                DO  k = nzb, nzt_topo_nestbc_r
+!
+!--                Wall for u on the south side, but not on the north side
+                   IF ( ( nzb_u_outer(j,i) > nzb_u_outer(j+1,i) )  .AND.       &
+                        ( nzb_u_outer(j,i) == nzb_u_outer(j-1,i) ) )  THEN
+                      inc        = 1
+                      wall_index = j
+                      CALL pmci_define_loglaw_correction_parameters( lc, lcr,  &
+                          k, j, inc, wall_index, z0(j,i), kb, direction, ncorr )
+!
+!--                   The direction of the wall-normal index is stored as the
+!--                   sign of the logc-element.
+                      logc_u_r(k,j,2) = inc * lc
+                      logc_ratio_u_r(k,j,2,0:ncorr-1) = lcr(0:ncorr-1)
+                      lcr(0:ncorr-1) = 1.0_wp
+                   ENDIF
+
+!
+!--                Wall for u on the north side, but not on the south side
+                   IF ( ( nzb_u_outer(j,i) > nzb_u_outer(j-1,i) )  .AND.       &
+                        ( nzb_u_outer(j,i) == nzb_u_outer(j+1,i) ) )  THEN
+                      inc        = -1
+                      wall_index =  j+1
+                      CALL pmci_define_loglaw_correction_parameters( lc, lcr,  &
+                          k, j, inc, wall_index, z0(j,i), kb, direction, ncorr )
+!
+!--                   The direction of the wall-normal index is stored as the
+!--                   sign of the logc-element.
+                      logc_u_r(k,j,2) = inc * lc
+                      logc_ratio_u_r(k,j,2,0:ncorr-1) = lcr(0:ncorr-1)
+                      lcr(0:ncorr-1) = 1.0_wp
+                   ENDIF
+
+!
+!--                Wall for w on the south side, but not on the north side
+                   IF ( ( nzb_w_outer(j,i) > nzb_w_outer(j+1,i) )  .AND.       &
+                        ( nzb_w_outer(j,i) == nzb_w_outer(j-1,i) ) )  THEN
+                      inc        =  1
+                      wall_index =  j
+                      CALL pmci_define_loglaw_correction_parameters( lc, lcr,  &
+                          k, j, inc, wall_index, z0(j,i), kb, direction, ncorr )
+!
+!--                   The direction of the wall-normal index is stored as the
+!--                   sign of the logc-element.
+                      logc_w_r(k,j,2) = inc * lc
+                      logc_ratio_w_r(k,j,2,0:ncorr-1) = lcr(0:ncorr-1)
+                      lcr(0:ncorr-1) = 1.0_wp
+                   ENDIF
+
+!
+!--                Wall for w on the north side, but not on the south side
+                   IF ( ( nzb_w_outer(j,i) > nzb_w_outer(j-1,i) )  .AND.       &
+                        ( nzb_w_outer(j,i) == nzb_w_outer(j+1,i) ) )  THEN
+                      inc        = -1
+                      wall_index =  j+1
+                      CALL pmci_define_loglaw_correction_parameters( lc, lcr,  &
+                          k, j, inc, wall_index, z0(j,i), kb, direction, ncorr )
+
+!
+!--                   The direction of the wall-normal index is stored as the
+!--                   sign of the logc-element.
+                      logc_w_r(k,j,2) = inc * lc
+                      logc_ratio_w_r(k,j,2,0:ncorr-1) = lcr(0:ncorr-1)
+                      lcr(0:ncorr-1) = 1.0_wp
+                   ENDIF
+
+                ENDDO
+             ENDDO
+
+          ENDIF   !  IF ( nest_bound_r )
+
+!        
+!--       South boundary
+          IF ( nest_bound_s )  THEN
+
+             ALLOCATE( logc_w_s(nzb:nzt_topo_nestbc_s, nxl:nxr, 1:2) )
+             ALLOCATE( logc_ratio_w_s(nzb:nzt_topo_nestbc_s,nxl:nxr,1:2,       &
+                                      0:ncorr-1) )
+             logc_w_s       = 0
+             logc_ratio_w_s = 1.0_wp
+             direction      = 3
+
+             DO  i = nxl, nxr
+                DO  k = nzb, nzt_topo_nestbc_s
+!
+!--                Wall for v on the left side, but not on the right side
+                   j  = 0
+                   IF ( ( nzb_v_outer(j,i) > nzb_v_outer(j,i+1) )  .AND.       &
+                        ( nzb_v_outer(j,i) == nzb_v_outer(j,i-1) ) )  THEN
+                      inc        =  1
+                      wall_index =  i
+                      CALL pmci_define_loglaw_correction_parameters( lc, lcr,  &
+                          k, i, inc, wall_index, z0(j,i), kb, direction, ncorr )
+!
+!--                   The direction of the wall-normal index is stored as the
+!--                   sign of the logc-element.
+                      logc_v_s(k,i,2) = inc * lc
+                      logc_ratio_v_s(k,i,2,0:ncorr-1) = lcr(0:ncorr-1)
+                      lcr(0:ncorr-1) = 1.0_wp
+                   ENDIF
+
+!
+!--                Wall for v on the right side, but not on the left side
+                   j  = 0
+                   IF ( ( nzb_v_outer(j,i) > nzb_v_outer(j,i-1) )  .AND.       &
+                        ( nzb_v_outer(j,i) == nzb_v_outer(j,i+1) ) )  THEN
+                      inc        = -1
+                      wall_index =  i+1
+                      CALL pmci_define_loglaw_correction_parameters( lc, lcr,  &
+                          k, i, inc, wall_index, z0(j,i), kb, direction, ncorr )
+!
+!--                   The direction of the wall-normal index is stored as the
+!--                   sign of the logc-element.
+                      logc_v_s(k,i,2) = inc * lc
+                      logc_ratio_v_s(k,i,2,0:ncorr-1) = lcr(0:ncorr-1)
+                      lcr(0:ncorr-1) = 1.0_wp
+                   ENDIF
+
+!
+!--                Wall for w on the left side, but not on the right side
+                   j  = -1
+                   IF ( ( nzb_w_outer(j,i) > nzb_w_outer(j,i+1) )  .AND.       &
+                        ( nzb_w_outer(j,i) == nzb_w_outer(j,i-1) ) )  THEN
+                      inc        =  1
+                      wall_index =  i
+                      CALL pmci_define_loglaw_correction_parameters( lc, lcr,  &
+                          k, i, inc, wall_index, z0(j,i), kb, direction, ncorr )
+!
+!--                   The direction of the wall-normal index is stored as the
+!--                   sign of the logc-element.
+                      logc_w_s(k,i,2) = inc * lc
+                      logc_ratio_w_s(k,i,2,0:ncorr - 1) = lcr(0:ncorr-1)
+                      lcr(0:ncorr-1) = 1.0_wp
+                   ENDIF
+
+!
+!--                Wall for w on the right side, but not on the left side
+                   j  = -1
+                   IF ( ( nzb_w_outer(j,i) > nzb_w_outer(j,i-1) )  .AND.       &
+                        ( nzb_w_outer(j,i) == nzb_w_outer(j,i+1) ) )  THEN
+                      inc        = -1
+                      wall_index =  i+1
+                      CALL pmci_define_loglaw_correction_parameters( lc, lcr,  &
+                          k, i, inc, wall_index, z0(j,i), kb, direction, ncorr )
+!
+!--                   The direction of the wall-normal index is stored as the
+!--                   sign of the logc-element.
+                      logc_w_s(k,i,2) = inc * lc
+                      logc_ratio_w_s(k,i,2,0:ncorr-1) = lcr(0:ncorr-1)
+                      lcr(0:ncorr-1) = 1.0_wp
+                   ENDIF
+
+                ENDDO
+             ENDDO
+
+          ENDIF   !  IF (nest_bound_s )
+
+!        
+!--       North boundary
+          IF ( nest_bound_n )  THEN
+
+             ALLOCATE( logc_w_n(nzb:nzt_topo_nestbc_n, nxl:nxr, 1:2) )
+             ALLOCATE( logc_ratio_w_n(nzb:nzt_topo_nestbc_n,nxl:nxr,1:2,       &
+                                      0:ncorr-1) )
+             logc_w_n       = 0
+             logc_ratio_w_n = 1.0_wp
+             direction      = 3
+             j  = nyn + 1
+
+             DO  i = nxl, nxr
+                DO  k = nzb, nzt_topo_nestbc_n
+!
+!--                Wall for v on the left side, but not on the right side
+                   IF ( ( nzb_v_outer(j,i) > nzb_v_outer(j,i+1) )  .AND.       &
+                        ( nzb_v_outer(j,i) == nzb_v_outer(j,i-1) ) )  THEN
+                      inc        = 1
+                      wall_index = i
+                      CALL pmci_define_loglaw_correction_parameters( lc, lcr,  &
+                          k, i, inc, wall_index, z0(j,i), kb, direction, ncorr )
+!
+!--                   The direction of the wall-normal index is stored as the
+!--                   sign of the logc-element.
+                      logc_v_n(k,i,2) = inc * lc
+                      logc_ratio_v_n(k,i,2,0:ncorr-1) = lcr(0:ncorr-1)
+                      lcr(0:ncorr-1) = 1.0_wp
+                   ENDIF
+
+!
+!--                Wall for v on the right side, but not on the left side
+                   IF ( ( nzb_v_outer(j,i) > nzb_v_outer(j,i-1) )  .AND.       &
+                        ( nzb_v_outer(j,i) == nzb_v_outer(j,i+1) ) )  THEN
+                      inc        = -1
+                      wall_index =  i + 1
+                      CALL pmci_define_loglaw_correction_parameters( lc, lcr,  &
+                          k, i, inc, wall_index, z0(j,i), kb, direction, ncorr )
+!
+!--                   The direction of the wall-normal index is stored as the
+!--                   sign of the logc-element.
+                      logc_v_n(k,i,2) = inc * lc
+                      logc_ratio_v_n(k,i,2,0:ncorr-1) = lcr(0:ncorr-1)
+                      lcr(0:ncorr-1) = 1.0_wp
+                   ENDIF
+
+!
+!--                Wall for w on the left side, but not on the right side
+                   IF ( ( nzb_w_outer(j,i) > nzb_w_outer(j,i+1) )  .AND.       &
+                        ( nzb_w_outer(j,i) == nzb_w_outer(j,i-1) ) )  THEN
+                      inc        = 1
+                      wall_index = i
+                      CALL pmci_define_loglaw_correction_parameters( lc, lcr,  &
+                          k, i, inc, wall_index, z0(j,i), kb, direction, ncorr )
+!
+!--                   The direction of the wall-normal index is stored as the
+!--                   sign of the logc-element.
+                      logc_w_n(k,i,2) = inc * lc
+                      logc_ratio_w_n(k,i,2,0:ncorr-1) = lcr(0:ncorr-1)
+                      lcr(0:ncorr-1) = 1.0_wp
+                   ENDIF
+
+!
+!--                Wall for w on the right side, but not on the left side
+                   IF ( ( nzb_w_outer(j,i) > nzb_w_outer(j,i-1) )  .AND.       &
+                        ( nzb_w_outer(j,i) == nzb_w_outer(j,i+1) ) )  THEN
+                      inc        = -1
+                      wall_index =  i+1
+                      CALL pmci_define_loglaw_correction_parameters( lc, lcr,  &
+                          k, i, inc, wall_index, z0(j,i), kb, direction, ncorr )
+!
+!--                   The direction of the wall-normal index is stored as the
+!--                   sign of the logc-element.
+                      logc_w_n(k,i,2) = inc * lc
+                      logc_ratio_w_n(k,i,2,0:ncorr-1) = lcr(0:ncorr-1)
+                      lcr(0:ncorr-1) = 1.0_wp
+                   ENDIF
+
+                ENDDO
+             ENDDO
+
+          ENDIF   !  IF ( nest_bound_n )
+
+       ENDIF   !  IF ( topography /= 'flat' )
+
+    END SUBROUTINE pmci_init_loglaw_correction
+
+
+
+    SUBROUTINE pmci_define_loglaw_correction_parameters( lc, lcr, k, ij, inc,  &
+                                        wall_index, z0_l, kb, direction, ncorr )
+
+       IMPLICIT NONE
+
+       INTEGER(iwp), INTENT(IN)  ::  direction                 !:
+       INTEGER(iwp), INTENT(IN)  ::  ij                        !:
+       INTEGER(iwp), INTENT(IN)  ::  inc                       !:
+       INTEGER(iwp), INTENT(IN)  ::  k                         !:
+       INTEGER(iwp), INTENT(IN)  ::  kb                        !:
+       INTEGER(iwp), INTENT(OUT) ::  lc                        !:
+       INTEGER(iwp), INTENT(IN)  ::  ncorr                     !:
+       INTEGER(iwp), INTENT(IN)  ::  wall_index                !:
+
+       INTEGER(iwp) ::  alcorr       !:
+       INTEGER(iwp) ::  corr_index   !:
+       INTEGER(iwp) ::  lcorr        !:
+
+       LOGICAL      ::  more         !:
+
+       REAL(wp), DIMENSION(0:ncorr-1), INTENT(OUT) ::  lcr     !:
+       REAL(wp), INTENT(IN)      ::  z0_l                      !:
+      
+       REAL(wp)     ::  logvelc1     !:
+      
+
+       SELECT CASE ( direction )
+
+          CASE (1)   !  k
+             more = .TRUE.
+             lcorr = 0
+             DO  WHILE ( more .AND. lcorr <= ncorr-1 )
+                corr_index = k + lcorr
+                IF ( lcorr == 0 )  THEN
+                   CALL pmci_find_logc_pivot_k( lc, logvelc1, z0_l, kb )
+                ENDIF
+               
+                IF ( corr_index < lc )  THEN
+                   lcr(lcorr) = LOG( ( zu(k) - zw(kb) ) / z0_l ) / logvelc1
+                   more = .TRUE.
+                ELSE
+                   lcr(lcorr) = 1.0
+                   more = .FALSE.
+                ENDIF
+                lcorr = lcorr + 1
+             ENDDO
+
+          CASE (2)   !  j
+             more = .TRUE.
+             lcorr  = 0
+             alcorr = 0
+             DO  WHILE ( more  .AND.  alcorr <= ncorr-1 )
+                corr_index = ij + lcorr   ! In this case (direction = 2) ij is j
+                IF ( lcorr == 0 )  THEN
+                   CALL pmci_find_logc_pivot_j( lc, logvelc1, ij, wall_index,  &
+                                                z0_l, inc )
+                ENDIF
+
+!
+!--             The role of inc here is to make the comparison operation "<"
+!--             valid in both directions
+                IF ( inc * corr_index < inc * lc )  THEN
+                   lcr(alcorr) = LOG( ABS( coord_y(corr_index) + 0.5_wp * dy   &
+                                         - coord_y(wall_index) ) / z0_l )      &
+                                 / logvelc1
+                   more = .TRUE.
+                ELSE
+                   lcr(alcorr) = 1.0_wp
+                   more = .FALSE.
+                ENDIF
+                lcorr  = lcorr + inc
+                alcorr = ABS( lcorr )
+             ENDDO
+
+          CASE (3)   !  i
+             more = .TRUE.
+             lcorr  = 0
+             alcorr = 0
+             DO  WHILE ( more  .AND.  alcorr <= ncorr-1 )
+                corr_index = ij + lcorr   ! In this case (direction = 3) ij is i
+                IF ( lcorr == 0 )  THEN
+                   CALL pmci_find_logc_pivot_i( lc, logvelc1, ij, wall_index,  &
+                                                z0_l, inc )
+                ENDIF
+!
+!--             The role of inc here is to make the comparison operation "<"
+!--             valid in both directions
+                IF ( inc * corr_index < inc * lc )  THEN
+                   lcr(alcorr) = LOG( ABS( coord_x(corr_index) + 0.5_wp * dx   &
+                                         - coord_x(wall_index) ) / z0_l )      &
+                                 / logvelc1
+                   more = .TRUE.
+                ELSE
+                   lcr(alcorr) = 1.0_wp
+                   more = .FALSE.
+                ENDIF
+                lcorr  = lcorr + inc
+                alcorr = ABS( lcorr )
+             ENDDO
+
+       END SELECT
+
+    END SUBROUTINE pmci_define_loglaw_correction_parameters
+
+
+
+    SUBROUTINE pmci_find_logc_pivot_k( lc, logzc1, z0_l, kb )
+!
+!--    Finds the pivot node and te log-law factor for near-wall nodes for
+!--    which the wall-parallel velocity components will be log-law corrected
+!--    after interpolation. This subroutine is only for horizontal walls.
+
+       IMPLICIT NONE
+
+       INTEGER(iwp), INTENT(IN)  ::  kb   !:
+       INTEGER(iwp), INTENT(OUT) ::  lc   !:
+
+       INTEGER(iwp) ::  kbc    !:
+       INTEGER(iwp) ::  k1     !:
+
+       REAL(wp),INTENT(OUT) ::  logzc1     !:
+       REAL(wp), INTENT(IN) ::  z0_l       !:
+
+       REAL(wp) ::  zuc1   !:
+
+
+       kbc = nzb + 1
+!
+!--    kbc is the first coarse-grid point above the surface
+       DO  WHILE ( cg%zu(kbc) < zu(kb) )
+          kbc = kbc + 1
+       ENDDO
+       zuc1  = cg%zu(kbc)
+       k1    = kb + 1
+       DO  WHILE ( zu(k1) < zuc1 )  !  Important: must be <, not <=
+          k1 = k1 + 1
+       ENDDO
+       logzc1 = LOG( (zu(k1) - zw(kb) ) / z0_l )
+       lc = k1
+
+    END SUBROUTINE pmci_find_logc_pivot_k
+
+
+
+    SUBROUTINE pmci_find_logc_pivot_j( lc, logyc1, j, jw, z0_l, inc )
+!
+!--    Finds the pivot node and te log-law factor for near-wall nodes for
+!--    which the wall-parallel velocity components will be log-law corrected
+!--    after interpolation. This subroutine is only for vertical walls on
+!--    south/north sides of the node.
+
+       IMPLICIT NONE
+
+       INTEGER(iwp), INTENT(IN)  ::  inc    !:  increment must be 1 or -1.
+       INTEGER(iwp), INTENT(IN)  ::  j      !:
+       INTEGER(iwp), INTENT(IN)  ::  jw     !:
+       INTEGER(iwp), INTENT(OUT) ::  lc     !:
+
+       INTEGER(iwp) ::  j1       !:
+
+       REAL(wp), INTENT(IN) ::  z0_l   !:
+
+       REAL(wp) ::  logyc1   !:
+       REAL(wp) ::  yc1      !:
+
+!
+!--    yc1 is the y-coordinate of the first coarse-grid u- and w-nodes out from
+!--    the wall
+       yc1  = coord_y(jw) + 0.5_wp * inc * cg%dy
+!
+!--    j1 is the first fine-grid index further away from the wall than yc1
+       j1 = j
+!
+!--    Important: must be <, not <=
+       DO  WHILE ( inc * ( coord_y(j1) + 0.5_wp * dy ) < inc * yc1 )
+          j1 = j1 + inc
+       ENDDO
+
+       logyc1 = LOG( ABS( coord_y(j1) + 0.5_wp * dy - coord_y(jw) ) / z0_l )
+       lc = j1
+
+    END SUBROUTINE pmci_find_logc_pivot_j
+
+
+
+    SUBROUTINE pmci_find_logc_pivot_i( lc, logxc1, i, iw, z0_l, inc )
+!
+!--    Finds the pivot node and the log-law factor for near-wall nodes for
+!--    which the wall-parallel velocity components will be log-law corrected
+!--    after interpolation. This subroutine is only for vertical walls on
+!--    south/north sides of the node.
+
+       IMPLICIT NONE
+
+       INTEGER(iwp), INTENT(IN)  ::  i      !:
+       INTEGER(iwp), INTENT(IN)  ::  inc    !: increment must be 1 or -1.
+       INTEGER(iwp), INTENT(IN)  ::  iw     !:
+       INTEGER(iwp), INTENT(OUT) ::  lc     !:
+
+       INTEGER(iwp) ::  i1       !:
+
+       REAL(wp), INTENT(IN) ::  z0_l   !:
+
+       REAL(wp) ::  logxc1   !:
+       REAL(wp) ::  xc1      !:
+
+!
+!--    xc1 is the x-coordinate of the first coarse-grid v- and w-nodes out from
+!--    the wall
+       xc1  = coord_x(iw) + 0.5_wp * inc * cg%dx
+!
+!--    i1 is the first fine-grid index futher away from the wall than xc1.
+       i1 = i
+!
+!--    Important: must be <, not <=
+       DO  WHILE ( inc * ( coord_x(i1) + 0.5_wp *dx ) < inc * xc1 )
+          i1 = i1 + inc
+       ENDDO
+      
+       logxc1 = LOG( ABS( coord_x(i1) + 0.5_wp*dx - coord_x(iw) ) / z0_l )
+       lc = i1
+
+    END SUBROUTINE pmci_find_logc_pivot_i
+
+
+
+
+    SUBROUTINE pmci_init_anterp_tophat
+!
+!--    Precomputation of the client-array indices for
+!--    corresponding coarse-grid array index and the
+!--    Under-relaxation coefficients to be used by anterp_tophat.
+
+       IMPLICIT NONE
+
+       INTEGER(iwp) ::  i        !: Fine-grid index
+       INTEGER(iwp) ::  ii       !: Coarse-grid index
+       INTEGER(iwp) ::  istart   !:
+       INTEGER(iwp) ::  j        !: Fine-grid index
+       INTEGER(iwp) ::  jj       !: Coarse-grid index
+       INTEGER(iwp) ::  jstart   !:
+       INTEGER(iwp) ::  k        !: Fine-grid index
+       INTEGER(iwp) ::  kk       !: Coarse-grid index
+       INTEGER(iwp) ::  kstart   !:
+       REAL(wp)     ::  xi       !:
+       REAL(wp)     ::  eta      !:
+       REAL(wp)     ::  zeta     !:
+     
+!
+!--    Default values:
+       IF ( anterp_relax_length_l < 0.0_wp )  THEN
+          anterp_relax_length_l = 0.1_wp * ( nx + 1 ) * dx
+       ENDIF
+       IF ( anterp_relax_length_r < 0.0_wp )  THEN
+          anterp_relax_length_r = 0.1_wp * ( nx + 1 ) * dx
+       ENDIF
+       IF ( anterp_relax_length_s < 0.0_wp )  THEN
+          anterp_relax_length_s = 0.1_wp * ( ny + 1 ) * dy
+       ENDIF
+       IF ( anterp_relax_length_n < 0.0_wp )  THEN
+          anterp_relax_length_n = 0.1_wp * ( ny + 1 ) * dy
+       ENDIF
+       IF ( anterp_relax_length_t < 0.0_wp )  THEN
+          anterp_relax_length_t = 0.1_wp * zu(nzt)
+       ENDIF
+
+!
+!--    First determine kctu and kctw that are the coarse-grid upper bounds for
+!--    index k
+       kk = 0
+       DO  WHILE ( cg%zu(kk) < zu(nzt) )
+          kk = kk + 1
+       ENDDO
+       kctu = kk - 1
+
+       kk = 0
+       DO  WHILE ( cg%zw(kk) < zw(nzt-1) )
+          kk = kk + 1
+       ENDDO
+       kctw = kk - 1
+
+       ALLOCATE( iflu(icl:icr) )
+       ALLOCATE( iflo(icl:icr) )
+       ALLOCATE( ifuu(icl:icr) )
+       ALLOCATE( ifuo(icl:icr) )
+       ALLOCATE( jflv(jcs:jcn) )
+       ALLOCATE( jflo(jcs:jcn) )
+       ALLOCATE( jfuv(jcs:jcn) )
+       ALLOCATE( jfuo(jcs:jcn) )
+       ALLOCATE( kflw(0:kctw) )
+       ALLOCATE( kflo(0:kctu) )
+       ALLOCATE( kfuw(0:kctw) )
+       ALLOCATE( kfuo(0:kctu) )
+
+!
+!--    i-indices of u for each ii-index value
+       istart = nxlg
+       DO  ii = icl, icr
+          i = istart
+          DO  WHILE ( ( coord_x(i) < cg%coord_x(ii) - 0.5_wp * cg%dx )  .AND.  &
+                      ( i < nxrg ) )
+             i = i + 1
+          ENDDO
+          iflu(ii) = MIN( MAX( i, nxlg ), nxrg )
+          DO  WHILE ( ( coord_x(i) < cg%coord_x(ii) + 0.5_wp * cg%dx )  .AND.  &
+                      ( i < nxrg ) )
+             i = i + 1
+          ENDDO
+          ifuu(ii) = MIN( MAX( i, nxlg ), nxrg )
+          istart = iflu(ii)
+       ENDDO
+
+!
+!--    i-indices of others for each ii-index value
+       istart = nxlg
+       DO  ii = icl, icr
+          i = istart
+          DO  WHILE ( ( coord_x(i) + 0.5_wp * dx < cg%coord_x(ii) )  .AND.     &
+                      ( i < nxrg ) )
+             i = i + 1
+          ENDDO
+          iflo(ii) = MIN( MAX( i, nxlg ), nxrg )
+          DO  WHILE ( ( coord_x(i) + 0.5_wp * dx < cg%coord_x(ii) + cg%dx )    &
+                      .AND.  ( i < nxrg ) )
+             i = i + 1
+          ENDDO
+          ifuo(ii) = MIN(MAX(i,nxlg),nxrg)
+          istart = iflo(ii)
+       ENDDO
+
+!
+!--    j-indices of v for each jj-index value
+       jstart = nysg
+       DO  jj = jcs, jcn
+          j = jstart
+          DO  WHILE ( ( coord_y(j) < cg%coord_y(jj) - 0.5_wp * cg%dy )  .AND.  &
+                      ( j < nyng ) )
+             j = j + 1
+          ENDDO
+          jflv(jj) = MIN( MAX( j, nysg ), nyng )
+          DO  WHILE ( ( coord_y(j) < cg%coord_y(jj) + 0.5_wp * cg%dy )  .AND.  &
+                      ( j < nyng ) )
+             j = j + 1
+          ENDDO
+          jfuv(jj) = MIN( MAX( j, nysg ), nyng )
+          jstart = jflv(jj)
+       ENDDO
+
+!
+!--    j-indices of others for each jj-index value
+       jstart = nysg
+       DO  jj = jcs, jcn
+          j = jstart
+          DO  WHILE ( ( coord_y(j) + 0.5_wp * dy < cg%coord_y(jj) )  .AND.     &
+                      ( j < nyng ) )
+             j = j + 1
+          ENDDO
+          jflo(jj) = MIN( MAX( j, nysg ), nyng )
+          DO  WHILE ( ( coord_y(j) + 0.5_wp * dy < cg%coord_y(jj) + cg%dy )    &
+                      .AND.  ( j < nyng ) )
+             j = j + 1
+          ENDDO
+          jfuo(jj) = MIN( MAX( j, nysg ), nyng )
+          jstart = jflv(jj)
+       ENDDO
+
+!
+!--    k-indices of w for each kk-index value
+       kstart  = 0
+       kflw(0) = 0
+       kfuw(0) = 0
+       DO  kk = 1, kctw
+          k = kstart
+          DO  WHILE ( ( zw(k) < cg%zw(kk) - 0.5_wp * cg%dzw(kk) )  .AND.       &
+                      ( k < nzt ) )
+             k = k + 1
+          ENDDO
+          kflw(kk) = MIN( MAX( k, 1 ), nzt + 1 )
+          DO  WHILE ( ( zw(k) < cg%zw(kk) + 0.5_wp * cg%dzw(kk+1) )  .AND.     &
+                      ( k < nzt ) )
+             k = k + 1
+          ENDDO
+          kfuw(kk) = MIN( MAX( k, 1 ), nzt + 1 )
+          kstart = kflw(kk)
+       ENDDO
+
+!
+!--    k-indices of others for each kk-index value
+       kstart  = 0
+       kflo(0) = 0
+       kfuo(0) = 0
+       DO  kk = 1, kctu
+          k = kstart
+          DO  WHILE ( ( zu(k) < cg%zu(kk) - 0.5_wp * cg%dzu(kk) )  .AND.       &
+                      ( k < nzt ) )
+             k = k + 1
+          ENDDO
+          kflo(kk) = MIN( MAX( k, 1 ), nzt + 1 )
+          DO  WHILE ( ( zu(k) < cg%zu(kk) + 0.5_wp * cg%dzu(kk+1) )  .AND.     &
+                      ( k < nzt ) )
+             k = k + 1
+          ENDDO
+          kfuo(kk) = MIN( MAX( k-1, 1 ), nzt + 1 )
+          kstart = kflo(kk)
+       ENDDO
+     
+!
+!--    Spatial under-relaxation coefficients
+       ALLOCATE( frax(icl:icr) )
+
+       DO  ii = icl, icr
+          IF ( nest_bound_l )  THEN
+             xi = ( MAX( 0.0_wp, ( cg%coord_x(ii) - lower_left_coord_x ) ) /   &
+                    anterp_relax_length_l )**4
+          ELSEIF ( nest_bound_r )  THEN
+             xi = ( MAX( 0.0_wp, ( lower_left_coord_x + ( nx + 1 ) * dx -      &
+                                   cg%coord_x(ii) ) ) /                        &
+                    anterp_relax_length_r )**4
+          ELSE
+             xi = 999999.9_wp
+          ENDIF
+          frax(ii) = xi / ( 1.0_wp + xi )
+       ENDDO
+
+       ALLOCATE( fray(jcs:jcn) )
+
+       DO  jj = jcs, jcn
+          IF ( nest_bound_s )  THEN
+             eta = ( MAX( 0.0_wp, ( cg%coord_y(jj) - lower_left_coord_y ) ) /  &
+                     anterp_relax_length_s )**4
+          ELSEIF ( nest_bound_n )  THEN
+             eta = ( MAX( 0.0_wp, ( lower_left_coord_y + ( ny + 1 ) * dy -     &
+                                    cg%coord_y(jj)) ) /                        &
+                     anterp_relax_length_n )**4
+          ELSE
+             eta = 999999.9_wp
+          ENDIF
+          fray(jj) = eta / ( 1.0_wp + eta )
+       ENDDO
+      
+       ALLOCATE( fraz(0:kctu) )
+       DO  kk = 0, kctu
+          zeta = ( ( zu(nzt) - cg%zu(kk) ) / anterp_relax_length_t )**4
+          fraz(kk) = zeta / ( 1.0_wp + zeta )
+       ENDDO
+
+    END SUBROUTINE pmci_init_anterp_tophat
+
+
+
+    SUBROUTINE pmci_init_tkefactor
+
+!
+!--    Computes the scaling factor for the SGS TKE from coarse grid to be used
+!--    as BC for the fine grid. Based on the Kolmogorov energy spectrum
+!--    for the inertial subrange and assumption of sharp cut-off of the resolved
+!--    energy spectrum. Near the surface, the reduction of TKE is made
+!--    smaller than further away from the surface.
+
+       IMPLICIT NONE
+       REAL(wp), PARAMETER ::  cfw = 0.2_wp          !:
+       REAL(wp), PARAMETER ::  c_tkef = 0.6_wp       !:
+       REAL(wp)            ::  fw                    !:
+       REAL(wp), PARAMETER ::  fw0 = 0.9_wp          !:
+       REAL(wp)            ::  glsf                  !:
+       REAL(wp)            ::  glsc                  !:
+       REAL(wp)            ::  height                !:
+       REAL(wp), PARAMETER ::  p13 = 1.0_wp/3.0_wp   !:
+       REAL(wp), PARAMETER ::  p23 = 2.0_wp/3.0_wp   !:
+       INTEGER(iwp)        ::  k                     !:
+       INTEGER(iwp)        ::  kc                    !:
+        
+
+       IF ( nest_bound_l )  THEN
+          ALLOCATE( tkefactor_l(nzb:nzt+1,nysg:nyng) )
+          tkefactor_l = 0.0_wp
+          i = nxl - 1
+          DO  j = nysg, nyng
+             DO  k = nzb_s_inner(j,i) + 1, nzt
+                kc     = kco(k+1)
+                glsf   = ( dx * dy * dzu(k) )**p13
+                glsc   = ( cg%dx * cg%dy *cg%dzu(kc) )**p13
+                height = zu(k) - zu(nzb_s_inner(j,i))
+                fw     = EXP( -cfw * height / glsf )
+                tkefactor_l(k,j) = c_tkef * ( fw0 * fw + ( 1.0_wp - fw ) *     &
+                                              ( glsf / glsc )**p23 )
+             ENDDO
+             tkefactor_l(nzb_s_inner(j,i),j) = c_tkef * fw0
+          ENDDO
+       ENDIF
+
+       IF ( nest_bound_r )  THEN
+          ALLOCATE( tkefactor_r(nzb:nzt+1,nysg:nyng) )
+          tkefactor_r = 0.0_wp
+          i = nxr + 1
+          DO  j = nysg, nyng
+             DO  k = nzb_s_inner(j,i) + 1, nzt
+                kc     = kco(k+1)
+                glsf   = ( dx * dy * dzu(k) )**p13
+                glsc   = ( cg%dx * cg%dy * cg%dzu(kc) )**p13
+                height = zu(k) - zu(nzb_s_inner(j,i))
+                fw     = EXP( -cfw * height / glsf )
+                tkefactor_r(k,j) = c_tkef * ( fw0 * fw + ( 1.0_wp - fw ) *     &
+                                              ( glsf / glsc )**p23 )
+             ENDDO
+             tkefactor_r(nzb_s_inner(j,i),j) = c_tkef * fw0
+          ENDDO
+       ENDIF
+
+      IF ( nest_bound_s )  THEN
+          ALLOCATE( tkefactor_s(nzb:nzt+1,nxlg:nxrg) )
+          tkefactor_s = 0.0_wp
+          j = nys - 1
+          DO  i = nxlg, nxrg
+             DO  k = nzb_s_inner(j,i) + 1, nzt
+                kc     = kco(k+1)
+                glsf   = ( dx * dy * dzu(k) )**p13
+                glsc   = ( cg%dx * cg%dy * cg%dzu(kc) ) ** p13
+                height = zu(k) - zu(nzb_s_inner(j,i))
+                fw     = EXP( -cfw*height / glsf )
+                tkefactor_s(k,i) = c_tkef * ( fw0 * fw + ( 1.0_wp - fw ) *     &
+                                              ( glsf / glsc )**p23 )
+             ENDDO
+             tkefactor_s(nzb_s_inner(j,i),i) = c_tkef * fw0
+          ENDDO
+       ENDIF
+
+       IF ( nest_bound_n )  THEN
+          ALLOCATE( tkefactor_n(nzb:nzt+1,nxlg:nxrg) )
+          tkefactor_n = 0.0_wp
+          j = nyn + 1
+          DO  i = nxlg, nxrg
+             DO  k = nzb_s_inner(j,i)+1, nzt
+                kc     = kco(k+1)
+                glsf   = ( dx * dy * dzu(k) )**p13
+                glsc   = ( cg%dx * cg%dy * cg%dzu(kc) )**p13
+                height = zu(k) - zu(nzb_s_inner(j,i))
+                fw     = EXP( -cfw * height / glsf )
+                tkefactor_n(k,i) = c_tkef * ( fw0 * fw + ( 1.0_wp - fw ) *     &
+                                              ( glsf / glsc )**p23 )
+             ENDDO
+             tkefactor_n(nzb_s_inner(j,i),i) = c_tkef * fw0
+          ENDDO
+       ENDIF
+
+       ALLOCATE( tkefactor_t(nysg:nyng,nxlg:nxrg) )
+       k = nzt
+       DO  i = nxlg, nxrg
+          DO  j = nysg, nyng
+             kc     = kco(k+1)
+             glsf   = ( dx * dy * dzu(k) )**p13
+             glsc   = ( cg%dx * cg%dy * cg%dzu(kc) )**p13
+             height = zu(k) - zu(nzb_s_inner(j,i))
+             fw     = EXP( -cfw * height / glsf )
+             tkefactor_t(j,i) = c_tkef * ( fw0 * fw + ( 1.0_wp - fw ) *        &
+                                           ( glsf / glsc )**p23 )
+          ENDDO
+       ENDDO
+      
+    END SUBROUTINE pmci_init_tkefactor
+
+#endif
+ END SUBROUTINE pmci_setup_client
+
+
+
+ SUBROUTINE pmci_setup_coordinates
+
+#if defined( __parallel )
+    IMPLICIT NONE
+
+    INTEGER(iwp) ::  i   !:
+    INTEGER(iwp) ::  j   !:
+
+!
+!-- Create coordinate arrays.
+    ALLOCATE( coord_x(-nbgp:nx+nbgp) )
+    ALLOCATE( coord_y(-nbgp:ny+nbgp) )
+     
+    DO  i = -nbgp, nx + nbgp
+       coord_x(i) = lower_left_coord_x + i * dx
+    ENDDO
+     
+    DO  j = -nbgp, ny + nbgp
+       coord_y(j) = lower_left_coord_y + j * dy
+    ENDDO
+
+#endif
+ END SUBROUTINE pmci_setup_coordinates
+
+
+
+
+ SUBROUTINE pmci_set_array_pointer( name, client_id, nz_cl )
+
+    IMPLICIT NONE
+
+    INTEGER, INTENT(IN)          ::  client_id   !:
+    INTEGER, INTENT(IN)          ::  nz_cl       !:
+    CHARACTER(LEN=*), INTENT(IN) ::  name        !:
+
+#if defined( __parallel )
+    INTEGER(iwp) ::  ierr        !:
+    INTEGER(iwp) ::  istat       !:
+
+    REAL(wp), POINTER, DIMENSION(:,:)   ::  p_2d        !:
+    REAL(wp), POINTER, DIMENSION(:,:)   ::  p_2d_sec    !:
+    REAL(wp), POINTER, DIMENSION(:,:,:) ::  p_3d        !:
+    REAL(wp), POINTER, DIMENSION(:,:,:) ::  p_3d_sec    !:
+
+
+    NULLIFY( p_3d )
+    NULLIFY( p_2d )
+
+!
+!-- List of array names, which can be coupled.
+!-- In case of 3D please change also the second array for the pointer version
+    IF ( TRIM(name) == "u"  )  p_3d => u
+    IF ( TRIM(name) == "v"  )  p_3d => v
+    IF ( TRIM(name) == "w"  )  p_3d => w
+    IF ( TRIM(name) == "e"  )  p_3d => e
+    IF ( TRIM(name) == "pt" )  p_3d => pt
+    IF ( TRIM(name) == "q"  )  p_3d => q
+!
+!-- Next line is just an example for a 2D array (not active for coupling!)
+!-- Please note, that z0 has to be declared as TARGET array in modules.f90
+!    IF ( TRIM(name) == "z0" )    p_2d => z0
+
+#if defined( __nopointer )
+    IF ( ASSOCIATED( p_3d ) )  THEN
+       CALL pmc_s_set_dataarray( client_id, p_3d, nz_cl, nz )
+    ELSEIF ( ASSOCIATED( p_2d ) )  THEN
+       CALL pmc_s_set_dataarray( client_id, p_2d )
+    ELSE
+!
+!--    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
+#else
+    IF ( TRIM(name) == "u"  )  p_3d_sec => u_2
+    IF ( TRIM(name) == "v"  )  p_3d_sec => v_2
+    IF ( TRIM(name) == "w"  )  p_3d_sec => w_2
+    IF ( TRIM(name) == "e"  )  p_3d_sec => e_2
+    IF ( TRIM(name) == "pt" )  p_3d_sec => pt_2
+    IF ( TRIM(name) == "q"  )  p_3d_sec => q_2
+
+    IF ( ASSOCIATED( p_3d ) )  THEN
+       CALL pmc_s_set_dataarray( client_id, p_3d, nz_cl, nz, &
+                                 array_2 = p_3d_sec )
+    ELSEIF ( ASSOCIATED( p_2d ) )  THEN
+       CALL pmc_s_set_dataarray( client_id, p_2d )
+    ELSE
+!
+!--    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
+
+#endif
+ END SUBROUTINE pmci_set_array_pointer
+
+
+
+ SUBROUTINE pmci_create_client_arrays( name, is, ie, js, je, nzc  )
+
+    IMPLICIT NONE
+
+    CHARACTER(LEN=*), INTENT(IN) ::  name    !:
+
+    INTEGER(iwp), INTENT(IN) ::  ie      !:
+    INTEGER(iwp), INTENT(IN) ::  is      !:
+    INTEGER(iwp), INTENT(IN) ::  je      !:
+    INTEGER(iwp), INTENT(IN) ::  js      !:
+    INTEGER(iwp), INTENT(IN) ::  nzc     !:  Note that nzc is cg%nz
+
+#if defined( __parallel )
+    INTEGER(iwp) ::  ierr    !:
+    INTEGER(iwp) ::  istat   !:
+
+    REAL(wp), POINTER,DIMENSION(:,:)   ::  p_2d    !:
+    REAL(wp), POINTER,DIMENSION(:,:,:) ::  p_3d    !:
+
+
+    NULLIFY( p_3d )
+    NULLIFY( p_2d )
+
+!
+!-- List of array names, which can be coupled
+    IF ( TRIM( name ) == "u" )  THEN
+       IF ( .NOT. ALLOCATED( uc ) )  ALLOCATE( uc(0:nzc+1, js:je, is:ie) )
+       p_3d => uc
+    ELSEIF ( TRIM( name ) == "v" )  THEN
+       IF ( .NOT. ALLOCATED( vc ) )  ALLOCATE( vc(0:nzc+1, js:je, is:ie) )
+       p_3d => vc
+    ELSEIF ( TRIM( name ) == "w" )  THEN
+       IF ( .NOT. ALLOCATED( wc ) )  ALLOCATE( wc(0:nzc+1, js:je, is:ie) )
+       p_3d => wc
+    ELSEIF ( TRIM( name ) == "e" )  THEN
+       IF ( .NOT. ALLOCATED( ec ) )  ALLOCATE( ec(0:nzc+1, js:je, is:ie) )
+       p_3d => ec
+    ELSEIF ( TRIM( name ) == "pt")  THEN
+       IF ( .NOT. ALLOCATED( ptc ) ) ALLOCATE( ptc(0:nzc+1, js:je, is:ie) )
+       p_3d => ptc
+    ELSEIF ( TRIM( name ) == "q")  THEN
+       IF ( .NOT. ALLOCATED( qc ) ) ALLOCATE( qc(0:nzc+1, js:je, is:ie) )
+       p_3d => qc
+    !ELSEIF (trim(name) == "z0") then
+       !IF (.not.allocated(z0c))  allocate(z0c(js:je, is:ie))
+       !p_2d => z0c
+    ENDIF
+
+    IF ( ASSOCIATED( p_3d ) )  THEN
+       CALL pmc_c_set_dataarray( p_3d )
+    ELSEIF ( ASSOCIATED( p_2d ) )  THEN
+       CALL pmc_c_set_dataarray( p_2d )
+    ELSE
+!
+!--    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
+!
+!--       Prevent others from continuing
+          CALL MPI_BARRIER( comm2d, ierr )
+       ENDIF
+    ENDIF
+
+#endif
+ END SUBROUTINE pmci_create_client_arrays
+
+
+
+ SUBROUTINE pmci_server_initialize
+!-- TO_DO: add general explanations about what this subroutine does
+#if defined( __parallel )
+    IMPLICIT NONE
+
+    INTEGER(iwp) ::  client_id   !:
+    INTEGER(iwp) ::  m           !:
+
+    REAL(wp) ::  waittime    !:
+
+
+    DO  m = 1, SIZE( pmc_server_for_client ) - 1
+       client_id = pmc_server_for_client(m)
+       CALL pmc_s_fillbuffer( client_id, waittime=waittime )
+    ENDDO
+
+#endif
+ END SUBROUTINE pmci_server_initialize
+
+
+
+ SUBROUTINE pmci_client_initialize
+!-- TO_DO: add general explanations about what this subroutine does
+#if defined( __parallel )
+    IMPLICIT NONE
+
+    INTEGER(iwp) ::  i          !:
+    INTEGER(iwp) ::  icl        !:
+    INTEGER(iwp) ::  icr        !:
+    INTEGER(iwp) ::  j          !:
+    INTEGER(iwp) ::  jcn        !:
+    INTEGER(iwp) ::  jcs        !:
+
+    REAL(wp) ::  waittime   !:
+
+!
+!-- Root id is never a client
+    IF ( cpl_id > 1 )  THEN
+
+!
+!--    Client domain boundaries in the server index space
+       icl = coarse_bound(1)
+       icr = coarse_bound(2)
+       jcs = coarse_bound(3)
+       jcn = coarse_bound(4)
+
+!
+!--    Get data from server
+       CALL pmc_c_getbuffer( waittime = waittime )
+
+!
+!--    The interpolation.
+       CALL pmci_interp_tril_all ( u,  uc,  icu, jco, kco, r1xu, r2xu, r1yo,   &
+                                   r2yo, r1zo, r2zo, nzb_u_inner, 'u' )
+       CALL pmci_interp_tril_all ( v,  vc,  ico, jcv, kco, r1xo, r2xo, r1yv,   &
+                                   r2yv, r1zo, r2zo, nzb_v_inner, 'v' )
+       CALL pmci_interp_tril_all ( w,  wc,  ico, jco, kcw, r1xo, r2xo, r1yo,   &
+                                   r2yo, r1zw, r2zw, nzb_w_inner, 'w' )
+       CALL pmci_interp_tril_all ( e,  ec,  ico, jco, kco, r1xo, r2xo, r1yo,   &
+                                   r2yo, r1zo, r2zo, nzb_s_inner, 'e' )
+       CALL pmci_interp_tril_all ( pt, ptc, ico, jco, kco, r1xo, r2xo, r1yo,   &
+                                   r2yo, r1zo, r2zo, nzb_s_inner, 's' )
+       IF ( humidity  .OR.  passive_scalar )  THEN
+          CALL pmci_interp_tril_all ( q, qc, ico, jco, kco, r1xo, r2xo, r1yo,  &
+                                      r2yo, r1zo, r2zo, nzb_s_inner, 's' )
+       ENDIF
+
+       IF ( topography /= 'flat' )  THEN
+!
+!--       Inside buildings set velocities and TKE back to zero.
+!--       Other scalars (pt, q, s, km, kh, p, sa, ...) are ignored at present,
+!--       maybe revise later.
+          DO   i = nxlg, nxrg
+             DO   j = nysg, nyng
+                u(nzb:nzb_u_inner(j,i),j,i)   = 0.0_wp
+                v(nzb:nzb_v_inner(j,i),j,i)   = 0.0_wp
+                w(nzb:nzb_w_inner(j,i),j,i)   = 0.0_wp
+                e(nzb:nzb_s_inner(j,i),j,i)   = 0.0_wp
+                u_p(nzb:nzb_u_inner(j,i),j,i) = 0.0_wp
+                v_p(nzb:nzb_v_inner(j,i),j,i) = 0.0_wp
+                w_p(nzb:nzb_w_inner(j,i),j,i) = 0.0_wp
+                e_p(nzb:nzb_s_inner(j,i),j,i) = 0.0_wp
+             ENDDO
+          ENDDO
+       ENDIF
+    ENDIF
+
+
+ CONTAINS
+
+
+    SUBROUTINE pmci_interp_tril_all( f, fc, ic, jc, kc, r1x, r2x, r1y, r2y,    &
+                                     r1z, r2z, kb, var )
+!
+!--    Interpolation of the internal values for the client-domain initialization
+!--    This subroutine is based on trilinear interpolation.
+!--    Coding based on interp_tril_lr/sn/t
+       IMPLICIT NONE
+
+       CHARACTER(LEN=1), INTENT(IN) :: var  !:
+
+       INTEGER(iwp), DIMENSION(nxlg:nxrg), INTENT(IN)           ::  ic    !:
+       INTEGER(iwp), DIMENSION(nysg:nyng), INTENT(IN)           ::  jc    !:
+       INTEGER(iwp), DIMENSION(nzb:nzt+1), INTENT(IN)           ::  kc    !:
+       INTEGER(iwp), DIMENSION(nysg:nyng,nxlg:nxrg), INTENT(IN) ::  kb    !:
+
+       INTEGER(iwp) ::  i      !:
+       INTEGER(iwp) ::  ib     !:
+       INTEGER(iwp) ::  ie     !:
+       INTEGER(iwp) ::  j      !:
+       INTEGER(iwp) ::  jb     !:
+       INTEGER(iwp) ::  je     !:
+       INTEGER(iwp) ::  k      !:
+       INTEGER(iwp) ::  k1     !:
+       INTEGER(iwp) ::  kbc    !:
+       INTEGER(iwp) ::  l      !:
+       INTEGER(iwp) ::  m      !:
+       INTEGER(iwp) ::  n      !:
+
+       REAL(wp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg), INTENT(INOUT) :: f !:
+       REAL(wp), DIMENSION(0:cg%nz+1,jcs:jcn,icl:icr), INTENT(IN) :: fc    !:
+       REAL(wp), DIMENSION(nxlg:nxrg), INTENT(IN) :: r1x   !:
+       REAL(wp), DIMENSION(nxlg:nxrg), INTENT(IN) :: r2x   !:
+       REAL(wp), DIMENSION(nysg:nyng), INTENT(IN) :: r1y   !:
+       REAL(wp), DIMENSION(nysg:nyng), INTENT(IN) :: r2y   !:
+       REAL(wp), DIMENSION(nzb:nzt+1), INTENT(IN) :: r1z   !:
+       REAL(wp), DIMENSION(nzb:nzt+1), INTENT(IN) :: r2z   !:
+
+       REAL(wp) ::  fk         !:
+       REAL(wp) ::  fkj        !:
+       REAL(wp) ::  fkjp       !:
+       REAL(wp) ::  fkp        !:
+       REAL(wp) ::  fkpj       !:
+       REAL(wp) ::  fkpjp      !:
+       REAL(wp) ::  logratio   !:
+       REAL(wp) ::  logzuc1    !:
+       REAL(wp) ::  zuc1       !:
+
+
+       ib = nxl
+       ie = nxr
+       jb = nys
+       je = nyn
+       IF ( nest_bound_l )  THEN
+          ib = nxl - 1
+!
+!--       For u, nxl is a ghost node, but not for the other variables
+          IF ( var == 'u' )  THEN
+             ib = nxl
+          ENDIF
+       ENDIF
+       IF ( nest_bound_s )  THEN
+          jb = nys - 1
+!
+!--       For v, nys is a ghost node, but not for the other variables
+          IF ( var == 'v' )  THEN
+             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, ie
+          DO  j = jb, je
+             DO  k = kb(j,i), nzt + 1
+                l = ic(i)
+                m = jc(j)
+                n = kc(k)
+                fkj      = r1x(i) * fc(n,m,l)     + r2x(i) * fc(n,m,l+1)
+                fkjp     = r1x(i) * fc(n,m+1,l)   + r2x(i) * fc(n,m+1,l+1)
+                fkpj     = r1x(i) * fc(n+1,m,l)   + r2x(i) * fc(n+1,m,l+1)
+                fkpjp    = r1x(i) * fc(n+1,m+1,l) + r2x(i) * fc(n+1,m+1,l+1)
+                fk       = r1y(j) * fkj  + r2y(j) * fkjp
+                fkp      = r1y(j) * fkpj + r2y(j) * fkpjp
+                f(k,j,i) = r1z(k) * fk   + r2z(k) * fkp
+             ENDDO
+          ENDDO
+       ENDDO
+
+!
+!--    Correct the interpolated values of u and v in near-wall nodes, i.e. in
+!--    the nodes below the coarse-grid nodes with k=1. The corrction is only
+!--    made over horizontal wall surfaces in this phase. For the nest boundary
+!--    conditions, a corresponding correction is made for all vertical walls,
+!--    too.
+       IF ( var == 'u' .OR. var == 'v' )  THEN
+          DO  i = ib, nxr
+             DO  j = jb, nyn
+                kbc = 1
+!
+!--             kbc is the first coarse-grid point above the surface
+                DO  WHILE ( cg%zu(kbc) < zu(kb(j,i)) )
+                   kbc = kbc + 1
+                ENDDO
+                zuc1 = cg%zu(kbc)
+                k1   = kb(j,i) + 1
+                DO  WHILE ( zu(k1) < zuc1 )
+                   k1 = k1 + 1
+                ENDDO
+                logzuc1 = LOG( ( zu(k1) - zu(kb(j,i)) ) / z0(j,i) )
+
+                k = kb(j,i) + 1
+                DO  WHILE ( zu(k) < zuc1 )
+                   logratio = ( LOG( ( zu(k) - zu(kb(j,i)) ) / z0(j,i)) ) / logzuc1
+                   f(k,j,i) = logratio * f(k1,j,i)
+                   k  = k + 1
+                ENDDO
+                f(kb(j,i),j,i) = 0.0_wp
+             ENDDO
+          ENDDO
+
+       ELSEIF ( var == 'w' )  THEN
+
+          DO  i = ib, nxr
+              DO  j = jb, nyn
+                f(kb(j,i),j,i) = 0.0_wp
+             ENDDO
+          ENDDO
+
+       ENDIF
+
+    END SUBROUTINE pmci_interp_tril_all
+
+#endif
+ END SUBROUTINE pmci_client_initialize
+
+
+
+ SUBROUTINE pmci_check_setting_mismatches
+!
+!-- Check for mismatches between settings of master and client variables
+!-- (e.g., all clients have to follow the end_time settings of the root model).
+!-- The root model overwrites variables in the other models, so these variables
+!-- only need to be set once in file PARIN.
+
+#if defined( __parallel )
+
+    USE control_parameters,                                                    &
+        ONLY:  dt_restart, end_time, message_string, restart_time, time_restart
+
+    IMPLICIT NONE
+
+    INTEGER ::  ierr
+
+    REAL(wp) ::  dt_restart_root
+    REAL(wp) ::  end_time_root
+    REAL(wp) ::  restart_time_root
+    REAL(wp) ::  time_restart_root
+
+!
+!-- Check the time to be simulated.
+!-- Here, and in the following, the root process communicates the respective
+!-- variable to all others, and its value will then be compared with the local
+!-- values.
+    IF ( pmc_is_rootmodel() )  end_time_root = end_time
+    CALL MPI_BCAST( end_time_root, 1, MPI_REAL, 0, comm_world_nesting, ierr )
+
+    IF ( .NOT. pmc_is_rootmodel() )  THEN
+       IF ( end_time /= end_time_root )  THEN
+          WRITE( message_string, * )  'mismatch between root model and ',      &
+               'client settings &   end_time(root) = ', end_time_root,         &
+               ' &   end_time(client) = ', end_time, ' & client value is set', &
+               ' to root value'
+          CALL message( 'pmci_check_setting_mismatches', 'PA0419', 0, 1, 0, 6, &
+                        0 )
+          end_time = end_time_root
+       ENDIF
+    ENDIF
+
+!
+!-- Same for restart time
+    IF ( pmc_is_rootmodel() )  restart_time_root = restart_time
+    CALL MPI_BCAST( restart_time_root, 1, MPI_REAL, 0, comm_world_nesting, ierr )
+
+    IF ( .NOT. pmc_is_rootmodel() )  THEN
+       IF ( restart_time /= restart_time_root )  THEN
+          WRITE( message_string, * )  'mismatch between root model and ',      &
+               'client settings &   restart_time(root) = ', restart_time_root, &
+               ' &   restart_time(client) = ', restart_time, ' & client ',     &
+               'value is set to root value'
+          CALL message( 'pmci_check_setting_mismatches', 'PA0419', 0, 1, 0, 6, &
+                        0 )
+          restart_time = restart_time_root
+       ENDIF
+    ENDIF
+
+!
+!-- Same for dt_restart
+    IF ( pmc_is_rootmodel() )  dt_restart_root = dt_restart
+    CALL MPI_BCAST( dt_restart_root, 1, MPI_REAL, 0, comm_world_nesting, ierr )
+
+    IF ( .NOT. pmc_is_rootmodel() )  THEN
+       IF ( dt_restart /= dt_restart_root )  THEN
+          WRITE( message_string, * )  'mismatch between root model and ',      &
+               'client settings &   dt_restart(root) = ', dt_restart_root,     &
+               ' &   dt_restart(client) = ', dt_restart, ' & client ',         &
+               'value is set to root value'
+          CALL message( 'pmci_check_setting_mismatches', 'PA0419', 0, 1, 0, 6, &
+                        0 )
+          dt_restart = dt_restart_root
+       ENDIF
+    ENDIF
+
+!
+!-- Same for time_restart
+    IF ( pmc_is_rootmodel() )  time_restart_root = time_restart
+    CALL MPI_BCAST( time_restart_root, 1, MPI_REAL, 0, comm_world_nesting, ierr )
+
+    IF ( .NOT. pmc_is_rootmodel() )  THEN
+       IF ( time_restart /= time_restart_root )  THEN
+          WRITE( message_string, * )  'mismatch between root model and ',      &
+               'client settings &   time_restart(root) = ', time_restart_root, &
+               ' &   time_restart(client) = ', time_restart, ' & client ',     &
+               'value is set to root value'
+          CALL message( 'pmci_check_setting_mismatches', 'PA0419', 0, 1, 0, 6, &
+                        0 )
+          time_restart = time_restart_root
+       ENDIF
+    ENDIF
+
+#endif
+
+ END SUBROUTINE pmci_check_setting_mismatches
+
+
+
+ SUBROUTINE pmci_ensure_nest_mass_conservation
+
+#if defined( __parallel )
+!
+!-- Adjust the volume-flow rate through the top boundary so that the net volume
+!-- flow through all boundaries of the current nest domain becomes zero.
+    IMPLICIT NONE
+
+    INTEGER(iwp) ::  i                          !:
+    INTEGER(iwp) ::  ierr                       !:
+    INTEGER(iwp) ::  j                          !:
+    INTEGER(iwp) ::  k                          !:
+
+    REAL(wp) ::  dxdy                            !:
+    REAL(wp) ::  innor                           !:
+    REAL(wp) ::  w_lt                            !:
+    REAL(wp), DIMENSION(1:3) ::  volume_flow_l   !:
+
+!
+!-- Sum up the volume flow through the left/right boundaries
+    volume_flow(1)   = 0.0_wp
+    volume_flow_l(1) = 0.0_wp
+
+    IF ( nest_bound_l )  THEN
+       i = 0
+       innor = dy
+       DO   j = nys, nyn
+          DO   k = nzb_u_inner(j,i)+1, nzt
+             volume_flow_l(1) = volume_flow_l(1) + innor * u(k,j,i) * dzw(k)
+          ENDDO
+       ENDDO
+    ENDIF
+
+    IF ( nest_bound_r )  THEN
+       i = nx + 1
+       innor = -dy
+       DO   j = nys, nyn
+          DO   k = nzb_u_inner(j,i)+1, nzt
+             volume_flow_l(1) = volume_flow_l(1) + innor * u(k,j,i) * dzw(k)
+          ENDDO
+       ENDDO
+    ENDIF
+
+#if defined( __parallel )
+    IF ( collective_wait )  CALL MPI_BARRIER( comm2d, ierr )
+    CALL MPI_ALLREDUCE( volume_flow_l(1), volume_flow(1), 1, MPI_REAL, &
+                        MPI_SUM, comm2d, ierr )
+#else
+    volume_flow(1) = volume_flow_l(1)
+#endif
+
+!
+!-- Sum up the volume flow through the south/north boundaries
+    volume_flow(2)   = 0.0_wp
+    volume_flow_l(2) = 0.0_wp
+
+    IF ( nest_bound_s )  THEN
+       j = 0
+       innor = dx
+       DO   i = nxl, nxr
+          DO   k = nzb_v_inner(j,i)+1, nzt
+             volume_flow_l(2) = volume_flow_l(2) + innor * v(k,j,i) * dzw(k)
+          ENDDO
+       ENDDO
+    ENDIF
+
+    IF ( nest_bound_n )  THEN
+       j = ny + 1
+       innor = -dx
+       DO   i = nxl, nxr
+          DO   k = nzb_v_inner(j,i)+1, nzt
+             volume_flow_l(2) = volume_flow_l(2) + innor * v(k,j,i) * dzw(k)
+          ENDDO
+       ENDDO
+    ENDIF
+
+#if defined( __parallel )
+    IF ( collective_wait )  CALL MPI_BARRIER( comm2d, ierr )
+    CALL MPI_ALLREDUCE( volume_flow_l(2), volume_flow(2), 1, MPI_REAL,         &
+                        MPI_SUM, comm2d, ierr )
+#else
+    volume_flow(2) = volume_flow_l(2)
+#endif
+
+!
+!-- Sum up the volume flow through the top boundary
+    volume_flow(3)   = 0.0_wp
+    volume_flow_l(3) = 0.0_wp
+    dxdy = dx * dy
+    k = nzt
+    DO   i = nxl, nxr
+       DO   j = nys, nyn
+          volume_flow_l(3) = volume_flow_l(3) - w(k,j,i) * dxdy
+       ENDDO
+    ENDDO
+
+#if defined( __parallel )
+    IF ( collective_wait )  CALL MPI_BARRIER( comm2d, ierr )
+    CALL MPI_ALLREDUCE( volume_flow_l(3), volume_flow(3), 1, MPI_REAL,         &
+                        MPI_SUM, comm2d, ierr )
+#else
+    volume_flow(3) = volume_flow_l(3)
+#endif
+
+!
+!-- Correct the top-boundary value of w
+    w_lt = (volume_flow(1) + volume_flow(2) + volume_flow(3)) / area_t
+    DO   i = nxl, nxr
+       DO   j = nys, nyn
+          DO  k = nzt, nzt + 1
+             w(k,j,i) = w(k,j,i) + w_lt
+          ENDDO
+       ENDDO
+    ENDDO
+
+#endif
+ END SUBROUTINE pmci_ensure_nest_mass_conservation
+
+
+!-- TO_DO: the timestep sycnchronization could be done easier using
+!--        an MPI_ALLREDUCE with MIN over MPI_COMM_WORLD
+ SUBROUTINE pmci_server_synchronize
+
+#if defined( __parallel )
+!
+!-- Unify the time steps for each model and synchronize. This is based on the
+!-- assumption that the native time step (original dt_3d) of any server is
+!-- always larger than the smallest native time step of it s clients.
+    IMPLICIT NONE
+
+    INTEGER(iwp) ::  client_id   !:
+    INTEGER(iwp) ::  ierr        !:
+    INTEGER(iwp) ::  m           !:
+
+    REAL(wp), DIMENSION(1) ::  dtc         !:
+    REAL(wp), DIMENSION(1) ::  dtl         !:
+
+
+    CALL cpu_log( log_point_s(70), 'pmc sync', 'start' )
+
+!
+!-- First find the smallest native time step of all the clients of the current
+!-- server.
+    dtl(1) = 999999.9_wp
+    DO  m = 1, SIZE( PMC_Server_for_Client )-1
+       client_id = PMC_Server_for_Client(m)
+       IF ( myid == 0 )  THEN
+          CALL pmc_recv_from_client( client_id, dtc, SIZE( dtc ), 0, 101, ierr )
+          dtl(1) = MIN( dtl(1), dtc(1) )
+          dt_3d   = dtl(1)
+       ENDIF
+    ENDDO
+
+!
+!-- Broadcast the unified time step to all server processes
+    CALL MPI_BCAST( dt_3d, 1, MPI_REAL, 0, comm2d, ierr )
+
+!
+!-- Send the new time step to all the clients of the current server
+    DO  m = 1, SIZE( PMC_Server_for_Client ) - 1
+       client_id = PMC_Server_for_Client(m)
+       IF ( myid == 0 )  THEN
+          CALL pmc_send_to_client( client_id, dtl, SIZE( dtl ), 0, 102, ierr )
+       ENDIF
+    ENDDO
+
+    CALL cpu_log( log_point_s(70), 'pmc sync', 'stop' )
+
+#endif
+ END SUBROUTINE pmci_server_synchronize
+
+
+
+ SUBROUTINE pmci_client_synchronize
+
+#if defined( __parallel )
+!
+!-- Unify the time steps for each model and synchronize. This is based on the
+!-- assumption that the native time step (original dt_3d) of any server is
+!-- always larger than the smallest native time step of it s clients.
+
+    IMPLICIT NONE
+
+    INTEGER(iwp) ::  ierr   !:
+
+    REAL(wp), DIMENSION(1) ::  dtl    !:
+    REAL(wp), DIMENSION(1) ::  dts    !:
+    
+
+    dtl(1) = dt_3d
+    IF ( cpl_id > 1 )  THEN
+
+       CALL cpu_log( log_point_s(70), 'pmc sync', 'start' )
+
+       IF ( myid==0 )  THEN
+          CALL pmc_send_to_server( dtl, SIZE( dtl ), 0, 101, ierr )
+          CALL pmc_recv_from_server( dts, SIZE( dts ), 0, 102, ierr )
+          dt_3d = dts(1)
+       ENDIF
+
+!
+!--    Broadcast the unified time step to all server processes
+       CALL MPI_BCAST( dt_3d, 1, MPI_REAL, 0, comm2d, ierr )
+
+       CALL cpu_log( log_point_s(70), 'pmc sync', 'stop' )
+
+    ENDIF
+
+#endif
+ END SUBROUTINE pmci_client_synchronize
+                
+
+
+ SUBROUTINE pmci_set_swaplevel( swaplevel )
+!
+!-- After each Runge-Kutta sub-timestep, alternately set buffer one or buffer
+!-- two active
+
+    IMPLICIT NONE
+
+    INTEGER(iwp),INTENT(IN) ::  swaplevel  !: swaplevel (1 or 2) of PALM's
+                                           !: timestep
+
+    INTEGER(iwp)            ::  client_id  !:
+    INTEGER(iwp)            ::  m          !:
+
+    DO  m = 1, SIZE( pmc_server_for_client )-1
+       client_id = pmc_server_for_client(m)
+       CALL pmc_s_set_active_data_array( client_id, swaplevel )
+    ENDDO
+
+ END SUBROUTINE pmci_set_swaplevel
+
+
+
+ SUBROUTINE pmci_datatrans( local_nesting_mode )
+!
+!-- Althoug nesting_mode is a variable of this model, pass it as an argument to
+!-- allow for example to force one-way initialization phase
+
+    IMPLICIT NONE
+
+    INTEGER(iwp)           ::  ierr   !:
+    INTEGER(iwp)           ::  istat  !:
+
+    CHARACTER(LEN=*),INTENT(IN) ::  local_nesting_mode
+
+    IF ( local_nesting_mode == 'one-way' )  THEN
+
+       CALL pmci_client_datatrans( server_to_client )
+       CALL pmci_server_datatrans( server_to_client )
+
+    ELSE
+
+       IF( nesting_datatransfer_mode == 'cascade' )  THEN
+
+          CALL pmci_client_datatrans( server_to_client )
+          CALL pmci_server_datatrans( server_to_client )
+
+          CALL pmci_server_datatrans( client_to_server )
+          CALL pmci_client_datatrans( client_to_server )
+
+       ELSEIF( nesting_datatransfer_mode == 'overlap')  THEN
+
+          CALL pmci_server_datatrans( server_to_client )
+          CALL pmci_client_datatrans( server_to_client )
+
+          CALL pmci_client_datatrans( client_to_server )
+          CALL pmci_server_datatrans( client_to_server )
+
+       ELSEIF( TRIM( nesting_datatransfer_mode ) == 'mixed' )  THEN
+
+          CALL pmci_server_datatrans( server_to_client )
+          CALL pmci_client_datatrans( server_to_client )
+
+          CALL pmci_server_datatrans( client_to_server )
+          CALL pmci_client_datatrans( client_to_server )
+
+       ENDIF
+
+    ENDIF
+
+ END SUBROUTINE pmci_datatrans
+
+
+
+
+ SUBROUTINE pmci_server_datatrans( direction )
+
+    IMPLICIT NONE
+
+    INTEGER(iwp),INTENT(IN) ::  direction   !:
+
+#if defined( __parallel )
+    INTEGER(iwp) ::  client_id   !:
+    INTEGER(iwp) ::  i           !:
+    INTEGER(iwp) ::  j           !:
+    INTEGER(iwp) ::  ierr        !:
+    INTEGER(iwp) ::  m           !:
+
+    REAL(wp)               ::  waittime    !:
+    REAL(wp), DIMENSION(1) ::  dtc         !:
+    REAL(wp), DIMENSION(1) ::  dtl         !:
+
+
+    DO  m = 1, SIZE( PMC_Server_for_Client )-1
+       client_id = PMC_Server_for_Client(m)
+       
+       IF ( direction == server_to_client )  THEN
+          CALL cpu_log( log_point_s(71), 'pmc server send', 'start' )
+          CALL pmc_s_fillbuffer( client_id )
+          CALL cpu_log( log_point_s(71), 'pmc server send', 'stop' )
+       ELSE
+!
+!--       Communication from client to server
+          CALL cpu_log( log_point_s(72), 'pmc server recv', 'start' )
+          client_id = pmc_server_for_client(m)
+          CALL pmc_s_getdata_from_buffer( client_id )
+          CALL cpu_log( log_point_s(72), 'pmc server recv', 'stop' )
+
+!
+!--       The anterpolated data is now available in u etc
+          IF ( topography /= 'flat' )  THEN
+
+!
+!--          Inside buildings/topography reset velocities and TKE back to zero.
+!--          Other scalars (pt, q, s, km, kh, p, sa, ...) are ignored at
+!--          present, maybe revise later.
+             DO   i = nxlg, nxrg
+                DO   j = nysg, nyng
+                   u(nzb:nzb_u_inner(j,i),j,i)  = 0.0_wp
+                   v(nzb:nzb_v_inner(j,i),j,i)  = 0.0_wp
+                   w(nzb:nzb_w_inner(j,i),j,i)  = 0.0_wp
+                   e(nzb:nzb_s_inner(j,i),j,i)  = 0.0_wp
+!
+!--                TO_DO: zero setting of temperature within topography creates
+!--                       wrong results
+!                   pt(nzb:nzb_s_inner(j,i),j,i) = 0.0_wp
+!                   IF ( humidity  .OR.  passive_scalar )  THEN
+!                      q(nzb:nzb_s_inner(j,i),j,i) = 0.0_wp
+!                   ENDIF
+                ENDDO
+             ENDDO
+          ENDIF
+       ENDIF
+    ENDDO
+
+#endif
+ END SUBROUTINE pmci_server_datatrans
+
+
+
+ SUBROUTINE pmci_client_datatrans( direction )
+
+    IMPLICIT NONE
+
+    INTEGER(iwp), INTENT(IN) ::  direction   !:
+
+#if defined( __parallel )
+    INTEGER(iwp) ::  ierr        !:
+    INTEGER(iwp) ::  icl         !:
+    INTEGER(iwp) ::  icr         !:
+    INTEGER(iwp) ::  jcs         !:
+    INTEGER(iwp) ::  jcn         !:
+    
+    REAL(wp), DIMENSION(1) ::  dtl         !:
+    REAL(wp), DIMENSION(1) ::  dts         !:
+
+
+    dtl = dt_3d
+    IF ( cpl_id > 1 )  THEN
+!
+!--    Client domain boundaries in the server indice space.
+       icl = coarse_bound(1)
+       icr = coarse_bound(2)
+       jcs = coarse_bound(3)
+       jcn = coarse_bound(4)
+
+       IF ( direction == server_to_client )  THEN
+
+          CALL cpu_log( log_point_s(73), 'pmc client recv', 'start' )
+          CALL pmc_c_getbuffer( )
+          CALL cpu_log( log_point_s(73), 'pmc client recv', 'stop' )
+
+          CALL cpu_log( log_point_s(75), 'pmc interpolation', 'start' )
+          CALL pmci_interpolation
+          CALL cpu_log( log_point_s(75), 'pmc interpolation', 'stop' )
+
+       ELSE
+!
+!--       direction == client_to_server
+          CALL cpu_log( log_point_s(76), 'pmc anterpolation', 'start' )
+          CALL pmci_anterpolation
+          CALL cpu_log( log_point_s(76), 'pmc anterpolation', 'stop' )
+
+          CALL cpu_log( log_point_s(74), 'pmc client send', 'start' )
+          CALL pmc_c_putbuffer( )
+          CALL cpu_log( log_point_s(74), 'pmc client send', 'stop' )
+
+       ENDIF
+    ENDIF
+
+ CONTAINS
+
+    SUBROUTINE pmci_interpolation
+
+!
+!--    A wrapper routine for all interpolation and extrapolation actions
+       IMPLICIT NONE
+
+!
+!--    Add IF-condition here: IF not vertical nesting
+!--    Left border pe:
+       IF ( nest_bound_l )  THEN
+          CALL pmci_interp_tril_lr( u,  uc,  icu, jco, kco, r1xu, r2xu, r1yo,  &
+                                    r2yo, r1zo, r2zo, nzb_u_inner, logc_u_l,   &
+                                    logc_ratio_u_l, nzt_topo_nestbc_l, 'l',    &
+                                    'u' )
+          CALL pmci_interp_tril_lr( v,  vc,  ico, jcv, kco, r1xo, r2xo, r1yv,  &
+                                    r2yv, r1zo, r2zo, nzb_v_inner, logc_v_l,   &
+                                    logc_ratio_v_l, nzt_topo_nestbc_l, 'l',    &
+                                    'v' )
+          CALL pmci_interp_tril_lr( w,  wc,  ico, jco, kcw, r1xo, r2xo, r1yo,  &
+                                    r2yo, r1zw, r2zw, nzb_w_inner, logc_w_l,   &
+                                    logc_ratio_w_l, nzt_topo_nestbc_l, 'l',    &
+                                    'w' )
+          CALL pmci_interp_tril_lr( e,  ec,  ico, jco, kco, r1xo, r2xo, r1yo,  &
+                                    r2yo, r1zo, r2zo, nzb_s_inner, logc_u_l,   &
+                                    logc_ratio_u_l, nzt_topo_nestbc_l, 'l',    &
+                                    'e' )
+          CALL pmci_interp_tril_lr( pt, ptc, ico, jco, kco, r1xo, r2xo, r1yo,  &
+                                    r2yo, r1zo, r2zo, nzb_s_inner, logc_u_l,   &
+                                    logc_ratio_u_l, nzt_topo_nestbc_l, 'l',    &
+                                    's' )
+          IF ( humidity  .OR.  passive_scalar )  THEN
+             CALL pmci_interp_tril_lr( q, qc, ico, jco, kco, r1xo, r2xo, r1yo, &
+                                       r2yo, r1zo, r2zo, nzb_s_inner,          &
+                                       logc_u_l, logc_ratio_u_l,               &
+                                       nzt_topo_nestbc_l, 'l', 's' )
+          ENDIF
+
+          IF ( nesting_mode == 'one-way' )  THEN
+             CALL pmci_extrap_ifoutflow_lr( u, nzb_u_inner, 'l', 'u' )
+             CALL pmci_extrap_ifoutflow_lr( v, nzb_v_inner, 'l', 'v' )
+             CALL pmci_extrap_ifoutflow_lr( w, nzb_w_inner, 'l', 'w' )
+             CALL pmci_extrap_ifoutflow_lr( e, nzb_s_inner, 'l', 'e' )
+             CALL pmci_extrap_ifoutflow_lr( pt,nzb_s_inner, 'l', 's' )
+             IF ( humidity  .OR.  passive_scalar )  THEN
+                CALL pmci_extrap_ifoutflow_lr( q, nzb_s_inner, 'l', 's' )
+             ENDIF
+          ENDIF
+
+       ENDIF
+!
+!--    Right border pe
+       IF ( nest_bound_r )  THEN
+          CALL pmci_interp_tril_lr( u,  uc,  icu, jco, kco, r1xu, r2xu, r1yo,  &
+                                    r2yo, r1zo, r2zo, nzb_u_inner, logc_u_r,   &
+                                    logc_ratio_u_r, nzt_topo_nestbc_r, 'r',    &
+                                    'u' )
+          CALL pmci_interp_tril_lr( v,  vc,  ico, jcv, kco, r1xo, r2xo, r1yv,  &
+                                    r2yv, r1zo, r2zo, nzb_v_inner, logc_v_r,   &
+                                    logc_ratio_v_r, nzt_topo_nestbc_r, 'r',    &
+                                    'v' )
+          CALL pmci_interp_tril_lr( w,  wc,  ico, jco, kcw, r1xo, r2xo, r1yo,  &
+                                    r2yo, r1zw, r2zw, nzb_w_inner, logc_w_r,   &
+                                    logc_ratio_w_r, nzt_topo_nestbc_r, 'r',    &
+                                    'w' )
+          CALL pmci_interp_tril_lr( e,  ec,  ico, jco, kco, r1xo, r2xo, r1yo,  &
+                                    r2yo, r1zo, r2zo, nzb_s_inner, logc_u_r,   &
+                                    logc_ratio_u_r, nzt_topo_nestbc_r, 'r',    &
+                                    'e' )
+          CALL pmci_interp_tril_lr( pt, ptc, ico, jco, kco, r1xo, r2xo, r1yo,  &
+                                    r2yo, r1zo, r2zo, nzb_s_inner, logc_u_r,   &
+                                    logc_ratio_u_r, nzt_topo_nestbc_r, 'r',    &
+                                    's' )
+          IF ( humidity  .OR.  passive_scalar )  THEN
+             CALL pmci_interp_tril_lr( q, qc, ico, jco, kco, r1xo, r2xo, r1yo, &
+                                       r2yo, r1zo, r2zo, nzb_s_inner,          &
+                                       logc_u_r, logc_ratio_u_r,               &
+                                       nzt_topo_nestbc_r, 'r', 's' )
+          ENDIF
+
+          IF ( nesting_mode == 'one-way' )  THEN
+             CALL pmci_extrap_ifoutflow_lr( u, nzb_u_inner, 'r', 'u' )
+             CALL pmci_extrap_ifoutflow_lr( v, nzb_v_inner, 'r', 'v' )
+             CALL pmci_extrap_ifoutflow_lr( w, nzb_w_inner, 'r', 'w' )
+             CALL pmci_extrap_ifoutflow_lr( e, nzb_s_inner, 'r', 'e' )
+             CALL pmci_extrap_ifoutflow_lr( pt,nzb_s_inner, 'r', 's' )
+             IF ( humidity  .OR.  passive_scalar )  THEN
+                CALL pmci_extrap_ifoutflow_lr( q, nzb_s_inner, 'r', 's' )
+             ENDIF
+          ENDIF
+
+       ENDIF
+!
+!--    South border pe
+       IF ( nest_bound_s )  THEN
+          CALL pmci_interp_tril_sn( u,  uc,  icu, jco, kco, r1xu, r2xu, r1yo,  &
+                                    r2yo, r1zo, r2zo, nzb_u_inner, logc_u_s,   &
+                                    logc_ratio_u_s, nzt_topo_nestbc_s, 's',    &
+                                    'u' )
+          CALL pmci_interp_tril_sn( v,  vc,  ico, jcv, kco, r1xo, r2xo, r1yv,  &
+                                    r2yv, r1zo, r2zo, nzb_v_inner, logc_v_s,   &
+                                    logc_ratio_v_s, nzt_topo_nestbc_s, 's',    &
+                                    'v' )
+          CALL pmci_interp_tril_sn( w,  wc,  ico, jco, kcw, r1xo, r2xo, r1yo,  &
+                                    r2yo, r1zw, r2zw, nzb_w_inner, logc_w_s,   &
+                                    logc_ratio_w_s, nzt_topo_nestbc_s, 's',    &
+                                    'w' )
+          CALL pmci_interp_tril_sn( e,  ec,  ico, jco, kco, r1xo, r2xo, r1yo,  &
+                                    r2yo, r1zo, r2zo, nzb_s_inner, logc_u_s,   &
+                                    logc_ratio_u_s, nzt_topo_nestbc_s, 's',    &
+                                    'e' )
+          CALL pmci_interp_tril_sn( pt, ptc, ico, jco, kco, r1xo, r2xo, r1yo,  &
+                                    r2yo, r1zo, r2zo, nzb_s_inner, logc_u_s,   &
+                                    logc_ratio_u_s, nzt_topo_nestbc_s, 's',    &
+                                    's' )
+          IF ( humidity  .OR.  passive_scalar )  THEN
+             CALL pmci_interp_tril_sn( q, qc, ico, jco, kco, r1xo, r2xo, r1yo, &
+                                       r2yo, r1zo, r2zo, nzb_s_inner,          &
+                                       logc_u_s, logc_ratio_u_s,               &
+                                       nzt_topo_nestbc_s, 's', 's' )
+          ENDIF
+
+          IF ( nesting_mode == 'one-way' )  THEN
+             CALL pmci_extrap_ifoutflow_sn( u, nzb_u_inner, 's', 'u' )
+             CALL pmci_extrap_ifoutflow_sn( v, nzb_v_inner, 's', 'v' )
+             CALL pmci_extrap_ifoutflow_sn( w, nzb_w_inner, 's', 'w' )
+             CALL pmci_extrap_ifoutflow_sn( e, nzb_s_inner, 's', 'e' )
+             CALL pmci_extrap_ifoutflow_sn( pt,nzb_s_inner, 's', 's' )
+             IF ( humidity  .OR.  passive_scalar )  THEN
+                CALL pmci_extrap_ifoutflow_sn( q, nzb_s_inner, 's', 's' )
+             ENDIF
+          ENDIF
+
+       ENDIF
+!
+!--    North border pe
+       IF ( nest_bound_n )  THEN
+          CALL pmci_interp_tril_sn( u,  uc,  icu, jco, kco, r1xu, r2xu, r1yo,  &
+                                    r2yo, r1zo, r2zo, nzb_u_inner, logc_u_n,   &
+                                    logc_ratio_u_n, nzt_topo_nestbc_n, 'n',    &
+                                    'u' )
+          CALL pmci_interp_tril_sn( v,  vc,  ico, jcv, kco, r1xo, r2xo, r1yv,  &
+                                    r2yv, r1zo, r2zo, nzb_v_inner, logc_v_n,   &
+                                    logc_ratio_v_n, nzt_topo_nestbc_n, 'n',    &
+                                    'v' )
+          CALL pmci_interp_tril_sn( w,  wc,  ico, jco, kcw, r1xo, r2xo, r1yo,  &
+                                    r2yo, r1zw, r2zw, nzb_w_inner, logc_w_n,   &
+                                    logc_ratio_w_n, nzt_topo_nestbc_n, 'n',    &
+                                    'w' )
+          CALL pmci_interp_tril_sn( e,  ec,  ico, jco, kco, r1xo, r2xo, r1yo,  &
+                                    r2yo, r1zo, r2zo, nzb_s_inner, logc_u_n,   &
+                                    logc_ratio_u_n, nzt_topo_nestbc_n, 'n',    &
+                                    'e' )
+          CALL pmci_interp_tril_sn( pt, ptc, ico, jco, kco, r1xo, r2xo, r1yo,  &
+                                    r2yo, r1zo, r2zo, nzb_s_inner, logc_u_n,   &
+                                    logc_ratio_u_n, nzt_topo_nestbc_n, 'n',    &
+                                    's' )
+          IF ( humidity  .OR.  passive_scalar )  THEN
+             CALL pmci_interp_tril_sn( q, qc, ico, jco, kco, r1xo, r2xo, r1yo, &
+                                       r2yo, r1zo, r2zo, nzb_s_inner,          &
+                                       logc_u_n, logc_ratio_u_n,               &
+                                       nzt_topo_nestbc_n, 'n', 's' )
+          ENDIF
+
+          IF ( nesting_mode == 'one-way' )  THEN
+             CALL pmci_extrap_ifoutflow_sn( u, nzb_u_inner, 'n', 'u' )
+             CALL pmci_extrap_ifoutflow_sn( v, nzb_v_inner, 'n', 'v' )
+             CALL pmci_extrap_ifoutflow_sn( w, nzb_w_inner, 'n', 'w' )
+             CALL pmci_extrap_ifoutflow_sn( e, nzb_s_inner, 'n', 'e' )
+             CALL pmci_extrap_ifoutflow_sn( pt,nzb_s_inner, 'n', 's' )
+             IF ( humidity  .OR.  passive_scalar )  THEN
+                CALL pmci_extrap_ifoutflow_sn( q, nzb_s_inner, 'n', 's' )
+             ENDIF
+
+          ENDIF
+
+       ENDIF
+
+!
+!--    All PEs are top-border PEs
+       CALL pmci_interp_tril_t( u,  uc,  icu, jco, kco, r1xu, r2xu, r1yo,      &
+                                r2yo, r1zo, r2zo, 'u' )
+       CALL pmci_interp_tril_t( v,  vc,  ico, jcv, kco, r1xo, r2xo, r1yv,      &
+                                r2yv, r1zo, r2zo, 'v' )
+       CALL pmci_interp_tril_t( w,  wc,  ico, jco, kcw, r1xo, r2xo, r1yo,      &
+                                r2yo, r1zw, r2zw, 'w' )
+       CALL pmci_interp_tril_t( e,  ec,  ico, jco, kco, r1xo, r2xo, r1yo,      &
+                                r2yo, r1zo, r2zo, 'e' )
+       CALL pmci_interp_tril_t( pt, ptc, ico, jco, kco, r1xo, r2xo, r1yo,      &
+                                r2yo, r1zo, r2zo, 's' )
+       IF ( humidity .OR. passive_scalar )  THEN
+          CALL pmci_interp_tril_t( q, qc, ico, jco, kco, r1xo, r2xo, r1yo,     &
+                                   r2yo, r1zo, r2zo, 's' )
+       ENDIF
+
+       IF ( nesting_mode == 'one-way' )  THEN
+          CALL pmci_extrap_ifoutflow_t( u,  'u' )
+          CALL pmci_extrap_ifoutflow_t( v,  'v' )
+          CALL pmci_extrap_ifoutflow_t( w,  'w' )
+          CALL pmci_extrap_ifoutflow_t( e,  'e' )
+          CALL pmci_extrap_ifoutflow_t( pt, 's' )
+          IF ( humidity  .OR.  passive_scalar )  THEN
+             CALL pmci_extrap_ifoutflow_t( q, 's' )
+          ENDIF
+      ENDIF
+
+   END SUBROUTINE pmci_interpolation
+
+
+
+   SUBROUTINE pmci_anterpolation
+
+!
+!--   A wrapper routine for all anterpolation actions.
+      IMPLICIT NONE
+
+      CALL pmci_anterp_tophat( u,  uc,  kctu, iflu, ifuu, jflo, jfuo, kflo,    &
+                               kfuo, 'u' )
+      CALL pmci_anterp_tophat( v,  vc,  kctu, iflo, ifuo, jflv, jfuv, kflo,    &
+                               kfuo, 'v' )
+      CALL pmci_anterp_tophat( w,  wc,  kctw, iflo, ifuo, jflo, jfuo, kflw,    &
+                               kfuw, 'w' )
+      CALL pmci_anterp_tophat( pt, ptc, kctu, iflo, ifuo, jflo, jfuo, kflo,    &
+                               kfuo, 's' )
+      IF ( humidity  .OR.  passive_scalar )  THEN
+         CALL pmci_anterp_tophat( q, qc, kctu, iflo, ifuo, jflo, jfuo, kflo,   &
+                                  kfuo, 's' )
+      ENDIF
+
+   END SUBROUTINE pmci_anterpolation
+
+
+
+   SUBROUTINE pmci_interp_tril_lr( f, fc, ic, jc, kc, r1x, r2x, r1y, r2y, r1z, &
+                                   r2z, kb, logc, logc_ratio, nzt_topo_nestbc, &
+                                   edge, var )
+!
+!--   Interpolation of ghost-node values used as the client-domain boundary
+!--   conditions. This subroutine handles the left and right boundaries. It is
+!--   based on trilinear interpolation.
+
+      IMPLICIT NONE
+
+      REAL(wp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg),                      &
+                                      INTENT(INOUT) ::  f       !:
+      REAL(wp), DIMENSION(0:cg%nz+1,jcs:jcn,icl:icr),                          &
+                                      INTENT(IN)    ::  fc      !:
+      REAL(wp), DIMENSION(nzb:nzt_topo_nestbc,nys:nyn,1:2,0:ncorr-1),          &
+                                      INTENT(IN)    ::  logc_ratio   !:
+      REAL(wp), DIMENSION(nxlg:nxrg), INTENT(IN)    ::  r1x     !:
+      REAL(wp), DIMENSION(nxlg:nxrg), INTENT(IN)    ::  r2x     !:
+      REAL(wp), DIMENSION(nysg:nyng), INTENT(IN)    ::  r1y     !:
+      REAL(wp), DIMENSION(nysg:nyng), INTENT(IN)    ::  r2y     !:
+      REAL(wp), DIMENSION(nzb:nzt+1), INTENT(IN)    ::  r1z     !:
+      REAL(wp), DIMENSION(nzb:nzt+1), INTENT(IN)    ::  r2z     !:
+      
+      INTEGER(iwp), DIMENSION(nxlg:nxrg), INTENT(IN)           ::  ic     !:
+      INTEGER(iwp), DIMENSION(nysg:nyng), INTENT(IN)           ::  jc     !:
+      INTEGER(iwp), DIMENSION(nysg:nyng,nxlg:nxrg), INTENT(IN) ::  kb     !:
+      INTEGER(iwp), DIMENSION(nzb:nzt+1), INTENT(IN)           ::  kc     !:
+      INTEGER(iwp), DIMENSION(nzb:nzt_topo_nestbc,nys:nyn,1:2),                &
+                                          INTENT(IN)           ::  logc   !:
+      INTEGER(iwp) ::  nzt_topo_nestbc   !:
+
+      CHARACTER(LEN=1),INTENT(IN) ::  edge   !:
+      CHARACTER(LEN=1),INTENT(IN) ::  var    !:
+
+      INTEGER(iwp) ::  i       !:
+      INTEGER(iwp) ::  ib      !:
+      INTEGER(iwp) ::  ibgp    !:
+      INTEGER(iwp) ::  iw      !:
+      INTEGER(iwp) ::  j       !:
+      INTEGER(iwp) ::  jco     !:
+      INTEGER(iwp) ::  jcorr   !:
+      INTEGER(iwp) ::  jinc    !:
+      INTEGER(iwp) ::  jw      !:
+      INTEGER(iwp) ::  j1      !:
+      INTEGER(iwp) ::  k       !:
+      INTEGER(iwp) ::  kco     !:
+      INTEGER(iwp) ::  kcorr   !:
+      INTEGER(iwp) ::  k1      !:
+      INTEGER(iwp) ::  l       !:
+      INTEGER(iwp) ::  m       !:
+      INTEGER(iwp) ::  n       !:
+      INTEGER(iwp) ::  kbc     !:
+      
+      REAL(wp) ::  coarse_dx   !:
+      REAL(wp) ::  coarse_dy   !:
+      REAL(wp) ::  coarse_dz   !:
+      REAL(wp) ::  fkj         !:
+      REAL(wp) ::  fkjp        !:
+      REAL(wp) ::  fkpj        !:
+      REAL(wp) ::  fkpjp       !:
+      REAL(wp) ::  fk          !:
+      REAL(wp) ::  fkp         !:
+      
+! 
+!--   Check which edge is to be handled
+      IF ( edge == 'l' )  THEN
+!
+!--      For u, nxl is a ghost node, but not for the other variables
+         IF ( var == 'u' )  THEN
+            i  = nxl
+            ib = nxl - 1 
+         ELSE
+            i  = nxl - 1
+            ib = nxl - 2
+         ENDIF
+      ELSEIF ( edge == 'r' )  THEN
+         i  = nxr + 1
+         ib = nxr + 2
+      ENDIF
+      
+      DO  j = nys, nyn+1
+         DO  k = kb(j,i), nzt+1
+            l = ic(i)
+            m = jc(j)
+            n = kc(k)
+            fkj      = r1x(i) * fc(n,m,l)     + r2x(i) * fc(n,m,l+1)
+            fkjp     = r1x(i) * fc(n,m+1,l)   + r2x(i) * fc(n,m+1,l+1)
+            fkpj     = r1x(i) * fc(n+1,m,l)   + r2x(i) * fc(n+1,m,l+1)
+            fkpjp    = r1x(i) * fc(n+1,m+1,l) + r2x(i) * fc(n+1,m+1,l+1)
+            fk       = r1y(j) * fkj  + r2y(j) * fkjp
+            fkp      = r1y(j) * fkpj + r2y(j) * fkpjp
+            f(k,j,i) = r1z(k) * fk   + r2z(k) * fkp
+         ENDDO
+      ENDDO
+
+!
+!--   Generalized log-law-correction algorithm.
+!--   Doubly two-dimensional index arrays logc(:,:,1:2) and log-ratio arrays 
+!--   logc_ratio(:,:,1:2,0:ncorr-1) have been precomputed in subroutine
+!--   pmci_init_loglaw_correction.
+!
+!--   Solid surface below the node 
+      IF ( var == 'u' .OR. var == 'v' )  THEN           
+         DO  j = nys, nyn
+            k = kb(j,i)+1
+            IF ( ( logc(k,j,1) /= 0 )  .AND.  ( logc(k,j,2) == 0 ) )  THEN
+               k1 = logc(k,j,1)
+               DO  kcorr=0,ncorr - 1
+                  kco = k + kcorr
+                  f(kco,j,i) = logc_ratio(k,j,1,kcorr) * f(k1,j,i)
+               ENDDO
+            ENDIF
+         ENDDO
+      ENDIF
+
+!
+!--   In case of non-flat topography, also vertical walls and corners need to be
+!--   treated. Only single and double wall nodes are corrected. Triple and
+!--   higher-multiple wall nodes are not corrected as the log law would not be
+!--   valid anyway in such locations.
+      IF ( topography /= 'flat' )  THEN
+         IF ( var == 'u' .OR. var == 'w' )  THEN                 
+
+!
+!--         Solid surface only on south/north side of the node                   
+            DO  j = nys, nyn
+               DO  k = kb(j,i)+1, nzt_topo_nestbc
+                  IF ( ( logc(k,j,2) /= 0 )  .AND.  ( logc(k,j,1) == 0 ) )  THEN
+
+!
+!--                  Direction of the wall-normal index is carried in as the
+!--                  sign of logc
+                     jinc = SIGN( 1, logc(k,j,2) )
+                     j1   = ABS( logc(k,j,2) )
+                     DO  jcorr = 0, ncorr-1
+                        jco = j + jinc * jcorr
+                        f(k,jco,i) = logc_ratio(k,j,2,jcorr) * f(k,j1,i)
+                     ENDDO
+                  ENDIF
+               ENDDO
+            ENDDO
+         ENDIF
+
+!
+!--      Solid surface on both below and on south/north side of the node           
+         IF ( var == 'u' )  THEN
+            DO  j = nys, nyn
+               k = kb(j,i) + 1
+               IF ( ( logc(k,j,2) /= 0 )  .AND.  ( logc(k,j,1) /= 0 ) )  THEN
+                  k1   = logc(k,j,1)                 
+                  jinc = SIGN( 1, logc(k,j,2) )
+                  j1   = ABS( logc(k,j,2) )                 
+                  DO  jcorr = 0, ncorr-1
+                     jco = j + jinc * jcorr
+                     DO  kcorr = 0, ncorr-1
+                        kco = k + kcorr
+                        f(kco,jco,i) = 0.5_wp * ( logc_ratio(k,j,1,kcorr) *    &
+                                                  f(k1,j,i)                    &
+                                                + logc_ratio(k,j,2,jcorr) *    &
+                                                  f(k,j1,i) )
+                     ENDDO
+                  ENDDO
+               ENDIF
+            ENDDO
+         ENDIF
+
+      ENDIF  ! ( topography /= 'flat' )
+
+!
+!--   Rescale if f is the TKE.
+      IF ( var == 'e')  THEN
+         IF ( edge == 'l' )  THEN
+            DO  j = nys, nyn + 1
+               DO  k = kb(j,i), nzt + 1
+                  f(k,j,i) = tkefactor_l(k,j) * f(k,j,i)
+               ENDDO
+            ENDDO
+         ELSEIF ( edge == 'r' )  THEN           
+            DO  j = nys, nyn+1
+               DO  k = kb(j,i), nzt+1
+                  f(k,j,i) = tkefactor_r(k,j) * f(k,j,i)
+               ENDDO
+            ENDDO
+         ENDIF
+      ENDIF
+
+!
+!--   Store the boundary values also into the other redundant ghost node layers
+      IF ( edge == 'l' )  THEN
+         DO  ibgp = -nbgp, ib
+            f(0:nzt+1,nysg:nyng,ibgp) = f(0:nzt+1,nysg:nyng,i)
+         ENDDO
+      ELSEIF ( edge == 'r' )  THEN
+         DO  ibgp = ib, nx+nbgp
+            f(0:nzt+1,nysg:nyng,ibgp) = f(0:nzt+1,nysg:nyng,i)
+         ENDDO
+      ENDIF
+
+   END SUBROUTINE pmci_interp_tril_lr
+
+
+
+   SUBROUTINE pmci_interp_tril_sn( f, fc, ic, jc, kc, r1x, r2x, r1y, r2y, r1z, &
+                                   r2z, kb, logc, logc_ratio,                  &
+                                   nzt_topo_nestbc, edge, var )
+
+!
+!--   Interpolation of ghost-node values used as the client-domain boundary
+!--   conditions. This subroutine handles the south and north boundaries. 
+!--   This subroutine is based on trilinear interpolation.
+
+      IMPLICIT NONE
+
+      REAL(wp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg),                      &
+                                      INTENT(INOUT) ::  f             !:
+      REAL(wp), DIMENSION(0:cg%nz+1,jcs:jcn,icl:icr),                          &
+                                      INTENT(IN)    ::  fc            !:
+      REAL(wp), DIMENSION(nzb:nzt_topo_nestbc,nxl:nxr,1:2,0:ncorr-1),          &
+                                      INTENT(IN)    ::  logc_ratio    !:
+      REAL(wp), DIMENSION(nxlg:nxrg), INTENT(IN)    ::  r1x           !:
+      REAL(wp), DIMENSION(nxlg:nxrg), INTENT(IN)    ::  r2x           !:
+      REAL(wp), DIMENSION(nysg:nyng), INTENT(IN)    ::  r1y           !:
+      REAL(wp), DIMENSION(nysg:nyng), INTENT(IN)    ::  r2y           !:
+      REAL(wp), DIMENSION(nzb:nzt+1), INTENT(IN)    ::  r1z           !:
+      REAL(wp), DIMENSION(nzb:nzt+1), INTENT(IN)    ::  r2z           !:
+      
+      INTEGER(iwp), DIMENSION(nxlg:nxrg), INTENT(IN)           ::  ic    !:
+      INTEGER(iwp), DIMENSION(nysg:nyng), INTENT(IN)           ::  jc    !:
+      INTEGER(iwp), DIMENSION(nysg:nyng,nxlg:nxrg), INTENT(IN) ::  kb    !:
+      INTEGER(iwp), DIMENSION(nzb:nzt+1), INTENT(IN)           ::  kc    !:
+      INTEGER(iwp), DIMENSION(nzb:nzt_topo_nestbc,nxl:nxr,1:2),                &
+                                          INTENT(IN)           ::  logc  !:
+      INTEGER(iwp) ::  nzt_topo_nestbc   !:
+
+      CHARACTER(LEN=1), INTENT(IN) ::  edge   !:
+      CHARACTER(LEN=1), INTENT(IN) ::  var    !:
+      
+      INTEGER(iwp) ::  i       !:
+      INTEGER(iwp) ::  iinc    !:
+      INTEGER(iwp) ::  icorr   !:
+      INTEGER(iwp) ::  ico     !:
+      INTEGER(iwp) ::  i1      !:
+      INTEGER(iwp) ::  j       !:
+      INTEGER(iwp) ::  jb      !:
+      INTEGER(iwp) ::  jbgp    !:
+      INTEGER(iwp) ::  k       !:
+      INTEGER(iwp) ::  kcorr   !:
+      INTEGER(iwp) ::  kco     !:
+      INTEGER(iwp) ::  k1      !:
+      INTEGER(iwp) ::  l       !:
+      INTEGER(iwp) ::  m       !:
+      INTEGER(iwp) ::  n       !:
+                            
+      REAL(wp) ::  coarse_dx   !:
+      REAL(wp) ::  coarse_dy   !:
+      REAL(wp) ::  coarse_dz   !:
+      REAL(wp) ::  fk          !:
+      REAL(wp) ::  fkj         !:
+      REAL(wp) ::  fkjp        !:
+      REAL(wp) ::  fkpj        !:
+      REAL(wp) ::  fkpjp       !:
+      REAL(wp) ::  fkp         !:
+      
+!
+!--   Check which edge is to be handled: south or north
+      IF ( edge == 's' )  THEN
+!
+!--      For v, nys is a ghost node, but not for the other variables
+         IF ( var == 'v' )  THEN
+            j  = nys
+            jb = nys - 1 
+         ELSE
+            j  = nys - 1
+            jb = nys - 2
+         ENDIF
+      ELSEIF ( edge == 'n' )  THEN
+         j  = nyn + 1
+         jb = nyn + 2
+      ENDIF
+
+      DO  i = nxl, nxr+1
+         DO  k = kb(j,i), nzt+1
+            l = ic(i)
+            m = jc(j)
+            n = kc(k)              
+            fkj      = r1x(i) * fc(n,m,l)     + r2x(i) * fc(n,m,l+1)
+            fkjp     = r1x(i) * fc(n,m+1,l)   + r2x(i) * fc(n,m+1,l+1)
+            fkpj     = r1x(i) * fc(n+1,m,l)   + r2x(i) * fc(n+1,m,l+1)
+            fkpjp    = r1x(i) * fc(n+1,m+1,l) + r2x(i) * fc(n+1,m+1,l+1)
+            fk       = r1y(j) * fkj  + r2y(j) * fkjp
+            fkp      = r1y(j) * fkpj + r2y(j) * fkpjp
+            f(k,j,i) = r1z(k) * fk   + r2z(k) * fkp
+         ENDDO
+      ENDDO
+
+!
+!--   Generalized log-law-correction algorithm.
+!--   Multiply two-dimensional index arrays logc(:,:,1:2) and log-ratio arrays 
+!--   logc_ratio(:,:,1:2,0:ncorr-1) have been precomputed in subroutine
+!--   pmci_init_loglaw_correction.
+!
+!--   Solid surface below the node 
+      IF ( var == 'u'  .OR.  var == 'v' )  THEN           
+         DO  i = nxl, nxr
+            k = kb(j,i) + 1
+            IF ( ( logc(k,i,1) /= 0 )  .AND.  ( logc(k,i,2) == 0 ) )  THEN
+               k1 = logc(k,i,1)
+               DO  kcorr = 0, ncorr-1
+                  kco = k + kcorr
+                  f(kco,j,i) = logc_ratio(k,i,1,kcorr) * f(k1,j,i)
+               ENDDO
+            ENDIF
+         ENDDO
+      ENDIF
+
+!
+!--   In case of non-flat topography, also vertical walls and corners need to be
+!--   treated. Only single and double wall nodes are corrected.
+!--   Triple and higher-multiple wall nodes are not corrected as it would be
+!--   extremely complicated and the log law would not be valid anyway in such
+!--   locations.
+      IF ( topography /= 'flat' )  THEN
+         IF ( var == 'v' .OR. var == 'w' )  THEN
+            DO  i = nxl, nxr
+               DO  k = kb(j,i), nzt_topo_nestbc
+
+!
+!--               Solid surface only on left/right side of the node           
+                  IF ( ( logc(k,i,2) /= 0 )  .AND.  ( logc(k,i,1) == 0 ) )  THEN
+
+!
+!--                  Direction of the wall-normal index is carried in as the
+!--                  sign of logc
+                     iinc = SIGN( 1, logc(k,i,2) )
+                     i1  = ABS( logc(k,i,2) )
+                     DO  icorr = 0, ncorr-1
+                        ico = i + iinc * icorr
+                        f(k,j,ico) = logc_ratio(k,i,2,icorr) * f(k,j,i1)
+                     ENDDO
+                  ENDIF
+               ENDDO
+            ENDDO
+         ENDIF
+
+!
+!--      Solid surface on both below and on left/right side of the node           
+         IF ( var == 'v' )  THEN
+            DO  i = nxl, nxr
+               k = kb(j,i) + 1
+               IF ( ( logc(k,i,2) /= 0 )  .AND.  ( logc(k,i,1) /= 0 ) )  THEN
+                  k1   = logc(k,i,1)         
+                  iinc = SIGN( 1, logc(k,i,2) )
+                  i1   = ABS( logc(k,i,2) )
+                  DO  icorr = 0, ncorr-1
+                     ico = i + iinc * icorr
+                     DO  kcorr = 0, ncorr-1
+                        kco = k + kcorr
+                        f(kco,i,ico) = 0.5_wp * ( logc_ratio(k,i,1,kcorr) *    &
+                                                  f(k1,j,i)  &
+                                                + logc_ratio(k,i,2,icorr) *    &
+                                                  f(k,j,i1) )
+                     ENDDO
+                  ENDDO
+               ENDIF
+            ENDDO
+         ENDIF
+         
+      ENDIF  ! ( topography /= 'flat' )
+
+!
+!--   Rescale if f is the TKE.
+      IF ( var == 'e')  THEN
+         IF ( edge == 's' )  THEN
+            DO  i = nxl, nxr + 1
+               DO  k = kb(j,i), nzt+1
+                  f(k,j,i) = tkefactor_s(k,i) * f(k,j,i)
+               ENDDO
+            ENDDO
+         ELSEIF ( edge == 'n' )  THEN
+            DO  i = nxl, nxr + 1
+               DO  k = kb(j,i), nzt+1
+                  f(k,j,i) = tkefactor_n(k,i) * f(k,j,i)
+               ENDDO
+            ENDDO
+         ENDIF
+      ENDIF
+
+!
+!--   Store the boundary values also into the other redundant ghost node layers
+      IF ( edge == 's' )  THEN
+         DO  jbgp = -nbgp, jb
+            f(0:nzt+1,jbgp,nxlg:nxrg) = f(0:nzt+1,j,nxlg:nxrg)
+         ENDDO
+      ELSEIF ( edge == 'n' )  THEN
+         DO  jbgp = jb, ny+nbgp
+            f(0:nzt+1,jbgp,nxlg:nxrg) = f(0:nzt+1,j,nxlg:nxrg)
+         ENDDO
+      ENDIF
+
+   END SUBROUTINE pmci_interp_tril_sn
+
+ 
+
+   SUBROUTINE pmci_interp_tril_t( f, fc, ic, jc, kc, r1x, r2x, r1y, r2y, r1z,  &
+                                  r2z, var )
+
+!
+!--   Interpolation of ghost-node values used as the client-domain boundary
+!--   conditions. This subroutine handles the top boundary. 
+!--   This subroutine is based on trilinear interpolation.
+
+      IMPLICIT NONE
+
+      REAL(wp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg),                      &
+                                      INTENT(INOUT) ::  f     !:
+      REAL(wp), DIMENSION(0:cg%nz+1,jcs:jcn,icl:icr),                          &
+                                      INTENT(IN)    ::  fc    !:
+      REAL(wp), DIMENSION(nxlg:nxrg), INTENT(IN)    ::  r1x   !:
+      REAL(wp), DIMENSION(nxlg:nxrg), INTENT(IN)    ::  r2x   !:
+      REAL(wp), DIMENSION(nysg:nyng), INTENT(IN)    ::  r1y   !:
+      REAL(wp), DIMENSION(nysg:nyng), INTENT(IN)    ::  r2y   !:
+      REAL(wp), DIMENSION(nzb:nzt+1), INTENT(IN)    ::  r1z   !:
+      REAL(wp), DIMENSION(nzb:nzt+1), INTENT(IN)    ::  r2z   !:
+      
+      INTEGER(iwp), DIMENSION(nxlg:nxrg), INTENT(IN) ::  ic    !:
+      INTEGER(iwp), DIMENSION(nysg:nyng), INTENT(IN) ::  jc    !:
+      INTEGER(iwp), DIMENSION(nzb:nzt+1), INTENT(IN) ::  kc    !:
+      
+      CHARACTER(LEN=1), INTENT(IN) :: var   !:
+
+      INTEGER(iwp) ::  i   !:
+      INTEGER(iwp) ::  j   !:
+      INTEGER(iwp) ::  k   !:
+      INTEGER(iwp) ::  l   !:
+      INTEGER(iwp) ::  m   !:
+      INTEGER(iwp) ::  n   !:
+      
+      REAL(wp) ::  coarse_dx   !:
+      REAL(wp) ::  coarse_dy   !:
+      REAL(wp) ::  coarse_dz   !:
+      REAL(wp) ::  fk          !:
+      REAL(wp) ::  fkj         !:
+      REAL(wp) ::  fkjp        !:
+      REAL(wp) ::  fkpj        !:
+      REAL(wp) ::  fkpjp       !:
+      REAL(wp) ::  fkp         !:
+
+      
+      IF ( var == 'w' )  THEN
+         k  = nzt
+      ELSE
+         k  = nzt + 1
+      ENDIF
+     
+      DO  i = nxl-1, nxr+1
+         DO  j = nys-1, nyn+1
+            l = ic(i)
+            m = jc(j)
+            n = kc(k)              
+            fkj      = r1x(i) * fc(n,m,l)     + r2x(i) * fc(n,m,l+1)
+            fkjp     = r1x(i) * fc(n,m+1,l)   + r2x(i) * fc(n,m+1,l+1)
+            fkpj     = r1x(i) * fc(n+1,m,l)   + r2x(i) * fc(n+1,m,l+1)
+            fkpjp    = r1x(i) * fc(n+1,m+1,l) + r2x(i) * fc(n+1,m+1,l+1)
+            fk       = r1y(j) * fkj  + r2y(j) * fkjp
+            fkp      = r1y(j) * fkpj + r2y(j) * fkpjp
+            f(k,j,i) = r1z(k) * fk   + r2z(k) * fkp
+         ENDDO
+      ENDDO
+
+!
+!--   Just fill up the second ghost-node layer for w.
+      IF ( var == 'w' )  THEN
+         f(nzt+1,:,:) = f(nzt,:,:)
+      ENDIF
+
+!
+!--   Rescale if f is the TKE.
+!--   It is assumed that the bottom surface never reaches the top boundary of a
+!--   nest domain.
+      IF ( var == 'e' )  THEN
+         DO  i = nxl, nxr
+            DO  j = nys, nyn
+               f(k,j,i) = tkefactor_t(j,i) * f(k,j,i)
+            ENDDO
+         ENDDO
+      ENDIF
+
+   END SUBROUTINE pmci_interp_tril_t
+
+
+
+    SUBROUTINE pmci_extrap_ifoutflow_lr( f, kb, edge, var )
+!
+!--    After the interpolation of ghost-node values for the client-domain
+!--    boundary conditions, this subroutine checks if there is a local outflow
+!--    through the boundary. In that case this subroutine overwrites the
+!--    interpolated values by values extrapolated from the domain. This
+!--    subroutine handles the left and right boundaries. However, this operation
+!--    is only needed in case of one-way coupling.
+
+       IMPLICIT NONE
+
+       CHARACTER(LEN=1),INTENT(IN) ::  edge   !:
+       CHARACTER(LEN=1),INTENT(IN) ::  var    !:
+
+       INTEGER(iwp) ::  i     !:
+       INTEGER(iwp) ::  ib    !:
+       INTEGER(iwp) ::  ibgp  !:
+       INTEGER(iwp) ::  ied   !:
+       INTEGER(iwp) ::  j     !:
+       INTEGER(iwp) ::  k     !:
+      
+       INTEGER(iwp), DIMENSION(nysg:nyng,nxlg:nxrg), INTENT(IN) ::  kb   !:
+
+       REAL(wp) ::  outnor    !:
+       REAL(wp) ::  vdotnor   !:
+
+       REAL(wp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg), INTENT(INOUT) :: f !:
+
+!
+!--    Check which edge is to be handled: left or right
+       IF ( edge == 'l' )  THEN
+          IF ( var == 'u' )  THEN
+             i   = nxl
+             ib  = nxl - 1
+             ied = nxl + 1
+          ELSE
+             i   = nxl - 1
+             ib  = nxl - 2
+             ied = nxl
+          ENDIF
+          outnor = -1.0_wp
+       ELSEIF ( edge == 'r' )  THEN
+          i      = nxr + 1
+          ib     = nxr + 2
+          ied    = nxr
+          outnor = 1.0_wp
+       ENDIF
+
+       DO  j = nys, nyn+1
+          DO  k = kb(j,i), nzt+1
+             vdotnor = outnor * u(k,j,ied)
+!
+!--          Local outflow
+             IF ( vdotnor > 0.0_wp )  THEN
+                f(k,j,i) = f(k,j,ied)
+             ENDIF
+          ENDDO
+          IF ( (var == 'u' )  .OR.  (var == 'v' )  .OR.  (var == 'w') )  THEN
+             f(kb(j,i),j,i) = 0.0_wp
+          ENDIF
+       ENDDO
+
+!
+!--    Store the boundary values also into the redundant ghost node layers.
+       IF ( edge == 'l' )  THEN
+          DO ibgp = -nbgp, ib
+             f(0:nzt+1,nysg:nyng,ibgp) = f(0:nzt+1,nysg:nyng,i)
+          ENDDO
+       ELSEIF ( edge == 'r' )  THEN
+          DO ibgp = ib, nx+nbgp
+             f(0:nzt+1,nysg:nyng,ibgp) = f(0:nzt+1,nysg:nyng,i)
+          ENDDO
+       ENDIF
+
+    END SUBROUTINE pmci_extrap_ifoutflow_lr
+
+
+
+    SUBROUTINE pmci_extrap_ifoutflow_sn( f, kb, edge, var )
+!
+!--    After  the interpolation of ghost-node values for the client-domain
+!--    boundary conditions, this subroutine checks if there is a local outflow
+!--    through the boundary. In that case this subroutine overwrites the
+!--    interpolated values by values extrapolated from the domain. This
+!--    subroutine handles the south and north boundaries.
+
+       IMPLICIT NONE
+
+       CHARACTER(LEN=1), INTENT(IN) ::  edge   !:
+       CHARACTER(LEN=1), INTENT(IN) ::  var    !:
+      
+       INTEGER(iwp) ::  i         !:
+       INTEGER(iwp) ::  j         !:
+       INTEGER(iwp) ::  jb        !:
+       INTEGER(iwp) ::  jbgp      !:
+       INTEGER(iwp) ::  jed       !:
+       INTEGER(iwp) ::  k         !:
+
+       INTEGER(iwp), DIMENSION(nysg:nyng,nxlg:nxrg), INTENT(IN) ::  kb   !:
+
+       REAL(wp)     ::  outnor    !:
+       REAL(wp)     ::  vdotnor   !:
+
+       REAL(wp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg), INTENT(INOUT) :: f !:
+
+!
+!--    Check which edge is to be handled: left or right
+       IF ( edge == 's' )  THEN
+          IF ( var == 'v' )  THEN
+             j   = nys
+             jb  = nys - 1
+             jed = nys + 1
+          ELSE
+             j   = nys - 1
+             jb  = nys - 2
+             jed = nys
+          ENDIF
+          outnor = -1.0_wp
+       ELSEIF ( edge == 'n' )  THEN
+          j      = nyn + 1
+          jb     = nyn + 2
+          jed    = nyn
+          outnor = 1.0_wp
+       ENDIF
+
+       DO  i = nxl, nxr+1
+          DO  k = kb(j,i), nzt+1
+             vdotnor = outnor * v(k,jed,i)
+!
+!--          Local outflow
+             IF ( vdotnor > 0.0_wp )  THEN
+                f(k,j,i) = f(k,jed,i)
+             ENDIF
+          ENDDO
+          IF ( (var == 'u' )  .OR.  (var == 'v' )  .OR.  (var == 'w') )  THEN
+             f(kb(j,i),j,i) = 0.0_wp
+          ENDIF
+       ENDDO
+
+!
+!--    Store the boundary values also into the redundant ghost node layers.
+       IF ( edge == 's' )  THEN
+          DO  jbgp = -nbgp, jb
+             f(0:nzt+1,jbgp,nxlg:nxrg) = f(0:nzt+1,j,nxlg:nxrg)
+          ENDDO
+       ELSEIF ( edge == 'n' )  THEN
+          DO  jbgp = jb, ny+nbgp
+             f(0:nzt+1,jbgp,nxlg:nxrg) = f(0:nzt+1,j,nxlg:nxrg)
+          ENDDO
+       ENDIF
+
+    END SUBROUTINE pmci_extrap_ifoutflow_sn
+
+ 
+
+    SUBROUTINE pmci_extrap_ifoutflow_t( f, var )
+!
+!--    Interpolation of ghost-node values used as the client-domain boundary
+!--    conditions. This subroutine handles the top boundary. It is based on
+!--    trilinear interpolation.
+
+       IMPLICIT NONE
+
+       CHARACTER(LEN=1), INTENT(IN) ::  var   !:
+      
+       INTEGER(iwp) ::  i     !:
+       INTEGER(iwp) ::  j     !:
+       INTEGER(iwp) ::  k     !:
+       INTEGER(iwp) ::  ked   !:
+
+       REAL(wp) ::  vdotnor   !:
+
+       REAL(wp), DIMENSION(nzb:nzt+1,nys-nbgp:nyn+nbgp,nxl-nbgp:nxr+nbgp),     &
+                 INTENT(INOUT) ::  f   !:
+     
+
+       IF ( var == 'w' )  THEN
+          k    = nzt
+          ked  = nzt - 1
+       ELSE
+          k    = nzt + 1
+          ked  = nzt
+       ENDIF
+
+       DO  i = nxl, nxr
+          DO  j = nys, nyn
+             vdotnor = w(ked,j,i)
+!
+!--          Local outflow
+             IF ( vdotnor > 0.0_wp )  THEN
+                f(k,j,i) = f(ked,j,i)
+             ENDIF
+          ENDDO
+       ENDDO
+
+!
+!--    Just fill up the second ghost-node layer for w
+       IF ( var == 'w' )  THEN
+          f(nzt+1,:,:) = f(nzt,:,:)
+       ENDIF
+
+    END SUBROUTINE pmci_extrap_ifoutflow_t
+
+
+
+    SUBROUTINE pmci_anterp_tophat( f, fc, kct, ifl, ifu, jfl, jfu, kfl, kfu,   &
+                                   var )
+!
+!--    Anterpolation of internal-node values to be used as the server-domain
+!--    values. This subroutine is based on the first-order numerical
+!--    integration of the fine-grid values contained within the coarse-grid
+!--    cell.
+
+       IMPLICIT NONE
+
+       CHARACTER(LEN=1), INTENT(IN) ::  var   !:
+
+       INTEGER(iwp) ::  i         !: Fine-grid index
+       INTEGER(iwp) ::  ii        !: Coarse-grid index
+       INTEGER(iwp) ::  iclp      !:
+       INTEGER(iwp) ::  icrm      !:
+       INTEGER(iwp) ::  ifc       !:
+       INTEGER(iwp) ::  ijfc      !:
+       INTEGER(iwp) ::  j         !: Fine-grid index
+       INTEGER(iwp) ::  jj        !: Coarse-grid index
+       INTEGER(iwp) ::  jcnm      !:
+       INTEGER(iwp) ::  jcsp      !:
+       INTEGER(iwp) ::  k         !: Fine-grid index
+       INTEGER(iwp) ::  kk        !: Coarse-grid index
+       INTEGER(iwp) ::  kcb       !:
+       INTEGER(iwp) ::  nfc       !:
+
+       INTEGER(iwp), INTENT(IN) ::  kct   !:
+
+       INTEGER(iwp), DIMENSION(icl:icr), INTENT(IN) ::  ifl   !:
+       INTEGER(iwp), DIMENSION(icl:icr), INTENT(IN) ::  ifu   !:
+       INTEGER(iwp), DIMENSION(jcs:jcn), INTENT(IN) ::  jfl   !:
+       INTEGER(iwp), DIMENSION(jcs:jcn), INTENT(IN) ::  jfu   !:
+       INTEGER(iwp), DIMENSION(0:kct), INTENT(IN)   ::  kfl   !:
+       INTEGER(iwp), DIMENSION(0:kct), INTENT(IN)   ::  kfu   !:
+
+
+       REAL(wp) ::  cellsum   !:
+       REAL(wp) ::  f1f       !:
+       REAL(wp) ::  fra       !:
+
+       REAL(wp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg), INTENT(IN) ::  f   !:
+       REAL(wp), DIMENSION(0:cg%nz+1,jcs:jcn,icl:icr), INTENT(INOUT)  ::  fc  !:
+  
+
+!
+!--    Initialize the index bounds for anterpolation 
+       iclp = icl 
+       icrm = icr 
+       jcsp = jcs 
+       jcnm = jcn 
+
+!
+!--    Define the index bounds iclp, icrm, jcsp and jcnm.
+!--    Note that kcb is simply zero and kct enters here as a parameter and it is
+!--    determined in pmci_init_anterp_tophat
+       IF ( nest_bound_l )  THEN
+          IF ( var == 'u' )  THEN
+             iclp = icl + nhll + 1
+          ELSE
+             iclp = icl + nhll
+          ENDIF
+       ENDIF
+       IF ( nest_bound_r )  THEN
+          icrm = icr - nhlr
+       ENDIF
+
+       IF ( nest_bound_s )  THEN
+          IF ( var == 'v' )  THEN
+             jcsp = jcs + nhls + 1
+          ELSE
+             jcsp = jcs + nhls
+          ENDIF
+       ENDIF
+       IF ( nest_bound_n )  THEN
+          jcnm = jcn - nhln
+       ENDIF
+       kcb = 0
+
+!
+!--    Note that l,m, and n are coarse-grid indices and i,j, and k are fine-grid
+!--    indices.
+       DO  ii = iclp, icrm
+          ifc = ifu(ii) - ifl(ii) + 1
+          DO  jj = jcsp, jcnm
+             ijfc = ifc * ( jfu(jj) - jfl(jj) + 1 )
+!
+!--          For simplicity anterpolate within buildings too
+             DO  kk = kcb, kct
+                nfc =  ijfc * ( kfu(kk) - kfl(kk) + 1 )
+                cellsum = 0.0_wp
+                DO  i = ifl(ii), ifu(ii)
+                   DO  j = jfl(jj), jfu(jj)
+                      DO  k = kfl(kk), kfu(kk)
+                         cellsum = cellsum + f(k,j,i)
+                      ENDDO
+                   ENDDO
+                ENDDO
+!
+!--             Spatial under-relaxation.
+                fra  = frax(ii) * fray(jj) * fraz(kk)
+!
+!--             Block out the fine-grid corner patches from the anterpolation
+                IF ( ( ifl(ii) < nxl ) .OR. ( ifu(ii) > nxr ) )  THEN
+                   IF ( ( jfl(jj) < nys ) .OR. ( jfu(jj) > nyn ) )  THEN
+                      fra = 0.0_wp
+                   ENDIF
+                ENDIF
+!
+!--             TO DO: introduce 3-d coarse grid array for precomputed
+!--             1/REAL(nfc) values
+                fc(kk,jj,ii) = ( 1.0_wp - fra ) * fc(kk,jj,ii) +               &
+                               fra * cellsum / REAL( nfc, KIND = wp )
+
+             ENDDO
+          ENDDO
+       ENDDO
+
+    END SUBROUTINE pmci_anterp_tophat
+
+#endif
+ END SUBROUTINE pmci_client_datatrans
+
+END MODULE pmc_interface
Index: lm/trunk/SOURCE/pmc_mpi_wrapper.f90
===================================================================
--- /palm/trunk/SOURCE/pmc_mpi_wrapper.f90	(revision 1849)
+++ 	(revision )
@@ -1,553 +1,0 @@
-MODULE pmc_mpi_wrapper
-
-!--------------------------------------------------------------------------------!
-! This file is part of PALM.
-!
-! PALM is free software: you can redistribute it and/or modify it under the terms
-! of the GNU General Public License as published by the Free Software Foundation,
-! either version 3 of the License, or (at your option) any later version.
-!
-! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
-! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
-! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along with
-! PALM. If not, see <http://www.gnu.org/licenses/>.
-!
-! Copyright 1997-2016 Leibniz Universitaet Hannover
-!--------------------------------------------------------------------------------!
-!
-! Current revisions:
-! ------------------
-!
-!
-! Former revisions:
-! -----------------
-! $Id$
-!
-! 1808 2016-04-05 19:44:00Z raasch
-! MPI module used by default on all machines
-!
-! 1779 2016-03-03 08:01:28Z raasch
-! kind=dp replaced by wp
-!
-! 1764 2016-02-28 12:45:19Z raasch
-! cpp-statement added (nesting can only be used in parallel mode),
-! kind-parameters adjusted to PALM-kinds
-!
-! 1762 2016-02-25 12:31:13Z hellstea
-! Initial revision by K. Ketelsen
-!
-! Description:
-! ------------
-!
-! MPI Wrapper of Palm Model Coupler
-!------------------------------------------------------------------------------!
-
-#if defined( __parallel )
-   use, intrinsic :: iso_c_binding
-
-#if defined( __mpifh )
-    INCLUDE "mpif.h"
-#else
-    USE MPI
-#endif
-   USE  kinds
-   USE  PMC_handle_communicator, ONLY: m_to_server_comm, m_to_client_comm, m_model_comm, m_model_rank
-   IMPLICIT none
-   PRIVATE
-   SAVE
-
-   INTERFACE PMC_Send_to_Server
-      MODULE PROCEDURE PMC_Send_to_Server_INTEGER
-      MODULE PROCEDURE PMC_Send_to_Server_INTEGER_2
-      MODULE PROCEDURE PMC_Send_to_Server_real_r1
-      MODULE PROCEDURE PMC_Send_to_Server_real_r2
-      MODULE PROCEDURE PMC_Send_to_Server_real_r3
-   END INTERFACE PMC_Send_to_Server
-
-   INTERFACE PMC_Recv_from_Server
-      MODULE PROCEDURE PMC_Recv_from_Server_INTEGER
-      MODULE PROCEDURE PMC_Recv_from_Server_real_r1
-      MODULE PROCEDURE PMC_Recv_from_Server_real_r2
-      MODULE PROCEDURE PMC_Recv_from_Server_real_r3
-   END INTERFACE PMC_Recv_from_Server
-
-   INTERFACE PMC_Send_to_Client
-      MODULE PROCEDURE PMC_Send_to_Client_INTEGER
-      MODULE PROCEDURE PMC_Send_to_Client_real_r1
-      MODULE PROCEDURE PMC_Send_to_Client_real_r2
-      MODULE PROCEDURE PMC_Send_to_Client_real_r3
-   END INTERFACE PMC_Send_to_Client
-
-   INTERFACE PMC_Recv_from_Client
-      MODULE PROCEDURE PMC_Recv_from_Client_INTEGER
-      MODULE PROCEDURE PMC_Recv_from_Client_INTEGER_2
-      MODULE PROCEDURE PMC_Recv_from_Client_real_r1
-      MODULE PROCEDURE PMC_Recv_from_Client_real_r2
-      MODULE PROCEDURE PMC_Recv_from_Client_real_r3
-   END INTERFACE PMC_Recv_from_Client
-
-   INTERFACE PMC_Bcast
-      MODULE PROCEDURE PMC_Bcast_INTEGER
-      MODULE PROCEDURE PMC_Bcast_character
-   END INTERFACE PMC_Bcast
-
-   INTERFACE PMC_Inter_Bcast
-      MODULE PROCEDURE PMC_Inter_Bcast_INTEGER_1
-   END INTERFACE PMC_Inter_Bcast
-
-   INTERFACE PMC_Alloc_mem
-      MODULE PROCEDURE PMC_Alloc_mem_INTEGER_1
-      MODULE PROCEDURE PMC_Alloc_mem_Real_1
-   END INTERFACE PMC_Alloc_mem
-
-   INTERFACE PMC_TIME
-      MODULE PROCEDURE PMC_TIME
-   END INTERFACE PMC_TIME
-
-   PUBLIC PMC_Send_to_Server, PMC_Recv_from_Server
-   PUBLIC PMC_Send_to_Client, PMC_Recv_from_Client
-   PUBLIC PMC_Bcast, PMC_Inter_Bcast, PMC_Alloc_mem
-   PUBLIC PMC_TIME
-
-CONTAINS
-
-   SUBROUTINE  PMC_Send_to_Server_INTEGER (buf, n, Server_rank, tag, ierr)
-      IMPLICIT     none
-      INTEGER, DIMENSION(:), INTENT(IN)         :: buf
-      INTEGER, INTENT(IN)                       :: n
-      INTEGER, INTENT(IN)                       :: Server_rank
-      INTEGER, INTENT(IN)                       :: tag
-      INTEGER, INTENT(OUT)                      :: ierr
-    
-      ierr = 0
-      CALL MPI_Send (buf, n, MPI_INTEGER, Server_rank, tag, m_to_server_comm, ierr)
-    
-      return
-   END SUBROUTINE  PMC_Send_to_Server_INTEGER
-
-   SUBROUTINE  PMC_Recv_from_Server_INTEGER (buf, n, Server_rank, tag, ierr)
-      IMPLICIT     none
-      INTEGER, DIMENSION(:), INTENT(OUT)        :: buf
-      INTEGER, INTENT(IN)                       :: n
-      INTEGER, INTENT(IN)                       :: Server_rank
-      INTEGER, INTENT(IN)                       :: tag
-      INTEGER, INTENT(OUT)                      :: ierr
-
-      ierr = 0
-      CALL MPI_Recv (buf, n, MPI_INTEGER, Server_rank, tag, m_to_server_comm, &
-         MPI_STATUS_IGNORE, ierr)
-
-      return
-   END SUBROUTINE  PMC_Recv_from_Server_INTEGER
-
-   SUBROUTINE  PMC_Send_to_Server_INTEGER_2 (buf, n, Server_rank, tag, ierr)
-      IMPLICIT     none
-      INTEGER, DIMENSION(:,:), INTENT(IN)       :: buf
-      INTEGER, INTENT(IN)                       :: n
-      INTEGER, INTENT(IN)                       :: Server_rank
-      INTEGER, INTENT(IN)                       :: tag
-      INTEGER, INTENT(OUT)                      :: ierr
-
-      ierr = 0
-      CALL MPI_Send (buf, n, MPI_INTEGER, Server_rank, tag, m_to_server_comm, ierr)
-
-      return
-   END SUBROUTINE  PMC_Send_to_Server_INTEGER_2
-
-   SUBROUTINE  PMC_Send_to_Server_real_r1 (buf, n, Server_rank, tag, ierr)
-
-      IMPLICIT     none
-
-      REAL(wp), DIMENSION(:), INTENT(IN) ::  buf
-      INTEGER, INTENT(IN)                ::  n
-      INTEGER, INTENT(IN)                ::  Server_rank
-      INTEGER, INTENT(IN)                ::  tag
-      INTEGER, INTENT(OUT)               ::  ierr
-
-      ierr = 0
-      CALL MPI_Send (buf, n, MPI_REAL, Server_rank, tag, m_to_server_comm, ierr)
-
-      return
-   END SUBROUTINE  PMC_Send_to_Server_real_r1
-
-   SUBROUTINE  PMC_Recv_from_Server_real_r1 (buf, n, Server_rank, tag, ierr)
-
-      IMPLICIT     none
-
-      REAL(wp), DIMENSION(:), INTENT(OUT) ::  buf
-      INTEGER, INTENT(IN)                 ::  n
-      INTEGER, INTENT(IN)                 ::  Server_rank
-      INTEGER, INTENT(IN)                 ::  tag
-      INTEGER, INTENT(OUT)                ::  ierr
-
-      ierr = 0
-      CALL MPI_Recv (buf, n, MPI_REAL, Server_rank, tag, m_to_server_comm,     &
-                     MPI_STATUS_IGNORE, ierr)
-
-      return
-   END SUBROUTINE  PMC_Recv_from_Server_real_r1
-
-   SUBROUTINE  PMC_Send_to_Server_real_r2 (buf, n, Server_rank, tag, ierr)
-
-      IMPLICIT     none
-
-      REAL(wp), DIMENSION(:,:), INTENT(IN) ::  buf
-      INTEGER, INTENT(IN)                  ::  n
-      INTEGER, INTENT(IN)                  ::  Server_rank
-      INTEGER, INTENT(IN)                  ::  tag
-      INTEGER, INTENT(OUT)                 ::  ierr
-
-      ierr = 0
-      CALL MPI_Send (buf, n, MPI_REAL, Server_rank, tag, m_to_server_comm, ierr)
-
-      return
-   END SUBROUTINE  PMC_Send_to_Server_real_r2
-
-   SUBROUTINE  PMC_Recv_from_Server_real_r2 (buf, n, Server_rank, tag, ierr)
-
-      IMPLICIT     none
-
-      REAL(wp), DIMENSION(:,:), INTENT(OUT) ::  buf
-      INTEGER, INTENT(IN)                   ::  n
-      INTEGER, INTENT(IN)                   ::  Server_rank
-      INTEGER, INTENT(IN)                   ::  tag
-      INTEGER, INTENT(OUT)                  ::  ierr
-
-      ierr = 0
-      CALL MPI_Recv (buf, n, MPI_REAL, Server_rank, tag, m_to_server_comm, &
-         MPI_STATUS_IGNORE, ierr)
-
-      return
-   END SUBROUTINE  PMC_Recv_from_Server_real_r2
-
-   SUBROUTINE  PMC_Send_to_Server_real_r3 (buf, n, Server_rank, tag, ierr)
-
-      IMPLICIT     none
-
-      REAL(wp), DIMENSION(:,:,:), INTENT(IN) ::  buf
-      INTEGER, INTENT(IN)                    ::  n
-      INTEGER, INTENT(IN)                    ::  Server_rank
-      INTEGER, INTENT(IN)                    ::  tag
-      INTEGER, INTENT(OUT)                   ::  ierr
-
-      ierr = 0
-      CALL MPI_Send (buf, n, MPI_REAL, Server_rank, tag, m_to_server_comm, ierr)
-
-      return
-   END SUBROUTINE  PMC_Send_to_Server_real_r3
-
-   SUBROUTINE  PMC_Recv_from_Server_real_r3 (buf, n, Server_rank, tag, ierr)
-
-      IMPLICIT     none
-
-      REAL(wp), DIMENSION(:,:,:), INTENT(OUT) ::  buf
-      INTEGER, INTENT(IN)                     ::  n
-      INTEGER, INTENT(IN)                     ::  Server_rank
-      INTEGER, INTENT(IN)                     ::  tag
-      INTEGER, INTENT(OUT)                    ::  ierr
-
-      ierr = 0
-      CALL MPI_Recv (buf, n, MPI_REAL, Server_rank, tag, m_to_server_comm, &
-         MPI_STATUS_IGNORE, ierr)
-
-      return
-   END SUBROUTINE  PMC_Recv_from_Server_real_r3
-
-
-   SUBROUTINE  PMC_Send_to_Client_INTEGER (Client_id, buf, n, Client_rank, tag, ierr)
-      IMPLICIT     none
-      INTEGER, INTENT(IN)                       :: Client_id
-      INTEGER, DIMENSION(:), INTENT(IN)         :: buf
-      INTEGER, INTENT(IN)                       :: n
-      INTEGER, INTENT(IN)                       :: Client_rank
-      INTEGER, INTENT(IN)                       :: tag
-      INTEGER, INTENT(OUT)                      :: ierr
-
-      ierr = 0
-      CALL MPI_Send (buf, n, MPI_INTEGER, Client_rank, tag, m_to_client_comm(Client_id), ierr)
-
-      return
-   END SUBROUTINE  PMC_Send_to_Client_INTEGER
-
-   SUBROUTINE  PMC_Recv_from_Client_INTEGER (Client_id, buf, n, Client_rank, tag, ierr)
-      IMPLICIT     none
-      INTEGER, INTENT(IN)                       :: Client_id
-      INTEGER, DIMENSION(:), INTENT(INOUT)      :: buf
-      INTEGER, INTENT(IN)                       :: n
-      INTEGER, INTENT(IN)                       :: Client_rank
-      INTEGER, INTENT(IN)                       :: tag
-      INTEGER, INTENT(OUT)                      :: ierr
-
-      ierr = 0
-      CALL MPI_Recv (buf, n, MPI_INTEGER, Client_rank, tag, m_to_client_comm(Client_id), &
-         MPI_STATUS_IGNORE, ierr)
-
-      return
-   END SUBROUTINE  PMC_Recv_from_Client_INTEGER
-
-   SUBROUTINE  PMC_Recv_from_Client_INTEGER_2 (Client_id, buf, n, Client_rank, tag, ierr)
-      IMPLICIT     none
-      INTEGER, INTENT(IN)                       :: Client_id
-      INTEGER, DIMENSION(:,:), INTENT(OUT)      :: buf
-      INTEGER, INTENT(IN)                       :: n
-      INTEGER, INTENT(IN)                       :: Client_rank
-      INTEGER, INTENT(IN)                       :: tag
-      INTEGER, INTENT(OUT)                      :: ierr
-
-      ierr = 0
-      CALL MPI_Recv (buf, n, MPI_INTEGER, Client_rank, tag, m_to_client_comm(Client_id), &
-         MPI_STATUS_IGNORE, ierr)
-
-      return
-   END SUBROUTINE  PMC_Recv_from_Client_INTEGER_2
-
-   SUBROUTINE  PMC_Send_to_Client_real_r1 (Client_id, buf, n, Client_rank, tag, ierr)
-
-      IMPLICIT     none
-
-      INTEGER, INTENT(IN)                ::  Client_id
-      REAL(wp), DIMENSION(:), INTENT(IN) ::  buf
-      INTEGER, INTENT(IN)                ::  n
-      INTEGER, INTENT(IN)                ::  Client_rank
-      INTEGER, INTENT(IN)                ::  tag
-      INTEGER, INTENT(OUT)               ::  ierr
-
-      ierr = 0
-      CALL MPI_Send (buf, n, MPI_REAL, Client_rank, tag, m_to_client_comm(Client_id), &
-         ierr)
-
-      return
-   END SUBROUTINE  PMC_Send_to_Client_real_r1
-
-   SUBROUTINE  PMC_Recv_from_Client_real_r1 (Client_id, buf, n, Client_rank, tag, ierr)
-
-      IMPLICIT     none
-
-      INTEGER, INTENT(IN)                   ::  Client_id
-      REAL(wp), DIMENSION(:), INTENT(INOUT) ::  buf
-      INTEGER, INTENT(IN)                   ::  n
-      INTEGER, INTENT(IN)                   ::  Client_rank
-      INTEGER, INTENT(IN)                   ::  tag
-      INTEGER, INTENT(OUT)                  ::  ierr
-
-      ierr = 0
-      CALL MPI_Recv (buf, n, MPI_REAL, Client_rank, tag, m_to_client_comm(Client_id), &
-         MPI_STATUS_IGNORE, ierr)
-
-      return
-   END SUBROUTINE  PMC_Recv_from_Client_real_r1
-
-   SUBROUTINE  PMC_Send_to_Client_real_r2 (Client_id, buf, n, Client_rank, tag, ierr)
-
-      IMPLICIT     none
-
-      INTEGER, INTENT(IN)                  ::  Client_id
-      REAL(wp), DIMENSION(:,:), INTENT(IN) ::  buf
-      INTEGER, INTENT(IN)                  ::  n
-      INTEGER, INTENT(IN)                  ::  Client_rank
-      INTEGER, INTENT(IN)                  ::  tag
-      INTEGER, INTENT(OUT)                 ::  ierr
-
-      ierr = 0
-      CALL MPI_Send (buf, n, MPI_REAL, Client_rank, tag, m_to_client_comm(Client_id), &
-         ierr)
-
-      return
-   END SUBROUTINE  PMC_Send_to_Client_real_r2
-
-   SUBROUTINE  PMC_Recv_from_Client_real_r2 (Client_id, buf, n, Client_rank, tag, ierr)
-
-      IMPLICIT     none
-
-      INTEGER, INTENT(IN)                   ::  Client_id
-      REAL(wp), DIMENSION(:,:), INTENT(OUT) ::  buf
-      INTEGER, INTENT(IN)                   ::  n
-      INTEGER, INTENT(IN)                   ::  Client_rank
-      INTEGER, INTENT(IN)                   ::  tag
-      INTEGER, INTENT(OUT)                  ::  ierr
-
-      ierr = 0
-      CALL MPI_Recv (buf, n, MPI_REAL, Client_rank, tag, m_to_client_comm(Client_id), &
-         MPI_STATUS_IGNORE, ierr)
-
-      return
-   END SUBROUTINE  PMC_Recv_from_Client_real_r2
-
-   SUBROUTINE  PMC_Send_to_Client_real_r3 (Client_id, buf, n, Client_rank, tag, ierr)
-
-      IMPLICIT     none
-
-      INTEGER, INTENT(IN)                    ::  Client_id
-      REAL(wp), DIMENSION(:,:,:), INTENT(IN) ::  buf
-      INTEGER, INTENT(IN)                    ::  n
-      INTEGER, INTENT(IN)                    ::  Client_rank
-      INTEGER, INTENT(IN)                    ::  tag
-      INTEGER, INTENT(OUT)                   ::  ierr
-
-      ierr = 0
-      CALL MPI_Send (buf, n, MPI_REAL, Client_rank, tag, m_to_client_comm(Client_id), &
-         ierr)
-
-      return
-   END SUBROUTINE  PMC_Send_to_Client_real_r3
-
-   SUBROUTINE  PMC_Recv_from_Client_real_r3 (Client_id, buf, n, Client_rank, tag, ierr)
-
-      IMPLICIT     none
-
-      INTEGER, INTENT(IN)                     ::  Client_id
-      REAL(wp), DIMENSION(:,:,:), INTENT(OUT) ::  buf
-      INTEGER, INTENT(IN)                     :: n
-      INTEGER, INTENT(IN)                     :: Client_rank
-      INTEGER, INTENT(IN)                     :: tag
-      INTEGER, INTENT(OUT)                    :: ierr
-
-      ierr = 0
-      CALL MPI_Recv (buf, n, MPI_REAL, Client_rank, tag, m_to_client_comm(Client_id), &
-         MPI_STATUS_IGNORE, ierr)
-
-      return
-   END SUBROUTINE  PMC_Recv_from_Client_real_r3
-
-   SUBROUTINE  PMC_Bcast_INTEGER (buf, root_pe, comm, ierr)
-      IMPLICIT     none
-      INTEGER, INTENT(INOUT)                      :: buf
-      INTEGER, INTENT(IN)                         :: root_pe
-      INTEGER, INTENT(IN),optional                :: comm
-      INTEGER, INTENT(OUT),optional               :: ierr
-      !-- local variables
-      INTEGER                                     :: myComm
-      INTEGER                                     :: myErr
-
-      if(present (comm))  then
-         myComm = comm
-      else
-         myComm = m_model_comm
-      end if
-
-      CALL MPI_Bcast (buf, 1, MPI_INTEGER, root_pe, myComm, myErr)
-
-      if(present (ierr))  then
-         ierr = myErr
-      end if
-
-      return
-   END SUBROUTINE  PMC_Bcast_INTEGER
-
-   SUBROUTINE  PMC_Bcast_character (buf, root_pe, comm, ierr)
-      IMPLICIT     none
-      character(len=*), INTENT(INOUT)             :: buf
-      INTEGER, INTENT(IN)                         :: root_pe
-      INTEGER, INTENT(IN),optional                :: comm
-      INTEGER, INTENT(OUT),optional               :: ierr
-      !-- local variables
-      INTEGER                                     :: myComm
-      INTEGER                                     :: myErr
-
-      if(present (comm))  then
-         myComm = comm
-      else
-         myComm = m_model_comm
-      end if
-
-      CALL MPI_Bcast (buf, len(buf), MPI_Character, root_pe, myComm, myErr)
-
-      if(present (ierr))  then
-         ierr = myErr
-      end if
-
-      return
-   END SUBROUTINE  PMC_Bcast_character
-
-   SUBROUTINE  PMC_Inter_Bcast_INTEGER_1 (buf, Client_id, ierr)
-      IMPLICIT     none
-      INTEGER, INTENT(INOUT),DIMENSION(:)         :: buf
-      INTEGER, INTENT(IN),optional                :: Client_id
-      INTEGER, INTENT(OUT),optional               :: ierr
-      !-- local variables
-      INTEGER                                     :: myComm
-      INTEGER                                     :: myErr
-      INTEGER                                     :: root_pe
-
-      !   PE 0 Server Broadcast to all Client PE's
-
-      if(present (Client_id))  then
-         myComm  = m_to_client_comm(Client_id)
-         if(m_model_rank == 0)  then
-            root_pe = MPI_ROOT
-         else
-            root_pe = MPI_PROC_NULL
-         end if
-      else
-         myComm  = m_to_server_comm
-         root_pe = 0
-      end if
-
-      CALL MPI_Bcast (buf, size(buf), MPI_INTEGER, root_pe, myComm, myErr)
-
-      if(present (ierr))  then
-         ierr = myErr
-      end if
-
-      return
-   END SUBROUTINE  PMC_Inter_Bcast_INTEGER_1
-
-!  Allocate  Memory with MPI_Alloc_mem using intermediate C-pointer
-
-   SUBROUTINE  PMC_Alloc_mem_INTEGER_1 (iarray, idim1)
-      IMPLICIT     none
-      INTEGER,DIMENSION(:),POINTER,INTENT(INOUT) :: iarray
-      INTEGER,INTENT(IN)                         :: idim1
-
-      Type(c_ptr)                             :: p_myInd
-      INTEGER,DIMENSION(1)                    :: aShape
-      INTEGER(KIND=MPI_ADDRESS_KIND)          :: WinSize
-      INTEGER                                 :: ierr
-
-      WinSize = idim1*c_sizeof(ierr)                          ! Length of INTEGER
-
-      CALL MPI_Alloc_mem  (WinSize , MPI_INFO_NULL, p_myInd, ierr);
-      aShape(1) = idim1
-      CALL c_f_pointer(p_myInd,iarray,aShape)
-
-      return
-   END SUBROUTINE  PMC_Alloc_mem_INTEGER_1
-
-   SUBROUTINE  PMC_Alloc_mem_Real_1 (array, idim1, base_ptr)
-      IMPLICIT     none
-      REAL(kind=wp),DIMENSION(:),POINTER,INTENT(INOUT) :: array
-      INTEGER(idp),INTENT(IN)                          :: idim1
-      Type(c_ptr),INTENT(OUT),optional                 :: base_ptr
-
-
-      Type(c_ptr)                             :: p_myInd
-      INTEGER,DIMENSION(1)                    :: aShape
-      INTEGER(KIND=MPI_ADDRESS_KIND)          :: WinSize
-      INTEGER                                 :: ierr
-
-      WinSize = idim1*wp                          ! Length of INTEGER
-
-      CALL MPI_Alloc_mem  (WinSize , MPI_INFO_NULL, p_myInd, ierr);
-      aShape(1) = idim1
-      CALL c_f_pointer(p_myInd,array,aShape)
-
-      if(present(base_ptr))   then
-         base_ptr = p_myInd
-      end if
-
-      return
-   END SUBROUTINE  PMC_Alloc_mem_Real_1
-
-   FUNCTION PMC_TIME ()
-      REAL(kind=wp)          :: PMC_TIME
-
-      PMC_TIME = MPI_Wtime ()
-
-      return
-
-    END FUNCTION PMC_TIME
-
-#endif
- END MODULE pmc_mpi_wrapper
Index: /palm/trunk/SOURCE/pmc_mpi_wrapper_mod.f90
===================================================================
--- /palm/trunk/SOURCE/pmc_mpi_wrapper_mod.f90	(revision 1850)
+++ /palm/trunk/SOURCE/pmc_mpi_wrapper_mod.f90	(revision 1850)
@@ -0,0 +1,554 @@
+MODULE pmc_mpi_wrapper
+
+!--------------------------------------------------------------------------------!
+! This file is part of PALM.
+!
+! PALM is free software: you can redistribute it and/or modify it under the terms
+! of the GNU General Public License as published by the Free Software Foundation,
+! either version 3 of the License, or (at your option) any later version.
+!
+! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
+! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
+! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along with
+! PALM. If not, see <http://www.gnu.org/licenses/>.
+!
+! Copyright 1997-2016 Leibniz Universitaet Hannover
+!--------------------------------------------------------------------------------!
+!
+! Current revisions:
+! ------------------
+! Module renamed
+!
+!
+! Former revisions:
+! -----------------
+! $Id$
+!
+! 1808 2016-04-05 19:44:00Z raasch
+! MPI module used by default on all machines
+!
+! 1779 2016-03-03 08:01:28Z raasch
+! kind=dp replaced by wp
+!
+! 1764 2016-02-28 12:45:19Z raasch
+! cpp-statement added (nesting can only be used in parallel mode),
+! kind-parameters adjusted to PALM-kinds
+!
+! 1762 2016-02-25 12:31:13Z hellstea
+! Initial revision by K. Ketelsen
+!
+! Description:
+! ------------
+!
+! MPI Wrapper of Palm Model Coupler
+!------------------------------------------------------------------------------!
+
+#if defined( __parallel )
+   use, intrinsic :: iso_c_binding
+
+#if defined( __mpifh )
+    INCLUDE "mpif.h"
+#else
+    USE MPI
+#endif
+   USE  kinds
+   USE  PMC_handle_communicator, ONLY: m_to_server_comm, m_to_client_comm, m_model_comm, m_model_rank
+   IMPLICIT none
+   PRIVATE
+   SAVE
+
+   INTERFACE PMC_Send_to_Server
+      MODULE PROCEDURE PMC_Send_to_Server_INTEGER
+      MODULE PROCEDURE PMC_Send_to_Server_INTEGER_2
+      MODULE PROCEDURE PMC_Send_to_Server_real_r1
+      MODULE PROCEDURE PMC_Send_to_Server_real_r2
+      MODULE PROCEDURE PMC_Send_to_Server_real_r3
+   END INTERFACE PMC_Send_to_Server
+
+   INTERFACE PMC_Recv_from_Server
+      MODULE PROCEDURE PMC_Recv_from_Server_INTEGER
+      MODULE PROCEDURE PMC_Recv_from_Server_real_r1
+      MODULE PROCEDURE PMC_Recv_from_Server_real_r2
+      MODULE PROCEDURE PMC_Recv_from_Server_real_r3
+   END INTERFACE PMC_Recv_from_Server
+
+   INTERFACE PMC_Send_to_Client
+      MODULE PROCEDURE PMC_Send_to_Client_INTEGER
+      MODULE PROCEDURE PMC_Send_to_Client_real_r1
+      MODULE PROCEDURE PMC_Send_to_Client_real_r2
+      MODULE PROCEDURE PMC_Send_to_Client_real_r3
+   END INTERFACE PMC_Send_to_Client
+
+   INTERFACE PMC_Recv_from_Client
+      MODULE PROCEDURE PMC_Recv_from_Client_INTEGER
+      MODULE PROCEDURE PMC_Recv_from_Client_INTEGER_2
+      MODULE PROCEDURE PMC_Recv_from_Client_real_r1
+      MODULE PROCEDURE PMC_Recv_from_Client_real_r2
+      MODULE PROCEDURE PMC_Recv_from_Client_real_r3
+   END INTERFACE PMC_Recv_from_Client
+
+   INTERFACE PMC_Bcast
+      MODULE PROCEDURE PMC_Bcast_INTEGER
+      MODULE PROCEDURE PMC_Bcast_character
+   END INTERFACE PMC_Bcast
+
+   INTERFACE PMC_Inter_Bcast
+      MODULE PROCEDURE PMC_Inter_Bcast_INTEGER_1
+   END INTERFACE PMC_Inter_Bcast
+
+   INTERFACE PMC_Alloc_mem
+      MODULE PROCEDURE PMC_Alloc_mem_INTEGER_1
+      MODULE PROCEDURE PMC_Alloc_mem_Real_1
+   END INTERFACE PMC_Alloc_mem
+
+   INTERFACE PMC_TIME
+      MODULE PROCEDURE PMC_TIME
+   END INTERFACE PMC_TIME
+
+   PUBLIC PMC_Send_to_Server, PMC_Recv_from_Server
+   PUBLIC PMC_Send_to_Client, PMC_Recv_from_Client
+   PUBLIC PMC_Bcast, PMC_Inter_Bcast, PMC_Alloc_mem
+   PUBLIC PMC_TIME
+
+CONTAINS
+
+   SUBROUTINE  PMC_Send_to_Server_INTEGER (buf, n, Server_rank, tag, ierr)
+      IMPLICIT     none
+      INTEGER, DIMENSION(:), INTENT(IN)         :: buf
+      INTEGER, INTENT(IN)                       :: n
+      INTEGER, INTENT(IN)                       :: Server_rank
+      INTEGER, INTENT(IN)                       :: tag
+      INTEGER, INTENT(OUT)                      :: ierr
+    
+      ierr = 0
+      CALL MPI_Send (buf, n, MPI_INTEGER, Server_rank, tag, m_to_server_comm, ierr)
+    
+      return
+   END SUBROUTINE  PMC_Send_to_Server_INTEGER
+
+   SUBROUTINE  PMC_Recv_from_Server_INTEGER (buf, n, Server_rank, tag, ierr)
+      IMPLICIT     none
+      INTEGER, DIMENSION(:), INTENT(OUT)        :: buf
+      INTEGER, INTENT(IN)                       :: n
+      INTEGER, INTENT(IN)                       :: Server_rank
+      INTEGER, INTENT(IN)                       :: tag
+      INTEGER, INTENT(OUT)                      :: ierr
+
+      ierr = 0
+      CALL MPI_Recv (buf, n, MPI_INTEGER, Server_rank, tag, m_to_server_comm, &
+         MPI_STATUS_IGNORE, ierr)
+
+      return
+   END SUBROUTINE  PMC_Recv_from_Server_INTEGER
+
+   SUBROUTINE  PMC_Send_to_Server_INTEGER_2 (buf, n, Server_rank, tag, ierr)
+      IMPLICIT     none
+      INTEGER, DIMENSION(:,:), INTENT(IN)       :: buf
+      INTEGER, INTENT(IN)                       :: n
+      INTEGER, INTENT(IN)                       :: Server_rank
+      INTEGER, INTENT(IN)                       :: tag
+      INTEGER, INTENT(OUT)                      :: ierr
+
+      ierr = 0
+      CALL MPI_Send (buf, n, MPI_INTEGER, Server_rank, tag, m_to_server_comm, ierr)
+
+      return
+   END SUBROUTINE  PMC_Send_to_Server_INTEGER_2
+
+   SUBROUTINE  PMC_Send_to_Server_real_r1 (buf, n, Server_rank, tag, ierr)
+
+      IMPLICIT     none
+
+      REAL(wp), DIMENSION(:), INTENT(IN) ::  buf
+      INTEGER, INTENT(IN)                ::  n
+      INTEGER, INTENT(IN)                ::  Server_rank
+      INTEGER, INTENT(IN)                ::  tag
+      INTEGER, INTENT(OUT)               ::  ierr
+
+      ierr = 0
+      CALL MPI_Send (buf, n, MPI_REAL, Server_rank, tag, m_to_server_comm, ierr)
+
+      return
+   END SUBROUTINE  PMC_Send_to_Server_real_r1
+
+   SUBROUTINE  PMC_Recv_from_Server_real_r1 (buf, n, Server_rank, tag, ierr)
+
+      IMPLICIT     none
+
+      REAL(wp), DIMENSION(:), INTENT(OUT) ::  buf
+      INTEGER, INTENT(IN)                 ::  n
+      INTEGER, INTENT(IN)                 ::  Server_rank
+      INTEGER, INTENT(IN)                 ::  tag
+      INTEGER, INTENT(OUT)                ::  ierr
+
+      ierr = 0
+      CALL MPI_Recv (buf, n, MPI_REAL, Server_rank, tag, m_to_server_comm,     &
+                     MPI_STATUS_IGNORE, ierr)
+
+      return
+   END SUBROUTINE  PMC_Recv_from_Server_real_r1
+
+   SUBROUTINE  PMC_Send_to_Server_real_r2 (buf, n, Server_rank, tag, ierr)
+
+      IMPLICIT     none
+
+      REAL(wp), DIMENSION(:,:), INTENT(IN) ::  buf
+      INTEGER, INTENT(IN)                  ::  n
+      INTEGER, INTENT(IN)                  ::  Server_rank
+      INTEGER, INTENT(IN)                  ::  tag
+      INTEGER, INTENT(OUT)                 ::  ierr
+
+      ierr = 0
+      CALL MPI_Send (buf, n, MPI_REAL, Server_rank, tag, m_to_server_comm, ierr)
+
+      return
+   END SUBROUTINE  PMC_Send_to_Server_real_r2
+
+   SUBROUTINE  PMC_Recv_from_Server_real_r2 (buf, n, Server_rank, tag, ierr)
+
+      IMPLICIT     none
+
+      REAL(wp), DIMENSION(:,:), INTENT(OUT) ::  buf
+      INTEGER, INTENT(IN)                   ::  n
+      INTEGER, INTENT(IN)                   ::  Server_rank
+      INTEGER, INTENT(IN)                   ::  tag
+      INTEGER, INTENT(OUT)                  ::  ierr
+
+      ierr = 0
+      CALL MPI_Recv (buf, n, MPI_REAL, Server_rank, tag, m_to_server_comm, &
+         MPI_STATUS_IGNORE, ierr)
+
+      return
+   END SUBROUTINE  PMC_Recv_from_Server_real_r2
+
+   SUBROUTINE  PMC_Send_to_Server_real_r3 (buf, n, Server_rank, tag, ierr)
+
+      IMPLICIT     none
+
+      REAL(wp), DIMENSION(:,:,:), INTENT(IN) ::  buf
+      INTEGER, INTENT(IN)                    ::  n
+      INTEGER, INTENT(IN)                    ::  Server_rank
+      INTEGER, INTENT(IN)                    ::  tag
+      INTEGER, INTENT(OUT)                   ::  ierr
+
+      ierr = 0
+      CALL MPI_Send (buf, n, MPI_REAL, Server_rank, tag, m_to_server_comm, ierr)
+
+      return
+   END SUBROUTINE  PMC_Send_to_Server_real_r3
+
+   SUBROUTINE  PMC_Recv_from_Server_real_r3 (buf, n, Server_rank, tag, ierr)
+
+      IMPLICIT     none
+
+      REAL(wp), DIMENSION(:,:,:), INTENT(OUT) ::  buf
+      INTEGER, INTENT(IN)                     ::  n
+      INTEGER, INTENT(IN)                     ::  Server_rank
+      INTEGER, INTENT(IN)                     ::  tag
+      INTEGER, INTENT(OUT)                    ::  ierr
+
+      ierr = 0
+      CALL MPI_Recv (buf, n, MPI_REAL, Server_rank, tag, m_to_server_comm, &
+         MPI_STATUS_IGNORE, ierr)
+
+      return
+   END SUBROUTINE  PMC_Recv_from_Server_real_r3
+
+
+   SUBROUTINE  PMC_Send_to_Client_INTEGER (Client_id, buf, n, Client_rank, tag, ierr)
+      IMPLICIT     none
+      INTEGER, INTENT(IN)                       :: Client_id
+      INTEGER, DIMENSION(:), INTENT(IN)         :: buf
+      INTEGER, INTENT(IN)                       :: n
+      INTEGER, INTENT(IN)                       :: Client_rank
+      INTEGER, INTENT(IN)                       :: tag
+      INTEGER, INTENT(OUT)                      :: ierr
+
+      ierr = 0
+      CALL MPI_Send (buf, n, MPI_INTEGER, Client_rank, tag, m_to_client_comm(Client_id), ierr)
+
+      return
+   END SUBROUTINE  PMC_Send_to_Client_INTEGER
+
+   SUBROUTINE  PMC_Recv_from_Client_INTEGER (Client_id, buf, n, Client_rank, tag, ierr)
+      IMPLICIT     none
+      INTEGER, INTENT(IN)                       :: Client_id
+      INTEGER, DIMENSION(:), INTENT(INOUT)      :: buf
+      INTEGER, INTENT(IN)                       :: n
+      INTEGER, INTENT(IN)                       :: Client_rank
+      INTEGER, INTENT(IN)                       :: tag
+      INTEGER, INTENT(OUT)                      :: ierr
+
+      ierr = 0
+      CALL MPI_Recv (buf, n, MPI_INTEGER, Client_rank, tag, m_to_client_comm(Client_id), &
+         MPI_STATUS_IGNORE, ierr)
+
+      return
+   END SUBROUTINE  PMC_Recv_from_Client_INTEGER
+
+   SUBROUTINE  PMC_Recv_from_Client_INTEGER_2 (Client_id, buf, n, Client_rank, tag, ierr)
+      IMPLICIT     none
+      INTEGER, INTENT(IN)                       :: Client_id
+      INTEGER, DIMENSION(:,:), INTENT(OUT)      :: buf
+      INTEGER, INTENT(IN)                       :: n
+      INTEGER, INTENT(IN)                       :: Client_rank
+      INTEGER, INTENT(IN)                       :: tag
+      INTEGER, INTENT(OUT)                      :: ierr
+
+      ierr = 0
+      CALL MPI_Recv (buf, n, MPI_INTEGER, Client_rank, tag, m_to_client_comm(Client_id), &
+         MPI_STATUS_IGNORE, ierr)
+
+      return
+   END SUBROUTINE  PMC_Recv_from_Client_INTEGER_2
+
+   SUBROUTINE  PMC_Send_to_Client_real_r1 (Client_id, buf, n, Client_rank, tag, ierr)
+
+      IMPLICIT     none
+
+      INTEGER, INTENT(IN)                ::  Client_id
+      REAL(wp), DIMENSION(:), INTENT(IN) ::  buf
+      INTEGER, INTENT(IN)                ::  n
+      INTEGER, INTENT(IN)                ::  Client_rank
+      INTEGER, INTENT(IN)                ::  tag
+      INTEGER, INTENT(OUT)               ::  ierr
+
+      ierr = 0
+      CALL MPI_Send (buf, n, MPI_REAL, Client_rank, tag, m_to_client_comm(Client_id), &
+         ierr)
+
+      return
+   END SUBROUTINE  PMC_Send_to_Client_real_r1
+
+   SUBROUTINE  PMC_Recv_from_Client_real_r1 (Client_id, buf, n, Client_rank, tag, ierr)
+
+      IMPLICIT     none
+
+      INTEGER, INTENT(IN)                   ::  Client_id
+      REAL(wp), DIMENSION(:), INTENT(INOUT) ::  buf
+      INTEGER, INTENT(IN)                   ::  n
+      INTEGER, INTENT(IN)                   ::  Client_rank
+      INTEGER, INTENT(IN)                   ::  tag
+      INTEGER, INTENT(OUT)                  ::  ierr
+
+      ierr = 0
+      CALL MPI_Recv (buf, n, MPI_REAL, Client_rank, tag, m_to_client_comm(Client_id), &
+         MPI_STATUS_IGNORE, ierr)
+
+      return
+   END SUBROUTINE  PMC_Recv_from_Client_real_r1
+
+   SUBROUTINE  PMC_Send_to_Client_real_r2 (Client_id, buf, n, Client_rank, tag, ierr)
+
+      IMPLICIT     none
+
+      INTEGER, INTENT(IN)                  ::  Client_id
+      REAL(wp), DIMENSION(:,:), INTENT(IN) ::  buf
+      INTEGER, INTENT(IN)                  ::  n
+      INTEGER, INTENT(IN)                  ::  Client_rank
+      INTEGER, INTENT(IN)                  ::  tag
+      INTEGER, INTENT(OUT)                 ::  ierr
+
+      ierr = 0
+      CALL MPI_Send (buf, n, MPI_REAL, Client_rank, tag, m_to_client_comm(Client_id), &
+         ierr)
+
+      return
+   END SUBROUTINE  PMC_Send_to_Client_real_r2
+
+   SUBROUTINE  PMC_Recv_from_Client_real_r2 (Client_id, buf, n, Client_rank, tag, ierr)
+
+      IMPLICIT     none
+
+      INTEGER, INTENT(IN)                   ::  Client_id
+      REAL(wp), DIMENSION(:,:), INTENT(OUT) ::  buf
+      INTEGER, INTENT(IN)                   ::  n
+      INTEGER, INTENT(IN)                   ::  Client_rank
+      INTEGER, INTENT(IN)                   ::  tag
+      INTEGER, INTENT(OUT)                  ::  ierr
+
+      ierr = 0
+      CALL MPI_Recv (buf, n, MPI_REAL, Client_rank, tag, m_to_client_comm(Client_id), &
+         MPI_STATUS_IGNORE, ierr)
+
+      return
+   END SUBROUTINE  PMC_Recv_from_Client_real_r2
+
+   SUBROUTINE  PMC_Send_to_Client_real_r3 (Client_id, buf, n, Client_rank, tag, ierr)
+
+      IMPLICIT     none
+
+      INTEGER, INTENT(IN)                    ::  Client_id
+      REAL(wp), DIMENSION(:,:,:), INTENT(IN) ::  buf
+      INTEGER, INTENT(IN)                    ::  n
+      INTEGER, INTENT(IN)                    ::  Client_rank
+      INTEGER, INTENT(IN)                    ::  tag
+      INTEGER, INTENT(OUT)                   ::  ierr
+
+      ierr = 0
+      CALL MPI_Send (buf, n, MPI_REAL, Client_rank, tag, m_to_client_comm(Client_id), &
+         ierr)
+
+      return
+   END SUBROUTINE  PMC_Send_to_Client_real_r3
+
+   SUBROUTINE  PMC_Recv_from_Client_real_r3 (Client_id, buf, n, Client_rank, tag, ierr)
+
+      IMPLICIT     none
+
+      INTEGER, INTENT(IN)                     ::  Client_id
+      REAL(wp), DIMENSION(:,:,:), INTENT(OUT) ::  buf
+      INTEGER, INTENT(IN)                     :: n
+      INTEGER, INTENT(IN)                     :: Client_rank
+      INTEGER, INTENT(IN)                     :: tag
+      INTEGER, INTENT(OUT)                    :: ierr
+
+      ierr = 0
+      CALL MPI_Recv (buf, n, MPI_REAL, Client_rank, tag, m_to_client_comm(Client_id), &
+         MPI_STATUS_IGNORE, ierr)
+
+      return
+   END SUBROUTINE  PMC_Recv_from_Client_real_r3
+
+   SUBROUTINE  PMC_Bcast_INTEGER (buf, root_pe, comm, ierr)
+      IMPLICIT     none
+      INTEGER, INTENT(INOUT)                      :: buf
+      INTEGER, INTENT(IN)                         :: root_pe
+      INTEGER, INTENT(IN),optional                :: comm
+      INTEGER, INTENT(OUT),optional               :: ierr
+      !-- local variables
+      INTEGER                                     :: myComm
+      INTEGER                                     :: myErr
+
+      if(present (comm))  then
+         myComm = comm
+      else
+         myComm = m_model_comm
+      end if
+
+      CALL MPI_Bcast (buf, 1, MPI_INTEGER, root_pe, myComm, myErr)
+
+      if(present (ierr))  then
+         ierr = myErr
+      end if
+
+      return
+   END SUBROUTINE  PMC_Bcast_INTEGER
+
+   SUBROUTINE  PMC_Bcast_character (buf, root_pe, comm, ierr)
+      IMPLICIT     none
+      character(len=*), INTENT(INOUT)             :: buf
+      INTEGER, INTENT(IN)                         :: root_pe
+      INTEGER, INTENT(IN),optional                :: comm
+      INTEGER, INTENT(OUT),optional               :: ierr
+      !-- local variables
+      INTEGER                                     :: myComm
+      INTEGER                                     :: myErr
+
+      if(present (comm))  then
+         myComm = comm
+      else
+         myComm = m_model_comm
+      end if
+
+      CALL MPI_Bcast (buf, len(buf), MPI_Character, root_pe, myComm, myErr)
+
+      if(present (ierr))  then
+         ierr = myErr
+      end if
+
+      return
+   END SUBROUTINE  PMC_Bcast_character
+
+   SUBROUTINE  PMC_Inter_Bcast_INTEGER_1 (buf, Client_id, ierr)
+      IMPLICIT     none
+      INTEGER, INTENT(INOUT),DIMENSION(:)         :: buf
+      INTEGER, INTENT(IN),optional                :: Client_id
+      INTEGER, INTENT(OUT),optional               :: ierr
+      !-- local variables
+      INTEGER                                     :: myComm
+      INTEGER                                     :: myErr
+      INTEGER                                     :: root_pe
+
+      !   PE 0 Server Broadcast to all Client PE's
+
+      if(present (Client_id))  then
+         myComm  = m_to_client_comm(Client_id)
+         if(m_model_rank == 0)  then
+            root_pe = MPI_ROOT
+         else
+            root_pe = MPI_PROC_NULL
+         end if
+      else
+         myComm  = m_to_server_comm
+         root_pe = 0
+      end if
+
+      CALL MPI_Bcast (buf, size(buf), MPI_INTEGER, root_pe, myComm, myErr)
+
+      if(present (ierr))  then
+         ierr = myErr
+      end if
+
+      return
+   END SUBROUTINE  PMC_Inter_Bcast_INTEGER_1
+
+!  Allocate  Memory with MPI_Alloc_mem using intermediate C-pointer
+
+   SUBROUTINE  PMC_Alloc_mem_INTEGER_1 (iarray, idim1)
+      IMPLICIT     none
+      INTEGER,DIMENSION(:),POINTER,INTENT(INOUT) :: iarray
+      INTEGER,INTENT(IN)                         :: idim1
+
+      Type(c_ptr)                             :: p_myInd
+      INTEGER,DIMENSION(1)                    :: aShape
+      INTEGER(KIND=MPI_ADDRESS_KIND)          :: WinSize
+      INTEGER                                 :: ierr
+
+      WinSize = idim1*c_sizeof(ierr)                          ! Length of INTEGER
+
+      CALL MPI_Alloc_mem  (WinSize , MPI_INFO_NULL, p_myInd, ierr);
+      aShape(1) = idim1
+      CALL c_f_pointer(p_myInd,iarray,aShape)
+
+      return
+   END SUBROUTINE  PMC_Alloc_mem_INTEGER_1
+
+   SUBROUTINE  PMC_Alloc_mem_Real_1 (array, idim1, base_ptr)
+      IMPLICIT     none
+      REAL(kind=wp),DIMENSION(:),POINTER,INTENT(INOUT) :: array
+      INTEGER(idp),INTENT(IN)                          :: idim1
+      Type(c_ptr),INTENT(OUT),optional                 :: base_ptr
+
+
+      Type(c_ptr)                             :: p_myInd
+      INTEGER,DIMENSION(1)                    :: aShape
+      INTEGER(KIND=MPI_ADDRESS_KIND)          :: WinSize
+      INTEGER                                 :: ierr
+
+      WinSize = idim1*wp                          ! Length of INTEGER
+
+      CALL MPI_Alloc_mem  (WinSize , MPI_INFO_NULL, p_myInd, ierr);
+      aShape(1) = idim1
+      CALL c_f_pointer(p_myInd,array,aShape)
+
+      if(present(base_ptr))   then
+         base_ptr = p_myInd
+      end if
+
+      return
+   END SUBROUTINE  PMC_Alloc_mem_Real_1
+
+   FUNCTION PMC_TIME ()
+      REAL(kind=wp)          :: PMC_TIME
+
+      PMC_TIME = MPI_Wtime ()
+
+      return
+
+    END FUNCTION PMC_TIME
+
+#endif
+ END MODULE pmc_mpi_wrapper
Index: lm/trunk/SOURCE/pmc_server.f90
===================================================================
--- /palm/trunk/SOURCE/pmc_server.f90	(revision 1849)
+++ 	(revision )
@@ -1,817 +1,0 @@
-MODULE pmc_server
-
-!--------------------------------------------------------------------------------!
-! This file is part of PALM.
-!
-! PALM is free software: you can redistribute it and/or modify it under the terms
-! of the GNU General Public License as published by the Free Software Foundation,
-! either version 3 of the License, or (at your option) any later version.
-!
-! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
-! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
-! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along with
-! PALM. If not, see <http://www.gnu.org/licenses/>.
-!
-! Copyright 1997-2016 Leibniz Universitaet Hannover
-!--------------------------------------------------------------------------------!
-!
-! Current revisions:
-! ------------------
-! 
-! 
-! Former revisions:
-! -----------------
-! $Id$
-!
-! 1833 2016-04-07 14:23:03Z raasch
-! gfortran requires pointer attributes for some array declarations,
-! long line wrapped
-!
-! 1808 2016-04-05 19:44:00Z raasch
-! MPI module used by default on all machines
-!
-! 1797 2016-03-21 16:50:28Z raasch
-! introduction of different datatransfer modes
-!
-! 1791 2016-03-11 10:41:25Z raasch
-! Debug write-statements commented out
-!
-! 1786 2016-03-08 05:49:27Z raasch
-! change in client-server data transfer: server now gets data from client
-! instead that client put's it to the server
-!
-! 1779 2016-03-03 08:01:28Z raasch
-! kind=dp replaced by wp,
-! error messages removed or changed to PALM style, dim_order removed
-! array management changed from linked list to sequential loop
-!
-! 1766 2016-02-29 08:37:15Z raasch
-! modifications to allow for using PALM's pointer version
-! +new routine pmc_s_set_active_data_array
-!
-! 1764 2016-02-28 12:45:19Z raasch
-! cpp-statement added (nesting can only be used in parallel mode)
-!
-! 1762 2016-02-25 12:31:13Z hellstea
-! Initial revision by K. Ketelsen
-!
-! Description:
-! ------------
-!
-! Server part of Palm Model Coupler
-!------------------------------------------------------------------------------!
-
-#if defined( __parallel )
-   use, intrinsic :: iso_c_binding
-
-#if defined( __mpifh )
-    INCLUDE "mpif.h"
-#else
-    USE MPI
-#endif
-   USE  kinds
-   USE  PMC_general,               ONLY: ClientDef, PMC_MAX_MODELL,PMC_sort, DA_NameDef, DA_Desclen, DA_Namelen,       &
-                                         PMC_G_SetName, PeDef, ArrayDef, PMC_MAX_ARRAY
-   USE  PMC_handle_communicator,   ONLY: m_model_comm,m_model_rank,m_model_npes, m_to_client_comm,                     &
-                                         PMC_Server_for_Client, m_world_rank
-   USE   PMC_MPI_wrapper,          ONLY: PMC_Send_to_Client, PMC_Recv_from_Client, PMC_Bcast, PMC_Inter_Bcast,         &
-                                         PMC_Alloc_mem, PMC_Time
-
-   IMPLICIT none
-   PRIVATE
-   SAVE
-
-   TYPE ClientIndexDef
-      INTEGER                                        :: NrPoints
-      INTEGER,DIMENSION(:,:),allocatable             :: index_list_2d
-   END TYPE ClientIndexDef
-
-   TYPE(ClientDef),DIMENSION(PMC_MAX_MODELL)          :: Clients
-   TYPE(ClientIndexDef),DIMENSION(PMC_MAX_MODELL)     :: indClients
-
-   INTEGER                                            :: next_array_in_list = 0
-
-   PUBLIC PMC_Server_for_Client
-
-   INTERFACE PMC_ServerInit
-      MODULE procedure  PMC_ServerInit
-   END INTERFACE PMC_ServerInit
-
-    INTERFACE PMC_S_Set_2D_index_list
-        MODULE procedure PMC_S_Set_2D_index_list
-    END INTERFACE PMC_S_Set_2D_index_list
-
-    INTERFACE PMC_S_clear_next_array_list
-        MODULE procedure PMC_S_clear_next_array_list
-    END INTERFACE PMC_S_clear_next_array_list
-
-    INTERFACE PMC_S_GetNextArray
-        MODULE procedure PMC_S_GetNextArray
-    END INTERFACE PMC_S_GetNextArray
-
-    INTERFACE PMC_S_Set_DataArray
-        MODULE procedure PMC_S_Set_DataArray_2d
-        MODULE procedure PMC_S_Set_DataArray_3d
-    END INTERFACE PMC_S_Set_DataArray
-
-    INTERFACE PMC_S_setInd_and_AllocMem
-        MODULE procedure PMC_S_setInd_and_AllocMem
-    END INTERFACE PMC_S_setInd_and_AllocMem
-
-    INTERFACE PMC_S_FillBuffer
-        MODULE procedure PMC_S_FillBuffer
-    END INTERFACE PMC_S_FillBuffer
-
-    INTERFACE PMC_S_GetData_from_Buffer
-        MODULE procedure PMC_S_GetData_from_Buffer
-    END INTERFACE PMC_S_GetData_from_Buffer
-
-    INTERFACE PMC_S_Set_Active_data_array
-        MODULE procedure PMC_S_Set_Active_data_array
-    END INTERFACE PMC_S_Set_Active_data_array
-
-    ! PUBLIC section
-
-    PUBLIC PMC_ServerInit, PMC_S_Set_2D_index_list, PMC_S_GetNextArray, PMC_S_Set_DataArray
-    PUBLIC PMC_S_setInd_and_AllocMem, PMC_S_FillBuffer, PMC_S_GetData_from_Buffer, PMC_S_Set_Active_data_array
-    PUBLIC PMC_S_clear_next_array_list
-
-CONTAINS
-
-   SUBROUTINE PMC_ServerInit
-      IMPLICIT none
-      INTEGER                 :: i
-      INTEGER                 :: j
-      INTEGER                 :: ClientId
-      INTEGER                 :: istat
-
-      do i=1,size(PMC_Server_for_Client)-1
-!         if(m_model_comm == 0) write(0,*) 'PMC_Server: Initialize client Id',PMC_Server_for_Client(i)
-
-         ClientId = PMC_Server_for_Client(i)
-
-         Clients(ClientId)%model_comm = m_model_comm
-         Clients(ClientId)%inter_comm = m_to_client_comm(ClientId)
-
-         ! Get rank and size
-         CALL MPI_Comm_rank (Clients(ClientId)%model_comm, Clients(ClientId)%model_rank, istat);
-         CALL MPI_Comm_size (Clients(ClientId)%model_comm, Clients(ClientId)%model_npes, istat);
-         CALL MPI_Comm_remote_size (Clients(ClientId)%inter_comm, Clients(ClientId)%inter_npes, istat);
-
-         ! Intra communicater is used for MPI_Get
-         CALL MPI_Intercomm_merge (Clients(ClientId)%inter_comm, .false., Clients(ClientId)%intra_comm, istat);
-         CALL MPI_Comm_rank (Clients(ClientId)%intra_comm, Clients(ClientId)%intra_rank, istat);
-
-!         write(9,*) 'ClientId ',i,ClientId,m_world_rank, Clients(ClientId)%inter_npes
-
-         ALLOCATE (Clients(ClientId)%PEs(Clients(ClientId)%inter_npes))
-!
-!--      Allocate for all client PEs an array of TYPE ArrayDef to store information of transfer array
-         do j=1,Clients(ClientId)%inter_npes
-           Allocate(Clients(ClientId)%PEs(j)%array_list(PMC_MAX_ARRAY))
-         end do
-
-         CALL Get_DA_names_from_client (ClientId)
-      end do
-
-      return
-   END SUBROUTINE PMC_ServerInit
-
-    SUBROUTINE PMC_S_Set_2D_index_list (ClientId, index_list)
-        IMPLICIT none
-        INTEGER,INTENT(IN)                         :: ClientId
-        INTEGER,DIMENSION(:,:),INTENT(INOUT)       :: index_list      !Index list will be modified in sort, therefore INOUT
-
-        !-- Local variables
-        INTEGER                 :: ip,is,ie,ian,ic,n
-        INTEGER                 :: istat
-
-        if(m_model_rank == 0)   then
-            CALL PMC_sort (index_list, 6)                       ! Sort to ascending Server PE
-            is = 1
-
-            do ip=0,m_model_npes-1
-
-                !       Split into Server PEs
-                ie = is-1                                     !there may be no entry for this PE
-                if(is <= size(index_list,2) .and. ie >= 0)  then
-                    do while ( index_list(6,ie+1) == ip)
-                        ie = ie+1
-                        if( ie == size(index_list,2)) EXIT
-                    end do
-
-                    ian = ie-is+1
-                else
-                    is  = -1
-                    ie  = -2
-                    ian = 0
-                end if
-
-                !       Send data to other server PEs
-
-                if(ip == 0)   then
-                    indClients(ClientId)%NrPoints = ian
-                    if(ian > 0)   then
-                        ALLOCATE (indClients(ClientId)%index_list_2d(6,ian))
-                        indClients(ClientId)%index_list_2d(:,1:ian) = index_list(:,is:ie)
-                    end if
-                else
-                    CALL MPI_Send (ian, 1, MPI_INTEGER, ip, 1000, m_model_comm, istat)
-                    if(ian > 0) then
-                        CALL MPI_Send (index_list(1,is), 6*ian, MPI_INTEGER, ip, 1001,                  &
-                            m_model_comm, istat)
-                    end if
-                end if
-                is = ie+1
-            end do
-        else
-            CALL MPI_Recv (indClients(ClientId)%NrPoints, 1, MPI_INTEGER, 0, 1000, m_model_comm,     &
-                MPI_STATUS_IGNORE, istat)
-            ian = indClients(ClientId)%NrPoints
-             if(ian > 0) then
-                ALLOCATE(indClients(ClientId)%index_list_2d(6,ian))
-                CALL MPI_RECV (indClients(ClientId)%index_list_2d, 6*ian, MPI_INTEGER, 0, 1001,        &
-                    m_model_comm, MPI_STATUS_IGNORE, istat)
-            end if
-        end if
-
-        CALL Set_PE_index_list (ClientId,Clients(ClientId),indClients(ClientId)%index_list_2d,indClients(ClientId)%NrPoints)
-
-        return
-    END SUBROUTINE PMC_S_Set_2D_index_list
-
-    SUBROUTINE PMC_S_clear_next_array_list
-       IMPLICIT none
-
-       next_array_in_list = 0
-
-       return
-    END SUBROUTINE PMC_S_clear_next_array_list
-
-!   List handling is still required to get minimal interaction with pmc_interface
-    logical function PMC_S_GetNextArray (ClientId, myName)
-       INTEGER(iwp),INTENT(IN)                    :: ClientId
-       CHARACTER(len=*),INTENT(OUT)               :: myName
-
-!--    local variables
-       TYPE(PeDef),POINTER          :: aPE
-       TYPE(ArrayDef),POINTER       :: ar
-
-       next_array_in_list = next_array_in_list+1
-
-!--    Array Names are the same on all client PE, so take first PE to get the name
-       aPE => Clients(ClientId)%PEs(1)
-
-       if(next_array_in_list > aPE%Nr_arrays) then
-          PMC_S_GetNextArray = .false.              ! all arrays done
-          return
-       end if
-
-       ar  => aPE%array_list(next_array_in_list)
-       myName = ar%name
-
-       PMC_S_GetNextArray =  .true.                 ! Return true if legal array
-       return
-    END function PMC_S_GetNextArray
-
-    SUBROUTINE PMC_S_Set_DataArray_2d (ClientId, array, array_2 )
-
-        IMPLICIT none
-
-        INTEGER,INTENT(IN) ::  ClientId
-
-        REAL(wp), INTENT(IN), DIMENSION(:,:), POINTER           ::  array
-        REAL(wp), INTENT(IN), DIMENSION(:,:), POINTER, OPTIONAL ::  array_2
-
-        INTEGER                           :: NrDims
-        INTEGER,DIMENSION (4)             :: dims
-        TYPE(c_ptr)                       :: array_adr
-        TYPE(c_ptr)                       :: second_adr
-
-        dims = 1
-
-        NrDims    = 2
-        dims(1)   = size(array,1)
-        dims(2)   = size(array,2)
-        array_adr = c_loc(array)
-
-        IF ( PRESENT( array_2 ) )  THEN
-           second_adr = c_loc(array_2)
-           CALL PMC_S_SetArray (ClientId, NrDims, dims, array_adr, second_adr = second_adr)
-        ELSE
-           CALL PMC_S_SetArray (ClientId, NrDims, dims, array_adr)
-        ENDIF
-
-        return
-    END SUBROUTINE PMC_S_Set_DataArray_2d
-
-    SUBROUTINE PMC_S_Set_DataArray_3d (ClientId, array, nz_cl, nz, array_2 )
-
-        IMPLICIT none
-
-        INTEGER,INTENT(IN) ::  ClientId
-
-        REAL(wp), INTENT(IN), DIMENSION(:,:,:), POINTER           ::  array
-        REAL(wp), INTENT(IN), DIMENSION(:,:,:), POINTER, OPTIONAL ::  array_2
-        INTEGER,INTENT(IN)                         :: nz_cl
-        INTEGER,INTENT(IN)                         :: nz
-
-        INTEGER                           :: NrDims
-        INTEGER,DIMENSION (4)             :: dims
-        TYPE(c_ptr)                       :: array_adr
-        TYPE(c_ptr)                       :: second_adr
-
-        dims = 1
-
-        dims      = 0
-        NrDims    = 3
-        dims(1)   = size(array,1)
-        dims(2)   = size(array,2)
-        dims(3)   = size(array,3)
-        dims(4)   = nz_cl+dims(1)-nz                        ! works for first dimension 1:nz and 0:nz+1
-
-        array_adr = c_loc(array)
-
-!
-!--     In PALM's pointer version, two indices have to be stored internally.
-!--     The active address of the data array is set in swap_timelevel
-        IF ( PRESENT( array_2 ) )  THEN
-          second_adr = c_loc(array_2)
-          CALL PMC_S_SetArray (ClientId, NrDims, dims, array_adr, second_adr = second_adr)
-        ELSE
-           CALL PMC_S_SetArray (ClientId, NrDims, dims, array_adr)
-        ENDIF
-
-        return
-   END SUBROUTINE PMC_S_Set_DataArray_3d
-
-   SUBROUTINE PMC_S_setInd_and_AllocMem (ClientId)
-
-      USE control_parameters,                                                  &
-          ONLY:  message_string
-
-      IMPLICIT none
-
-!
-!--   Naming convention for appendices:   _sc  -> server to client transfer
-!--                                       _cs  -> client to server transfer
-!--                                       Send -> Server to client transfer
-!--                                       Recv -> client to server transfer
-      INTEGER,INTENT(IN)                      :: ClientId
-
-      INTEGER                                 :: i, istat, ierr, j
-      INTEGER                                 :: arlen, myIndex, tag
-      INTEGER                                 :: rCount                    ! count MPI requests
-      INTEGER(idp)                            :: bufsize                   ! Size of MPI data Window
-      TYPE(PeDef),POINTER                     :: aPE
-      TYPE(ArrayDef),POINTER                  :: ar
-      CHARACTER(len=DA_Namelen)               :: myName
-      INTEGER,DIMENSION(1024)                 :: req
-      Type(c_ptr)                             :: base_ptr
-      REAL(wp),DIMENSION(:),POINTER,SAVE :: base_array_sc  !Base array for server to client transfer
-      REAL(wp),DIMENSION(:),POINTER,SAVE :: base_array_cs  !Base array for client to server transfer
-      INTEGER(KIND=MPI_ADDRESS_KIND)          :: WinSize
-
-!
-!--   Server to client direction
-      myIndex = 1
-      rCount  = 0
-      bufsize = 8
-
-!
-!--   First stride: Compute size and set index
-      do i=1,Clients(ClientId)%inter_npes
-         aPE => Clients(ClientId)%PEs(i)
-         tag = 200
-         do j=1,aPE%Nr_arrays
-            ar  => aPE%array_list(j)
-            if(ar%NrDims == 2) then
-               arlen     = aPE%NrEle                              ! 2D
-            else if(ar%NrDims == 3) then
-               arlen     = aPE%NrEle * ar%A_dim(4);               ! 3D
-            else
-               arlen     = -1
-            end if
-            ar%SendIndex = myIndex
-
-            tag    = tag+1
-            rCount = rCount+1
-            CALL MPI_Isend (myIndex, 1, MPI_INTEGER, i-1, tag, Clients(ClientId)%inter_comm, req(rCount),ierr)
-
-            if(rCount == 1024) then                                  ! Maximum of 1024 outstanding requests
-               CALL MPI_Waitall (rCount, req, MPI_STATUSES_IGNORE, ierr)
-               rCount = 0;
-            end if
-
-            myIndex = myIndex+arlen
-            bufsize = bufsize+arlen
-            ar%SendSize = arlen
-
-         end do
-         if(rCount > 0) then                       ! Wait for all send completed
-            CALL MPI_Waitall (rCount, req, MPI_STATUSES_IGNORE, ierr)
-         end if
-      end do
-
-!
-!--   Create RMA (One Sided Communication) window for data buffer server to
-!--   client transfer.
-!--   The buffer of MPI_Get (counter part of transfer) can be PE-local, i.e.
-!--   it can but must not be part of the MPI RMA window.
-!--   Only one RMA window is required to prepare the data
-!--   for server -> client transfer on the server side and
-!--   for client -> server transfer on the client side
-      CALL PMC_Alloc_mem (base_array_sc, bufsize)
-      Clients(ClientId)%TotalBufferSize = bufsize*wp   !Total buffer size in Byte
-
-      WinSize = bufsize*wp
-      CALL MPI_Win_create (base_array_sc, WinSize, wp, MPI_INFO_NULL,          &
-                  Clients(ClientId)%intra_comm,  Clients(ClientId)%win_server_client, ierr)
-      CALL MPI_Win_fence (0, Clients(ClientId)%win_server_client, ierr);        !  Open Window to set data
-!
-!--   Second stride: Set Buffer pointer
-      do i=1,Clients(ClientId)%inter_npes
-         aPE => Clients(ClientId)%PEs(i)
-         do j=1,aPE%Nr_arrays
-            ar  => aPE%array_list(j)
-            ar%SendBuf = c_loc(base_array_sc(ar%SendIndex))
-            if(ar%SendIndex+ar%SendSize > bufsize) then
-               write(0,'(a,i4,4i7,1x,a)') 'Server Buffer too small ',i,        &
-                  ar%SendIndex,ar%SendSize,ar%SendIndex+ar%SendSize,bufsize,trim(ar%name)
-               CALL MPI_Abort (MPI_COMM_WORLD, istat, ierr)
-            end if
-         end do
-      end do
-
-!--   Client to server direction
-
-      bufsize  = 8
-
-!--   First stride, Compute size and set index
-
-      do i=1,Clients(ClientId)%inter_npes
-         aPE => Clients(ClientId)%PEs(i)
-         tag = 300
-
-         do j=1,aPE%Nr_arrays
-            ar  => aPE%array_list(j)
-
-            ! Receive Index from client
-            tag = tag+1
-            CALL MPI_Recv (myIndex, 1, MPI_INTEGER, i-1, tag, Clients(ClientId)%inter_comm, MPI_STATUS_IGNORE, ierr)
-
-            if(ar%NrDims == 3) then
-               bufsize = max(bufsize,aPE%NrEle * ar%A_dim(4))               ! 3D
-            else
-               bufsize = max(bufsize,aPE%NrEle)                             ! 2D
-            end if
-            ar%RecvIndex = myIndex
-          end do
-
-      end do
-
-!--   Create RMA (One Sided Communication) data buffer
-!--   The buffer for MPI_Get can be PE local, i.e. it can but must not be part of the MPI RMA window
-
-      CALL PMC_Alloc_mem (base_array_cs, bufsize, base_ptr)
-      Clients(ClientId)%TotalBufferSize = bufsize*wp       !Total buffer size in Byte
-
-      CALL MPI_Barrier(Clients(ClientId)%intra_comm, ierr)
-
-!--   Second stride, Set Buffer pointer
-
-      do i=1,Clients(ClientId)%inter_npes
-         aPE => Clients(ClientId)%PEs(i)
-
-         do j=1,aPE%Nr_arrays
-            ar  => aPE%array_list(j)
-            ar%RecvBuf = base_ptr
-         end do
-      end do
-
-      return
-   END SUBROUTINE PMC_S_setInd_and_AllocMem
-
-   SUBROUTINE PMC_S_FillBuffer (ClientId, WaitTime)
-      IMPLICIT none
-      INTEGER,INTENT(IN)                  ::  ClientId
-      REAL(wp), INTENT(OUT), OPTIONAL     ::  WaitTime
-
-      INTEGER                             ::  ip,ij,istat,ierr,j
-      INTEGER                             ::  myIndex
-      REAL(wp)                            ::  t1,t2
-      TYPE(PeDef),POINTER                 ::  aPE
-      TYPE(ArrayDef),POINTER              ::  ar
-      CHARACTER(len=DA_Namelen)           ::  myName
-      INTEGER,DIMENSION(1)                ::  buf_shape
-      REAL(wp), POINTER, DIMENSION(:)     ::  buf
-      REAL(wp), POINTER, DIMENSION(:,:)   ::  data_2d
-      REAL(wp), POINTER, DIMENSION(:,:,:) ::  data_3d
-
-!--   Synchronization of the model is done in pmci_client_synchronize and pmci_server_synchronize
-!--   Therefor the RMA window cann be filled without sychronization at this point and the barrier
-!--   is not necessary
-!--   Please note that WaitTime has to be set in PMC_S_FillBuffer AND PMC_C_GetBuffer
-
-      if(present(WaitTime)) then
-        t1 = PMC_Time()
-        CALL MPI_Barrier(Clients(ClientId)%intra_comm, ierr)
-        t2 = PMC_Time()
-        WaitTime = t2-t1
-      end if
-
-      do ip=1,Clients(ClientId)%inter_npes
-         aPE => Clients(ClientId)%PEs(ip)
-         do j=1,aPE%Nr_arrays
-            ar  => aPE%array_list(j)
-            myIndex=1
-            if(ar%NrDims == 2) then
-               buf_shape(1) = aPE%NrEle
-               CALL c_f_pointer(ar%SendBuf, buf, buf_shape)
-               CALL c_f_pointer(ar%data, data_2d, ar%A_dim(1:2))
-               do ij=1,aPE%NrEle
-                  buf(myIndex) = data_2d(aPE%locInd(ij)%j,aPE%locInd(ij)%i)
-                  myIndex = myIndex+1
-               end do
-            else if(ar%NrDims == 3) then
-               buf_shape(1) = aPE%NrEle*ar%A_dim(4)
-               CALL c_f_pointer(ar%SendBuf, buf, buf_shape)
-               CALL c_f_pointer(ar%data, data_3d, ar%A_dim(1:3))
-               do ij=1,aPE%NrEle
-                  buf(myIndex:myIndex+ar%A_dim(4)-1) = data_3d(1:ar%A_dim(4),aPE%locInd(ij)%j,aPE%locInd(ij)%i)
-                  myIndex = myIndex+ar%A_dim(4)
-               end do
-            end if
-          end do
-      end do
-
-      CALL MPI_Barrier(Clients(ClientId)%intra_comm, ierr)    ! buffer is filled
-
-      return
-   END SUBROUTINE PMC_S_FillBuffer
-
-   SUBROUTINE PMC_S_GetData_from_Buffer (ClientId, WaitTime)
-
-      IMPLICIT none
-
-      INTEGER,INTENT(IN)                  ::  ClientId
-      REAL(wp), INTENT(OUT), OPTIONAL     ::  WaitTime
-
-      !-- local variables
-      INTEGER                             ::  ip,ij,istat,ierr,j
-      INTEGER                             ::  myIndex
-      INTEGER                             ::  nr
-      REAL(wp)                            ::  t1,t2
-      TYPE(PeDef),POINTER                 ::  aPE
-      TYPE(ArrayDef),POINTER              ::  ar
-      CHARACTER(len=DA_Namelen)           ::  myName
-      INTEGER,DIMENSION(1)                ::  buf_shape
-      REAL(wp), POINTER, DIMENSION(:)     ::  buf
-      REAL(wp), POINTER, DIMENSION(:,:)   ::  data_2d
-      REAL(wp), POINTER, DIMENSION(:,:,:) ::  data_3d
-      INTEGER                             ::  target_pe
-      INTEGER(kind=MPI_ADDRESS_KIND)      ::  target_disp
-
-      t1 = PMC_Time()
-      CALL MPI_Barrier(Clients(ClientId)%intra_comm, ierr)                         ! Wait for client to fill buffer
-      t2 = PMC_Time()-t1
-      if(present(WaitTime)) WaitTime = t2
-
-!      CALL MPI_Win_fence (0, Clients(ClientId)%win_server_client, ierr)            ! Fence might do it, test later
-      CALL MPI_Barrier(Clients(ClientId)%intra_comm, ierr)                         ! Wait for buffer is filled
-
-      do ip=1,Clients(ClientId)%inter_npes
-         aPE => Clients(ClientId)%PEs(ip)
-         do j=1,aPE%Nr_arrays
-            ar  => aPE%array_list(j)
-
-            if(ar%RecvIndex < 0)  CYCLE
-
-            if(ar%NrDims == 2) then
-               nr = aPE%NrEle
-            else if(ar%NrDims == 3) then
-               nr = aPE%NrEle*ar%A_dim(4)
-            end if
-
-            buf_shape(1) = nr
-            CALL c_f_pointer(ar%RecvBuf, buf, buf_shape)
-!
-!--         MPI passive target RMA
-
-            if(nr > 0)   then
-               target_disp = ar%RecvIndex-1
-               target_pe = ip-1+m_model_npes                         ! client PEs are located behind server PEs
-               CALL MPI_Win_lock (MPI_LOCK_SHARED , target_pe, 0, Clients(ClientId)%win_server_client, ierr)
-               CALL MPI_Get (buf, nr, MPI_REAL, target_pe, target_disp, nr, MPI_REAL, Clients(ClientId)%win_server_client, ierr)
-               CALL MPI_Win_unlock (target_pe, Clients(ClientId)%win_server_client, ierr)
-            end if
-
-            myIndex=1
-            if(ar%NrDims == 2) then
-               CALL c_f_pointer(ar%data, data_2d, ar%A_dim(1:2))
-               do ij=1,aPE%NrEle
-                  data_2d(aPE%locInd(ij)%j,aPE%locInd(ij)%i) = buf(myIndex)
-                  myIndex = myIndex+1
-               end do
-            else if(ar%NrDims == 3) then
-               CALL c_f_pointer(ar%data, data_3d, ar%A_dim(1:3))
-               do ij=1,aPE%NrEle
-                  data_3d(1:ar%A_dim(4),aPE%locInd(ij)%j,aPE%locInd(ij)%i) = buf(myIndex:myIndex+ar%A_dim(4)-1)
-                  myIndex = myIndex+ar%A_dim(4)
-               end do
-            end if
-          end do
-      end do
-
-   END SUBROUTINE PMC_S_GetData_from_Buffer
-
-! Private SUBROUTINEs
-
-   SUBROUTINE Get_DA_names_from_client (ClientId)
-        IMPLICIT none
-        INTEGER,INTENT(IN)                    :: ClientId
-        !-- local variables
-        type(DA_NameDef)                      :: myName
-
-        !   Get Data Array Description and Name from Client
-
-        do
-            CALL PMC_Bcast ( myName%couple_index, 0, comm=m_to_client_comm(ClientId))
-            if(myName%couple_index == -1) EXIT
-            CALL PMC_Bcast ( myName%ServerDesc,   0, comm=m_to_client_comm(ClientId))
-            CALL PMC_Bcast ( myName%NameOnServer, 0, comm=m_to_client_comm(ClientId))
-            CALL PMC_Bcast ( myName%ClientDesc,   0, comm=m_to_client_comm(ClientId))
-            CALL PMC_Bcast ( myName%NameOnClient, 0, comm=m_to_client_comm(ClientId))
-
-            CALL PMC_G_SetName (clients(ClientID), myName%couple_index, myName%NameOnServer )
-        end do
-
-        return
-   END SUBROUTINE Get_DA_names_from_client
-
-   SUBROUTINE PMC_S_SetArray (ClientId, NrDims, dims, array_adr, second_adr)
-      IMPLICIT none
-
-      INTEGER,INTENT(IN)                      :: ClientId
-      INTEGER,INTENT(IN)                      :: NrDims
-      INTEGER,INTENT(IN),DIMENSION(:)         :: dims
-      TYPE(c_ptr),INTENT(IN)                  :: array_adr
-      TYPE(c_ptr),INTENT(IN),OPTIONAL         :: second_adr
-
-      INTEGER                                 :: i
-      TYPE(PeDef),POINTER                     :: aPE
-      TYPE(ArrayDef),POINTER                  :: ar
-      CHARACTER(len=DA_Namelen)               :: myName
-
-      !  Set Array for Client interPE 0
-
-       do i=1,Clients(ClientId)%inter_npes
-          aPE => Clients(ClientId)%PEs(i)
-          ar  => aPE%array_list(next_array_in_list)
-          ar%NrDims    = NrDims
-          ar%A_dim     = dims
-          ar%data      = array_adr
-          if(present(second_adr)) then
-             ar%po_data(1) = array_adr
-             ar%po_data(2) = second_adr
-          else
-             ar%po_data(1) = C_NULL_PTR
-             ar%po_data(2) = C_NULL_PTR
-          end if
-       end do
-
-      return
-   END SUBROUTINE PMC_S_SetArray
-
-
-   SUBROUTINE PMC_S_Set_Active_data_array (ClientId,iactive)
-      IMPLICIT none
-
-      INTEGER,INTENT(IN)                      :: ClientId
-      INTEGER,INTENT(IN)                      :: iactive
-
-!--   local variables
-      INTEGER                                 :: i, ip, j
-      TYPE(PeDef),POINTER                     :: aPE
-      TYPE(ArrayDef),POINTER                  :: ar
-      CHARACTER(len=DA_Namelen)               :: myName
-
-      do ip=1,Clients(ClientId)%inter_npes
-         aPE => Clients(ClientId)%PEs(ip)
-         do j=1,aPE%Nr_arrays
-            ar  => aPE%array_list(j)
-            if(iactive == 1 .OR. iactive == 2)   then
-               ar%data = ar%po_data(iactive)
-            end if
-         end do
-      end do
-
-      return
-   END SUBROUTINE PMC_S_Set_Active_data_array
-
-
-    SUBROUTINE Set_PE_index_list (ClientId, myClient,index_list,NrP)
-       IMPLICIT none
-
-       INTEGER,INTENT(IN)                      :: ClientId
-       TYPE(ClientDef),INTENT(INOUT)           :: myClient
-       INTEGER,INTENT(IN),DIMENSION(:,:)       :: index_list
-       INTEGER,INTENT(IN)                      :: NrP
-
-!--    local variables
-       INTEGER                                 :: i,j,ind,ierr,i2
-       TYPE(PeDef),POINTER                     :: aPE
-       INTEGER                                 :: RemPE
-       INTEGER,DIMENSION(myClient%inter_npes)  :: RemInd
-       INTEGER,DIMENSION(:),POINTER            :: RemIndw
-       INTEGER,DIMENSION(:),POINTER            :: RLdef
-       INTEGER(KIND=MPI_ADDRESS_KIND)          :: WinSize
-       INTEGER                                 :: indWin,indWin2
-
-       ! First, count entries for every remote client PE
-
-       do i=1,myClient%inter_npes
-          aPE => myClient%PEs(i)
-          aPE%NrEle = 0
-       end do
-
-       do j=1,NrP                                ! loop over number of cells coarse grid
-          RemPE = index_list(5,j)+1              ! Pe number remote PE
-          aPE => myClient%PEs(RemPE)
-          aPE% NrEle = aPE% NrEle+1              ! Increment Number of elements for this client Pe
-       end do
-
-       do i=1,myClient%inter_npes
-          aPE => myClient%PEs(i)
-          ALLOCATE(aPE%locInd(aPE%NrEle))
-       end do
-
-       RemInd = 0
-
-       ! Second, Create lists
-
-       do j=1,NrP                                ! loop over number of cells coarse grid
-          RemPE = index_list(5,j)+1              ! Pe number remote PE
-          aPE => myClient%PEs(RemPE)
-          RemInd(RemPE)     = RemInd(RemPE)+1
-          ind               = RemInd(RemPE)
-          aPE%locInd(ind)%i = index_list(1,j)
-          aPE%locInd(ind)%j = index_list(2,j)
-       end do
-
-       !  Prepare Number of Elements for Client PEs
-       CALL PMC_Alloc_mem (RLdef, myClient%inter_npes*2)
-       WinSize = myClient%inter_npes*c_sizeof(i)*2   ! Number of Client PEs * size of INTEGER (i just arbitrary INTEGER)
-
-       CALL MPI_Win_create (RLdef, WinSize, iwp, MPI_INFO_NULL, myClient%intra_comm, indWin, ierr);
-       CALL MPI_Win_fence (0, indWin, ierr);         !  Open Window to set data
-
-       RLdef(1) = 0                                  ! Index on Remote PE 0
-       RLdef(2) = RemInd(1)                          ! Number of Elements on Rem PE 0
-
-       do i=2,myClient%inter_npes                    ! Reserve Buffer for index array
-          i2          = (i-1)*2+1
-          RLdef(i2)   = RLdef(i2-2) + RLdef(i2-1)*2  ! Index on Remote PE
-          RLdef(i2+1) = RemInd(i)                    ! Number of Elements on Remote PE
-       end do
-
-       CALL MPI_Win_fence (0, indWin, ierr);         ! Close Window to allow client to access data
-       CALL MPI_Win_fence (0, indWin, ierr);         ! Client has retrieved data
-
-       i2 = 2*myClient%inter_npes-1
-       WinSize = (RLdef(i2)+RLdef(i2+1))*2
-       WinSize = max(WinSize,1)                      ! Make sure, MPI_Alloc_mem works
-
-       CALL PMC_Alloc_mem (RemIndw, int(WinSize))
-
-       CALL MPI_Barrier (m_model_comm, ierr)
-       CALL MPI_Win_create (RemIndw, WinSize*c_sizeof(i), iwp, MPI_INFO_NULL, myClient%intra_comm, indWin2, ierr);
-
-       CALL MPI_Win_fence (0, indWin2, ierr);         !  Open Window to set data
-       do j=1,NrP                                ! this loop creates the 2D index list
-          RemPE = index_list(5,j)+1              ! Pe number remote PE
-          aPE => myClient%PEs(RemPE)
-          i2    = RemPE*2-1
-          ind   = RLdef(i2)+1
-          RemIndw(ind)   = index_list(3,j)
-          RemIndw(ind+1) = index_list(4,j)
-          RLdef(i2) = RLdef(i2)+2
-       end do
-       CALL MPI_Win_fence (0, indWin2, ierr);      !all data set
-
-       CALL MPI_Barrier(myClient%intra_comm, ierr) ! Dont know why, but this barrier is necessary before we can free the windows
-
-       CALL MPI_Win_free(indWin, ierr)
-       CALL MPI_Win_free(indWin2, ierr)
-
-!      Sollte funktionieren, Problem mit MPI implementation
-!      https://www.lrz.de/services/software/parallel/mpi/onesided
-!       CALL MPI_Free_mem (RemIndw, ierr)
-
-       return
-    END SUBROUTINE Set_PE_index_list
-
-#endif
-END MODULE pmc_server
Index: /palm/trunk/SOURCE/pmc_server_mod.f90
===================================================================
--- /palm/trunk/SOURCE/pmc_server_mod.f90	(revision 1850)
+++ /palm/trunk/SOURCE/pmc_server_mod.f90	(revision 1850)
@@ -0,0 +1,818 @@
+MODULE pmc_server
+
+!--------------------------------------------------------------------------------!
+! This file is part of PALM.
+!
+! PALM is free software: you can redistribute it and/or modify it under the terms
+! of the GNU General Public License as published by the Free Software Foundation,
+! either version 3 of the License, or (at your option) any later version.
+!
+! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
+! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
+! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along with
+! PALM. If not, see <http://www.gnu.org/licenses/>.
+!
+! Copyright 1997-2016 Leibniz Universitaet Hannover
+!--------------------------------------------------------------------------------!
+!
+! Current revisions:
+! ------------------
+! Module renamed
+! 
+! 
+! Former revisions:
+! -----------------
+! $Id$
+!
+! 1833 2016-04-07 14:23:03Z raasch
+! gfortran requires pointer attributes for some array declarations,
+! long line wrapped
+!
+! 1808 2016-04-05 19:44:00Z raasch
+! MPI module used by default on all machines
+!
+! 1797 2016-03-21 16:50:28Z raasch
+! introduction of different datatransfer modes
+!
+! 1791 2016-03-11 10:41:25Z raasch
+! Debug write-statements commented out
+!
+! 1786 2016-03-08 05:49:27Z raasch
+! change in client-server data transfer: server now gets data from client
+! instead that client put's it to the server
+!
+! 1779 2016-03-03 08:01:28Z raasch
+! kind=dp replaced by wp,
+! error messages removed or changed to PALM style, dim_order removed
+! array management changed from linked list to sequential loop
+!
+! 1766 2016-02-29 08:37:15Z raasch
+! modifications to allow for using PALM's pointer version
+! +new routine pmc_s_set_active_data_array
+!
+! 1764 2016-02-28 12:45:19Z raasch
+! cpp-statement added (nesting can only be used in parallel mode)
+!
+! 1762 2016-02-25 12:31:13Z hellstea
+! Initial revision by K. Ketelsen
+!
+! Description:
+! ------------
+!
+! Server part of Palm Model Coupler
+!------------------------------------------------------------------------------!
+
+#if defined( __parallel )
+   use, intrinsic :: iso_c_binding
+
+#if defined( __mpifh )
+    INCLUDE "mpif.h"
+#else
+    USE MPI
+#endif
+   USE  kinds
+   USE  PMC_general,               ONLY: ClientDef, PMC_MAX_MODELL,PMC_sort, DA_NameDef, DA_Desclen, DA_Namelen,       &
+                                         PMC_G_SetName, PeDef, ArrayDef, PMC_MAX_ARRAY
+   USE  PMC_handle_communicator,   ONLY: m_model_comm,m_model_rank,m_model_npes, m_to_client_comm,                     &
+                                         PMC_Server_for_Client, m_world_rank
+   USE   PMC_MPI_wrapper,          ONLY: PMC_Send_to_Client, PMC_Recv_from_Client, PMC_Bcast, PMC_Inter_Bcast,         &
+                                         PMC_Alloc_mem, PMC_Time
+
+   IMPLICIT none
+   PRIVATE
+   SAVE
+
+   TYPE ClientIndexDef
+      INTEGER                                        :: NrPoints
+      INTEGER,DIMENSION(:,:),allocatable             :: index_list_2d
+   END TYPE ClientIndexDef
+
+   TYPE(ClientDef),DIMENSION(PMC_MAX_MODELL)          :: Clients
+   TYPE(ClientIndexDef),DIMENSION(PMC_MAX_MODELL)     :: indClients
+
+   INTEGER                                            :: next_array_in_list = 0
+
+   PUBLIC PMC_Server_for_Client
+
+   INTERFACE PMC_ServerInit
+      MODULE procedure  PMC_ServerInit
+   END INTERFACE PMC_ServerInit
+
+    INTERFACE PMC_S_Set_2D_index_list
+        MODULE procedure PMC_S_Set_2D_index_list
+    END INTERFACE PMC_S_Set_2D_index_list
+
+    INTERFACE PMC_S_clear_next_array_list
+        MODULE procedure PMC_S_clear_next_array_list
+    END INTERFACE PMC_S_clear_next_array_list
+
+    INTERFACE PMC_S_GetNextArray
+        MODULE procedure PMC_S_GetNextArray
+    END INTERFACE PMC_S_GetNextArray
+
+    INTERFACE PMC_S_Set_DataArray
+        MODULE procedure PMC_S_Set_DataArray_2d
+        MODULE procedure PMC_S_Set_DataArray_3d
+    END INTERFACE PMC_S_Set_DataArray
+
+    INTERFACE PMC_S_setInd_and_AllocMem
+        MODULE procedure PMC_S_setInd_and_AllocMem
+    END INTERFACE PMC_S_setInd_and_AllocMem
+
+    INTERFACE PMC_S_FillBuffer
+        MODULE procedure PMC_S_FillBuffer
+    END INTERFACE PMC_S_FillBuffer
+
+    INTERFACE PMC_S_GetData_from_Buffer
+        MODULE procedure PMC_S_GetData_from_Buffer
+    END INTERFACE PMC_S_GetData_from_Buffer
+
+    INTERFACE PMC_S_Set_Active_data_array
+        MODULE procedure PMC_S_Set_Active_data_array
+    END INTERFACE PMC_S_Set_Active_data_array
+
+    ! PUBLIC section
+
+    PUBLIC PMC_ServerInit, PMC_S_Set_2D_index_list, PMC_S_GetNextArray, PMC_S_Set_DataArray
+    PUBLIC PMC_S_setInd_and_AllocMem, PMC_S_FillBuffer, PMC_S_GetData_from_Buffer, PMC_S_Set_Active_data_array
+    PUBLIC PMC_S_clear_next_array_list
+
+CONTAINS
+
+   SUBROUTINE PMC_ServerInit
+      IMPLICIT none
+      INTEGER                 :: i
+      INTEGER                 :: j
+      INTEGER                 :: ClientId
+      INTEGER                 :: istat
+
+      do i=1,size(PMC_Server_for_Client)-1
+!         if(m_model_comm == 0) write(0,*) 'PMC_Server: Initialize client Id',PMC_Server_for_Client(i)
+
+         ClientId = PMC_Server_for_Client(i)
+
+         Clients(ClientId)%model_comm = m_model_comm
+         Clients(ClientId)%inter_comm = m_to_client_comm(ClientId)
+
+         ! Get rank and size
+         CALL MPI_Comm_rank (Clients(ClientId)%model_comm, Clients(ClientId)%model_rank, istat);
+         CALL MPI_Comm_size (Clients(ClientId)%model_comm, Clients(ClientId)%model_npes, istat);
+         CALL MPI_Comm_remote_size (Clients(ClientId)%inter_comm, Clients(ClientId)%inter_npes, istat);
+
+         ! Intra communicater is used for MPI_Get
+         CALL MPI_Intercomm_merge (Clients(ClientId)%inter_comm, .false., Clients(ClientId)%intra_comm, istat);
+         CALL MPI_Comm_rank (Clients(ClientId)%intra_comm, Clients(ClientId)%intra_rank, istat);
+
+!         write(9,*) 'ClientId ',i,ClientId,m_world_rank, Clients(ClientId)%inter_npes
+
+         ALLOCATE (Clients(ClientId)%PEs(Clients(ClientId)%inter_npes))
+!
+!--      Allocate for all client PEs an array of TYPE ArrayDef to store information of transfer array
+         do j=1,Clients(ClientId)%inter_npes
+           Allocate(Clients(ClientId)%PEs(j)%array_list(PMC_MAX_ARRAY))
+         end do
+
+         CALL Get_DA_names_from_client (ClientId)
+      end do
+
+      return
+   END SUBROUTINE PMC_ServerInit
+
+    SUBROUTINE PMC_S_Set_2D_index_list (ClientId, index_list)
+        IMPLICIT none
+        INTEGER,INTENT(IN)                         :: ClientId
+        INTEGER,DIMENSION(:,:),INTENT(INOUT)       :: index_list      !Index list will be modified in sort, therefore INOUT
+
+        !-- Local variables
+        INTEGER                 :: ip,is,ie,ian,ic,n
+        INTEGER                 :: istat
+
+        if(m_model_rank == 0)   then
+            CALL PMC_sort (index_list, 6)                       ! Sort to ascending Server PE
+            is = 1
+
+            do ip=0,m_model_npes-1
+
+                !       Split into Server PEs
+                ie = is-1                                     !there may be no entry for this PE
+                if(is <= size(index_list,2) .and. ie >= 0)  then
+                    do while ( index_list(6,ie+1) == ip)
+                        ie = ie+1
+                        if( ie == size(index_list,2)) EXIT
+                    end do
+
+                    ian = ie-is+1
+                else
+                    is  = -1
+                    ie  = -2
+                    ian = 0
+                end if
+
+                !       Send data to other server PEs
+
+                if(ip == 0)   then
+                    indClients(ClientId)%NrPoints = ian
+                    if(ian > 0)   then
+                        ALLOCATE (indClients(ClientId)%index_list_2d(6,ian))
+                        indClients(ClientId)%index_list_2d(:,1:ian) = index_list(:,is:ie)
+                    end if
+                else
+                    CALL MPI_Send (ian, 1, MPI_INTEGER, ip, 1000, m_model_comm, istat)
+                    if(ian > 0) then
+                        CALL MPI_Send (index_list(1,is), 6*ian, MPI_INTEGER, ip, 1001,                  &
+                            m_model_comm, istat)
+                    end if
+                end if
+                is = ie+1
+            end do
+        else
+            CALL MPI_Recv (indClients(ClientId)%NrPoints, 1, MPI_INTEGER, 0, 1000, m_model_comm,     &
+                MPI_STATUS_IGNORE, istat)
+            ian = indClients(ClientId)%NrPoints
+             if(ian > 0) then
+                ALLOCATE(indClients(ClientId)%index_list_2d(6,ian))
+                CALL MPI_RECV (indClients(ClientId)%index_list_2d, 6*ian, MPI_INTEGER, 0, 1001,        &
+                    m_model_comm, MPI_STATUS_IGNORE, istat)
+            end if
+        end if
+
+        CALL Set_PE_index_list (ClientId,Clients(ClientId),indClients(ClientId)%index_list_2d,indClients(ClientId)%NrPoints)
+
+        return
+    END SUBROUTINE PMC_S_Set_2D_index_list
+
+    SUBROUTINE PMC_S_clear_next_array_list
+       IMPLICIT none
+
+       next_array_in_list = 0
+
+       return
+    END SUBROUTINE PMC_S_clear_next_array_list
+
+!   List handling is still required to get minimal interaction with pmc_interface
+    logical function PMC_S_GetNextArray (ClientId, myName)
+       INTEGER(iwp),INTENT(IN)                    :: ClientId
+       CHARACTER(len=*),INTENT(OUT)               :: myName
+
+!--    local variables
+       TYPE(PeDef),POINTER          :: aPE
+       TYPE(ArrayDef),POINTER       :: ar
+
+       next_array_in_list = next_array_in_list+1
+
+!--    Array Names are the same on all client PE, so take first PE to get the name
+       aPE => Clients(ClientId)%PEs(1)
+
+       if(next_array_in_list > aPE%Nr_arrays) then
+          PMC_S_GetNextArray = .false.              ! all arrays done
+          return
+       end if
+
+       ar  => aPE%array_list(next_array_in_list)
+       myName = ar%name
+
+       PMC_S_GetNextArray =  .true.                 ! Return true if legal array
+       return
+    END function PMC_S_GetNextArray
+
+    SUBROUTINE PMC_S_Set_DataArray_2d (ClientId, array, array_2 )
+
+        IMPLICIT none
+
+        INTEGER,INTENT(IN) ::  ClientId
+
+        REAL(wp), INTENT(IN), DIMENSION(:,:), POINTER           ::  array
+        REAL(wp), INTENT(IN), DIMENSION(:,:), POINTER, OPTIONAL ::  array_2
+
+        INTEGER                           :: NrDims
+        INTEGER,DIMENSION (4)             :: dims
+        TYPE(c_ptr)                       :: array_adr
+        TYPE(c_ptr)                       :: second_adr
+
+        dims = 1
+
+        NrDims    = 2
+        dims(1)   = size(array,1)
+        dims(2)   = size(array,2)
+        array_adr = c_loc(array)
+
+        IF ( PRESENT( array_2 ) )  THEN
+           second_adr = c_loc(array_2)
+           CALL PMC_S_SetArray (ClientId, NrDims, dims, array_adr, second_adr = second_adr)
+        ELSE
+           CALL PMC_S_SetArray (ClientId, NrDims, dims, array_adr)
+        ENDIF
+
+        return
+    END SUBROUTINE PMC_S_Set_DataArray_2d
+
+    SUBROUTINE PMC_S_Set_DataArray_3d (ClientId, array, nz_cl, nz, array_2 )
+
+        IMPLICIT none
+
+        INTEGER,INTENT(IN) ::  ClientId
+
+        REAL(wp), INTENT(IN), DIMENSION(:,:,:), POINTER           ::  array
+        REAL(wp), INTENT(IN), DIMENSION(:,:,:), POINTER, OPTIONAL ::  array_2
+        INTEGER,INTENT(IN)                         :: nz_cl
+        INTEGER,INTENT(IN)                         :: nz
+
+        INTEGER                           :: NrDims
+        INTEGER,DIMENSION (4)             :: dims
+        TYPE(c_ptr)                       :: array_adr
+        TYPE(c_ptr)                       :: second_adr
+
+        dims = 1
+
+        dims      = 0
+        NrDims    = 3
+        dims(1)   = size(array,1)
+        dims(2)   = size(array,2)
+        dims(3)   = size(array,3)
+        dims(4)   = nz_cl+dims(1)-nz                        ! works for first dimension 1:nz and 0:nz+1
+
+        array_adr = c_loc(array)
+
+!
+!--     In PALM's pointer version, two indices have to be stored internally.
+!--     The active address of the data array is set in swap_timelevel
+        IF ( PRESENT( array_2 ) )  THEN
+          second_adr = c_loc(array_2)
+          CALL PMC_S_SetArray (ClientId, NrDims, dims, array_adr, second_adr = second_adr)
+        ELSE
+           CALL PMC_S_SetArray (ClientId, NrDims, dims, array_adr)
+        ENDIF
+
+        return
+   END SUBROUTINE PMC_S_Set_DataArray_3d
+
+   SUBROUTINE PMC_S_setInd_and_AllocMem (ClientId)
+
+      USE control_parameters,                                                  &
+          ONLY:  message_string
+
+      IMPLICIT none
+
+!
+!--   Naming convention for appendices:   _sc  -> server to client transfer
+!--                                       _cs  -> client to server transfer
+!--                                       Send -> Server to client transfer
+!--                                       Recv -> client to server transfer
+      INTEGER,INTENT(IN)                      :: ClientId
+
+      INTEGER                                 :: i, istat, ierr, j
+      INTEGER                                 :: arlen, myIndex, tag
+      INTEGER                                 :: rCount                    ! count MPI requests
+      INTEGER(idp)                            :: bufsize                   ! Size of MPI data Window
+      TYPE(PeDef),POINTER                     :: aPE
+      TYPE(ArrayDef),POINTER                  :: ar
+      CHARACTER(len=DA_Namelen)               :: myName
+      INTEGER,DIMENSION(1024)                 :: req
+      Type(c_ptr)                             :: base_ptr
+      REAL(wp),DIMENSION(:),POINTER,SAVE :: base_array_sc  !Base array for server to client transfer
+      REAL(wp),DIMENSION(:),POINTER,SAVE :: base_array_cs  !Base array for client to server transfer
+      INTEGER(KIND=MPI_ADDRESS_KIND)          :: WinSize
+
+!
+!--   Server to client direction
+      myIndex = 1
+      rCount  = 0
+      bufsize = 8
+
+!
+!--   First stride: Compute size and set index
+      do i=1,Clients(ClientId)%inter_npes
+         aPE => Clients(ClientId)%PEs(i)
+         tag = 200
+         do j=1,aPE%Nr_arrays
+            ar  => aPE%array_list(j)
+            if(ar%NrDims == 2) then
+               arlen     = aPE%NrEle                              ! 2D
+            else if(ar%NrDims == 3) then
+               arlen     = aPE%NrEle * ar%A_dim(4);               ! 3D
+            else
+               arlen     = -1
+            end if
+            ar%SendIndex = myIndex
+
+            tag    = tag+1
+            rCount = rCount+1
+            CALL MPI_Isend (myIndex, 1, MPI_INTEGER, i-1, tag, Clients(ClientId)%inter_comm, req(rCount),ierr)
+
+            if(rCount == 1024) then                                  ! Maximum of 1024 outstanding requests
+               CALL MPI_Waitall (rCount, req, MPI_STATUSES_IGNORE, ierr)
+               rCount = 0;
+            end if
+
+            myIndex = myIndex+arlen
+            bufsize = bufsize+arlen
+            ar%SendSize = arlen
+
+         end do
+         if(rCount > 0) then                       ! Wait for all send completed
+            CALL MPI_Waitall (rCount, req, MPI_STATUSES_IGNORE, ierr)
+         end if
+      end do
+
+!
+!--   Create RMA (One Sided Communication) window for data buffer server to
+!--   client transfer.
+!--   The buffer of MPI_Get (counter part of transfer) can be PE-local, i.e.
+!--   it can but must not be part of the MPI RMA window.
+!--   Only one RMA window is required to prepare the data
+!--   for server -> client transfer on the server side and
+!--   for client -> server transfer on the client side
+      CALL PMC_Alloc_mem (base_array_sc, bufsize)
+      Clients(ClientId)%TotalBufferSize = bufsize*wp   !Total buffer size in Byte
+
+      WinSize = bufsize*wp
+      CALL MPI_Win_create (base_array_sc, WinSize, wp, MPI_INFO_NULL,          &
+                  Clients(ClientId)%intra_comm,  Clients(ClientId)%win_server_client, ierr)
+      CALL MPI_Win_fence (0, Clients(ClientId)%win_server_client, ierr);        !  Open Window to set data
+!
+!--   Second stride: Set Buffer pointer
+      do i=1,Clients(ClientId)%inter_npes
+         aPE => Clients(ClientId)%PEs(i)
+         do j=1,aPE%Nr_arrays
+            ar  => aPE%array_list(j)
+            ar%SendBuf = c_loc(base_array_sc(ar%SendIndex))
+            if(ar%SendIndex+ar%SendSize > bufsize) then
+               write(0,'(a,i4,4i7,1x,a)') 'Server Buffer too small ',i,        &
+                  ar%SendIndex,ar%SendSize,ar%SendIndex+ar%SendSize,bufsize,trim(ar%name)
+               CALL MPI_Abort (MPI_COMM_WORLD, istat, ierr)
+            end if
+         end do
+      end do
+
+!--   Client to server direction
+
+      bufsize  = 8
+
+!--   First stride, Compute size and set index
+
+      do i=1,Clients(ClientId)%inter_npes
+         aPE => Clients(ClientId)%PEs(i)
+         tag = 300
+
+         do j=1,aPE%Nr_arrays
+            ar  => aPE%array_list(j)
+
+            ! Receive Index from client
+            tag = tag+1
+            CALL MPI_Recv (myIndex, 1, MPI_INTEGER, i-1, tag, Clients(ClientId)%inter_comm, MPI_STATUS_IGNORE, ierr)
+
+            if(ar%NrDims == 3) then
+               bufsize = max(bufsize,aPE%NrEle * ar%A_dim(4))               ! 3D
+            else
+               bufsize = max(bufsize,aPE%NrEle)                             ! 2D
+            end if
+            ar%RecvIndex = myIndex
+          end do
+
+      end do
+
+!--   Create RMA (One Sided Communication) data buffer
+!--   The buffer for MPI_Get can be PE local, i.e. it can but must not be part of the MPI RMA window
+
+      CALL PMC_Alloc_mem (base_array_cs, bufsize, base_ptr)
+      Clients(ClientId)%TotalBufferSize = bufsize*wp       !Total buffer size in Byte
+
+      CALL MPI_Barrier(Clients(ClientId)%intra_comm, ierr)
+
+!--   Second stride, Set Buffer pointer
+
+      do i=1,Clients(ClientId)%inter_npes
+         aPE => Clients(ClientId)%PEs(i)
+
+         do j=1,aPE%Nr_arrays
+            ar  => aPE%array_list(j)
+            ar%RecvBuf = base_ptr
+         end do
+      end do
+
+      return
+   END SUBROUTINE PMC_S_setInd_and_AllocMem
+
+   SUBROUTINE PMC_S_FillBuffer (ClientId, WaitTime)
+      IMPLICIT none
+      INTEGER,INTENT(IN)                  ::  ClientId
+      REAL(wp), INTENT(OUT), OPTIONAL     ::  WaitTime
+
+      INTEGER                             ::  ip,ij,istat,ierr,j
+      INTEGER                             ::  myIndex
+      REAL(wp)                            ::  t1,t2
+      TYPE(PeDef),POINTER                 ::  aPE
+      TYPE(ArrayDef),POINTER              ::  ar
+      CHARACTER(len=DA_Namelen)           ::  myName
+      INTEGER,DIMENSION(1)                ::  buf_shape
+      REAL(wp), POINTER, DIMENSION(:)     ::  buf
+      REAL(wp), POINTER, DIMENSION(:,:)   ::  data_2d
+      REAL(wp), POINTER, DIMENSION(:,:,:) ::  data_3d
+
+!--   Synchronization of the model is done in pmci_client_synchronize and pmci_server_synchronize
+!--   Therefor the RMA window cann be filled without sychronization at this point and the barrier
+!--   is not necessary
+!--   Please note that WaitTime has to be set in PMC_S_FillBuffer AND PMC_C_GetBuffer
+
+      if(present(WaitTime)) then
+        t1 = PMC_Time()
+        CALL MPI_Barrier(Clients(ClientId)%intra_comm, ierr)
+        t2 = PMC_Time()
+        WaitTime = t2-t1
+      end if
+
+      do ip=1,Clients(ClientId)%inter_npes
+         aPE => Clients(ClientId)%PEs(ip)
+         do j=1,aPE%Nr_arrays
+            ar  => aPE%array_list(j)
+            myIndex=1
+            if(ar%NrDims == 2) then
+               buf_shape(1) = aPE%NrEle
+               CALL c_f_pointer(ar%SendBuf, buf, buf_shape)
+               CALL c_f_pointer(ar%data, data_2d, ar%A_dim(1:2))
+               do ij=1,aPE%NrEle
+                  buf(myIndex) = data_2d(aPE%locInd(ij)%j,aPE%locInd(ij)%i)
+                  myIndex = myIndex+1
+               end do
+            else if(ar%NrDims == 3) then
+               buf_shape(1) = aPE%NrEle*ar%A_dim(4)
+               CALL c_f_pointer(ar%SendBuf, buf, buf_shape)
+               CALL c_f_pointer(ar%data, data_3d, ar%A_dim(1:3))
+               do ij=1,aPE%NrEle
+                  buf(myIndex:myIndex+ar%A_dim(4)-1) = data_3d(1:ar%A_dim(4),aPE%locInd(ij)%j,aPE%locInd(ij)%i)
+                  myIndex = myIndex+ar%A_dim(4)
+               end do
+            end if
+          end do
+      end do
+
+      CALL MPI_Barrier(Clients(ClientId)%intra_comm, ierr)    ! buffer is filled
+
+      return
+   END SUBROUTINE PMC_S_FillBuffer
+
+   SUBROUTINE PMC_S_GetData_from_Buffer (ClientId, WaitTime)
+
+      IMPLICIT none
+
+      INTEGER,INTENT(IN)                  ::  ClientId
+      REAL(wp), INTENT(OUT), OPTIONAL     ::  WaitTime
+
+      !-- local variables
+      INTEGER                             ::  ip,ij,istat,ierr,j
+      INTEGER                             ::  myIndex
+      INTEGER                             ::  nr
+      REAL(wp)                            ::  t1,t2
+      TYPE(PeDef),POINTER                 ::  aPE
+      TYPE(ArrayDef),POINTER              ::  ar
+      CHARACTER(len=DA_Namelen)           ::  myName
+      INTEGER,DIMENSION(1)                ::  buf_shape
+      REAL(wp), POINTER, DIMENSION(:)     ::  buf
+      REAL(wp), POINTER, DIMENSION(:,:)   ::  data_2d
+      REAL(wp), POINTER, DIMENSION(:,:,:) ::  data_3d
+      INTEGER                             ::  target_pe
+      INTEGER(kind=MPI_ADDRESS_KIND)      ::  target_disp
+
+      t1 = PMC_Time()
+      CALL MPI_Barrier(Clients(ClientId)%intra_comm, ierr)                         ! Wait for client to fill buffer
+      t2 = PMC_Time()-t1
+      if(present(WaitTime)) WaitTime = t2
+
+!      CALL MPI_Win_fence (0, Clients(ClientId)%win_server_client, ierr)            ! Fence might do it, test later
+      CALL MPI_Barrier(Clients(ClientId)%intra_comm, ierr)                         ! Wait for buffer is filled
+
+      do ip=1,Clients(ClientId)%inter_npes
+         aPE => Clients(ClientId)%PEs(ip)
+         do j=1,aPE%Nr_arrays
+            ar  => aPE%array_list(j)
+
+            if(ar%RecvIndex < 0)  CYCLE
+
+            if(ar%NrDims == 2) then
+               nr = aPE%NrEle
+            else if(ar%NrDims == 3) then
+               nr = aPE%NrEle*ar%A_dim(4)
+            end if
+
+            buf_shape(1) = nr
+            CALL c_f_pointer(ar%RecvBuf, buf, buf_shape)
+!
+!--         MPI passive target RMA
+
+            if(nr > 0)   then
+               target_disp = ar%RecvIndex-1
+               target_pe = ip-1+m_model_npes                         ! client PEs are located behind server PEs
+               CALL MPI_Win_lock (MPI_LOCK_SHARED , target_pe, 0, Clients(ClientId)%win_server_client, ierr)
+               CALL MPI_Get (buf, nr, MPI_REAL, target_pe, target_disp, nr, MPI_REAL, Clients(ClientId)%win_server_client, ierr)
+               CALL MPI_Win_unlock (target_pe, Clients(ClientId)%win_server_client, ierr)
+            end if
+
+            myIndex=1
+            if(ar%NrDims == 2) then
+               CALL c_f_pointer(ar%data, data_2d, ar%A_dim(1:2))
+               do ij=1,aPE%NrEle
+                  data_2d(aPE%locInd(ij)%j,aPE%locInd(ij)%i) = buf(myIndex)
+                  myIndex = myIndex+1
+               end do
+            else if(ar%NrDims == 3) then
+               CALL c_f_pointer(ar%data, data_3d, ar%A_dim(1:3))
+               do ij=1,aPE%NrEle
+                  data_3d(1:ar%A_dim(4),aPE%locInd(ij)%j,aPE%locInd(ij)%i) = buf(myIndex:myIndex+ar%A_dim(4)-1)
+                  myIndex = myIndex+ar%A_dim(4)
+               end do
+            end if
+          end do
+      end do
+
+   END SUBROUTINE PMC_S_GetData_from_Buffer
+
+! Private SUBROUTINEs
+
+   SUBROUTINE Get_DA_names_from_client (ClientId)
+        IMPLICIT none
+        INTEGER,INTENT(IN)                    :: ClientId
+        !-- local variables
+        type(DA_NameDef)                      :: myName
+
+        !   Get Data Array Description and Name from Client
+
+        do
+            CALL PMC_Bcast ( myName%couple_index, 0, comm=m_to_client_comm(ClientId))
+            if(myName%couple_index == -1) EXIT
+            CALL PMC_Bcast ( myName%ServerDesc,   0, comm=m_to_client_comm(ClientId))
+            CALL PMC_Bcast ( myName%NameOnServer, 0, comm=m_to_client_comm(ClientId))
+            CALL PMC_Bcast ( myName%ClientDesc,   0, comm=m_to_client_comm(ClientId))
+            CALL PMC_Bcast ( myName%NameOnClient, 0, comm=m_to_client_comm(ClientId))
+
+            CALL PMC_G_SetName (clients(ClientID), myName%couple_index, myName%NameOnServer )
+        end do
+
+        return
+   END SUBROUTINE Get_DA_names_from_client
+
+   SUBROUTINE PMC_S_SetArray (ClientId, NrDims, dims, array_adr, second_adr)
+      IMPLICIT none
+
+      INTEGER,INTENT(IN)                      :: ClientId
+      INTEGER,INTENT(IN)                      :: NrDims
+      INTEGER,INTENT(IN),DIMENSION(:)         :: dims
+      TYPE(c_ptr),INTENT(IN)                  :: array_adr
+      TYPE(c_ptr),INTENT(IN),OPTIONAL         :: second_adr
+
+      INTEGER                                 :: i
+      TYPE(PeDef),POINTER                     :: aPE
+      TYPE(ArrayDef),POINTER                  :: ar
+      CHARACTER(len=DA_Namelen)               :: myName
+
+      !  Set Array for Client interPE 0
+
+       do i=1,Clients(ClientId)%inter_npes
+          aPE => Clients(ClientId)%PEs(i)
+          ar  => aPE%array_list(next_array_in_list)
+          ar%NrDims    = NrDims
+          ar%A_dim     = dims
+          ar%data      = array_adr
+          if(present(second_adr)) then
+             ar%po_data(1) = array_adr
+             ar%po_data(2) = second_adr
+          else
+             ar%po_data(1) = C_NULL_PTR
+             ar%po_data(2) = C_NULL_PTR
+          end if
+       end do
+
+      return
+   END SUBROUTINE PMC_S_SetArray
+
+
+   SUBROUTINE PMC_S_Set_Active_data_array (ClientId,iactive)
+      IMPLICIT none
+
+      INTEGER,INTENT(IN)                      :: ClientId
+      INTEGER,INTENT(IN)                      :: iactive
+
+!--   local variables
+      INTEGER                                 :: i, ip, j
+      TYPE(PeDef),POINTER                     :: aPE
+      TYPE(ArrayDef),POINTER                  :: ar
+      CHARACTER(len=DA_Namelen)               :: myName
+
+      do ip=1,Clients(ClientId)%inter_npes
+         aPE => Clients(ClientId)%PEs(ip)
+         do j=1,aPE%Nr_arrays
+            ar  => aPE%array_list(j)
+            if(iactive == 1 .OR. iactive == 2)   then
+               ar%data = ar%po_data(iactive)
+            end if
+         end do
+      end do
+
+      return
+   END SUBROUTINE PMC_S_Set_Active_data_array
+
+
+    SUBROUTINE Set_PE_index_list (ClientId, myClient,index_list,NrP)
+       IMPLICIT none
+
+       INTEGER,INTENT(IN)                      :: ClientId
+       TYPE(ClientDef),INTENT(INOUT)           :: myClient
+       INTEGER,INTENT(IN),DIMENSION(:,:)       :: index_list
+       INTEGER,INTENT(IN)                      :: NrP
+
+!--    local variables
+       INTEGER                                 :: i,j,ind,ierr,i2
+       TYPE(PeDef),POINTER                     :: aPE
+       INTEGER                                 :: RemPE
+       INTEGER,DIMENSION(myClient%inter_npes)  :: RemInd
+       INTEGER,DIMENSION(:),POINTER            :: RemIndw
+       INTEGER,DIMENSION(:),POINTER            :: RLdef
+       INTEGER(KIND=MPI_ADDRESS_KIND)          :: WinSize
+       INTEGER                                 :: indWin,indWin2
+
+       ! First, count entries for every remote client PE
+
+       do i=1,myClient%inter_npes
+          aPE => myClient%PEs(i)
+          aPE%NrEle = 0
+       end do
+
+       do j=1,NrP                                ! loop over number of cells coarse grid
+          RemPE = index_list(5,j)+1              ! Pe number remote PE
+          aPE => myClient%PEs(RemPE)
+          aPE% NrEle = aPE% NrEle+1              ! Increment Number of elements for this client Pe
+       end do
+
+       do i=1,myClient%inter_npes
+          aPE => myClient%PEs(i)
+          ALLOCATE(aPE%locInd(aPE%NrEle))
+       end do
+
+       RemInd = 0
+
+       ! Second, Create lists
+
+       do j=1,NrP                                ! loop over number of cells coarse grid
+          RemPE = index_list(5,j)+1              ! Pe number remote PE
+          aPE => myClient%PEs(RemPE)
+          RemInd(RemPE)     = RemInd(RemPE)+1
+          ind               = RemInd(RemPE)
+          aPE%locInd(ind)%i = index_list(1,j)
+          aPE%locInd(ind)%j = index_list(2,j)
+       end do
+
+       !  Prepare Number of Elements for Client PEs
+       CALL PMC_Alloc_mem (RLdef, myClient%inter_npes*2)
+       WinSize = myClient%inter_npes*c_sizeof(i)*2   ! Number of Client PEs * size of INTEGER (i just arbitrary INTEGER)
+
+       CALL MPI_Win_create (RLdef, WinSize, iwp, MPI_INFO_NULL, myClient%intra_comm, indWin, ierr);
+       CALL MPI_Win_fence (0, indWin, ierr);         !  Open Window to set data
+
+       RLdef(1) = 0                                  ! Index on Remote PE 0
+       RLdef(2) = RemInd(1)                          ! Number of Elements on Rem PE 0
+
+       do i=2,myClient%inter_npes                    ! Reserve Buffer for index array
+          i2          = (i-1)*2+1
+          RLdef(i2)   = RLdef(i2-2) + RLdef(i2-1)*2  ! Index on Remote PE
+          RLdef(i2+1) = RemInd(i)                    ! Number of Elements on Remote PE
+       end do
+
+       CALL MPI_Win_fence (0, indWin, ierr);         ! Close Window to allow client to access data
+       CALL MPI_Win_fence (0, indWin, ierr);         ! Client has retrieved data
+
+       i2 = 2*myClient%inter_npes-1
+       WinSize = (RLdef(i2)+RLdef(i2+1))*2
+       WinSize = max(WinSize,1)                      ! Make sure, MPI_Alloc_mem works
+
+       CALL PMC_Alloc_mem (RemIndw, int(WinSize))
+
+       CALL MPI_Barrier (m_model_comm, ierr)
+       CALL MPI_Win_create (RemIndw, WinSize*c_sizeof(i), iwp, MPI_INFO_NULL, myClient%intra_comm, indWin2, ierr);
+
+       CALL MPI_Win_fence (0, indWin2, ierr);         !  Open Window to set data
+       do j=1,NrP                                ! this loop creates the 2D index list
+          RemPE = index_list(5,j)+1              ! Pe number remote PE
+          aPE => myClient%PEs(RemPE)
+          i2    = RemPE*2-1
+          ind   = RLdef(i2)+1
+          RemIndw(ind)   = index_list(3,j)
+          RemIndw(ind+1) = index_list(4,j)
+          RLdef(i2) = RLdef(i2)+2
+       end do
+       CALL MPI_Win_fence (0, indWin2, ierr);      !all data set
+
+       CALL MPI_Barrier(myClient%intra_comm, ierr) ! Dont know why, but this barrier is necessary before we can free the windows
+
+       CALL MPI_Win_free(indWin, ierr)
+       CALL MPI_Win_free(indWin2, ierr)
+
+!      Sollte funktionieren, Problem mit MPI implementation
+!      https://www.lrz.de/services/software/parallel/mpi/onesided
+!       CALL MPI_Free_mem (RemIndw, ierr)
+
+       return
+    END SUBROUTINE Set_PE_index_list
+
+#endif
+END MODULE pmc_server
Index: lm/trunk/SOURCE/poisfft.f90
===================================================================
--- /palm/trunk/SOURCE/poisfft.f90	(revision 1849)
+++ 	(revision )
@@ -1,1497 +1,0 @@
-!> @file poisfft.f90
-!--------------------------------------------------------------------------------!
-! This file is part of PALM.
-!
-! PALM is free software: you can redistribute it and/or modify it under the terms
-! of the GNU General Public License as published by the Free Software Foundation,
-! either version 3 of the License, or (at your option) any later version.
-!
-! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
-! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
-! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along with
-! PALM. If not, see <http://www.gnu.org/licenses/>.
-!
-! Copyright 1997-2014  Leibniz Universitaet Hannover
-!--------------------------------------------------------------------------------!
-!
-! Current revisions:
-! -----------------
-! 
-! 
-! Former revisions:
-! -----------------
-! $Id$
-!
-! 1804 2016-04-05 16:30:18Z maronga
-! Removed code for parameter file check (__check)
-! 
-! 1682 2015-10-07 23:56:08Z knoop
-! Code annotations made doxygen readable 
-!
-! 1482 2014-10-18 12:34:45Z raasch
-! use 2d-decomposition, if accelerator boards are used
-!
-! 1406 2014-05-16 13:47:01Z raasch
-! bugfix for pgi 14.4: declare create moved after array declaration
-!
-! 1320 2014-03-20 08:40:49Z raasch
-! ONLY-attribute added to USE-statements,
-! kind-parameters added to all INTEGER and REAL declaration statements,
-! kinds are defined in new module kinds,
-! old module precision_kind is removed,
-! revision history before 2012 removed,
-! comment fields (!:) to be used for variable explanations added to
-! all variable declaration statements
-!
-! 1318 2014-03-17 13:35:16Z raasch
-! module interfaces removed
-!
-! 1306 2014-03-13 14:30:59Z raasch
-! openmp sections removed from the overlap branch,
-! second argument removed from parameter list
-!
-! 1216 2013-08-26 09:31:42Z raasch
-! resorting of arrays moved to separate routines resort_for_...,
-! one argument, used as temporary work array, removed from all transpose
-! routines
-! overlapping fft / transposition implemented
-!
-! 1212 2013-08-15 08:46:27Z raasch
-! tridia routines moved to seperate module tridia_solver
-!
-! 1208 2013-08-13 06:41:49Z raasch
-! acc-update clauses added for "ar" so that ffts other than cufft can also be
-! used (although they are not ported and will give a poor performance)
-!
-! 1111 2013-03-08 23:54:10Z raasch
-! further openACC porting of non-parallel (MPI) branch:
-! tridiagonal routines split into extermal subroutines (instead using CONTAINS),
-! no distinction between parallel/non-parallel in poisfft and tridia any more,
-! tridia routines moved to end of file because of probable bug in PGI compiler 12.5
-! (otherwise "invalid device function" is indicated during runtime),
-! optimization of tridia routines: constant elements and coefficients of tri are
-! stored in seperate arrays ddzuw and tric, last dimension of tri reduced from 5
-! to 2,
-! poisfft_init is now called internally from poisfft, maketri is called from
-! poisfft_init,
-! ibc_p_b = 2 removed
-!
-! 1106 2013-03-04 05:31:38Z raasch
-! routines fftx, ffty, fftxp, fftyp removed, calls replaced by fft_x, fft_y,
-! in the 1D-decomposition routines fft_x, ffty are replaced by fft_x_1d,
-! fft_y_1d
-!
-! 1103 2013-02-20 02:15:53Z raasch
-! tri, ar, and ar1 arguments in tridia-routines (2d) are removed because they
-! sometimes cause segmentation faults with intel 12.1 compiler
-!
-! 1092 2013-02-02 11:24:22Z raasch
-! unused variables removed
-!
-! 1036 2012-10-22 13:43:42Z raasch
-! code put under GPL (PALM 3.9)
-!
-! 2012-09-21 07:03:55Z raasch
-! FLOAT type conversion replaced by REAL
-!
-! 1003 2012-09-14 14:35:53Z raasch
-! indices nxa, nya, etc. replaced by nx, ny, etc.
-!
-! 940 2012-07-09 14:31:00Z raasch
-! special handling of tri-array as an argument in tridia_1dd routines switched
-! off because it caused segmentation faults with intel 12.1 compiler
-!
-! 877 2012-04-03 11:21:44Z suehring
-! Bugfix: Avoid divisions by zero in case of using a 'neumann' bc for the
-! pressure at the top of the model domain.
-!
-! 809 2012-01-30 13:32:58Z maronga
-! Bugfix: replaced .AND. and .NOT. with && and ! in the preprocessor directives
-!
-! 807 2012-01-25 11:53:51Z maronga
-! New cpp directive "__check" implemented which is used by check_namelist_files
-! (most of the code is unneeded by check_namelist_files).
-!
-! Revision 1.1  1997/07/24 11:24:14  raasch
-! Initial revision
-!
-!
-! Description:
-! ------------
-!> Solves the Poisson equation with a 2D spectral method
-!>        d^2 p / dx^2 + d^2 p / dy^2 + d^2 p / dz^2 = s
-!>
-!> Input:
-!> real    ar   contains (nnz,nny,nnx) elements of the velocity divergence,
-!>              starting from (1,nys,nxl)
-!>
-!> Output:
-!> real    ar   contains the solution for perturbation pressure p
-!------------------------------------------------------------------------------!
- MODULE poisfft_mod
- 
-
-    USE fft_xy,                                                                &
-        ONLY:  fft_init, fft_y, fft_y_1d, fft_y_m, fft_x, fft_x_1d, fft_x_m
-
-    USE indices,                                                               &
-        ONLY:  nnx, nny, nx, nxl, nxr, ny, nys, nyn, nz
-
-    USE transpose_indices,                                                     &
-        ONLY:  nxl_y, nxl_z, nxr_y, nxr_z, nys_x, nys_z, nyn_x, nyn_z, nzb_x,  &
-               nzb_y, nzt_x, nzt_y
-
-    USE tridia_solver,                                                         &
-        ONLY:  tridia_1dd, tridia_init, tridia_substi, tridia_substi_overlap
-
-    IMPLICIT NONE
-
-    LOGICAL, SAVE ::  poisfft_initialized = .FALSE.
-
-    PRIVATE
-
-    PUBLIC  poisfft, poisfft_init
-
-    INTERFACE poisfft
-       MODULE PROCEDURE poisfft
-    END INTERFACE poisfft
-
-    INTERFACE poisfft_init
-       MODULE PROCEDURE poisfft_init
-    END INTERFACE poisfft_init
-
-
- CONTAINS
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> @todo Missing subroutine description.
-!------------------------------------------------------------------------------!
-    SUBROUTINE poisfft_init
-
-       USE arrays_3d,                                                          &
-           ONLY:  ddzu_pres, ddzw
-
-       USE kinds
-
-       IMPLICIT NONE
-
-       INTEGER(iwp) ::  k  !<
-
-
-       CALL fft_init
-
-       CALL tridia_init
-
-       poisfft_initialized = .TRUE.
-
-    END SUBROUTINE poisfft_init
-
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Two-dimensional Fourier Transformation in x- and y-direction.
-!------------------------------------------------------------------------------!
-    SUBROUTINE poisfft( ar )
-
-       USE control_parameters,                                                 &
-           ONLY:  fft_method, transpose_compute_overlap
-
-       USE cpulog,                                                             &
-           ONLY:  cpu_log, cpu_log_nowait, log_point_s
-
-       USE kinds
-
-       USE pegrid
-
-       IMPLICIT NONE
-
-       INTEGER(iwp) ::  ii           !<
-       INTEGER(iwp) ::  iind         !<
-       INTEGER(iwp) ::  inew         !<
-       INTEGER(iwp) ::  jj           !<
-       INTEGER(iwp) ::  jind         !<
-       INTEGER(iwp) ::  jnew         !<
-       INTEGER(iwp) ::  ki           !<
-       INTEGER(iwp) ::  kk           !<
-       INTEGER(iwp) ::  knew         !<
-       INTEGER(iwp) ::  n            !<
-       INTEGER(iwp) ::  nblk         !<
-       INTEGER(iwp) ::  nnx_y        !<
-       INTEGER(iwp) ::  nny_z        !<
-       INTEGER(iwp) ::  nnz_t        !<
-       INTEGER(iwp) ::  nnz_x        !<
-       INTEGER(iwp) ::  nxl_y_bound  !<
-       INTEGER(iwp) ::  nxr_y_bound  !<
-
-       INTEGER(iwp), DIMENSION(4) ::  isave  !<
-
-       REAL(wp), DIMENSION(1:nz,nys:nyn,nxl:nxr) ::  ar      !<
-       REAL(wp), DIMENSION(nys:nyn,nxl:nxr,1:nz) ::  ar_inv  !<
-       !$acc declare create( ar_inv )
-
-       REAL(wp), DIMENSION(:,:,:),   ALLOCATABLE ::  ar1      !<
-       REAL(wp), DIMENSION(:,:,:),   ALLOCATABLE ::  f_in     !<
-       REAL(wp), DIMENSION(:,:,:),   ALLOCATABLE ::  f_inv    !<
-       REAL(wp), DIMENSION(:,:,:),   ALLOCATABLE ::  f_out_y  !<
-       REAL(wp), DIMENSION(:,:,:),   ALLOCATABLE ::  f_out_z  !<
-
-
-       CALL cpu_log( log_point_s(3), 'poisfft', 'start' )
-
-       IF ( .NOT. poisfft_initialized )  CALL poisfft_init
-
-!
-!--    Two-dimensional Fourier Transformation in x- and y-direction.
-       IF ( pdims(2) == 1  .AND.  pdims(1) > 1  .AND.  num_acc_per_node == 0 ) &
-       THEN
-
-!
-!--       1d-domain-decomposition along x:
-!--       FFT along y and transposition y --> x
-          CALL ffty_tr_yx( ar, ar )
-
-!
-!--       FFT along x, solving the tridiagonal system and backward FFT
-          CALL fftx_tri_fftx( ar )
-
-!
-!--       Transposition x --> y and backward FFT along y
-          CALL tr_xy_ffty( ar, ar )
-
-       ELSEIF ( pdims(1) == 1 .AND. pdims(2) > 1 .AND. num_acc_per_node == 0 ) &
-       THEN
-
-!
-!--       1d-domain-decomposition along y:
-!--       FFT along x and transposition x --> y
-          CALL fftx_tr_xy( ar, ar )
-
-!
-!--       FFT along y, solving the tridiagonal system and backward FFT
-          CALL ffty_tri_ffty( ar )
-
-!
-!--       Transposition y --> x and backward FFT along x
-          CALL tr_yx_fftx( ar, ar )
-
-       ELSEIF ( .NOT. transpose_compute_overlap )  THEN
-
-!
-!--       2d-domain-decomposition or no decomposition (1 PE run)
-!--       Transposition z --> x
-          CALL cpu_log( log_point_s(5), 'transpo forward', 'start' )
-          CALL resort_for_zx( ar, ar_inv )
-          CALL transpose_zx( ar_inv, ar )
-          CALL cpu_log( log_point_s(5), 'transpo forward', 'pause' )
-
-          CALL cpu_log( log_point_s(4), 'fft_x', 'start' )
-          IF ( fft_method /= 'system-specific' )  THEN
-             !$acc update host( ar )
-          ENDIF
-          CALL fft_x( ar, 'forward' )
-          IF ( fft_method /= 'system-specific' )  THEN
-             !$acc update device( ar )
-          ENDIF
-          CALL cpu_log( log_point_s(4), 'fft_x', 'pause' )
-
-!
-!--       Transposition x --> y
-          CALL cpu_log( log_point_s(5), 'transpo forward', 'continue' )
-          CALL resort_for_xy( ar, ar_inv )
-          CALL transpose_xy( ar_inv, ar )
-          CALL cpu_log( log_point_s(5), 'transpo forward', 'pause' )
-
-          CALL cpu_log( log_point_s(7), 'fft_y', 'start' )
-          IF ( fft_method /= 'system-specific' )  THEN
-             !$acc update host( ar )
-          ENDIF
-          CALL fft_y( ar, 'forward', ar_tr = ar,                &
-                      nxl_y_bound = nxl_y, nxr_y_bound = nxr_y, &
-                      nxl_y_l = nxl_y, nxr_y_l = nxr_y )
-          IF ( fft_method /= 'system-specific' )  THEN
-             !$acc update device( ar )
-          ENDIF
-          CALL cpu_log( log_point_s(7), 'fft_y', 'pause' )
-
-!
-!--       Transposition y --> z
-          CALL cpu_log( log_point_s(5), 'transpo forward', 'continue' )
-          CALL resort_for_yz( ar, ar_inv )
-          CALL transpose_yz( ar_inv, ar )
-          CALL cpu_log( log_point_s(5), 'transpo forward', 'stop' )
-
-!
-!--       Solve the tridiagonal equation system along z
-          CALL cpu_log( log_point_s(6), 'tridia', 'start' )
-          CALL tridia_substi( ar )
-          CALL cpu_log( log_point_s(6), 'tridia', 'stop' )
-
-!
-!--       Inverse Fourier Transformation
-!--       Transposition z --> y
-          CALL cpu_log( log_point_s(8), 'transpo invers', 'start' )
-          CALL transpose_zy( ar, ar_inv )
-          CALL resort_for_zy( ar_inv, ar )
-          CALL cpu_log( log_point_s(8), 'transpo invers', 'pause' )
-
-          CALL cpu_log( log_point_s(7), 'fft_y', 'continue' )
-          IF ( fft_method /= 'system-specific' )  THEN
-             !$acc update host( ar )
-          ENDIF
-          CALL fft_y( ar, 'backward', ar_tr = ar,               &
-                      nxl_y_bound = nxl_y, nxr_y_bound = nxr_y, &
-                      nxl_y_l = nxl_y, nxr_y_l = nxr_y )
-          IF ( fft_method /= 'system-specific' )  THEN
-             !$acc update device( ar )
-          ENDIF
-          CALL cpu_log( log_point_s(7), 'fft_y', 'stop' )
-
-!
-!--       Transposition y --> x
-          CALL cpu_log( log_point_s(8), 'transpo invers', 'continue' )
-          CALL transpose_yx( ar, ar_inv )
-          CALL resort_for_yx( ar_inv, ar )
-          CALL cpu_log( log_point_s(8), 'transpo invers', 'pause' )
-
-          CALL cpu_log( log_point_s(4), 'fft_x', 'continue' )
-          IF ( fft_method /= 'system-specific' )  THEN
-             !$acc update host( ar )
-          ENDIF
-          CALL fft_x( ar, 'backward' )
-          IF ( fft_method /= 'system-specific' )  THEN
-             !$acc update device( ar )
-          ENDIF
-          CALL cpu_log( log_point_s(4), 'fft_x', 'stop' )
-
-!
-!--       Transposition x --> z
-          CALL cpu_log( log_point_s(8), 'transpo invers', 'continue' )
-          CALL transpose_xz( ar, ar_inv )
-          CALL resort_for_xz( ar_inv, ar )
-          CALL cpu_log( log_point_s(8), 'transpo invers', 'stop' )
-
-       ELSE
-
-!
-!--       2d-domain-decomposition or no decomposition (1 PE run) with
-!--       overlapping transposition / fft
-!--       cputime logging must not use barriers, which would prevent overlapping
-          ALLOCATE( f_out_y(0:ny,nxl_y:nxr_y,nzb_y:nzt_y), &
-                    f_out_z(0:nx,nys_x:nyn_x,nzb_x:nzt_x) )
-!
-!--       Transposition z --> x + subsequent fft along x
-          ALLOCATE( f_inv(nys:nyn,nxl:nxr,1:nz) )
-          CALL resort_for_zx( ar, f_inv )
-!
-!--       Save original indices and gridpoint counter
-          isave(1) = nz
-          isave(2) = nzb_x
-          isave(3) = nzt_x
-          isave(4) = sendrecvcount_zx
-!
-!--       Set new indices for transformation
-          nblk  = nz / pdims(1)
-          nz    = pdims(1)
-          nnz_x = 1
-          nzb_x = 1 + myidx * nnz_x
-          nzt_x = ( myidx + 1 ) * nnz_x
-          sendrecvcount_zx = nnx * nny * nnz_x
-
-          ALLOCATE( ar1(0:nx,nys_x:nyn_x,nzb_x:nzt_x) )
-          ALLOCATE( f_in(nys:nyn,nxl:nxr,1:nz) )
-
-          DO  kk = 1, nblk
-
-             IF ( kk == 1 )  THEN
-                CALL cpu_log( log_point_s(5), 'transpo forward', 'start', cpu_log_nowait )
-             ELSE
-                CALL cpu_log( log_point_s(5), 'transpo forward', 'continue', cpu_log_nowait )
-             ENDIF
-
-             DO  knew = 1, nz
-                ki = kk + nblk * ( knew - 1 )
-                f_in(:,:,knew) = f_inv(:,:,ki)
-             ENDDO
-
-             CALL transpose_zx( f_in, ar1(:,:,:))
-             CALL cpu_log( log_point_s(5), 'transpo forward', 'pause' )
-
-             IF ( kk == 1 )  THEN
-                CALL cpu_log( log_point_s(4), 'fft_x', 'start', cpu_log_nowait )
-             ELSE
-                CALL cpu_log( log_point_s(4), 'fft_x', 'continue', cpu_log_nowait )
-             ENDIF
-
-             n = isave(2) + kk - 1
-             CALL fft_x( ar1(:,:,:), 'forward',  ar_2d = f_out_z(:,:,n))
-             CALL cpu_log( log_point_s(4), 'fft_x', 'pause' )
-
-          ENDDO
-!
-!--       Restore original indices/counters
-          nz               = isave(1)
-          nzb_x            = isave(2)
-          nzt_x            = isave(3)
-          sendrecvcount_zx = isave(4)
-
-          DEALLOCATE( ar1, f_in, f_inv )
-
-!
-!--       Transposition x --> y + subsequent fft along y
-          ALLOCATE( f_inv(nys_x:nyn_x,nzb_x:nzt_x,0:nx) )
-          CALL resort_for_xy( f_out_z, f_inv )
-!
-!--       Save original indices and gridpoint counter
-          isave(1) = nx
-          isave(2) = nxl_y
-          isave(3) = nxr_y
-          isave(4) = sendrecvcount_xy
-!
-!--       Set new indices for transformation
-          nblk  = ( ( nx+1 ) / pdims(2) ) - 1
-          nx    = pdims(2)
-          nnx_y = 1
-          nxl_y = myidy * nnx_y
-          nxr_y = ( myidy + 1 ) * nnx_y - 1
-          sendrecvcount_xy = nnx_y * ( nyn_x-nys_x+1 ) * ( nzt_x-nzb_x+1 )
-
-          ALLOCATE( ar1(0:ny,nxl_y:nxr_y,nzb_y:nzt_y) )
-          ALLOCATE( f_in(nys_x:nyn_x,nzb_x:nzt_x,0:nx) )
-
-          DO  ii = 0, nblk
-
-             CALL cpu_log( log_point_s(5), 'transpo forward', 'continue', cpu_log_nowait )
-
-             DO  inew = 0, nx-1
-                iind = ii + ( nblk + 1 ) * inew
-                f_in(:,:,inew) = f_inv(:,:,iind)
-             ENDDO
-
-             CALL transpose_xy( f_in, ar1(:,:,:) )
-
-             CALL cpu_log( log_point_s(5), 'transpo forward', 'pause' )
-
-             IF ( ii == 1 )  THEN
-                CALL cpu_log( log_point_s(7), 'fft_y', 'start', cpu_log_nowait )
-             ELSE
-                CALL cpu_log( log_point_s(7), 'fft_y', 'continue', cpu_log_nowait )
-             ENDIF
-
-             nxl_y_bound = isave(2)
-             nxr_y_bound = isave(3)
-             n           = isave(2) + ii
-             CALL fft_y( ar1(:,:,:), 'forward', ar_tr = f_out_y,               &
-                         nxl_y_bound = nxl_y_bound, nxr_y_bound = nxr_y_bound, &
-                         nxl_y_l = n, nxr_y_l = n )
-
-             CALL cpu_log( log_point_s(7), 'fft_y', 'pause' )
-
-          ENDDO
-!
-!--       Restore original indices/counters
-          nx               = isave(1)
-          nxl_y            = isave(2)
-          nxr_y            = isave(3)
-          sendrecvcount_xy = isave(4)
-
-          DEALLOCATE( ar1, f_in, f_inv )
-
-!
-!--       Transposition y --> z + subsequent tridia + resort for z --> y
-          ALLOCATE( f_inv(nxl_y:nxr_y,nzb_y:nzt_y,0:ny) )
-          CALL resort_for_yz( f_out_y, f_inv )
-!
-!--       Save original indices and gridpoint counter
-          isave(1) = ny
-          isave(2) = nys_z
-          isave(3) = nyn_z
-          isave(4) = sendrecvcount_yz
-!
-!--       Set new indices for transformation
-          nblk             = ( ( ny+1 ) / pdims(1) ) - 1
-          ny               = pdims(1)
-          nny_z            = 1
-          nys_z            = myidx * nny_z
-          nyn_z            = ( myidx + 1 ) * nny_z - 1
-          sendrecvcount_yz = ( nxr_y-nxl_y+1 ) * nny_z * ( nzt_y-nzb_y+1 )
-
-          ALLOCATE( ar1(nxl_z:nxr_z,nys_z:nyn_z,1:nz) )
-          ALLOCATE( f_in(nxl_y:nxr_y,nzb_y:nzt_y,0:ny) )
-
-          DO  jj = 0, nblk
-!
-!--          Forward Fourier Transformation
-!--          Transposition y --> z
-             CALL cpu_log( log_point_s(5), 'transpo forward', 'continue', cpu_log_nowait )
-
-             DO  jnew = 0, ny-1
-                jind = jj + ( nblk + 1 ) * jnew
-                f_in(:,:,jnew) = f_inv(:,:,jind)
-             ENDDO
-
-             CALL transpose_yz( f_in, ar1(:,:,:) )
-
-             IF ( jj == nblk )  THEN
-                CALL cpu_log( log_point_s(5), 'transpo forward', 'stop' )
-             ELSE
-                CALL cpu_log( log_point_s(5), 'transpo forward', 'pause' )
-             ENDIF
-
-!
-!--          Solve the tridiagonal equation system along z
-             CALL cpu_log( log_point_s(6), 'tridia', 'start', cpu_log_nowait )
-
-             n = isave(2) + jj
-             CALL tridia_substi_overlap( ar1(:,:,:), n )
-
-             CALL cpu_log( log_point_s(6), 'tridia', 'stop' )
-
-!
-!--          Inverse Fourier Transformation
-!--          Transposition z --> y
-!--          Only one thread should call MPI routines, therefore forward and
-!--          backward tranpose are in the same section
-             IF ( jj == 0 )  THEN
-                CALL cpu_log( log_point_s(8), 'transpo invers', 'start', cpu_log_nowait )
-             ELSE
-                CALL cpu_log( log_point_s(8), 'transpo invers', 'continue', cpu_log_nowait )
-             ENDIF
-
-             CALL transpose_zy( ar1(:,:,:), f_in )
-
-             DO  jnew = 0, ny-1
-                jind = jj + ( nblk + 1 ) * jnew
-                f_inv(:,:,jind) = f_in(:,:,jnew)
-             ENDDO
-
-             CALL cpu_log( log_point_s(8), 'transpo invers', 'pause' )
-
-          ENDDO
-!
-!--       Restore original indices/counters
-          ny               = isave(1)
-          nys_z            = isave(2)
-          nyn_z            = isave(3)
-          sendrecvcount_yz = isave(4)
-
-          CALL resort_for_zy( f_inv, f_out_y )
-
-          DEALLOCATE( ar1, f_in, f_inv )
-
-!
-!--       fft along y backward + subsequent transposition y --> x
-          ALLOCATE( f_inv(nys_x:nyn_x,nzb_x:nzt_x,0:nx) )
-!
-!--       Save original indices and gridpoint counter
-          isave(1) = nx
-          isave(2) = nxl_y
-          isave(3) = nxr_y
-          isave(4) = sendrecvcount_xy
-!
-!--       Set new indices for transformation
-          nblk             = (( nx+1 ) / pdims(2) ) - 1
-          nx               = pdims(2)
-          nnx_y            = 1
-          nxl_y            = myidy * nnx_y
-          nxr_y            = ( myidy + 1 ) * nnx_y - 1
-          sendrecvcount_xy = nnx_y * ( nyn_x-nys_x+1 ) * ( nzt_x-nzb_x+1 )
-
-          ALLOCATE( ar1(0:ny,nxl_y:nxr_y,nzb_y:nzt_y) )
-          ALLOCATE( f_in(nys_x:nyn_x,nzb_x:nzt_x,0:nx) )
-
-          DO  ii = 0, nblk
-
-             CALL cpu_log( log_point_s(7), 'fft_y', 'continue', cpu_log_nowait )
-
-             n = isave(2) + ii
-             nxl_y_bound = isave(2)
-             nxr_y_bound = isave(3)
-
-             CALL fft_y( ar1(:,:,:), 'backward', ar_tr = f_out_y,              &
-                         nxl_y_bound = nxl_y_bound, nxr_y_bound = nxr_y_bound, &
-                         nxl_y_l = n, nxr_y_l = n )
-
-             IF ( ii == nblk )  THEN
-                CALL cpu_log( log_point_s(7), 'fft_y', 'stop' )
-             ELSE
-                CALL cpu_log( log_point_s(7), 'fft_y', 'pause' )
-             ENDIF
-
-             CALL cpu_log( log_point_s(8), 'transpo invers', 'continue', cpu_log_nowait )
-
-             CALL transpose_yx( ar1(:,:,:), f_in )
-
-             DO  inew = 0, nx-1
-                iind = ii + (nblk+1) * inew
-                f_inv(:,:,iind) = f_in(:,:,inew)
-             ENDDO
-
-             CALL cpu_log( log_point_s(8), 'transpo invers', 'pause' )
-
-          ENDDO
-!
-!--       Restore original indices/counters
-          nx               = isave(1)
-          nxl_y            = isave(2)
-          nxr_y            = isave(3)
-          sendrecvcount_xy = isave(4)
-
-          CALL resort_for_yx( f_inv, f_out_z )
-
-          DEALLOCATE( ar1, f_in, f_inv )
-
-!
-!--       fft along x backward + subsequent final transposition x --> z
-          ALLOCATE( f_inv(nys:nyn,nxl:nxr,1:nz) )
-!
-!--       Save original indices and gridpoint counter
-          isave(1) = nz
-          isave(2) = nzb_x
-          isave(3) = nzt_x
-          isave(4) = sendrecvcount_zx
-!
-!--       Set new indices for transformation
-          nblk             = nz / pdims(1)
-          nz               = pdims(1)
-          nnz_x            = 1
-          nzb_x            = 1 + myidx * nnz_x
-          nzt_x            = ( myidx + 1 ) * nnz_x
-          sendrecvcount_zx = nnx * nny * nnz_x
-
-          ALLOCATE( ar1(0:nx,nys_x:nyn_x,nzb_x:nzt_x) )
-          ALLOCATE( f_in(nys:nyn,nxl:nxr,1:nz) )
-
-          DO  kk = 1, nblk
-
-             CALL cpu_log( log_point_s(4), 'fft_x', 'continue', cpu_log_nowait )
-
-             n = isave(2) + kk - 1
-             CALL fft_x( ar1(:,:,:), 'backward', f_out_z(:,:,n))
-
-             IF ( kk == nblk )  THEN
-                CALL cpu_log( log_point_s(4), 'fft_x', 'stop' )
-             ELSE
-                CALL cpu_log( log_point_s(4), 'fft_x', 'pause' )
-             ENDIF
-
-             CALL cpu_log( log_point_s(8), 'transpo invers', 'continue', cpu_log_nowait )
-
-             CALL transpose_xz( ar1(:,:,:), f_in )
-
-             DO  knew = 1, nz
-                ki = kk + nblk * (knew-1)
-                f_inv(:,:,ki) = f_in(:,:,knew)
-             ENDDO
-
-             IF ( kk == nblk )  THEN
-                CALL cpu_log( log_point_s(8), 'transpo invers', 'stop' )
-             ELSE
-                CALL cpu_log( log_point_s(8), 'transpo invers', 'pause' )
-             ENDIF
-
-          ENDDO
-!
-!--       Restore original indices/counters
-          nz               = isave(1)
-          nzb_x            = isave(2)
-          nzt_x            = isave(3)
-          sendrecvcount_zx = isave(4)
-
-          CALL resort_for_xz( f_inv, ar )
-
-          DEALLOCATE( ar1, f_in, f_inv )
-
-       ENDIF
-
-       CALL cpu_log( log_point_s(3), 'poisfft', 'stop' )
-
-    END SUBROUTINE poisfft
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Fourier-transformation along y with subsequent transposition y --> x for
-!> a 1d-decomposition along x.
-!>
-!> @attention The performance of this routine is much faster on the NEC-SX6,
-!>            if the first index of work_ffty_vec is odd. Otherwise
-!>            memory bank conflicts may occur (especially if the index is a
-!>            multiple of 128). That's why work_ffty_vec is dimensioned as
-!>            0:ny+1.
-!>            Of course, this will not work if users are using an odd number
-!>            of gridpoints along y.
-!------------------------------------------------------------------------------!
-    SUBROUTINE ffty_tr_yx( f_in, f_out )
-
-
-       USE control_parameters,                                                 &
-           ONLY:  host
-
-       USE cpulog,                                                             &
-           ONLY:  cpu_log, log_point_s
-
-       USE kinds
-
-       USE pegrid
-
-       IMPLICIT NONE
-
-       INTEGER(iwp)            ::  i            !<
-       INTEGER(iwp)            ::  iend         !<
-       INTEGER(iwp)            ::  iouter       !<
-       INTEGER(iwp)            ::  ir           !<
-       INTEGER(iwp)            ::  j            !<
-       INTEGER(iwp)            ::  k            !<
-
-       INTEGER(iwp), PARAMETER ::  stridex = 4  !<
-
-       REAL(wp), DIMENSION(0:ny,stridex)        ::  work_ffty      !<
-#if defined( __nec )
-       REAL(wp), DIMENSION(0:ny+1,1:nz,nxl:nxr) ::  work_ffty_vec  !<
-#endif
-       REAL(wp), DIMENSION(1:nz,0:ny,nxl:nxr)             ::  f_in   !<
-       REAL(wp), DIMENSION(nnx,1:nz,nys_x:nyn_x,pdims(1)) ::  f_out  !<
-       REAL(wp), DIMENSION(nxl:nxr,1:nz,0:ny)             ::  work   !<
-
-!
-!--    Carry out the FFT along y, where all data are present due to the
-!--    1d-decomposition along x. Resort the data in a way that x becomes
-!--    the first index.
-       CALL cpu_log( log_point_s(7), 'fft_y_1d', 'start' )
-
-       IF ( host(1:3) == 'nec' )  THEN
-#if defined( __nec )
-!
-!--       Code optimized for vector processors
-!$OMP     PARALLEL PRIVATE ( i, j, k )
-!$OMP     DO
-          DO  i = nxl, nxr
-
-             DO  j = 0, ny
-                DO  k = 1, nz
-                   work_ffty_vec(j,k,i) = f_in(k,j,i)
-                ENDDO
-             ENDDO
-
-             CALL fft_y_m( work_ffty_vec(:,:,i), ny+1, 'forward' )
-
-          ENDDO
-
-!$OMP     DO
-          DO  k = 1, nz
-             DO  j = 0, ny
-                DO  i = nxl, nxr
-                   work(i,k,j) = work_ffty_vec(j,k,i)
-                ENDDO
-             ENDDO
-          ENDDO
-!$OMP     END PARALLEL
-#endif
-
-       ELSE
-
-!
-!--       Cache optimized code.
-!--       The i-(x-)direction is split into a strided outer loop and an inner
-!--       loop for better cache performance
-!$OMP     PARALLEL PRIVATE (i,iend,iouter,ir,j,k,work_ffty)
-!$OMP     DO
-          DO  iouter = nxl, nxr, stridex
-
-             iend = MIN( iouter+stridex-1, nxr )  ! Upper bound for inner i loop
-
-             DO  k = 1, nz
-
-                DO  i = iouter, iend
-
-                   ir = i-iouter+1  ! counter within a stride
-                   DO  j = 0, ny
-                      work_ffty(j,ir) = f_in(k,j,i)
-                   ENDDO
-!
-!--                FFT along y
-                   CALL fft_y_1d( work_ffty(:,ir), 'forward' )
-
-                ENDDO
-
-!
-!--             Resort
-                DO  j = 0, ny
-                   DO  i = iouter, iend
-                      work(i,k,j) = work_ffty(j,i-iouter+1)
-                   ENDDO
-                ENDDO
-
-             ENDDO
-
-          ENDDO
-!$OMP     END PARALLEL
-
-       ENDIF
-       CALL cpu_log( log_point_s(7), 'fft_y_1d', 'pause' )
-
-!
-!--    Transpose array
-#if defined( __parallel )
-       CALL cpu_log( log_point_s(32), 'mpi_alltoall', 'start' )
-       IF ( collective_wait )  CALL MPI_BARRIER( comm2d, ierr )
-       CALL MPI_ALLTOALL( work(nxl,1,0),      sendrecvcount_xy, MPI_REAL, &
-                          f_out(1,1,nys_x,1), sendrecvcount_xy, MPI_REAL, &
-                          comm1dx, ierr )
-       CALL cpu_log( log_point_s(32), 'mpi_alltoall', 'stop' )
-#endif
-
-    END SUBROUTINE ffty_tr_yx
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!>  Transposition x --> y with a subsequent backward Fourier transformation for
-!>  a 1d-decomposition along x
-!------------------------------------------------------------------------------!
-    SUBROUTINE tr_xy_ffty( f_in, f_out )
-
-
-       USE control_parameters,                                                 &
-           ONLY:  host
-
-       USE cpulog,                                                             &
-           ONLY:  cpu_log, log_point_s
-
-       USE kinds
-
-       USE pegrid
-
-       IMPLICIT NONE
-
-       INTEGER(iwp)            ::  i            !<
-       INTEGER(iwp)            ::  iend         !<
-       INTEGER(iwp)            ::  iouter       !<
-       INTEGER(iwp)            ::  ir           !<
-       INTEGER(iwp)            ::  j            !<
-       INTEGER(iwp)            ::  k            !<
-
-       INTEGER(iwp), PARAMETER ::  stridex = 4  !<
-
-       REAL(wp), DIMENSION(0:ny,stridex)        ::  work_ffty      !<
-#if defined( __nec )
-       REAL(wp), DIMENSION(0:ny+1,1:nz,nxl:nxr) ::  work_ffty_vec  !<
-#endif
-       REAL(wp), DIMENSION(nnx,1:nz,nys_x:nyn_x,pdims(1)) ::  f_in   !<
-       REAL(wp), DIMENSION(1:nz,0:ny,nxl:nxr)             ::  f_out  !<
-       REAL(wp), DIMENSION(nxl:nxr,1:nz,0:ny)             ::  work   !<
-
-!
-!--    Transpose array
-#if defined( __parallel )
-       CALL cpu_log( log_point_s(32), 'mpi_alltoall', 'start' )
-       IF ( collective_wait )  CALL MPI_BARRIER( comm2d, ierr )
-       CALL MPI_ALLTOALL( f_in(1,1,nys_x,1), sendrecvcount_xy, MPI_REAL, &
-                          work(nxl,1,0),     sendrecvcount_xy, MPI_REAL, &
-                          comm1dx, ierr )
-       CALL cpu_log( log_point_s(32), 'mpi_alltoall', 'stop' )
-#endif
-
-!
-!--    Resort the data in a way that y becomes the first index and carry out the
-!--    backward fft along y.
-       CALL cpu_log( log_point_s(7), 'fft_y_1d', 'continue' )
-
-       IF ( host(1:3) == 'nec' )  THEN
-#if defined( __nec )
-!
-!--       Code optimized for vector processors
-!$OMP     PARALLEL PRIVATE ( i, j, k )
-!$OMP     DO
-          DO  k = 1, nz
-             DO  j = 0, ny
-                DO  i = nxl, nxr
-                   work_ffty_vec(j,k,i) = work(i,k,j)
-                ENDDO
-             ENDDO
-          ENDDO
-
-!$OMP     DO
-          DO  i = nxl, nxr
-
-             CALL fft_y_m( work_ffty_vec(:,:,i), ny+1, 'backward' )
-
-             DO  j = 0, ny
-                DO  k = 1, nz
-                   f_out(k,j,i) = work_ffty_vec(j,k,i)
-                ENDDO
-             ENDDO
-
-          ENDDO
-!$OMP     END PARALLEL
-#endif
-
-       ELSE
-
-!
-!--       Cache optimized code.
-!--       The i-(x-)direction is split into a strided outer loop and an inner
-!--       loop for better cache performance
-!$OMP     PARALLEL PRIVATE ( i, iend, iouter, ir, j, k, work_ffty )
-!$OMP     DO
-          DO  iouter = nxl, nxr, stridex
-
-             iend = MIN( iouter+stridex-1, nxr )  ! Upper bound for inner i loop
-
-             DO  k = 1, nz
-!
-!--             Resort
-                DO  j = 0, ny
-                   DO  i = iouter, iend
-                      work_ffty(j,i-iouter+1) = work(i,k,j)
-                   ENDDO
-                ENDDO
-
-                DO  i = iouter, iend
-
-!
-!--                FFT along y
-                   ir = i-iouter+1  ! counter within a stride
-                   CALL fft_y_1d( work_ffty(:,ir), 'backward' )
-
-                   DO  j = 0, ny
-                      f_out(k,j,i) = work_ffty(j,ir)
-                   ENDDO
-                ENDDO
-
-             ENDDO
-
-          ENDDO
-!$OMP     END PARALLEL
-
-       ENDIF
-
-       CALL cpu_log( log_point_s(7), 'fft_y_1d', 'stop' )
-
-    END SUBROUTINE tr_xy_ffty
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> FFT along x, solution of the tridiagonal system and backward FFT for
-!> a 1d-decomposition along x
-!>
-!> @warning this subroutine may still not work for hybrid parallelization
-!>          with OpenMP (for possible necessary changes see the original
-!>          routine poisfft_hybrid, developed by Klaus Ketelsen, May 2002)
-!------------------------------------------------------------------------------!
-    SUBROUTINE fftx_tri_fftx( ar )
-
-
-       USE control_parameters,                                                 &
-           ONLY:  host
-
-       USE cpulog,                                                             &
-           ONLY:  cpu_log, log_point_s
-
-       USE grid_variables,                                                     &
-           ONLY:  ddx2, ddy2
-
-       USE kinds
-
-       USE pegrid
-
-       IMPLICIT NONE
-
-       INTEGER(iwp) ::  i                   !<
-       INTEGER(iwp) ::  j                   !<
-       INTEGER(iwp) ::  k                   !<
-       INTEGER(iwp) ::  m                   !<
-       INTEGER(iwp) ::  n                   !<
-       INTEGER(iwp) ::  omp_get_thread_num  !<
-       INTEGER(iwp) ::  tn                  !<
-
-       REAL(wp), DIMENSION(0:nx)                          ::  work_fftx  !<
-       REAL(wp), DIMENSION(0:nx,1:nz)                     ::  work_trix  !<
-       REAL(wp), DIMENSION(nnx,1:nz,nys_x:nyn_x,pdims(1)) ::  ar         !<
-       REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE          ::  tri        !<
-
-
-       CALL cpu_log( log_point_s(33), 'fft_x_1d + tridia', 'start' )
-
-       ALLOCATE( tri(5,0:nx,0:nz-1,0:threads_per_task-1) )
-
-       tn = 0              ! Default thread number in case of one thread
-!$OMP  PARALLEL DO PRIVATE ( i, j, k, m, n, tn, work_fftx, work_trix )
-       DO  j = nys_x, nyn_x
-
-!$        tn = omp_get_thread_num()
-
-          IF ( host(1:3) == 'nec' )  THEN
-!
-!--          Code optimized for vector processors
-             DO  k = 1, nz
-
-                m = 0
-                DO  n = 1, pdims(1)
-                   DO  i = 1, nnx
-                      work_trix(m,k) = ar(i,k,j,n)
-                      m = m + 1
-                   ENDDO
-                ENDDO
-
-             ENDDO
-
-             CALL fft_x_m( work_trix, 'forward' )
-
-          ELSE
-!
-!--          Cache optimized code
-             DO  k = 1, nz
-
-                m = 0
-                DO  n = 1, pdims(1)
-                   DO  i = 1, nnx
-                      work_fftx(m) = ar(i,k,j,n)
-                      m = m + 1
-                   ENDDO
-                ENDDO
-
-                CALL fft_x_1d( work_fftx, 'forward' )
-
-                DO  i = 0, nx
-                   work_trix(i,k) = work_fftx(i)
-                ENDDO
-
-             ENDDO
-
-          ENDIF
-
-!
-!--       Solve the linear equation system
-          CALL tridia_1dd( ddx2, ddy2, nx, ny, j, work_trix, tri(:,:,:,tn) )
-
-          IF ( host(1:3) == 'nec' )  THEN
-!
-!--          Code optimized for vector processors
-             CALL fft_x_m( work_trix, 'backward' )
-
-             DO  k = 1, nz
-
-                m = 0
-                DO  n = 1, pdims(1)
-                   DO  i = 1, nnx
-                      ar(i,k,j,n) = work_trix(m,k)
-                      m = m + 1
-                   ENDDO
-                ENDDO
-
-             ENDDO
-
-          ELSE
-!
-!--          Cache optimized code
-             DO  k = 1, nz
-
-                DO  i = 0, nx
-                   work_fftx(i) = work_trix(i,k)
-                ENDDO
-
-                CALL fft_x_1d( work_fftx, 'backward' )
-
-                m = 0
-                DO  n = 1, pdims(1)
-                   DO  i = 1, nnx
-                      ar(i,k,j,n) = work_fftx(m)
-                      m = m + 1
-                   ENDDO
-                ENDDO
-
-             ENDDO
-
-          ENDIF
-
-       ENDDO
-
-       DEALLOCATE( tri )
-
-       CALL cpu_log( log_point_s(33), 'fft_x_1d + tridia', 'stop' )
-
-    END SUBROUTINE fftx_tri_fftx
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Fourier-transformation along x with subsequent transposition x --> y for
-!> a 1d-decomposition along y.
-!>
-!> @attention NEC-branch of this routine may significantly profit from
-!>            further optimizations. So far, performance is much worse than
-!>            for routine ffty_tr_yx (more than three times slower).
-!------------------------------------------------------------------------------!
-    SUBROUTINE fftx_tr_xy( f_in, f_out )
-
-
-       USE control_parameters,                                                 &
-           ONLY:  host
-
-       USE cpulog,                                                             &
-           ONLY:  cpu_log, log_point_s
-
-       USE kinds
-
-       USE pegrid
-
-       IMPLICIT NONE
-
-       INTEGER(iwp) ::  i  !<
-       INTEGER(iwp) ::  j  !<
-       INTEGER(iwp) ::  k  !<
-
-       REAL(wp), DIMENSION(0:nx,1:nz,nys:nyn)             ::  work_fftx  !<
-       REAL(wp), DIMENSION(1:nz,nys:nyn,0:nx)             ::  f_in       !<
-       REAL(wp), DIMENSION(nny,1:nz,nxl_y:nxr_y,pdims(2)) ::  f_out      !<
-       REAL(wp), DIMENSION(nys:nyn,1:nz,0:nx)             ::  work       !<
-
-!
-!--    Carry out the FFT along x, where all data are present due to the
-!--    1d-decomposition along y. Resort the data in a way that y becomes
-!--    the first index.
-       CALL cpu_log( log_point_s(4), 'fft_x_1d', 'start' )
-
-       IF ( host(1:3) == 'nec' )  THEN
-!
-!--       Code for vector processors
-!$OMP     PARALLEL PRIVATE ( i, j, k )
-!$OMP     DO
-          DO  i = 0, nx
-
-             DO  j = nys, nyn
-                DO  k = 1, nz
-                   work_fftx(i,k,j) = f_in(k,j,i)
-                ENDDO
-             ENDDO
-
-          ENDDO
-
-!$OMP     DO
-          DO  j = nys, nyn
-
-             CALL fft_x_m( work_fftx(:,:,j), 'forward' )
-
-             DO  k = 1, nz
-                DO  i = 0, nx
-                   work(j,k,i) = work_fftx(i,k,j)
-                ENDDO
-             ENDDO
-
-          ENDDO
-!$OMP     END PARALLEL
-
-       ELSE
-
-!
-!--       Cache optimized code (there might be still a potential for better
-!--       optimization).
-!$OMP     PARALLEL PRIVATE (i,j,k)
-!$OMP     DO
-          DO  i = 0, nx
-
-             DO  j = nys, nyn
-                DO  k = 1, nz
-                   work_fftx(i,k,j) = f_in(k,j,i)
-                ENDDO
-             ENDDO
-
-          ENDDO
-
-!$OMP     DO
-          DO  j = nys, nyn
-             DO  k = 1, nz
-
-                CALL fft_x_1d( work_fftx(0:nx,k,j), 'forward' )
-
-                DO  i = 0, nx
-                   work(j,k,i) = work_fftx(i,k,j)
-                ENDDO
-             ENDDO
-
-          ENDDO
-!$OMP     END PARALLEL
-
-       ENDIF
-       CALL cpu_log( log_point_s(4), 'fft_x_1d', 'pause' )
-
-!
-!--    Transpose array
-#if defined( __parallel )
-       CALL cpu_log( log_point_s(32), 'mpi_alltoall', 'start' )
-       IF ( collective_wait )  CALL MPI_BARRIER( comm2d, ierr )
-       CALL MPI_ALLTOALL( work(nys,1,0),      sendrecvcount_xy, MPI_REAL, &
-                          f_out(1,1,nxl_y,1), sendrecvcount_xy, MPI_REAL, &
-                          comm1dy, ierr )
-       CALL cpu_log( log_point_s(32), 'mpi_alltoall', 'stop' )
-#endif
-
-    END SUBROUTINE fftx_tr_xy
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Transposition y --> x with a subsequent backward Fourier transformation for
-!> a 1d-decomposition along x.
-!------------------------------------------------------------------------------!
-    SUBROUTINE tr_yx_fftx( f_in, f_out )
-
-
-       USE control_parameters,                                                 &
-           ONLY:  host
-
-       USE cpulog,                                                             &
-           ONLY:  cpu_log, log_point_s
-
-       USE kinds
-
-       USE pegrid
-
-       IMPLICIT NONE
-
-       INTEGER(iwp) ::  i  !<
-       INTEGER(iwp) ::  j  !<
-       INTEGER(iwp) ::  k  !<
-
-       REAL(wp), DIMENSION(0:nx,1:nz,nys:nyn)             ::  work_fftx  !<
-       REAL(wp), DIMENSION(nny,1:nz,nxl_y:nxr_y,pdims(2)) ::  f_in       !<
-       REAL(wp), DIMENSION(1:nz,nys:nyn,0:nx)             ::  f_out      !<
-       REAL(wp), DIMENSION(nys:nyn,1:nz,0:nx)             ::  work       !<
-
-!
-!--    Transpose array
-#if defined( __parallel )
-       CALL cpu_log( log_point_s(32), 'mpi_alltoall', 'start' )
-       IF ( collective_wait )  CALL MPI_BARRIER( comm2d, ierr )
-       CALL MPI_ALLTOALL( f_in(1,1,nxl_y,1), sendrecvcount_xy, MPI_REAL, &
-                          work(nys,1,0),     sendrecvcount_xy, MPI_REAL, &
-                          comm1dy, ierr )
-       CALL cpu_log( log_point_s(32), 'mpi_alltoall', 'stop' )
-#endif
-
-!
-!--    Carry out the FFT along x, where all data are present due to the
-!--    1d-decomposition along y. Resort the data in a way that y becomes
-!--    the first index.
-       CALL cpu_log( log_point_s(4), 'fft_x_1d', 'continue' )
-
-       IF ( host(1:3) == 'nec' )  THEN
-!
-!--       Code optimized for vector processors
-!$OMP     PARALLEL PRIVATE ( i, j, k )
-!$OMP     DO
-          DO  j = nys, nyn
-
-             DO  k = 1, nz
-                DO  i = 0, nx
-                   work_fftx(i,k,j) = work(j,k,i)
-                ENDDO
-             ENDDO
-
-             CALL fft_x_m( work_fftx(:,:,j), 'backward' )
-
-          ENDDO
-
-!$OMP     DO
-          DO  i = 0, nx
-             DO  j = nys, nyn
-                DO  k = 1, nz
-                   f_out(k,j,i) = work_fftx(i,k,j)
-                ENDDO
-             ENDDO
-          ENDDO
-!$OMP     END PARALLEL
-
-       ELSE
-
-!
-!--       Cache optimized code (there might be still a potential for better
-!--       optimization).
-!$OMP     PARALLEL PRIVATE (i,j,k)
-!$OMP     DO
-          DO  j = nys, nyn
-             DO  k = 1, nz
-
-                DO  i = 0, nx
-                   work_fftx(i,k,j) = work(j,k,i)
-                ENDDO
-
-                CALL fft_x_1d( work_fftx(0:nx,k,j), 'backward' )
-
-             ENDDO
-          ENDDO
-
-!$OMP     DO
-          DO  i = 0, nx
-             DO  j = nys, nyn
-                DO  k = 1, nz
-                   f_out(k,j,i) = work_fftx(i,k,j)
-                ENDDO
-             ENDDO
-          ENDDO
-!$OMP     END PARALLEL
-
-       ENDIF
-       CALL cpu_log( log_point_s(4), 'fft_x_1d', 'stop' )
-
-    END SUBROUTINE tr_yx_fftx
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> FFT along y, solution of the tridiagonal system and backward FFT for
-!> a 1d-decomposition along y.
-!>
-!> @warning this subroutine may still not work for hybrid parallelization
-!>          with OpenMP (for possible necessary changes see the original
-!>          routine poisfft_hybrid, developed by Klaus Ketelsen, May 2002)
-!------------------------------------------------------------------------------!
-    SUBROUTINE ffty_tri_ffty( ar )
-
-
-       USE control_parameters,                                                 &
-           ONLY:  host
-
-       USE cpulog,                                                             &
-           ONLY:  cpu_log, log_point_s
-
-       USE grid_variables,                                                     &
-           ONLY:  ddx2, ddy2
-
-       USE kinds
-
-       USE pegrid
-
-       IMPLICIT NONE
-
-       INTEGER(iwp) ::  i                   !<
-       INTEGER(iwp) ::  j                   !<
-       INTEGER(iwp) ::  k                   !<
-       INTEGER(iwp) ::  m                   !<
-       INTEGER(iwp) ::  n                   !<
-       INTEGER(iwp) ::  omp_get_thread_num  !<
-       INTEGER(iwp) ::  tn                  !<
-
-       REAL(wp), DIMENSION(0:ny)                          ::  work_ffty  !<
-       REAL(wp), DIMENSION(0:ny,1:nz)                     ::  work_triy  !<
-       REAL(wp), DIMENSION(nny,1:nz,nxl_y:nxr_y,pdims(2)) ::  ar         !<
-       REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE          ::  tri        !<
-
-
-       CALL cpu_log( log_point_s(39), 'fft_y_1d + tridia', 'start' )
-
-       ALLOCATE( tri(5,0:ny,0:nz-1,0:threads_per_task-1) )
-
-       tn = 0           ! Default thread number in case of one thread
-!$OMP  PARALLEL DO PRIVATE ( i, j, k, m, n, tn, work_ffty, work_triy )
-       DO  i = nxl_y, nxr_y
-
-!$        tn = omp_get_thread_num()
-
-          IF ( host(1:3) == 'nec' )  THEN
-!
-!--          Code optimized for vector processors
-             DO  k = 1, nz
-
-                m = 0
-                DO  n = 1, pdims(2)
-                   DO  j = 1, nny
-                      work_triy(m,k) = ar(j,k,i,n)
-                      m = m + 1
-                   ENDDO
-                ENDDO
-
-             ENDDO
-
-             CALL fft_y_m( work_triy, ny, 'forward' )
-
-          ELSE
-!
-!--          Cache optimized code
-             DO  k = 1, nz
-
-                m = 0
-                DO  n = 1, pdims(2)
-                   DO  j = 1, nny
-                      work_ffty(m) = ar(j,k,i,n)
-                      m = m + 1
-                   ENDDO
-                ENDDO
-
-                CALL fft_y_1d( work_ffty, 'forward' )
-
-                DO  j = 0, ny
-                   work_triy(j,k) = work_ffty(j)
-                ENDDO
-
-             ENDDO
-
-          ENDIF
-
-!
-!--       Solve the linear equation system
-          CALL tridia_1dd( ddy2, ddx2, ny, nx, i, work_triy, tri(:,:,:,tn) )
-
-          IF ( host(1:3) == 'nec' )  THEN
-!
-!--          Code optimized for vector processors
-             CALL fft_y_m( work_triy, ny, 'backward' )
-
-             DO  k = 1, nz
-
-                m = 0
-                DO  n = 1, pdims(2)
-                   DO  j = 1, nny
-                      ar(j,k,i,n) = work_triy(m,k)
-                      m = m + 1
-                   ENDDO
-                ENDDO
-
-             ENDDO
-
-          ELSE
-!
-!--          Cache optimized code
-             DO  k = 1, nz
-
-                DO  j = 0, ny
-                   work_ffty(j) = work_triy(j,k)
-                ENDDO
-
-                CALL fft_y_1d( work_ffty, 'backward' )
-
-                m = 0
-                DO  n = 1, pdims(2)
-                   DO  j = 1, nny
-                      ar(j,k,i,n) = work_ffty(m)
-                      m = m + 1
-                   ENDDO
-                ENDDO
-
-             ENDDO
-
-          ENDIF
-
-       ENDDO
-
-       DEALLOCATE( tri )
-
-       CALL cpu_log( log_point_s(39), 'fft_y_1d + tridia', 'stop' )
-
-    END SUBROUTINE ffty_tri_ffty
-
- END MODULE poisfft_mod
Index: /palm/trunk/SOURCE/poisfft_mod.f90
===================================================================
--- /palm/trunk/SOURCE/poisfft_mod.f90	(revision 1850)
+++ /palm/trunk/SOURCE/poisfft_mod.f90	(revision 1850)
@@ -0,0 +1,1498 @@
+!> @file poisfft_mod.f90
+!--------------------------------------------------------------------------------!
+! This file is part of PALM.
+!
+! PALM is free software: you can redistribute it and/or modify it under the terms
+! of the GNU General Public License as published by the Free Software Foundation,
+! either version 3 of the License, or (at your option) any later version.
+!
+! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
+! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
+! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along with
+! PALM. If not, see <http://www.gnu.org/licenses/>.
+!
+! Copyright 1997-2014  Leibniz Universitaet Hannover
+!--------------------------------------------------------------------------------!
+!
+! Current revisions:
+! -----------------
+! Module renamed
+! 
+! 
+! Former revisions:
+! -----------------
+! $Id$
+!
+! 1804 2016-04-05 16:30:18Z maronga
+! Removed code for parameter file check (__check)
+! 
+! 1682 2015-10-07 23:56:08Z knoop
+! Code annotations made doxygen readable 
+!
+! 1482 2014-10-18 12:34:45Z raasch
+! use 2d-decomposition, if accelerator boards are used
+!
+! 1406 2014-05-16 13:47:01Z raasch
+! bugfix for pgi 14.4: declare create moved after array declaration
+!
+! 1320 2014-03-20 08:40:49Z raasch
+! ONLY-attribute added to USE-statements,
+! kind-parameters added to all INTEGER and REAL declaration statements,
+! kinds are defined in new module kinds,
+! old module precision_kind is removed,
+! revision history before 2012 removed,
+! comment fields (!:) to be used for variable explanations added to
+! all variable declaration statements
+!
+! 1318 2014-03-17 13:35:16Z raasch
+! module interfaces removed
+!
+! 1306 2014-03-13 14:30:59Z raasch
+! openmp sections removed from the overlap branch,
+! second argument removed from parameter list
+!
+! 1216 2013-08-26 09:31:42Z raasch
+! resorting of arrays moved to separate routines resort_for_...,
+! one argument, used as temporary work array, removed from all transpose
+! routines
+! overlapping fft / transposition implemented
+!
+! 1212 2013-08-15 08:46:27Z raasch
+! tridia routines moved to seperate module tridia_solver
+!
+! 1208 2013-08-13 06:41:49Z raasch
+! acc-update clauses added for "ar" so that ffts other than cufft can also be
+! used (although they are not ported and will give a poor performance)
+!
+! 1111 2013-03-08 23:54:10Z raasch
+! further openACC porting of non-parallel (MPI) branch:
+! tridiagonal routines split into extermal subroutines (instead using CONTAINS),
+! no distinction between parallel/non-parallel in poisfft and tridia any more,
+! tridia routines moved to end of file because of probable bug in PGI compiler 12.5
+! (otherwise "invalid device function" is indicated during runtime),
+! optimization of tridia routines: constant elements and coefficients of tri are
+! stored in seperate arrays ddzuw and tric, last dimension of tri reduced from 5
+! to 2,
+! poisfft_init is now called internally from poisfft, maketri is called from
+! poisfft_init,
+! ibc_p_b = 2 removed
+!
+! 1106 2013-03-04 05:31:38Z raasch
+! routines fftx, ffty, fftxp, fftyp removed, calls replaced by fft_x, fft_y,
+! in the 1D-decomposition routines fft_x, ffty are replaced by fft_x_1d,
+! fft_y_1d
+!
+! 1103 2013-02-20 02:15:53Z raasch
+! tri, ar, and ar1 arguments in tridia-routines (2d) are removed because they
+! sometimes cause segmentation faults with intel 12.1 compiler
+!
+! 1092 2013-02-02 11:24:22Z raasch
+! unused variables removed
+!
+! 1036 2012-10-22 13:43:42Z raasch
+! code put under GPL (PALM 3.9)
+!
+! 2012-09-21 07:03:55Z raasch
+! FLOAT type conversion replaced by REAL
+!
+! 1003 2012-09-14 14:35:53Z raasch
+! indices nxa, nya, etc. replaced by nx, ny, etc.
+!
+! 940 2012-07-09 14:31:00Z raasch
+! special handling of tri-array as an argument in tridia_1dd routines switched
+! off because it caused segmentation faults with intel 12.1 compiler
+!
+! 877 2012-04-03 11:21:44Z suehring
+! Bugfix: Avoid divisions by zero in case of using a 'neumann' bc for the
+! pressure at the top of the model domain.
+!
+! 809 2012-01-30 13:32:58Z maronga
+! Bugfix: replaced .AND. and .NOT. with && and ! in the preprocessor directives
+!
+! 807 2012-01-25 11:53:51Z maronga
+! New cpp directive "__check" implemented which is used by check_namelist_files
+! (most of the code is unneeded by check_namelist_files).
+!
+! Revision 1.1  1997/07/24 11:24:14  raasch
+! Initial revision
+!
+!
+! Description:
+! ------------
+!> Solves the Poisson equation with a 2D spectral method
+!>        d^2 p / dx^2 + d^2 p / dy^2 + d^2 p / dz^2 = s
+!>
+!> Input:
+!> real    ar   contains (nnz,nny,nnx) elements of the velocity divergence,
+!>              starting from (1,nys,nxl)
+!>
+!> Output:
+!> real    ar   contains the solution for perturbation pressure p
+!------------------------------------------------------------------------------!
+ MODULE poisfft_mod
+ 
+
+    USE fft_xy,                                                                &
+        ONLY:  fft_init, fft_y, fft_y_1d, fft_y_m, fft_x, fft_x_1d, fft_x_m
+
+    USE indices,                                                               &
+        ONLY:  nnx, nny, nx, nxl, nxr, ny, nys, nyn, nz
+
+    USE transpose_indices,                                                     &
+        ONLY:  nxl_y, nxl_z, nxr_y, nxr_z, nys_x, nys_z, nyn_x, nyn_z, nzb_x,  &
+               nzb_y, nzt_x, nzt_y
+
+    USE tridia_solver,                                                         &
+        ONLY:  tridia_1dd, tridia_init, tridia_substi, tridia_substi_overlap
+
+    IMPLICIT NONE
+
+    LOGICAL, SAVE ::  poisfft_initialized = .FALSE.
+
+    PRIVATE
+
+    PUBLIC  poisfft, poisfft_init
+
+    INTERFACE poisfft
+       MODULE PROCEDURE poisfft
+    END INTERFACE poisfft
+
+    INTERFACE poisfft_init
+       MODULE PROCEDURE poisfft_init
+    END INTERFACE poisfft_init
+
+
+ CONTAINS
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> @todo Missing subroutine description.
+!------------------------------------------------------------------------------!
+    SUBROUTINE poisfft_init
+
+       USE arrays_3d,                                                          &
+           ONLY:  ddzu_pres, ddzw
+
+       USE kinds
+
+       IMPLICIT NONE
+
+       INTEGER(iwp) ::  k  !<
+
+
+       CALL fft_init
+
+       CALL tridia_init
+
+       poisfft_initialized = .TRUE.
+
+    END SUBROUTINE poisfft_init
+
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Two-dimensional Fourier Transformation in x- and y-direction.
+!------------------------------------------------------------------------------!
+    SUBROUTINE poisfft( ar )
+
+       USE control_parameters,                                                 &
+           ONLY:  fft_method, transpose_compute_overlap
+
+       USE cpulog,                                                             &
+           ONLY:  cpu_log, cpu_log_nowait, log_point_s
+
+       USE kinds
+
+       USE pegrid
+
+       IMPLICIT NONE
+
+       INTEGER(iwp) ::  ii           !<
+       INTEGER(iwp) ::  iind         !<
+       INTEGER(iwp) ::  inew         !<
+       INTEGER(iwp) ::  jj           !<
+       INTEGER(iwp) ::  jind         !<
+       INTEGER(iwp) ::  jnew         !<
+       INTEGER(iwp) ::  ki           !<
+       INTEGER(iwp) ::  kk           !<
+       INTEGER(iwp) ::  knew         !<
+       INTEGER(iwp) ::  n            !<
+       INTEGER(iwp) ::  nblk         !<
+       INTEGER(iwp) ::  nnx_y        !<
+       INTEGER(iwp) ::  nny_z        !<
+       INTEGER(iwp) ::  nnz_t        !<
+       INTEGER(iwp) ::  nnz_x        !<
+       INTEGER(iwp) ::  nxl_y_bound  !<
+       INTEGER(iwp) ::  nxr_y_bound  !<
+
+       INTEGER(iwp), DIMENSION(4) ::  isave  !<
+
+       REAL(wp), DIMENSION(1:nz,nys:nyn,nxl:nxr) ::  ar      !<
+       REAL(wp), DIMENSION(nys:nyn,nxl:nxr,1:nz) ::  ar_inv  !<
+       !$acc declare create( ar_inv )
+
+       REAL(wp), DIMENSION(:,:,:),   ALLOCATABLE ::  ar1      !<
+       REAL(wp), DIMENSION(:,:,:),   ALLOCATABLE ::  f_in     !<
+       REAL(wp), DIMENSION(:,:,:),   ALLOCATABLE ::  f_inv    !<
+       REAL(wp), DIMENSION(:,:,:),   ALLOCATABLE ::  f_out_y  !<
+       REAL(wp), DIMENSION(:,:,:),   ALLOCATABLE ::  f_out_z  !<
+
+
+       CALL cpu_log( log_point_s(3), 'poisfft', 'start' )
+
+       IF ( .NOT. poisfft_initialized )  CALL poisfft_init
+
+!
+!--    Two-dimensional Fourier Transformation in x- and y-direction.
+       IF ( pdims(2) == 1  .AND.  pdims(1) > 1  .AND.  num_acc_per_node == 0 ) &
+       THEN
+
+!
+!--       1d-domain-decomposition along x:
+!--       FFT along y and transposition y --> x
+          CALL ffty_tr_yx( ar, ar )
+
+!
+!--       FFT along x, solving the tridiagonal system and backward FFT
+          CALL fftx_tri_fftx( ar )
+
+!
+!--       Transposition x --> y and backward FFT along y
+          CALL tr_xy_ffty( ar, ar )
+
+       ELSEIF ( pdims(1) == 1 .AND. pdims(2) > 1 .AND. num_acc_per_node == 0 ) &
+       THEN
+
+!
+!--       1d-domain-decomposition along y:
+!--       FFT along x and transposition x --> y
+          CALL fftx_tr_xy( ar, ar )
+
+!
+!--       FFT along y, solving the tridiagonal system and backward FFT
+          CALL ffty_tri_ffty( ar )
+
+!
+!--       Transposition y --> x and backward FFT along x
+          CALL tr_yx_fftx( ar, ar )
+
+       ELSEIF ( .NOT. transpose_compute_overlap )  THEN
+
+!
+!--       2d-domain-decomposition or no decomposition (1 PE run)
+!--       Transposition z --> x
+          CALL cpu_log( log_point_s(5), 'transpo forward', 'start' )
+          CALL resort_for_zx( ar, ar_inv )
+          CALL transpose_zx( ar_inv, ar )
+          CALL cpu_log( log_point_s(5), 'transpo forward', 'pause' )
+
+          CALL cpu_log( log_point_s(4), 'fft_x', 'start' )
+          IF ( fft_method /= 'system-specific' )  THEN
+             !$acc update host( ar )
+          ENDIF
+          CALL fft_x( ar, 'forward' )
+          IF ( fft_method /= 'system-specific' )  THEN
+             !$acc update device( ar )
+          ENDIF
+          CALL cpu_log( log_point_s(4), 'fft_x', 'pause' )
+
+!
+!--       Transposition x --> y
+          CALL cpu_log( log_point_s(5), 'transpo forward', 'continue' )
+          CALL resort_for_xy( ar, ar_inv )
+          CALL transpose_xy( ar_inv, ar )
+          CALL cpu_log( log_point_s(5), 'transpo forward', 'pause' )
+
+          CALL cpu_log( log_point_s(7), 'fft_y', 'start' )
+          IF ( fft_method /= 'system-specific' )  THEN
+             !$acc update host( ar )
+          ENDIF
+          CALL fft_y( ar, 'forward', ar_tr = ar,                &
+                      nxl_y_bound = nxl_y, nxr_y_bound = nxr_y, &
+                      nxl_y_l = nxl_y, nxr_y_l = nxr_y )
+          IF ( fft_method /= 'system-specific' )  THEN
+             !$acc update device( ar )
+          ENDIF
+          CALL cpu_log( log_point_s(7), 'fft_y', 'pause' )
+
+!
+!--       Transposition y --> z
+          CALL cpu_log( log_point_s(5), 'transpo forward', 'continue' )
+          CALL resort_for_yz( ar, ar_inv )
+          CALL transpose_yz( ar_inv, ar )
+          CALL cpu_log( log_point_s(5), 'transpo forward', 'stop' )
+
+!
+!--       Solve the tridiagonal equation system along z
+          CALL cpu_log( log_point_s(6), 'tridia', 'start' )
+          CALL tridia_substi( ar )
+          CALL cpu_log( log_point_s(6), 'tridia', 'stop' )
+
+!
+!--       Inverse Fourier Transformation
+!--       Transposition z --> y
+          CALL cpu_log( log_point_s(8), 'transpo invers', 'start' )
+          CALL transpose_zy( ar, ar_inv )
+          CALL resort_for_zy( ar_inv, ar )
+          CALL cpu_log( log_point_s(8), 'transpo invers', 'pause' )
+
+          CALL cpu_log( log_point_s(7), 'fft_y', 'continue' )
+          IF ( fft_method /= 'system-specific' )  THEN
+             !$acc update host( ar )
+          ENDIF
+          CALL fft_y( ar, 'backward', ar_tr = ar,               &
+                      nxl_y_bound = nxl_y, nxr_y_bound = nxr_y, &
+                      nxl_y_l = nxl_y, nxr_y_l = nxr_y )
+          IF ( fft_method /= 'system-specific' )  THEN
+             !$acc update device( ar )
+          ENDIF
+          CALL cpu_log( log_point_s(7), 'fft_y', 'stop' )
+
+!
+!--       Transposition y --> x
+          CALL cpu_log( log_point_s(8), 'transpo invers', 'continue' )
+          CALL transpose_yx( ar, ar_inv )
+          CALL resort_for_yx( ar_inv, ar )
+          CALL cpu_log( log_point_s(8), 'transpo invers', 'pause' )
+
+          CALL cpu_log( log_point_s(4), 'fft_x', 'continue' )
+          IF ( fft_method /= 'system-specific' )  THEN
+             !$acc update host( ar )
+          ENDIF
+          CALL fft_x( ar, 'backward' )
+          IF ( fft_method /= 'system-specific' )  THEN
+             !$acc update device( ar )
+          ENDIF
+          CALL cpu_log( log_point_s(4), 'fft_x', 'stop' )
+
+!
+!--       Transposition x --> z
+          CALL cpu_log( log_point_s(8), 'transpo invers', 'continue' )
+          CALL transpose_xz( ar, ar_inv )
+          CALL resort_for_xz( ar_inv, ar )
+          CALL cpu_log( log_point_s(8), 'transpo invers', 'stop' )
+
+       ELSE
+
+!
+!--       2d-domain-decomposition or no decomposition (1 PE run) with
+!--       overlapping transposition / fft
+!--       cputime logging must not use barriers, which would prevent overlapping
+          ALLOCATE( f_out_y(0:ny,nxl_y:nxr_y,nzb_y:nzt_y), &
+                    f_out_z(0:nx,nys_x:nyn_x,nzb_x:nzt_x) )
+!
+!--       Transposition z --> x + subsequent fft along x
+          ALLOCATE( f_inv(nys:nyn,nxl:nxr,1:nz) )
+          CALL resort_for_zx( ar, f_inv )
+!
+!--       Save original indices and gridpoint counter
+          isave(1) = nz
+          isave(2) = nzb_x
+          isave(3) = nzt_x
+          isave(4) = sendrecvcount_zx
+!
+!--       Set new indices for transformation
+          nblk  = nz / pdims(1)
+          nz    = pdims(1)
+          nnz_x = 1
+          nzb_x = 1 + myidx * nnz_x
+          nzt_x = ( myidx + 1 ) * nnz_x
+          sendrecvcount_zx = nnx * nny * nnz_x
+
+          ALLOCATE( ar1(0:nx,nys_x:nyn_x,nzb_x:nzt_x) )
+          ALLOCATE( f_in(nys:nyn,nxl:nxr,1:nz) )
+
+          DO  kk = 1, nblk
+
+             IF ( kk == 1 )  THEN
+                CALL cpu_log( log_point_s(5), 'transpo forward', 'start', cpu_log_nowait )
+             ELSE
+                CALL cpu_log( log_point_s(5), 'transpo forward', 'continue', cpu_log_nowait )
+             ENDIF
+
+             DO  knew = 1, nz
+                ki = kk + nblk * ( knew - 1 )
+                f_in(:,:,knew) = f_inv(:,:,ki)
+             ENDDO
+
+             CALL transpose_zx( f_in, ar1(:,:,:))
+             CALL cpu_log( log_point_s(5), 'transpo forward', 'pause' )
+
+             IF ( kk == 1 )  THEN
+                CALL cpu_log( log_point_s(4), 'fft_x', 'start', cpu_log_nowait )
+             ELSE
+                CALL cpu_log( log_point_s(4), 'fft_x', 'continue', cpu_log_nowait )
+             ENDIF
+
+             n = isave(2) + kk - 1
+             CALL fft_x( ar1(:,:,:), 'forward',  ar_2d = f_out_z(:,:,n))
+             CALL cpu_log( log_point_s(4), 'fft_x', 'pause' )
+
+          ENDDO
+!
+!--       Restore original indices/counters
+          nz               = isave(1)
+          nzb_x            = isave(2)
+          nzt_x            = isave(3)
+          sendrecvcount_zx = isave(4)
+
+          DEALLOCATE( ar1, f_in, f_inv )
+
+!
+!--       Transposition x --> y + subsequent fft along y
+          ALLOCATE( f_inv(nys_x:nyn_x,nzb_x:nzt_x,0:nx) )
+          CALL resort_for_xy( f_out_z, f_inv )
+!
+!--       Save original indices and gridpoint counter
+          isave(1) = nx
+          isave(2) = nxl_y
+          isave(3) = nxr_y
+          isave(4) = sendrecvcount_xy
+!
+!--       Set new indices for transformation
+          nblk  = ( ( nx+1 ) / pdims(2) ) - 1
+          nx    = pdims(2)
+          nnx_y = 1
+          nxl_y = myidy * nnx_y
+          nxr_y = ( myidy + 1 ) * nnx_y - 1
+          sendrecvcount_xy = nnx_y * ( nyn_x-nys_x+1 ) * ( nzt_x-nzb_x+1 )
+
+          ALLOCATE( ar1(0:ny,nxl_y:nxr_y,nzb_y:nzt_y) )
+          ALLOCATE( f_in(nys_x:nyn_x,nzb_x:nzt_x,0:nx) )
+
+          DO  ii = 0, nblk
+
+             CALL cpu_log( log_point_s(5), 'transpo forward', 'continue', cpu_log_nowait )
+
+             DO  inew = 0, nx-1
+                iind = ii + ( nblk + 1 ) * inew
+                f_in(:,:,inew) = f_inv(:,:,iind)
+             ENDDO
+
+             CALL transpose_xy( f_in, ar1(:,:,:) )
+
+             CALL cpu_log( log_point_s(5), 'transpo forward', 'pause' )
+
+             IF ( ii == 1 )  THEN
+                CALL cpu_log( log_point_s(7), 'fft_y', 'start', cpu_log_nowait )
+             ELSE
+                CALL cpu_log( log_point_s(7), 'fft_y', 'continue', cpu_log_nowait )
+             ENDIF
+
+             nxl_y_bound = isave(2)
+             nxr_y_bound = isave(3)
+             n           = isave(2) + ii
+             CALL fft_y( ar1(:,:,:), 'forward', ar_tr = f_out_y,               &
+                         nxl_y_bound = nxl_y_bound, nxr_y_bound = nxr_y_bound, &
+                         nxl_y_l = n, nxr_y_l = n )
+
+             CALL cpu_log( log_point_s(7), 'fft_y', 'pause' )
+
+          ENDDO
+!
+!--       Restore original indices/counters
+          nx               = isave(1)
+          nxl_y            = isave(2)
+          nxr_y            = isave(3)
+          sendrecvcount_xy = isave(4)
+
+          DEALLOCATE( ar1, f_in, f_inv )
+
+!
+!--       Transposition y --> z + subsequent tridia + resort for z --> y
+          ALLOCATE( f_inv(nxl_y:nxr_y,nzb_y:nzt_y,0:ny) )
+          CALL resort_for_yz( f_out_y, f_inv )
+!
+!--       Save original indices and gridpoint counter
+          isave(1) = ny
+          isave(2) = nys_z
+          isave(3) = nyn_z
+          isave(4) = sendrecvcount_yz
+!
+!--       Set new indices for transformation
+          nblk             = ( ( ny+1 ) / pdims(1) ) - 1
+          ny               = pdims(1)
+          nny_z            = 1
+          nys_z            = myidx * nny_z
+          nyn_z            = ( myidx + 1 ) * nny_z - 1
+          sendrecvcount_yz = ( nxr_y-nxl_y+1 ) * nny_z * ( nzt_y-nzb_y+1 )
+
+          ALLOCATE( ar1(nxl_z:nxr_z,nys_z:nyn_z,1:nz) )
+          ALLOCATE( f_in(nxl_y:nxr_y,nzb_y:nzt_y,0:ny) )
+
+          DO  jj = 0, nblk
+!
+!--          Forward Fourier Transformation
+!--          Transposition y --> z
+             CALL cpu_log( log_point_s(5), 'transpo forward', 'continue', cpu_log_nowait )
+
+             DO  jnew = 0, ny-1
+                jind = jj + ( nblk + 1 ) * jnew
+                f_in(:,:,jnew) = f_inv(:,:,jind)
+             ENDDO
+
+             CALL transpose_yz( f_in, ar1(:,:,:) )
+
+             IF ( jj == nblk )  THEN
+                CALL cpu_log( log_point_s(5), 'transpo forward', 'stop' )
+             ELSE
+                CALL cpu_log( log_point_s(5), 'transpo forward', 'pause' )
+             ENDIF
+
+!
+!--          Solve the tridiagonal equation system along z
+             CALL cpu_log( log_point_s(6), 'tridia', 'start', cpu_log_nowait )
+
+             n = isave(2) + jj
+             CALL tridia_substi_overlap( ar1(:,:,:), n )
+
+             CALL cpu_log( log_point_s(6), 'tridia', 'stop' )
+
+!
+!--          Inverse Fourier Transformation
+!--          Transposition z --> y
+!--          Only one thread should call MPI routines, therefore forward and
+!--          backward tranpose are in the same section
+             IF ( jj == 0 )  THEN
+                CALL cpu_log( log_point_s(8), 'transpo invers', 'start', cpu_log_nowait )
+             ELSE
+                CALL cpu_log( log_point_s(8), 'transpo invers', 'continue', cpu_log_nowait )
+             ENDIF
+
+             CALL transpose_zy( ar1(:,:,:), f_in )
+
+             DO  jnew = 0, ny-1
+                jind = jj + ( nblk + 1 ) * jnew
+                f_inv(:,:,jind) = f_in(:,:,jnew)
+             ENDDO
+
+             CALL cpu_log( log_point_s(8), 'transpo invers', 'pause' )
+
+          ENDDO
+!
+!--       Restore original indices/counters
+          ny               = isave(1)
+          nys_z            = isave(2)
+          nyn_z            = isave(3)
+          sendrecvcount_yz = isave(4)
+
+          CALL resort_for_zy( f_inv, f_out_y )
+
+          DEALLOCATE( ar1, f_in, f_inv )
+
+!
+!--       fft along y backward + subsequent transposition y --> x
+          ALLOCATE( f_inv(nys_x:nyn_x,nzb_x:nzt_x,0:nx) )
+!
+!--       Save original indices and gridpoint counter
+          isave(1) = nx
+          isave(2) = nxl_y
+          isave(3) = nxr_y
+          isave(4) = sendrecvcount_xy
+!
+!--       Set new indices for transformation
+          nblk             = (( nx+1 ) / pdims(2) ) - 1
+          nx               = pdims(2)
+          nnx_y            = 1
+          nxl_y            = myidy * nnx_y
+          nxr_y            = ( myidy + 1 ) * nnx_y - 1
+          sendrecvcount_xy = nnx_y * ( nyn_x-nys_x+1 ) * ( nzt_x-nzb_x+1 )
+
+          ALLOCATE( ar1(0:ny,nxl_y:nxr_y,nzb_y:nzt_y) )
+          ALLOCATE( f_in(nys_x:nyn_x,nzb_x:nzt_x,0:nx) )
+
+          DO  ii = 0, nblk
+
+             CALL cpu_log( log_point_s(7), 'fft_y', 'continue', cpu_log_nowait )
+
+             n = isave(2) + ii
+             nxl_y_bound = isave(2)
+             nxr_y_bound = isave(3)
+
+             CALL fft_y( ar1(:,:,:), 'backward', ar_tr = f_out_y,              &
+                         nxl_y_bound = nxl_y_bound, nxr_y_bound = nxr_y_bound, &
+                         nxl_y_l = n, nxr_y_l = n )
+
+             IF ( ii == nblk )  THEN
+                CALL cpu_log( log_point_s(7), 'fft_y', 'stop' )
+             ELSE
+                CALL cpu_log( log_point_s(7), 'fft_y', 'pause' )
+             ENDIF
+
+             CALL cpu_log( log_point_s(8), 'transpo invers', 'continue', cpu_log_nowait )
+
+             CALL transpose_yx( ar1(:,:,:), f_in )
+
+             DO  inew = 0, nx-1
+                iind = ii + (nblk+1) * inew
+                f_inv(:,:,iind) = f_in(:,:,inew)
+             ENDDO
+
+             CALL cpu_log( log_point_s(8), 'transpo invers', 'pause' )
+
+          ENDDO
+!
+!--       Restore original indices/counters
+          nx               = isave(1)
+          nxl_y            = isave(2)
+          nxr_y            = isave(3)
+          sendrecvcount_xy = isave(4)
+
+          CALL resort_for_yx( f_inv, f_out_z )
+
+          DEALLOCATE( ar1, f_in, f_inv )
+
+!
+!--       fft along x backward + subsequent final transposition x --> z
+          ALLOCATE( f_inv(nys:nyn,nxl:nxr,1:nz) )
+!
+!--       Save original indices and gridpoint counter
+          isave(1) = nz
+          isave(2) = nzb_x
+          isave(3) = nzt_x
+          isave(4) = sendrecvcount_zx
+!
+!--       Set new indices for transformation
+          nblk             = nz / pdims(1)
+          nz               = pdims(1)
+          nnz_x            = 1
+          nzb_x            = 1 + myidx * nnz_x
+          nzt_x            = ( myidx + 1 ) * nnz_x
+          sendrecvcount_zx = nnx * nny * nnz_x
+
+          ALLOCATE( ar1(0:nx,nys_x:nyn_x,nzb_x:nzt_x) )
+          ALLOCATE( f_in(nys:nyn,nxl:nxr,1:nz) )
+
+          DO  kk = 1, nblk
+
+             CALL cpu_log( log_point_s(4), 'fft_x', 'continue', cpu_log_nowait )
+
+             n = isave(2) + kk - 1
+             CALL fft_x( ar1(:,:,:), 'backward', f_out_z(:,:,n))
+
+             IF ( kk == nblk )  THEN
+                CALL cpu_log( log_point_s(4), 'fft_x', 'stop' )
+             ELSE
+                CALL cpu_log( log_point_s(4), 'fft_x', 'pause' )
+             ENDIF
+
+             CALL cpu_log( log_point_s(8), 'transpo invers', 'continue', cpu_log_nowait )
+
+             CALL transpose_xz( ar1(:,:,:), f_in )
+
+             DO  knew = 1, nz
+                ki = kk + nblk * (knew-1)
+                f_inv(:,:,ki) = f_in(:,:,knew)
+             ENDDO
+
+             IF ( kk == nblk )  THEN
+                CALL cpu_log( log_point_s(8), 'transpo invers', 'stop' )
+             ELSE
+                CALL cpu_log( log_point_s(8), 'transpo invers', 'pause' )
+             ENDIF
+
+          ENDDO
+!
+!--       Restore original indices/counters
+          nz               = isave(1)
+          nzb_x            = isave(2)
+          nzt_x            = isave(3)
+          sendrecvcount_zx = isave(4)
+
+          CALL resort_for_xz( f_inv, ar )
+
+          DEALLOCATE( ar1, f_in, f_inv )
+
+       ENDIF
+
+       CALL cpu_log( log_point_s(3), 'poisfft', 'stop' )
+
+    END SUBROUTINE poisfft
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Fourier-transformation along y with subsequent transposition y --> x for
+!> a 1d-decomposition along x.
+!>
+!> @attention The performance of this routine is much faster on the NEC-SX6,
+!>            if the first index of work_ffty_vec is odd. Otherwise
+!>            memory bank conflicts may occur (especially if the index is a
+!>            multiple of 128). That's why work_ffty_vec is dimensioned as
+!>            0:ny+1.
+!>            Of course, this will not work if users are using an odd number
+!>            of gridpoints along y.
+!------------------------------------------------------------------------------!
+    SUBROUTINE ffty_tr_yx( f_in, f_out )
+
+
+       USE control_parameters,                                                 &
+           ONLY:  host
+
+       USE cpulog,                                                             &
+           ONLY:  cpu_log, log_point_s
+
+       USE kinds
+
+       USE pegrid
+
+       IMPLICIT NONE
+
+       INTEGER(iwp)            ::  i            !<
+       INTEGER(iwp)            ::  iend         !<
+       INTEGER(iwp)            ::  iouter       !<
+       INTEGER(iwp)            ::  ir           !<
+       INTEGER(iwp)            ::  j            !<
+       INTEGER(iwp)            ::  k            !<
+
+       INTEGER(iwp), PARAMETER ::  stridex = 4  !<
+
+       REAL(wp), DIMENSION(0:ny,stridex)        ::  work_ffty      !<
+#if defined( __nec )
+       REAL(wp), DIMENSION(0:ny+1,1:nz,nxl:nxr) ::  work_ffty_vec  !<
+#endif
+       REAL(wp), DIMENSION(1:nz,0:ny,nxl:nxr)             ::  f_in   !<
+       REAL(wp), DIMENSION(nnx,1:nz,nys_x:nyn_x,pdims(1)) ::  f_out  !<
+       REAL(wp), DIMENSION(nxl:nxr,1:nz,0:ny)             ::  work   !<
+
+!
+!--    Carry out the FFT along y, where all data are present due to the
+!--    1d-decomposition along x. Resort the data in a way that x becomes
+!--    the first index.
+       CALL cpu_log( log_point_s(7), 'fft_y_1d', 'start' )
+
+       IF ( host(1:3) == 'nec' )  THEN
+#if defined( __nec )
+!
+!--       Code optimized for vector processors
+!$OMP     PARALLEL PRIVATE ( i, j, k )
+!$OMP     DO
+          DO  i = nxl, nxr
+
+             DO  j = 0, ny
+                DO  k = 1, nz
+                   work_ffty_vec(j,k,i) = f_in(k,j,i)
+                ENDDO
+             ENDDO
+
+             CALL fft_y_m( work_ffty_vec(:,:,i), ny+1, 'forward' )
+
+          ENDDO
+
+!$OMP     DO
+          DO  k = 1, nz
+             DO  j = 0, ny
+                DO  i = nxl, nxr
+                   work(i,k,j) = work_ffty_vec(j,k,i)
+                ENDDO
+             ENDDO
+          ENDDO
+!$OMP     END PARALLEL
+#endif
+
+       ELSE
+
+!
+!--       Cache optimized code.
+!--       The i-(x-)direction is split into a strided outer loop and an inner
+!--       loop for better cache performance
+!$OMP     PARALLEL PRIVATE (i,iend,iouter,ir,j,k,work_ffty)
+!$OMP     DO
+          DO  iouter = nxl, nxr, stridex
+
+             iend = MIN( iouter+stridex-1, nxr )  ! Upper bound for inner i loop
+
+             DO  k = 1, nz
+
+                DO  i = iouter, iend
+
+                   ir = i-iouter+1  ! counter within a stride
+                   DO  j = 0, ny
+                      work_ffty(j,ir) = f_in(k,j,i)
+                   ENDDO
+!
+!--                FFT along y
+                   CALL fft_y_1d( work_ffty(:,ir), 'forward' )
+
+                ENDDO
+
+!
+!--             Resort
+                DO  j = 0, ny
+                   DO  i = iouter, iend
+                      work(i,k,j) = work_ffty(j,i-iouter+1)
+                   ENDDO
+                ENDDO
+
+             ENDDO
+
+          ENDDO
+!$OMP     END PARALLEL
+
+       ENDIF
+       CALL cpu_log( log_point_s(7), 'fft_y_1d', 'pause' )
+
+!
+!--    Transpose array
+#if defined( __parallel )
+       CALL cpu_log( log_point_s(32), 'mpi_alltoall', 'start' )
+       IF ( collective_wait )  CALL MPI_BARRIER( comm2d, ierr )
+       CALL MPI_ALLTOALL( work(nxl,1,0),      sendrecvcount_xy, MPI_REAL, &
+                          f_out(1,1,nys_x,1), sendrecvcount_xy, MPI_REAL, &
+                          comm1dx, ierr )
+       CALL cpu_log( log_point_s(32), 'mpi_alltoall', 'stop' )
+#endif
+
+    END SUBROUTINE ffty_tr_yx
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!>  Transposition x --> y with a subsequent backward Fourier transformation for
+!>  a 1d-decomposition along x
+!------------------------------------------------------------------------------!
+    SUBROUTINE tr_xy_ffty( f_in, f_out )
+
+
+       USE control_parameters,                                                 &
+           ONLY:  host
+
+       USE cpulog,                                                             &
+           ONLY:  cpu_log, log_point_s
+
+       USE kinds
+
+       USE pegrid
+
+       IMPLICIT NONE
+
+       INTEGER(iwp)            ::  i            !<
+       INTEGER(iwp)            ::  iend         !<
+       INTEGER(iwp)            ::  iouter       !<
+       INTEGER(iwp)            ::  ir           !<
+       INTEGER(iwp)            ::  j            !<
+       INTEGER(iwp)            ::  k            !<
+
+       INTEGER(iwp), PARAMETER ::  stridex = 4  !<
+
+       REAL(wp), DIMENSION(0:ny,stridex)        ::  work_ffty      !<
+#if defined( __nec )
+       REAL(wp), DIMENSION(0:ny+1,1:nz,nxl:nxr) ::  work_ffty_vec  !<
+#endif
+       REAL(wp), DIMENSION(nnx,1:nz,nys_x:nyn_x,pdims(1)) ::  f_in   !<
+       REAL(wp), DIMENSION(1:nz,0:ny,nxl:nxr)             ::  f_out  !<
+       REAL(wp), DIMENSION(nxl:nxr,1:nz,0:ny)             ::  work   !<
+
+!
+!--    Transpose array
+#if defined( __parallel )
+       CALL cpu_log( log_point_s(32), 'mpi_alltoall', 'start' )
+       IF ( collective_wait )  CALL MPI_BARRIER( comm2d, ierr )
+       CALL MPI_ALLTOALL( f_in(1,1,nys_x,1), sendrecvcount_xy, MPI_REAL, &
+                          work(nxl,1,0),     sendrecvcount_xy, MPI_REAL, &
+                          comm1dx, ierr )
+       CALL cpu_log( log_point_s(32), 'mpi_alltoall', 'stop' )
+#endif
+
+!
+!--    Resort the data in a way that y becomes the first index and carry out the
+!--    backward fft along y.
+       CALL cpu_log( log_point_s(7), 'fft_y_1d', 'continue' )
+
+       IF ( host(1:3) == 'nec' )  THEN
+#if defined( __nec )
+!
+!--       Code optimized for vector processors
+!$OMP     PARALLEL PRIVATE ( i, j, k )
+!$OMP     DO
+          DO  k = 1, nz
+             DO  j = 0, ny
+                DO  i = nxl, nxr
+                   work_ffty_vec(j,k,i) = work(i,k,j)
+                ENDDO
+             ENDDO
+          ENDDO
+
+!$OMP     DO
+          DO  i = nxl, nxr
+
+             CALL fft_y_m( work_ffty_vec(:,:,i), ny+1, 'backward' )
+
+             DO  j = 0, ny
+                DO  k = 1, nz
+                   f_out(k,j,i) = work_ffty_vec(j,k,i)
+                ENDDO
+             ENDDO
+
+          ENDDO
+!$OMP     END PARALLEL
+#endif
+
+       ELSE
+
+!
+!--       Cache optimized code.
+!--       The i-(x-)direction is split into a strided outer loop and an inner
+!--       loop for better cache performance
+!$OMP     PARALLEL PRIVATE ( i, iend, iouter, ir, j, k, work_ffty )
+!$OMP     DO
+          DO  iouter = nxl, nxr, stridex
+
+             iend = MIN( iouter+stridex-1, nxr )  ! Upper bound for inner i loop
+
+             DO  k = 1, nz
+!
+!--             Resort
+                DO  j = 0, ny
+                   DO  i = iouter, iend
+                      work_ffty(j,i-iouter+1) = work(i,k,j)
+                   ENDDO
+                ENDDO
+
+                DO  i = iouter, iend
+
+!
+!--                FFT along y
+                   ir = i-iouter+1  ! counter within a stride
+                   CALL fft_y_1d( work_ffty(:,ir), 'backward' )
+
+                   DO  j = 0, ny
+                      f_out(k,j,i) = work_ffty(j,ir)
+                   ENDDO
+                ENDDO
+
+             ENDDO
+
+          ENDDO
+!$OMP     END PARALLEL
+
+       ENDIF
+
+       CALL cpu_log( log_point_s(7), 'fft_y_1d', 'stop' )
+
+    END SUBROUTINE tr_xy_ffty
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> FFT along x, solution of the tridiagonal system and backward FFT for
+!> a 1d-decomposition along x
+!>
+!> @warning this subroutine may still not work for hybrid parallelization
+!>          with OpenMP (for possible necessary changes see the original
+!>          routine poisfft_hybrid, developed by Klaus Ketelsen, May 2002)
+!------------------------------------------------------------------------------!
+    SUBROUTINE fftx_tri_fftx( ar )
+
+
+       USE control_parameters,                                                 &
+           ONLY:  host
+
+       USE cpulog,                                                             &
+           ONLY:  cpu_log, log_point_s
+
+       USE grid_variables,                                                     &
+           ONLY:  ddx2, ddy2
+
+       USE kinds
+
+       USE pegrid
+
+       IMPLICIT NONE
+
+       INTEGER(iwp) ::  i                   !<
+       INTEGER(iwp) ::  j                   !<
+       INTEGER(iwp) ::  k                   !<
+       INTEGER(iwp) ::  m                   !<
+       INTEGER(iwp) ::  n                   !<
+       INTEGER(iwp) ::  omp_get_thread_num  !<
+       INTEGER(iwp) ::  tn                  !<
+
+       REAL(wp), DIMENSION(0:nx)                          ::  work_fftx  !<
+       REAL(wp), DIMENSION(0:nx,1:nz)                     ::  work_trix  !<
+       REAL(wp), DIMENSION(nnx,1:nz,nys_x:nyn_x,pdims(1)) ::  ar         !<
+       REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE          ::  tri        !<
+
+
+       CALL cpu_log( log_point_s(33), 'fft_x_1d + tridia', 'start' )
+
+       ALLOCATE( tri(5,0:nx,0:nz-1,0:threads_per_task-1) )
+
+       tn = 0              ! Default thread number in case of one thread
+!$OMP  PARALLEL DO PRIVATE ( i, j, k, m, n, tn, work_fftx, work_trix )
+       DO  j = nys_x, nyn_x
+
+!$        tn = omp_get_thread_num()
+
+          IF ( host(1:3) == 'nec' )  THEN
+!
+!--          Code optimized for vector processors
+             DO  k = 1, nz
+
+                m = 0
+                DO  n = 1, pdims(1)
+                   DO  i = 1, nnx
+                      work_trix(m,k) = ar(i,k,j,n)
+                      m = m + 1
+                   ENDDO
+                ENDDO
+
+             ENDDO
+
+             CALL fft_x_m( work_trix, 'forward' )
+
+          ELSE
+!
+!--          Cache optimized code
+             DO  k = 1, nz
+
+                m = 0
+                DO  n = 1, pdims(1)
+                   DO  i = 1, nnx
+                      work_fftx(m) = ar(i,k,j,n)
+                      m = m + 1
+                   ENDDO
+                ENDDO
+
+                CALL fft_x_1d( work_fftx, 'forward' )
+
+                DO  i = 0, nx
+                   work_trix(i,k) = work_fftx(i)
+                ENDDO
+
+             ENDDO
+
+          ENDIF
+
+!
+!--       Solve the linear equation system
+          CALL tridia_1dd( ddx2, ddy2, nx, ny, j, work_trix, tri(:,:,:,tn) )
+
+          IF ( host(1:3) == 'nec' )  THEN
+!
+!--          Code optimized for vector processors
+             CALL fft_x_m( work_trix, 'backward' )
+
+             DO  k = 1, nz
+
+                m = 0
+                DO  n = 1, pdims(1)
+                   DO  i = 1, nnx
+                      ar(i,k,j,n) = work_trix(m,k)
+                      m = m + 1
+                   ENDDO
+                ENDDO
+
+             ENDDO
+
+          ELSE
+!
+!--          Cache optimized code
+             DO  k = 1, nz
+
+                DO  i = 0, nx
+                   work_fftx(i) = work_trix(i,k)
+                ENDDO
+
+                CALL fft_x_1d( work_fftx, 'backward' )
+
+                m = 0
+                DO  n = 1, pdims(1)
+                   DO  i = 1, nnx
+                      ar(i,k,j,n) = work_fftx(m)
+                      m = m + 1
+                   ENDDO
+                ENDDO
+
+             ENDDO
+
+          ENDIF
+
+       ENDDO
+
+       DEALLOCATE( tri )
+
+       CALL cpu_log( log_point_s(33), 'fft_x_1d + tridia', 'stop' )
+
+    END SUBROUTINE fftx_tri_fftx
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Fourier-transformation along x with subsequent transposition x --> y for
+!> a 1d-decomposition along y.
+!>
+!> @attention NEC-branch of this routine may significantly profit from
+!>            further optimizations. So far, performance is much worse than
+!>            for routine ffty_tr_yx (more than three times slower).
+!------------------------------------------------------------------------------!
+    SUBROUTINE fftx_tr_xy( f_in, f_out )
+
+
+       USE control_parameters,                                                 &
+           ONLY:  host
+
+       USE cpulog,                                                             &
+           ONLY:  cpu_log, log_point_s
+
+       USE kinds
+
+       USE pegrid
+
+       IMPLICIT NONE
+
+       INTEGER(iwp) ::  i  !<
+       INTEGER(iwp) ::  j  !<
+       INTEGER(iwp) ::  k  !<
+
+       REAL(wp), DIMENSION(0:nx,1:nz,nys:nyn)             ::  work_fftx  !<
+       REAL(wp), DIMENSION(1:nz,nys:nyn,0:nx)             ::  f_in       !<
+       REAL(wp), DIMENSION(nny,1:nz,nxl_y:nxr_y,pdims(2)) ::  f_out      !<
+       REAL(wp), DIMENSION(nys:nyn,1:nz,0:nx)             ::  work       !<
+
+!
+!--    Carry out the FFT along x, where all data are present due to the
+!--    1d-decomposition along y. Resort the data in a way that y becomes
+!--    the first index.
+       CALL cpu_log( log_point_s(4), 'fft_x_1d', 'start' )
+
+       IF ( host(1:3) == 'nec' )  THEN
+!
+!--       Code for vector processors
+!$OMP     PARALLEL PRIVATE ( i, j, k )
+!$OMP     DO
+          DO  i = 0, nx
+
+             DO  j = nys, nyn
+                DO  k = 1, nz
+                   work_fftx(i,k,j) = f_in(k,j,i)
+                ENDDO
+             ENDDO
+
+          ENDDO
+
+!$OMP     DO
+          DO  j = nys, nyn
+
+             CALL fft_x_m( work_fftx(:,:,j), 'forward' )
+
+             DO  k = 1, nz
+                DO  i = 0, nx
+                   work(j,k,i) = work_fftx(i,k,j)
+                ENDDO
+             ENDDO
+
+          ENDDO
+!$OMP     END PARALLEL
+
+       ELSE
+
+!
+!--       Cache optimized code (there might be still a potential for better
+!--       optimization).
+!$OMP     PARALLEL PRIVATE (i,j,k)
+!$OMP     DO
+          DO  i = 0, nx
+
+             DO  j = nys, nyn
+                DO  k = 1, nz
+                   work_fftx(i,k,j) = f_in(k,j,i)
+                ENDDO
+             ENDDO
+
+          ENDDO
+
+!$OMP     DO
+          DO  j = nys, nyn
+             DO  k = 1, nz
+
+                CALL fft_x_1d( work_fftx(0:nx,k,j), 'forward' )
+
+                DO  i = 0, nx
+                   work(j,k,i) = work_fftx(i,k,j)
+                ENDDO
+             ENDDO
+
+          ENDDO
+!$OMP     END PARALLEL
+
+       ENDIF
+       CALL cpu_log( log_point_s(4), 'fft_x_1d', 'pause' )
+
+!
+!--    Transpose array
+#if defined( __parallel )
+       CALL cpu_log( log_point_s(32), 'mpi_alltoall', 'start' )
+       IF ( collective_wait )  CALL MPI_BARRIER( comm2d, ierr )
+       CALL MPI_ALLTOALL( work(nys,1,0),      sendrecvcount_xy, MPI_REAL, &
+                          f_out(1,1,nxl_y,1), sendrecvcount_xy, MPI_REAL, &
+                          comm1dy, ierr )
+       CALL cpu_log( log_point_s(32), 'mpi_alltoall', 'stop' )
+#endif
+
+    END SUBROUTINE fftx_tr_xy
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Transposition y --> x with a subsequent backward Fourier transformation for
+!> a 1d-decomposition along x.
+!------------------------------------------------------------------------------!
+    SUBROUTINE tr_yx_fftx( f_in, f_out )
+
+
+       USE control_parameters,                                                 &
+           ONLY:  host
+
+       USE cpulog,                                                             &
+           ONLY:  cpu_log, log_point_s
+
+       USE kinds
+
+       USE pegrid
+
+       IMPLICIT NONE
+
+       INTEGER(iwp) ::  i  !<
+       INTEGER(iwp) ::  j  !<
+       INTEGER(iwp) ::  k  !<
+
+       REAL(wp), DIMENSION(0:nx,1:nz,nys:nyn)             ::  work_fftx  !<
+       REAL(wp), DIMENSION(nny,1:nz,nxl_y:nxr_y,pdims(2)) ::  f_in       !<
+       REAL(wp), DIMENSION(1:nz,nys:nyn,0:nx)             ::  f_out      !<
+       REAL(wp), DIMENSION(nys:nyn,1:nz,0:nx)             ::  work       !<
+
+!
+!--    Transpose array
+#if defined( __parallel )
+       CALL cpu_log( log_point_s(32), 'mpi_alltoall', 'start' )
+       IF ( collective_wait )  CALL MPI_BARRIER( comm2d, ierr )
+       CALL MPI_ALLTOALL( f_in(1,1,nxl_y,1), sendrecvcount_xy, MPI_REAL, &
+                          work(nys,1,0),     sendrecvcount_xy, MPI_REAL, &
+                          comm1dy, ierr )
+       CALL cpu_log( log_point_s(32), 'mpi_alltoall', 'stop' )
+#endif
+
+!
+!--    Carry out the FFT along x, where all data are present due to the
+!--    1d-decomposition along y. Resort the data in a way that y becomes
+!--    the first index.
+       CALL cpu_log( log_point_s(4), 'fft_x_1d', 'continue' )
+
+       IF ( host(1:3) == 'nec' )  THEN
+!
+!--       Code optimized for vector processors
+!$OMP     PARALLEL PRIVATE ( i, j, k )
+!$OMP     DO
+          DO  j = nys, nyn
+
+             DO  k = 1, nz
+                DO  i = 0, nx
+                   work_fftx(i,k,j) = work(j,k,i)
+                ENDDO
+             ENDDO
+
+             CALL fft_x_m( work_fftx(:,:,j), 'backward' )
+
+          ENDDO
+
+!$OMP     DO
+          DO  i = 0, nx
+             DO  j = nys, nyn
+                DO  k = 1, nz
+                   f_out(k,j,i) = work_fftx(i,k,j)
+                ENDDO
+             ENDDO
+          ENDDO
+!$OMP     END PARALLEL
+
+       ELSE
+
+!
+!--       Cache optimized code (there might be still a potential for better
+!--       optimization).
+!$OMP     PARALLEL PRIVATE (i,j,k)
+!$OMP     DO
+          DO  j = nys, nyn
+             DO  k = 1, nz
+
+                DO  i = 0, nx
+                   work_fftx(i,k,j) = work(j,k,i)
+                ENDDO
+
+                CALL fft_x_1d( work_fftx(0:nx,k,j), 'backward' )
+
+             ENDDO
+          ENDDO
+
+!$OMP     DO
+          DO  i = 0, nx
+             DO  j = nys, nyn
+                DO  k = 1, nz
+                   f_out(k,j,i) = work_fftx(i,k,j)
+                ENDDO
+             ENDDO
+          ENDDO
+!$OMP     END PARALLEL
+
+       ENDIF
+       CALL cpu_log( log_point_s(4), 'fft_x_1d', 'stop' )
+
+    END SUBROUTINE tr_yx_fftx
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> FFT along y, solution of the tridiagonal system and backward FFT for
+!> a 1d-decomposition along y.
+!>
+!> @warning this subroutine may still not work for hybrid parallelization
+!>          with OpenMP (for possible necessary changes see the original
+!>          routine poisfft_hybrid, developed by Klaus Ketelsen, May 2002)
+!------------------------------------------------------------------------------!
+    SUBROUTINE ffty_tri_ffty( ar )
+
+
+       USE control_parameters,                                                 &
+           ONLY:  host
+
+       USE cpulog,                                                             &
+           ONLY:  cpu_log, log_point_s
+
+       USE grid_variables,                                                     &
+           ONLY:  ddx2, ddy2
+
+       USE kinds
+
+       USE pegrid
+
+       IMPLICIT NONE
+
+       INTEGER(iwp) ::  i                   !<
+       INTEGER(iwp) ::  j                   !<
+       INTEGER(iwp) ::  k                   !<
+       INTEGER(iwp) ::  m                   !<
+       INTEGER(iwp) ::  n                   !<
+       INTEGER(iwp) ::  omp_get_thread_num  !<
+       INTEGER(iwp) ::  tn                  !<
+
+       REAL(wp), DIMENSION(0:ny)                          ::  work_ffty  !<
+       REAL(wp), DIMENSION(0:ny,1:nz)                     ::  work_triy  !<
+       REAL(wp), DIMENSION(nny,1:nz,nxl_y:nxr_y,pdims(2)) ::  ar         !<
+       REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE          ::  tri        !<
+
+
+       CALL cpu_log( log_point_s(39), 'fft_y_1d + tridia', 'start' )
+
+       ALLOCATE( tri(5,0:ny,0:nz-1,0:threads_per_task-1) )
+
+       tn = 0           ! Default thread number in case of one thread
+!$OMP  PARALLEL DO PRIVATE ( i, j, k, m, n, tn, work_ffty, work_triy )
+       DO  i = nxl_y, nxr_y
+
+!$        tn = omp_get_thread_num()
+
+          IF ( host(1:3) == 'nec' )  THEN
+!
+!--          Code optimized for vector processors
+             DO  k = 1, nz
+
+                m = 0
+                DO  n = 1, pdims(2)
+                   DO  j = 1, nny
+                      work_triy(m,k) = ar(j,k,i,n)
+                      m = m + 1
+                   ENDDO
+                ENDDO
+
+             ENDDO
+
+             CALL fft_y_m( work_triy, ny, 'forward' )
+
+          ELSE
+!
+!--          Cache optimized code
+             DO  k = 1, nz
+
+                m = 0
+                DO  n = 1, pdims(2)
+                   DO  j = 1, nny
+                      work_ffty(m) = ar(j,k,i,n)
+                      m = m + 1
+                   ENDDO
+                ENDDO
+
+                CALL fft_y_1d( work_ffty, 'forward' )
+
+                DO  j = 0, ny
+                   work_triy(j,k) = work_ffty(j)
+                ENDDO
+
+             ENDDO
+
+          ENDIF
+
+!
+!--       Solve the linear equation system
+          CALL tridia_1dd( ddy2, ddx2, ny, nx, i, work_triy, tri(:,:,:,tn) )
+
+          IF ( host(1:3) == 'nec' )  THEN
+!
+!--          Code optimized for vector processors
+             CALL fft_y_m( work_triy, ny, 'backward' )
+
+             DO  k = 1, nz
+
+                m = 0
+                DO  n = 1, pdims(2)
+                   DO  j = 1, nny
+                      ar(j,k,i,n) = work_triy(m,k)
+                      m = m + 1
+                   ENDDO
+                ENDDO
+
+             ENDDO
+
+          ELSE
+!
+!--          Cache optimized code
+             DO  k = 1, nz
+
+                DO  j = 0, ny
+                   work_ffty(j) = work_triy(j,k)
+                ENDDO
+
+                CALL fft_y_1d( work_ffty, 'backward' )
+
+                m = 0
+                DO  n = 1, pdims(2)
+                   DO  j = 1, nny
+                      ar(j,k,i,n) = work_ffty(m)
+                      m = m + 1
+                   ENDDO
+                ENDDO
+
+             ENDDO
+
+          ENDIF
+
+       ENDDO
+
+       DEALLOCATE( tri )
+
+       CALL cpu_log( log_point_s(39), 'fft_y_1d + tridia', 'stop' )
+
+    END SUBROUTINE ffty_tri_ffty
+
+ END MODULE poisfft_mod
Index: lm/trunk/SOURCE/poismg_fast.f90
===================================================================
--- /palm/trunk/SOURCE/poismg_fast.f90	(revision 1849)
+++ 	(revision )
@@ -1,2946 +1,0 @@
-!> @file poismg_fast.f90
-!--------------------------------------------------------------------------------!
-! This file is part of PALM.
-!
-! PALM is free software: you can redistribute it and/or modify it under the terms
-! of the GNU General Public License as published by the Free Software Foundation,
-! either version 3 of the License, or (at your option) any later version.
-!
-! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
-! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
-! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along with
-! PALM. If not, see <http://www.gnu.org/licenses/>.
-!
-! Copyright 1997-2016 Leibniz Universitaet Hannover
-!--------------------------------------------------------------------------------!
-!
-! Current revisions:
-! -----------------
-!
-! 
-! Former revisions:
-! -----------------
-! $Id$
-!
-! 1762 2016-02-25 12:31:13Z hellstea
-! Introduction of nested domain feature
-!
-! 1682 2015-10-07 23:56:08Z knoop
-! Code annotations made doxygen readable 
-! 
-! 1609 2015-07-03 15:37:58Z maronga
-! Bugfix: allow compilation without __parallel.
-!
-! 1575 2015-03-27 09:56:27Z raasch
-! Initial revision.
-! Routine re-written and optimised based on poismg.
-!
-! Following optimisations have been made:
-! - vectorisation (for Intel-CPUs) of the red-black algorithm by resorting
-!   array elements with even and odd indices
-! - explicit boundary conditions for building walls removed (solver is
-!   running through the buildings
-! - reduced data transfer in case of ghost point exchange, because only
-!   "red" or "black" data points need to be exchanged. This is not applied
-!   for coarser grid levels, since for then the transfer time is latency bound
-!
-!
-! Description:
-! ------------
-!> Solves the Poisson equation for the perturbation pressure with a multigrid
-!> V- or W-Cycle scheme.
-!>
-!> This multigrid method was originally developed for PALM by Joerg Uhlenbrock,
-!> September 2000 - July 2001. It has been optimised for speed by Klaus
-!> Ketelsen in November 2014.
-!> 
-!> @attention Loop unrolling and cache optimization in SOR-Red/Black method
-!>            still does not give the expected speedup! 
-!>
-!> @todo Further work required.
-!------------------------------------------------------------------------------!
- MODULE poismg_mod
- 
-
-    USE cpulog,                                                                &
-        ONLY:  cpu_log, log_point_s
-
-    USE kinds
-
-    USE pegrid
-
-    PRIVATE
-
-    INTEGER, SAVE                             ::  ind_even_odd    !< border index between even and odd k index
-    INTEGER, DIMENSION(:), SAVE, ALLOCATABLE  ::  even_odd_level  !< stores ind_even_odd for all MG levels
-
-    REAL(wp), DIMENSION(:,:), SAVE, ALLOCATABLE ::  f1_mg_b, f2_mg_b, f3_mg_b  !< blocked version of f1_mg ...
-
-    INTERFACE poismg_fast
-       MODULE PROCEDURE poismg_fast
-    END INTERFACE poismg_fast
-
-    INTERFACE sort_k_to_even_odd_blocks
-       MODULE PROCEDURE sort_k_to_even_odd_blocks
-       MODULE PROCEDURE sort_k_to_even_odd_blocks_int
-       MODULE PROCEDURE sort_k_to_even_odd_blocks_1d
-    END INTERFACE sort_k_to_even_odd_blocks
-
-    PUBLIC poismg_fast
-
- CONTAINS
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Solves the Poisson equation for the perturbation pressure with a multigrid
-!> V- or W-Cycle scheme.
-!------------------------------------------------------------------------------!
-    SUBROUTINE poismg_fast( r )
-
-       USE arrays_3d,                                                          &
-           ONLY:  d, p_loc
-
-       USE control_parameters,                                                 &
-           ONLY:  gathered_size, grid_level, grid_level_count,                 &
-                  maximum_grid_level, message_string, mgcycles, mg_cycles,     &
-                  mg_switch_to_pe0_level, residual_limit, subdomain_size
-
-       USE cpulog,                                                             &
-           ONLY:  cpu_log, log_point_s
-
-       USE indices,                                                            &
-           ONLY:  nxl, nxlg, nxl_mg, nxr, nxrg, nxr_mg, nys, nysg, nys_mg, nyn,&
-                  nyng, nyn_mg, nzb, nzt, nzt_mg
-
-       IMPLICIT NONE
-
-       REAL(wp) ::  maxerror          !<
-       REAL(wp) ::  maximum_mgcycles  !<
-       REAL(wp) ::  residual_norm     !<
-
-       REAL(wp), DIMENSION(nzb:nzt+1,nys-1:nyn+1,nxl-1:nxr+1) ::  r  !<
-
-       REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::  p3  !<
-
-
-       CALL cpu_log( log_point_s(29), 'poismg_fast', 'start' )
-!
-!--    Initialize arrays and variables used in this subroutine
-
-!--    If the number of grid points of the gathered grid, which is collected
-!--    on PE0, is larger than the number of grid points of an PE, than array
-!--    p3 will be enlarged.
-       IF ( gathered_size > subdomain_size )  THEN
-          ALLOCATE( p3(nzb:nzt_mg(mg_switch_to_pe0_level)+1,nys_mg(            &
-                    mg_switch_to_pe0_level)-1:nyn_mg(mg_switch_to_pe0_level)+1,&
-                    nxl_mg(mg_switch_to_pe0_level)-1:nxr_mg(                   &
-                    mg_switch_to_pe0_level)+1) )
-       ELSE
-          ALLOCATE ( p3(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
-       ENDIF
-
-       p3 = 0.0_wp
-
- 
-!
-!--    Ghost boundaries have to be added to divergence array.
-!--    Exchange routine needs to know the grid level!
-       grid_level = maximum_grid_level
-       CALL exchange_horiz( d, 1)
-       d(nzb,:,:) = d(nzb+1,:,:)
-
-!
-!--    Initiation of the multigrid scheme. Does n cycles until the
-!--    residual is smaller than the given limit. The accuracy of the solution
-!--    of the poisson equation will increase with the number of cycles.
-!--    If the number of cycles is preset by the user, this number will be
-!--    carried out regardless of the accuracy.
-       grid_level_count =  0
-       mgcycles         =  0
-       IF ( mg_cycles == -1 )  THEN
-          maximum_mgcycles = 0
-          residual_norm    = 1.0_wp
-       ELSE
-          maximum_mgcycles = mg_cycles
-          residual_norm    = 0.0_wp
-       ENDIF
-
-!
-!--    Initial settings for sorting k-dimension from sequential order (alternate
-!--    even/odd) into blocks of even and odd or vice versa
-       CALL init_even_odd_blocks
-
-!
-!--    Sort input arrays in even/odd blocks along k-dimension
-       CALL sort_k_to_even_odd_blocks( d, grid_level )
-       CALL sort_k_to_even_odd_blocks( p_loc, grid_level )
-
-!
-!--    The complete multigrid cycles are running in block mode, i.e. over
-!--    seperate data blocks of even and odd indices
-       DO WHILE ( residual_norm > residual_limit  .OR. &
-                  mgcycles < maximum_mgcycles )
- 
-          CALL next_mg_level_fast( d, p_loc, p3, r)
-
-!
-!--       Calculate the residual if the user has not preset the number of
-!--       cycles to be performed
-          IF ( maximum_mgcycles == 0 )  THEN
-             CALL resid_fast( d, p_loc, r )
-             maxerror = SUM( r(nzb+1:nzt,nys:nyn,nxl:nxr)**2 )
-
-#if defined( __parallel )
-             IF ( collective_wait )  CALL MPI_BARRIER( comm2d, ierr )
-                CALL MPI_ALLREDUCE( maxerror, residual_norm, 1, MPI_REAL,      &
-                                    MPI_SUM, comm2d, ierr)
-#else
-                residual_norm = maxerror
-#endif
-             residual_norm = SQRT( residual_norm )
-          ENDIF
-
-          mgcycles = mgcycles + 1
-
-!
-!--       If the user has not limited the number of cycles, stop the run in case
-!--       of insufficient convergence
-          IF ( mgcycles > 1000  .AND.  mg_cycles == -1 )  THEN
-             message_string = 'no sufficient convergence within 1000 cycles'
-             CALL message( 'poismg_fast', 'PA0283', 1, 2, 0, 6, 0 )
-          ENDIF
-
-       ENDDO
-
-       DEALLOCATE( p3 )
-!
-!--    Result has to be sorted back from even/odd blocks to sequential order
-       CALL sort_k_to_sequential( p_loc )
-!
-!--    Unset the grid level. Variable is used to determine the MPI datatypes for
-!--    ghost point exchange
-       grid_level = 0
-
-       CALL cpu_log( log_point_s(29), 'poismg_fast', 'stop' )
-
-    END SUBROUTINE poismg_fast
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Computes the residual of the perturbation pressure.
-!------------------------------------------------------------------------------!
-    SUBROUTINE resid_fast( f_mg, p_mg, r )
-
-
-       USE arrays_3d,                                                          &
-           ONLY:  f1_mg, f2_mg, f3_mg
-
-       USE control_parameters,                                                 &
-           ONLY:  bc_lr_cyc, bc_ns_cyc, grid_level, ibc_p_b, ibc_p_t, inflow_l,&
-                  inflow_n, inflow_r, inflow_s, masking_method, nest_bound_l,  &
-                  nest_bound_n, nest_bound_r, nest_bound_s, outflow_l,         &
-                  outflow_n, outflow_r, outflow_s, topography
-
-       USE grid_variables,                                                     &
-           ONLY:  ddx2_mg, ddy2_mg
-
-       USE indices,                                                            &
-           ONLY:  flags, wall_flags_1, wall_flags_2, wall_flags_3,             &
-                  wall_flags_4, wall_flags_5, wall_flags_6, wall_flags_7,      &
-                  wall_flags_8, wall_flags_9, wall_flags_10, nxl_mg, nxr_mg,   &
-                  nys_mg, nyn_mg, nzb, nzt_mg
-
-       IMPLICIT NONE
-
-       INTEGER(iwp) ::  i
-       INTEGER(iwp) ::  j
-       INTEGER(iwp) ::  k
-       INTEGER(iwp) ::  l
-       INTEGER(iwp) :: km1      !<
-       INTEGER(iwp) :: kp1      !<
-
-       REAL(wp), DIMENSION(nzb:nzt_mg(grid_level)+1,                           &
-                       nys_mg(grid_level)-1:nyn_mg(grid_level)+1,              &
-                       nxl_mg(grid_level)-1:nxr_mg(grid_level)+1) ::  f_mg  !<
-       REAL(wp), DIMENSION(nzb:nzt_mg(grid_level)+1,                           &
-                       nys_mg(grid_level)-1:nyn_mg(grid_level)+1,              &
-                       nxl_mg(grid_level)-1:nxr_mg(grid_level)+1) ::  p_mg  !<
-       REAL(wp), DIMENSION(nzb:nzt_mg(grid_level)+1,                           &
-                       nys_mg(grid_level)-1:nyn_mg(grid_level)+1,              &
-                       nxl_mg(grid_level)-1:nxr_mg(grid_level)+1) ::  r     !<
-
-!
-!--    Calculate the residual
-       l = grid_level
-
-       CALL cpu_log( log_point_s(53), 'resid', 'start' )
-       IF ( topography == 'flat'  .OR.  masking_method )  THEN
-          !$OMP PARALLEL PRIVATE (i,j,k,km1,kp1)
-          !$OMP DO
-          DO  i = nxl_mg(l), nxr_mg(l)
-             DO  j = nys_mg(l), nyn_mg(l)
-                !DIR$ IVDEP
-                DO k = ind_even_odd+1, nzt_mg(l)
-                   km1 = k-ind_even_odd-1
-                   kp1 = k-ind_even_odd
-                   r(k,j,i) = f_mg(k,j,i)                                 &
-                      - ddx2_mg(l) *                                      &
-                      ( p_mg(k,j,i+1) +  p_mg(k,j,i-1)  )                 &
-                      - ddy2_mg(l) *                                      &
-                      ( p_mg(k,j+1,i) + p_mg(k,j-1,i)  )                  &
-                      - f2_mg_b(k,l) * p_mg(kp1,j,i)                      &
-                      - f3_mg_b(k,l) * p_mg(km1,j,i)                      &
-                      + f1_mg_b(k,l) * p_mg(k,j,i)
-                ENDDO
-                !DIR$ IVDEP
-                DO k = nzb+1, ind_even_odd
-                   km1 = k+ind_even_odd
-                   kp1 = k+ind_even_odd+1
-                   r(k,j,i) = f_mg(k,j,i)                                 &
-                      - ddx2_mg(l) *                                      &
-                      ( p_mg(k,j,i+1) +  p_mg(k,j,i-1)  )                 &
-                      - ddy2_mg(l) *                                      &
-                      ( p_mg(k,j+1,i) + p_mg(k,j-1,i)  )                  &
-                      - f2_mg_b(k,l) * p_mg(kp1,j,i)                      &
-                      - f3_mg_b(k,l) * p_mg(km1,j,i)                      &
-                      + f1_mg_b(k,l) * p_mg(k,j,i)
-                ENDDO
-             ENDDO
-          ENDDO
-          !$OMP END PARALLEL
-       ELSE
-!
-!--       Choose flag array of this level
-          SELECT CASE ( l )
-             CASE ( 1 )
-                flags => wall_flags_1
-             CASE ( 2 )
-                flags => wall_flags_2
-             CASE ( 3 )
-                flags => wall_flags_3
-             CASE ( 4 )
-                flags => wall_flags_4
-             CASE ( 5 )
-                flags => wall_flags_5
-             CASE ( 6 )
-                flags => wall_flags_6
-             CASE ( 7 )
-                flags => wall_flags_7
-             CASE ( 8 )
-                flags => wall_flags_8
-             CASE ( 9 )
-                flags => wall_flags_9
-             CASE ( 10 )
-                flags => wall_flags_10
-          END SELECT
-
-          !$OMP PARALLEL PRIVATE (i,j,k,km1,kp1)
-          !$OMP DO
-          DO  i = nxl_mg(l), nxr_mg(l)
-             DO  j = nys_mg(l), nyn_mg(l)
-
-                !DIR$ IVDEP
-                DO  k = ind_even_odd+1, nzt_mg(l)
-                   km1 = k-ind_even_odd-1
-                   kp1 = k-ind_even_odd
-
-                   r(k,j,i) = f_mg(k,j,i)                                         &
-                    - ddx2_mg(l) *                                                &
-                    ( MERGE(p_mg(k,j,i),p_mg(k,j,i+1),BTEST( flags(k,j,i), 5 ))   &
-                    + MERGE(p_mg(k,j,i),p_mg(k,j,i-1),BTEST( flags(k,j,i), 4 )) ) &
-                    - ddy2_mg(l)                                                  &
-                    * ( MERGE(p_mg(k,j,i),p_mg(k,j+1,i),BTEST( flags(k,j,i), 3 )) &
-                    + MERGE(p_mg(k,j,i),p_mg(k,j-1,i),BTEST( flags(k,j,i), 2 )) ) &
-                    - f2_mg(k,l) * p_mg(kp1,j,i)                                  &
-                    - f3_mg(k,l) *                                                &
-                      MERGE(p_mg(k,j,i),p_mg(km1,j,i),BTEST( flags(k,j,i), 0 ))   &
-                    + f1_mg(k,l) * p_mg(k,j,i)
-                ENDDO
-
-                !DIR$ IVDEP
-                DO  k = nzb+1, ind_even_odd
-                   km1 = k+ind_even_odd
-                   kp1 = k+ind_even_odd+1
-
-                   r(k,j,i) = f_mg(k,j,i)                                         &
-                    - ddx2_mg(l) *                                                &
-                    ( MERGE(p_mg(k,j,i),p_mg(k,j,i+1),BTEST( flags(k,j,i), 5 ))   &
-                    + MERGE(p_mg(k,j,i),p_mg(k,j,i-1),BTEST( flags(k,j,i), 4 )) ) &
-                    - ddy2_mg(l)                                                  &
-                    * ( MERGE(p_mg(k,j,i),p_mg(k,j+1,i),BTEST( flags(k,j,i), 3 )) &
-                    + MERGE(p_mg(k,j,i),p_mg(k,j-1,i),BTEST( flags(k,j,i), 2 )) ) &
-                    - f2_mg(k,l) * p_mg(kp1,j,i)                                  &
-                    - f3_mg(k,l) *                                                &
-                      MERGE(p_mg(k,j,i),p_mg(km1,j,i),BTEST( flags(k,j,i), 0 ))   &
-                    + f1_mg(k,l) * p_mg(k,j,i)
-                ENDDO
-!
-!--             The residual within topography should be zero
-                WHERE( BTEST(flags(nzb+1:nzt_mg(l),j,i), 6) )
-                   r(nzb+1:nzt_mg(l),j,i) = 0.0
-                END WHERE
-
-             ENDDO
-          ENDDO
-          !$OMP END PARALLEL
-
-       ENDIF
-
-!
-!--    Horizontal boundary conditions
-       CALL exchange_horiz( r, 1)
-
-       IF ( .NOT. bc_lr_cyc )  THEN
-          IF ( inflow_l .OR. outflow_l .OR. nest_bound_l )  THEN
-             r(:,:,nxl_mg(l)-1) = r(:,:,nxl_mg(l))
-          ENDIF
-          IF ( inflow_r .OR. outflow_r .OR. nest_bound_r )  THEN
-             r(:,:,nxr_mg(l)+1) = r(:,:,nxr_mg(l))
-          ENDIF
-       ENDIF
-
-       IF ( .NOT. bc_ns_cyc )  THEN
-          IF ( inflow_n .OR. outflow_n .OR. nest_bound_n )  THEN
-             r(:,nyn_mg(l)+1,:) = r(:,nyn_mg(l),:)
-          ENDIF
-          IF ( inflow_s .OR. outflow_s .OR. nest_bound_s )  THEN
-             r(:,nys_mg(l)-1,:) = r(:,nys_mg(l),:)
-          ENDIF
-       ENDIF
-
-!
-!--    Boundary conditions at bottom and top of the domain.outflow_l, outflow_n,
-!--    These points are not handled by the above loop. Points may be within
-!--    buildings, but that doesn't matter.
-       IF ( ibc_p_b == 1 )  THEN
-          r(nzb,:,: ) = r(nzb+1,:,:)
-       ELSE
-          r(nzb,:,: ) = 0.0_wp
-       ENDIF
-
-       IF ( ibc_p_t == 1 )  THEN
-          r(nzt_mg(l)+1,:,: ) = r(nzt_mg(l),:,:)
-       ELSE
-          r(nzt_mg(l)+1,:,: ) = 0.0_wp
-       ENDIF
-
-       CALL cpu_log( log_point_s(53), 'resid', 'stop' )
-
-    END SUBROUTINE resid_fast
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Interpolates the residual on the next coarser grid with "full weighting"
-!> scheme
-!------------------------------------------------------------------------------!
-    SUBROUTINE restrict_fast( f_mg, r )
-
-
-       USE control_parameters,                                                 &
-           ONLY:  bc_lr_cyc, bc_ns_cyc, grid_level, ibc_p_b, ibc_p_t, inflow_l,&
-                  inflow_n, inflow_r, inflow_s, masking_method, nest_bound_l,  &
-                  nest_bound_n, nest_bound_r, nest_bound_s, outflow_l,         &
-                  outflow_n, outflow_r, outflow_s, topography
-
-       USE indices,                                                            &
-           ONLY:  flags, wall_flags_1, wall_flags_2, wall_flags_3,             &
-                  wall_flags_4, wall_flags_5, wall_flags_6, wall_flags_7,      &
-                  wall_flags_8, wall_flags_9, wall_flags_10, nxl_mg, nxr_mg,   &
-                  nys_mg, nyn_mg, nzb, nzt_mg
-
-       IMPLICIT NONE
-
-       INTEGER(iwp) ::  i    !<
-       INTEGER(iwp) ::  ic   !<
-       INTEGER(iwp) ::  j    !<
-       INTEGER(iwp) ::  jc   !<
-       INTEGER(iwp) ::  k    !<
-       INTEGER(iwp) ::  kc   !<
-       INTEGER(iwp) ::  l    !<
-       INTEGER(iwp) ::  km1  !<
-       INTEGER(iwp) ::  kp1  !<
-
-       REAL(wp) ::  rkjim    !<
-       REAL(wp) ::  rkjip    !<
-       REAL(wp) ::  rkjmi    !<
-       REAL(wp) ::  rkjmim   !<
-       REAL(wp) ::  rkjmip   !<
-       REAL(wp) ::  rkjpi    !<
-       REAL(wp) ::  rkjpim   !<
-       REAL(wp) ::  rkjpip   !<
-       REAL(wp) ::  rkmji    !<
-       REAL(wp) ::  rkmjim   !<
-       REAL(wp) ::  rkmjip   !<
-       REAL(wp) ::  rkmjmi   !<
-       REAL(wp) ::  rkmjmim  !<
-       REAL(wp) ::  rkmjmip  !<
-       REAL(wp) ::  rkmjpi   !<
-       REAL(wp) ::  rkmjpim  !<
-       REAL(wp) ::  rkmjpip  !<
-
-       REAL(wp), DIMENSION(nzb:nzt_mg(grid_level)+1,                           &
-                           nys_mg(grid_level)-1:nyn_mg(grid_level)+1,          &
-                           nxl_mg(grid_level)-1:nxr_mg(grid_level)+1) ::  f_mg  !<
-
-       REAL(wp), DIMENSION(nzb:nzt_mg(grid_level+1)+1,                         &
-                           nys_mg(grid_level+1)-1:nyn_mg(grid_level+1)+1,      &
-                           nxl_mg(grid_level+1)-1:nxr_mg(grid_level+1)+1) ::  r !<
-
-!
-!--    Interpolate the residual
-       l = grid_level
-
-       CALL cpu_log( log_point_s(54), 'restrict', 'start' )
-
-       IF ( topography == 'flat'  .OR.  masking_method )  THEN
-!
-!--       No wall treatment
-          !$OMP PARALLEL PRIVATE (i,j,k,ic,jc,kc,km1,kp1)
-          DO  ic = nxl_mg(l), nxr_mg(l)
-             i = 2*ic
-             !$OMP DO SCHEDULE( STATIC )
-             DO  jc = nys_mg(l), nyn_mg(l)
-!
-!--             Calculation for the first point along k
-                j  = 2*jc
-                k   = ind_even_odd+1
-                kp1 = k-ind_even_odd
-                kc  = k-ind_even_odd
-                f_mg(kc,jc,ic) =  1.0_wp / 64.0_wp * (                         &
-                                  8.0_wp * r(k,j,i)                            &
-                               +  4.0_wp * ( r(k,j,i-1)     + r(k,j,i+1)     + &
-                                             r(k,j+1,i)     + r(k,j-1,i)     ) &
-                               +  2.0_wp * ( r(k,j-1,i-1)   + r(k,j+1,i-1)   + &
-                                             r(k,j-1,i+1)   + r(k,j+1,i+1)   ) &
-                               + 16.0_wp * r(k,j,i)                            &
-                               +  4.0_wp * r(kp1,j,i)                          &
-                               +  2.0_wp * ( r(kp1,j,i-1)   + r(kp1,j,i+1)   + &
-                                             r(kp1,j+1,i)   + r(kp1,j-1,i)   ) &
-                               +           ( r(kp1,j-1,i-1) + r(kp1,j+1,i-1) + &
-                                             r(kp1,j-1,i+1) + r(kp1,j+1,i+1) ) &
-                                                      )
-!
-!--             Calculation for the other points along k
-                !DIR$ IVDEP
-                DO k = ind_even_odd+2, nzt_mg(l+1)    ! Fine grid at this point
-                   km1 = k-ind_even_odd-1
-                   kp1 = k-ind_even_odd
-                   kc  = k-ind_even_odd               ! Coarse grid index
-
-                   f_mg(kc,jc,ic) = 1.0_wp / 64.0_wp * (                      &
-                                  8.0_wp * r(k,j,i)                            &
-                                + 4.0_wp * ( r(k,j,i-1)     + r(k,j,i+1)     + &
-                                             r(k,j+1,i)     + r(k,j-1,i)     ) &
-                                + 2.0_wp * ( r(k,j-1,i-1)   + r(k,j+1,i-1)   + &
-                                             r(k,j-1,i+1)   + r(k,j+1,i+1)   ) &
-                                + 4.0_wp * r(km1,j,i)                          &
-                                + 2.0_wp * ( r(km1,j,i-1)   + r(km1,j,i+1)   + &
-                                             r(km1,j+1,i)   + r(km1,j-1,i)   ) &
-                                +          ( r(km1,j-1,i-1) + r(km1,j+1,i-1) + &
-                                             r(km1,j-1,i+1) + r(km1,j+1,i+1) ) &
-                                + 4.0_wp * r(kp1,j,i)                          &
-                                + 2.0_wp * ( r(kp1,j,i-1)   + r(kp1,j,i+1)   + &
-                                             r(kp1,j+1,i)   + r(kp1,j-1,i)   ) &
-                                +          ( r(kp1,j-1,i-1) + r(kp1,j+1,i-1) + &
-                                             r(kp1,j-1,i+1) + r(kp1,j+1,i+1) ) &
-                                           )
-                ENDDO
-             ENDDO
-             !$OMP ENDDO nowait
-          ENDDO
-          !$OMP END PARALLEL
-
-       ELSE
-!
-!--       Choose flag array of the upper level
-          SELECT CASE ( l+1 )
-             CASE ( 1 )
-                flags => wall_flags_1
-             CASE ( 2 )
-                flags => wall_flags_2
-             CASE ( 3 )
-                flags => wall_flags_3
-             CASE ( 4 )
-                flags => wall_flags_4
-             CASE ( 5 )
-                flags => wall_flags_5
-             CASE ( 6 )
-                flags => wall_flags_6
-             CASE ( 7 )
-                flags => wall_flags_7
-             CASE ( 8 )
-                flags => wall_flags_8
-             CASE ( 9 )
-                flags => wall_flags_9
-             CASE ( 10 )
-                flags => wall_flags_10
-          END SELECT
-    
-          !$OMP PARALLEL PRIVATE (i,j,k,ic,jc,kc,km1,kp1,rkjim,rkjip,rkjpi,    &
-          !$OMP                   rkjmim,rkjpim,rkjmip,rkjpip,rkmji,rkmjim,    &
-          !$OMP                   rkmjip,rkmjpi,rkmjmi,rkmjmim,rkmjpim,        &
-          !$OMP                   rkmjmip,rkmjpip)
-          !$OMP DO
-          DO  ic = nxl_mg(l), nxr_mg(l)
-             i = 2*ic
-             DO  jc = nys_mg(l), nyn_mg(l)
-                j = 2*jc
-                !DIR$ IVDEP
-                DO k = ind_even_odd+1, nzt_mg(l+1)      !fine grid at this point
-
-                    km1 = k-ind_even_odd-1
-                    kp1 = k-ind_even_odd
-                    kc  = k-ind_even_odd                !Coarse grid index
-!
-!--                 Use implicit Neumann BCs if the respective gridpoint is
-!--                 inside the building
-                    rkjim   = MERGE(r(k,j,i),r(k,j,i-1),BTEST( flags(k,j,i-1), 6))
-                    rkjip   = MERGE(r(k,j,i),r(k,j,i+1),BTEST( flags(k,j,i+1), 6))
-                    rkjpi   = MERGE(r(k,j,i),r(k,j+1,i),BTEST( flags(k,j+1,i), 6))
-                    rkjmi   = MERGE(r(k,j,i),r(k,j-1,i),BTEST( flags(k,j-1,i), 6))
-
-                    rkjmim  = MERGE(r(k,j,i),r(k,j-1,i-1),BTEST( flags(k,j-1,i-1), 6))
-                    rkjpim  = MERGE(r(k,j,i),r(k,j+1,i-1),BTEST( flags(k,j+1,i-1), 6))
-                    rkjmip  = MERGE(r(k,j,i),r(k,j-1,i+1),BTEST( flags(k,j-1,i+1), 6))
-                    rkjpip  = MERGE(r(k,j,i),r(k,j+1,i+1),BTEST( flags(k,j+1,i+1), 6))
-
-                    rkmji   = MERGE(r(k,j,i),r(km1,j,i)  ,BTEST( flags(km1,j,i)  , 6))
-                    rkmjim  = MERGE(r(k,j,i),r(km1,j,i-1),BTEST( flags(km1,j,i-1), 6))
-                    rkmjip  = MERGE(r(k,j,i),r(km1,j,i+1),BTEST( flags(km1,j,i+1), 6))
-                    rkmjpi  = MERGE(r(k,j,i),r(km1,j+1,i),BTEST( flags(km1,j+1,i), 6))
-                    rkmjmi  = MERGE(r(k,j,i),r(km1,j-1,i),BTEST( flags(km1,j-1,i), 6))
-
-                    rkmjmim = MERGE(r(k,j,i),r(km1,j-1,i-1),BTEST( flags(km1,j-1,i-1), 6))
-                    rkmjpim = MERGE(r(k,j,i),r(km1,j+1,i-1),BTEST( flags(km1,j+1,i-1), 6))
-                    rkmjmip = MERGE(r(k,j,i),r(km1,j-1,i+1),BTEST( flags(km1,j-1,i+1), 6))
-                    rkmjpip = MERGE(r(k,j,i),r(km1,j+1,i+1),BTEST( flags(km1,j+1,i+1), 6))
-
-                    f_mg(kc,jc,ic) = 1.0_wp / 64.0_wp * (                      &
-                           8.0_wp * r(k,j,i)                                   &
-                         + 4.0_wp * ( rkjim   + rkjip   +  rkjpi   + rkjmi   ) &
-                         + 2.0_wp * ( rkjmim  + rkjpim  +  rkjmip  + rkjpip  ) &
-                         + 4.0_wp * rkmji                                      &
-                         + 2.0_wp * ( rkmjim  + rkmjip  +  rkmjpi  + rkmjmi  ) &
-                         +          ( rkmjmim + rkmjpim +  rkmjmip + rkmjpip ) &
-                         + 4.0_wp * r(kp1,j,i)                                 &
-                         + 2.0_wp * ( r(kp1,j,i-1)   + r(kp1,j,i+1)   +        &
-                                      r(kp1,j+1,i)   + r(kp1,j-1,i)   )        &
-                         +          ( r(kp1,j-1,i-1) + r(kp1,j+1,i-1) +        &
-                                      r(kp1,j-1,i+1) + r(kp1,j+1,i+1) )        &
-                                                        )
-                ENDDO
-             ENDDO
-          ENDDO
-          !$OMP END PARALLEL
-
-       ENDIF
-
-!
-!--    Horizontal boundary conditions
-       CALL exchange_horiz( f_mg, 1)
-
-       IF ( .NOT. bc_lr_cyc )  THEN
-          IF ( inflow_l .OR. outflow_l .OR. nest_bound_l )  THEN
-             f_mg(:,:,nxl_mg(l)-1) = f_mg(:,:,nxl_mg(l))
-          ENDIF
-          IF ( inflow_r .OR. outflow_r .OR. nest_bound_r )  THEN
-             f_mg(:,:,nxr_mg(l)+1) = f_mg(:,:,nxr_mg(l))
-          ENDIF
-       ENDIF
-
-       IF ( .NOT. bc_ns_cyc )  THEN
-          IF ( inflow_n .OR. outflow_n .OR. nest_bound_n )  THEN
-             f_mg(:,nyn_mg(l)+1,:) = f_mg(:,nyn_mg(l),:)
-          ENDIF
-          IF ( inflow_s .OR. outflow_s .OR. nest_bound_s )  THEN
-             f_mg(:,nys_mg(l)-1,:) = f_mg(:,nys_mg(l),:)
-          ENDIF
-       ENDIF
-
-!
-!--    Boundary conditions at bottom and top of the domain.
-!--    These points are not handled by the above loop. Points may be within
-!--    buildings, but that doesn't matter.
-       IF ( ibc_p_b == 1 )  THEN
-          f_mg(nzb,:,: ) = f_mg(nzb+1,:,:)
-       ELSE
-          f_mg(nzb,:,: ) = 0.0_wp
-       ENDIF
-
-       IF ( ibc_p_t == 1 )  THEN
-          f_mg(nzt_mg(l)+1,:,: ) = f_mg(nzt_mg(l),:,:)
-       ELSE
-          f_mg(nzt_mg(l)+1,:,: ) = 0.0_wp
-       ENDIF
-
-       CALL cpu_log( log_point_s(54), 'restrict', 'stop' )
-!
-!--    Why do we need a sorting here?
-       CALL sort_k_to_even_odd_blocks( f_mg , l)
-
-    END SUBROUTINE restrict_fast
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Interpolates the correction of the perturbation pressure 
-!> to the next finer grid.
-!------------------------------------------------------------------------------!
-    SUBROUTINE prolong_fast( p, temp )
-
-
-       USE control_parameters,                                                 &
-           ONLY:  bc_lr_cyc, bc_ns_cyc, grid_level, ibc_p_b, ibc_p_t, inflow_l,&
-                  inflow_n, inflow_r, inflow_s, nest_bound_l, nest_bound_n,    &
-                  nest_bound_r, nest_bound_s, outflow_l, outflow_n,            &
-                  outflow_r, outflow_s
-
-       USE indices,                                                            &
-           ONLY:  nxl_mg, nxr_mg, nys_mg, nyn_mg, nzb, nzt_mg
-
-       IMPLICIT NONE
-
-       INTEGER(iwp) ::  i   !<
-       INTEGER(iwp) ::  j   !<
-       INTEGER(iwp) ::  k   !<
-       INTEGER(iwp) ::  l   !<
-       INTEGER(iwp) ::  kp1 !<
-       INTEGER(iwp) ::  ke  !< Index for prolog even
-       INTEGER(iwp) ::  ko  !< Index for prolog odd
-
-       REAL(wp), DIMENSION(nzb:nzt_mg(grid_level-1)+1,                         &
-                           nys_mg(grid_level-1)-1:nyn_mg(grid_level-1)+1,      &
-                           nxl_mg(grid_level-1)-1:nxr_mg(grid_level-1)+1 ) ::  p  !<
-
-       REAL(wp), DIMENSION(nzb:nzt_mg(grid_level)+1,                           &
-                           nys_mg(grid_level)-1:nyn_mg(grid_level)+1,          &
-                           nxl_mg(grid_level)-1:nxr_mg(grid_level)+1) ::  temp  !<
-
-
-       CALL cpu_log( log_point_s(55), 'prolong', 'start' )
-
-!
-!--    First, store elements of the coarser grid on the next finer grid
-       l = grid_level
-       ind_even_odd = even_odd_level(grid_level-1)
-
-       !$OMP PARALLEL PRIVATE (i,j,k,kp1,ke,ko)
-       !$OMP DO
-       DO  i = nxl_mg(l-1), nxr_mg(l-1)
-          DO  j = nys_mg(l-1), nyn_mg(l-1)
-
-             !DIR$ IVDEP
-             DO k = ind_even_odd+1, nzt_mg(l-1)
-                kp1 = k - ind_even_odd
-                ke  = 2 * ( k-ind_even_odd - 1 ) + 1
-                ko  = 2 * k - 1
-!
-!--             Points of the coarse grid are directly stored on the next finer
-!--             grid
-                temp(ko,2*j,2*i)   = p(k,j,i)
-!
-!--             Points between two coarse-grid points
-                temp(ko,2*j,2*i+1) = 0.5_wp * ( p(k,j,i) + p(k,j,i+1) )
-                temp(ko,2*j+1,2*i) = 0.5_wp * ( p(k,j,i) + p(k,j+1,i) )
-                temp(ke,2*j,2*i)   = 0.5_wp * ( p(k,j,i) + p(kp1,j,i) )
-!
-!--             Points in the center of the planes stretched by four points
-!--             of the coarse grid cube
-                temp(ko,2*j+1,2*i+1) = 0.25_wp * ( p(k,j,i)   + p(k,j,i+1) +   &
-                                                   p(k,j+1,i) + p(k,j+1,i+1) )
-                temp(ke,2*j,2*i+1)   = 0.25_wp * ( p(k,j,i)   + p(k,j,i+1) +   &
-                                                   p(kp1,j,i) + p(kp1,j,i+1) )
-                temp(ke,2*j+1,2*i)   = 0.25_wp * ( p(k,j,i)   + p(k,j+1,i) +   &
-                                                   p(kp1,j,i) + p(kp1,j+1,i) )
-!
-!--             Points in the middle of coarse grid cube
-                temp(ke,2*j+1,2*i+1) = 0.125_wp *                              &
-                                               ( p(k,j,i)     + p(k,j,i+1)   + &
-                                                 p(k,j+1,i)   + p(k,j+1,i+1) + &
-                                                 p(kp1,j,i)   + p(kp1,j,i+1) + &
-                                                 p(kp1,j+1,i) + p(kp1,j+1,i+1) )
-             ENDDO
-
-             !DIR$ IVDEP
-             DO k = nzb+1, ind_even_odd
-                kp1 = k + ind_even_odd + 1
-                ke  = 2 * k
-                ko  = 2 * ( k + ind_even_odd )
-!
-!--             Points of the coarse grid are directly stored on the next finer
-!--             grid
-                temp(ko,2*j,2*i)   = p(k,j,i)
-!
-!--             Points between two coarse-grid points
-                temp(ko,2*j,2*i+1) = 0.5_wp * ( p(k,j,i) + p(k,j,i+1) )
-                temp(ko,2*j+1,2*i) = 0.5_wp * ( p(k,j,i) + p(k,j+1,i) )
-                temp(ke,2*j,2*i)   = 0.5_wp * ( p(k,j,i) + p(kp1,j,i) )
-!
-!--             Points in the center of the planes stretched by four points
-!--             of the coarse grid cube
-                temp(ko,2*j+1,2*i+1) = 0.25_wp * ( p(k,j,i)   + p(k,j,i+1) +   &
-                                                   p(k,j+1,i) + p(k,j+1,i+1) )
-                temp(ke,2*j,2*i+1)   = 0.25_wp * ( p(k,j,i)   + p(k,j,i+1) +   &
-                                                   p(kp1,j,i) + p(kp1,j,i+1) )
-                temp(ke,2*j+1,2*i)   = 0.25_wp * ( p(k,j,i)   + p(k,j+1,i) +   &
-                                                   p(kp1,j,i) + p(kp1,j+1,i) )
-!
-!--             Points in the middle of coarse grid cube
-                temp(ke,2*j+1,2*i+1) = 0.125_wp *                              &
-                                               ( p(k,j,i)     + p(k,j,i+1)   + &
-                                                 p(k,j+1,i)   + p(k,j+1,i+1) + &
-                                                 p(kp1,j,i)   + p(kp1,j,i+1) + &
-                                                 p(kp1,j+1,i) + p(kp1,j+1,i+1) )
-             ENDDO
-
-          ENDDO
-       ENDDO
-       !$OMP END PARALLEL
-
-       ind_even_odd = even_odd_level(grid_level)
-!
-!--    Horizontal boundary conditions
-       CALL exchange_horiz( temp, 1)
-
-       IF ( .NOT. bc_lr_cyc )  THEN
-          IF ( inflow_l .OR. outflow_l .OR. nest_bound_l )  THEN
-             temp(:,:,nxl_mg(l)-1) = temp(:,:,nxl_mg(l))
-          ENDIF
-          IF ( inflow_r .OR. outflow_r .OR. nest_bound_r )  THEN
-             temp(:,:,nxr_mg(l)+1) = temp(:,:,nxr_mg(l))
-          ENDIF
-       ENDIF
-
-       IF ( .NOT. bc_ns_cyc )  THEN
-          IF ( inflow_n .OR. outflow_n .OR. nest_bound_n )  THEN
-             temp(:,nyn_mg(l)+1,:) = temp(:,nyn_mg(l),:)
-          ENDIF
-          IF ( inflow_s .OR. outflow_s .OR. nest_bound_s )  THEN
-             temp(:,nys_mg(l)-1,:) = temp(:,nys_mg(l),:)
-          ENDIF
-       ENDIF
-
-!
-!--    Bottom and top boundary conditions
-       IF ( ibc_p_b == 1 )  THEN
-          temp(nzb,:,: ) = temp(ind_even_odd+1,:,:)
-       ELSE
-          temp(nzb,:,: ) = 0.0_wp
-       ENDIF
-
-       IF ( ibc_p_t == 1 )  THEN
-          temp(nzt_mg(l)+1,:,: ) = temp(ind_even_odd,:,:)
-       ELSE
-          temp(nzt_mg(l)+1,:,: ) = 0.0_wp
-       ENDIF
-
-       CALL cpu_log( log_point_s(55), 'prolong', 'stop' )
-
-    END SUBROUTINE prolong_fast
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Relaxation method for the multigrid scheme. A Gauss-Seidel iteration with
-!> 3D-Red-Black decomposition (GS-RB) is used.
-!------------------------------------------------------------------------------!
-    SUBROUTINE redblack_fast( f_mg, p_mg )
-
-
-       USE arrays_3d,                                                          &
-           ONLY:  f1_mg, f2_mg, f3_mg
-
-       USE control_parameters,                                                 &
-           ONLY:  bc_lr_cyc, bc_ns_cyc, grid_level, ibc_p_b, ibc_p_t, inflow_l,&
-                  inflow_n, inflow_r, inflow_s, masking_method, nest_bound_l,  &
-                  nest_bound_n, nest_bound_r, nest_bound_s, ngsrb,             &
-                  outflow_l, outflow_n, outflow_r, outflow_s, topography
-
-       USE grid_variables,                                                     &
-           ONLY:  ddx2_mg, ddy2_mg
-
-       USE indices,                                                            &
-           ONLY:  flags, wall_flags_1, wall_flags_2, wall_flags_3,             &
-                  wall_flags_4, wall_flags_5, wall_flags_6, wall_flags_7,      &
-                  wall_flags_8, wall_flags_9, wall_flags_10, nxl_mg, nxr_mg,   &
-                  nys_mg, nyn_mg, nzb, nzt_mg
-
-       IMPLICIT NONE
-
-       INTEGER(iwp) :: color    !<
-       INTEGER(iwp) :: i        !<
-       INTEGER(iwp) :: ic       !<
-       INTEGER(iwp) :: j        !<
-       INTEGER(iwp) :: jc       !<
-       INTEGER(iwp) :: jj       !<
-       INTEGER(iwp) :: k        !<
-       INTEGER(iwp) :: l        !<
-       INTEGER(iwp) :: n        !<
-       INTEGER(iwp) :: km1      !<
-       INTEGER(iwp) :: kp1      !<
-
-       LOGICAL :: unroll        !<
-
-       REAL(wp) ::  wall_left   !<
-       REAL(wp) ::  wall_north  !<
-       REAL(wp) ::  wall_right  !<
-       REAL(wp) ::  wall_south  !<
-       REAL(wp) ::  wall_total  !<
-       REAL(wp) ::  wall_top    !<
-
-       REAL(wp), DIMENSION(nzb:nzt_mg(grid_level)+1,                           &
-                           nys_mg(grid_level)-1:nyn_mg(grid_level)+1,          &
-                           nxl_mg(grid_level)-1:nxr_mg(grid_level)+1) ::  f_mg  !<
-       REAL(wp), DIMENSION(nzb:nzt_mg(grid_level)+1,                           &
-                           nys_mg(grid_level)-1:nyn_mg(grid_level)+1,          &
-                           nxl_mg(grid_level)-1:nxr_mg(grid_level)+1) ::  p_mg  !<
-
-       l = grid_level
-
-!
-!--    Choose flag array of this level
-       IF ( topography /= 'flat'  .AND.  .NOT. masking_method )  THEN
-
-          SELECT CASE ( l )
-             CASE ( 1 )
-                flags => wall_flags_1
-             CASE ( 2 )
-                flags => wall_flags_2
-             CASE ( 3 )
-                flags => wall_flags_3
-             CASE ( 4 )
-                flags => wall_flags_4
-             CASE ( 5 )
-                flags => wall_flags_5
-             CASE ( 6 )
-                flags => wall_flags_6
-             CASE ( 7 )
-                flags => wall_flags_7
-             CASE ( 8 )
-                flags => wall_flags_8
-             CASE ( 9 )
-                flags => wall_flags_9
-             CASE ( 10 )
-                flags => wall_flags_10
-          END SELECT
-
-       ENDIF
-
-       unroll = ( MOD( nyn_mg(l)-nys_mg(l)+1, 4 ) == 0  .AND. &
-                  MOD( nxr_mg(l)-nxl_mg(l)+1, 2 ) == 0 )
-
-       DO  n = 1, ngsrb
-       
-          DO  color = 1, 2
-!
-!--          No wall treatment in case of flat topography
-             IF ( topography == 'flat'  .OR.  masking_method )  THEN
-
-                IF ( .NOT. unroll )  THEN
-
-                   CALL cpu_log( log_point_s(36), 'redblack_no_unroll_f', 'start' )
-!
-!--                Without unrolling of loops, no cache optimization
-                   !$OMP PARALLEL PRIVATE (i,j,k,km1,kp1)
-                   !$OMP DO
-                   DO  i = nxl_mg(l), nxr_mg(l), 2
-                      DO  j = nys_mg(l) + 2 - color, nyn_mg(l), 2
-                         !DIR$ IVDEP
-                         DO  k = ind_even_odd+1, nzt_mg(l)
-                            km1 = k-ind_even_odd-1
-                            kp1 = k-ind_even_odd
-                            p_mg(k,j,i) = 1.0_wp / f1_mg_b(k,l) * (            &
-                               ddx2_mg(l) *                                    &
-                               ( p_mg(k,j,i+1) + p_mg(k,j,i-1)  )              &
-                               + ddy2_mg(l) *                                  &
-                               ( p_mg(k,j+1,i) + p_mg(k,j-1,i)  )              &
-                               + f2_mg_b(k,l) * p_mg(kp1,j,i)                  &
-                               + f3_mg_b(k,l) * p_mg(km1,j,i)                  &
-                               - f_mg(k,j,i)               )
-                         ENDDO
-                      ENDDO
-                   ENDDO
-   
-                   !$OMP DO
-                   DO  i = nxl_mg(l)+1, nxr_mg(l), 2
-                      DO  j = nys_mg(l) + (color-1), nyn_mg(l), 2
-                          !DIR$ IVDEP
-                          DO  k = ind_even_odd+1, nzt_mg(l)
-                            km1 = k-ind_even_odd-1
-                            kp1 = k-ind_even_odd
-                            p_mg(k,j,i) = 1.0_wp / f1_mg_b(k,l) * (            &
-                               ddx2_mg(l) *                                    &
-                               ( p_mg(k,j,i+1) + p_mg(k,j,i-1)  )              &
-                               + ddy2_mg(l) *                                  &
-                               ( p_mg(k,j+1,i) + p_mg(k,j-1,i) )               &
-                               + f2_mg_b(k,l) * p_mg(kp1,j,i)                  &
-                               + f3_mg_b(k,l) * p_mg(km1,j,i)                  &
-                               - f_mg(k,j,i)               )
-                         ENDDO
-                      ENDDO
-                   ENDDO
-  
-                   !$OMP DO
-                   DO  i = nxl_mg(l), nxr_mg(l), 2
-                      DO  j = nys_mg(l) + (color-1), nyn_mg(l), 2
-                         !DIR$ IVDEP
-                         DO  k = nzb+1, ind_even_odd
-                            km1 = k+ind_even_odd
-                            kp1 = k+ind_even_odd+1
-                            p_mg(k,j,i) = 1.0_wp / f1_mg_b(k,l) * (            &
-                               ddx2_mg(l) *                                    &
-                               ( p_mg(k,j,i+1) + p_mg(k,j,i-1) )               &
-                               + ddy2_mg(l) *                                  &
-                               ( p_mg(k,j+1,i) + p_mg(k,j-1,i) )               &
-                               + f2_mg_b(k,l) * p_mg(kp1,j,i)                  &
-                               + f3_mg_b(k,l) * p_mg(km1,j,i)                  &
-                               - f_mg(k,j,i)               )
-                         ENDDO
-                      ENDDO
-                   ENDDO
-
-                   !$OMP DO
-                   DO  i = nxl_mg(l)+1, nxr_mg(l), 2
-                      DO  j = nys_mg(l) + 2 - color, nyn_mg(l), 2
-                         !DIR$ IVDEP
-                         DO  k = nzb+1, ind_even_odd
-                            km1 = k+ind_even_odd
-                            kp1 = k+ind_even_odd+1
-                            p_mg(k,j,i) = 1.0_wp / f1_mg_b(k,l) * (            &
-                               ddx2_mg(l) *                                    &
-                               ( p_mg(k,j,i+1) + p_mg(k,j,i-1) )               &
-                               + ddy2_mg(l) *                                  &
-                               ( p_mg(k,j+1,i) + p_mg(k,j-1,i) )               &
-                               + f2_mg_b(k,l) * p_mg(kp1,j,i)                  &
-                               + f3_mg_b(k,l) * p_mg(km1,j,i)                  &
-                               - f_mg(k,j,i)               )
-                         ENDDO
-                      ENDDO
-                   ENDDO
-                   !$OMP END PARALLEL
-
-                   CALL cpu_log( log_point_s(36), 'redblack_no_unroll_f', 'stop' )
-
-                ELSE
-!
-!--                Loop unrolling along y, only one i loop for better cache use
-                   CALL cpu_log( log_point_s(38), 'redblack_unroll_f', 'start' )
-
-                   !$OMP PARALLEL PRIVATE (i,j,k,ic,jc,km1,kp1,jj)
-                   !$OMP DO
-                   DO  ic = nxl_mg(l), nxr_mg(l), 2
-                      DO  jc = nys_mg(l), nyn_mg(l), 4
-                         i  = ic
-                         jj = jc+2-color
-                         !DIR$ IVDEP
-                         DO  k = ind_even_odd+1, nzt_mg(l)
-                            km1 = k-ind_even_odd-1
-                            kp1 = k-ind_even_odd
-                            j   = jj
-                            p_mg(k,j,i) = 1.0_wp / f1_mg_b(k,l) * (            &
-                               ddx2_mg(l) *                                    &
-                               ( p_mg(k,j,i+1) + p_mg(k,j,i-1) )               &
-                               + ddy2_mg(l) *                                  &
-                               ( p_mg(k,j+1,i) + p_mg(k,j-1,i) )               &
-                               + f2_mg_b(k,l) * p_mg(kp1,j,i)                  &
-                               + f3_mg_b(k,l) * p_mg(km1,j,i)                  &
-                               - f_mg(k,j,i)               )
-                            j = jj+2
-                            p_mg(k,j,i) = 1.0_wp / f1_mg_b(k,l) * (            &
-                               ddx2_mg(l) *                                    &
-                               ( p_mg(k,j,i+1) + p_mg(k,j,i-1) )               &
-                               + ddy2_mg(l) *                                  &
-                               ( p_mg(k,j+1,i) + p_mg(k,j-1,i) )               &
-                               + f2_mg_b(k,l) * p_mg(kp1,j,i)                  &
-                               + f3_mg_b(k,l) * p_mg(km1,j,i)                  &
-                               - f_mg(k,j,i)               )
-                         ENDDO
-
-                         i  = ic+1
-                         jj = jc+color-1
-                         !DIR$ IVDEP
-                         DO  k = ind_even_odd+1, nzt_mg(l)
-                            km1 = k-ind_even_odd-1
-                            kp1 = k-ind_even_odd
-                            j   = jj
-                            p_mg(k,j,i) = 1.0_wp / f1_mg_b(k,l) * (            &
-                               ddx2_mg(l) *                                    &
-                               ( p_mg(k,j,i+1) + p_mg(k,j,i-1)  )              &
-                               + ddy2_mg(l) *                                  &
-                               ( p_mg(k,j+1,i) + p_mg(k,j-1,i) )               &
-                               + f2_mg_b(k,l) * p_mg(kp1,j,i)                  &
-                               + f3_mg_b(k,l) * p_mg(km1,j,i)                  &
-                               - f_mg(k,j,i)               )
-                            j = jj+2
-                            p_mg(k,j,i) = 1.0_wp / f1_mg_b(k,l) * (            &
-                               ddx2_mg(l) *                                    &
-                               ( p_mg(k,j,i+1) + p_mg(k,j,i-1)  )              &
-                               + ddy2_mg(l) *                                  &
-                               ( p_mg(k,j+1,i) + p_mg(k,j-1,i)  )              &
-                               + f2_mg_b(k,l) * p_mg(kp1,j,i)                  &
-                               + f3_mg_b(k,l) * p_mg(km1,j,i)                  &
-                               - f_mg(k,j,i)               )
-                         ENDDO
-
-                         i  = ic
-                         jj = jc+color-1
-                         !DIR$ IVDEP
-                         DO  k = nzb+1, ind_even_odd
-                            km1 = k+ind_even_odd
-                            kp1 = k+ind_even_odd+1
-                            j   = jj
-                            p_mg(k,j,i) = 1.0_wp / f1_mg_b(k,l) * (            &
-                               ddx2_mg(l) *                                    &
-                               ( p_mg(k,j,i+1) + p_mg(k,j,i-1)  )              &
-                               + ddy2_mg(l) *                                  &
-                               ( p_mg(k,j+1,i) + p_mg(k,j-1,i)  )              &
-                               + f2_mg_b(k,l) * p_mg(kp1,j,i)                  &
-                               + f3_mg_b(k,l) * p_mg(km1,j,i)                  &
-                               - f_mg(k,j,i)               )
-                            j = jj+2
-                            p_mg(k,j,i) = 1.0_wp / f1_mg_b(k,l) * (            &
-                               ddx2_mg(l) *                                    &
-                               ( p_mg(k,j,i+1) + p_mg(k,j,i-1) )               &
-                               + ddy2_mg(l) *                                  &
-                               ( p_mg(k,j+1,i) + p_mg(k,j-1,i) )               &
-                               + f2_mg_b(k,l) * p_mg(kp1,j,i)                  &
-                               + f3_mg_b(k,l) * p_mg(km1,j,i)                  &
-                               - f_mg(k,j,i)               )
-                         ENDDO
-
-                         i  = ic+1
-                         jj = jc+2-color
-                         !DIR$ IVDEP
-                         DO  k = nzb+1, ind_even_odd
-                            km1 = k+ind_even_odd
-                            kp1 = k+ind_even_odd+1
-                            j   = jj
-                            p_mg(k,j,i) = 1.0_wp / f1_mg_b(k,l) * (            &
-                               ddx2_mg(l) *                                    &
-                               ( p_mg(k,j,i+1) + p_mg(k,j,i-1)  )              &
-                               + ddy2_mg(l) *                                  &
-                               ( p_mg(k,j+1,i) + p_mg(k,j-1,i) )               &
-                               + f2_mg_b(k,l) * p_mg(kp1,j,i)                  &
-                               + f3_mg_b(k,l) * p_mg(km1,j,i)                  &
-                               - f_mg(k,j,i)               )
-                            j = jj+2
-                            p_mg(k,j,i) = 1.0_wp / f1_mg_b(k,l) * (            &
-                               ddx2_mg(l) *                                    &
-                               ( p_mg(k,j,i+1) + p_mg(k,j,i-1) )               &
-                               + ddy2_mg(l) *                                  &
-                               ( p_mg(k,j+1,i) + p_mg(k,j-1,i)  )              &
-                               + f2_mg_b(k,l) * p_mg(kp1,j,i)                  &
-                               + f3_mg_b(k,l) * p_mg(km1,j,i)                  &
-                               - f_mg(k,j,i)               )
-                         ENDDO
-
-                      ENDDO
-                   ENDDO
-                   !$OMP END PARALLEL
-
-                   CALL cpu_log( log_point_s(38), 'redblack_unroll_f', 'stop' )
-
-                ENDIF
-
-             ELSE
-
-                IF ( .NOT. unroll )  THEN
-
-                   CALL cpu_log( log_point_s(36), 'redblack_no_unroll', 'start' )
-!
-!--                Without unrolling of loops, no cache optimization /
-!--                vectorization. Therefore, the non-vectorized IBITS function
-!--                is still used.
-                   !$OMP PARALLEL PRIVATE (i,j,k,km1,kp1)
-                   !$OMP DO
-                   DO  i = nxl_mg(l), nxr_mg(l), 2
-                      DO  j = nys_mg(l) + 2 - color, nyn_mg(l), 2
-                         !DIR$ IVDEP
-                         DO  k = ind_even_odd+1, nzt_mg(l)
-                            km1 = k-ind_even_odd-1
-                            kp1 = k-ind_even_odd
-
-                            p_mg(k,j,i) = 1.0_wp / f1_mg(k,l) * (              &
-                               ddx2_mg(l) *                                    &
-                               ( p_mg(k,j,i+1) + IBITS( flags(k,j,i), 5, 1 ) * &
-                               ( p_mg(k,j,i) - p_mg(k,j,i+1) ) +               &
-                               p_mg(k,j,i-1) + IBITS( flags(k,j,i), 4, 1 ) *   &
-                               ( p_mg(k,j,i) - p_mg(k,j,i-1) ) )               &
-                               + ddy2_mg(l) *                                  &
-                               ( p_mg(k,j+1,i) + IBITS( flags(k,j,i), 3, 1 ) * &
-                               ( p_mg(k,j,i) - p_mg(k,j+1,i) ) +               &
-                               p_mg(k,j-1,i) + IBITS( flags(k,j,i), 2, 1 ) *   &
-                               ( p_mg(k,j,i) - p_mg(k,j-1,i) ) )               &
-                               + f2_mg(k,l) * p_mg(kp1,j,i)                    &
-                               + f3_mg(k,l) *                                  &
-                               ( p_mg(km1,j,i) + IBITS( flags(k,j,i), 0, 1 ) * &
-                               ( p_mg(k,j,i) - p_mg(km1,j,i) ) )               &
-                               - f_mg(k,j,i)               )
-                         ENDDO
-                      ENDDO
-                   ENDDO
-   
-                   !$OMP DO
-                   DO  i = nxl_mg(l)+1, nxr_mg(l), 2
-                      DO  j = nys_mg(l) + (color-1), nyn_mg(l), 2
-                          !DIR$ IVDEP
-                          DO  k = ind_even_odd+1, nzt_mg(l)
-                            km1 = k-ind_even_odd-1
-                            kp1 = k-ind_even_odd
-
-                            p_mg(k,j,i) = 1.0_wp / f1_mg(k,l) * (              &
-                               ddx2_mg(l) *                                    &
-                               ( p_mg(k,j,i+1) + IBITS( flags(k,j,i), 5, 1 ) * &
-                               ( p_mg(k,j,i) - p_mg(k,j,i+1) ) +               &
-                               p_mg(k,j,i-1) + IBITS( flags(k,j,i), 4, 1 ) *   &
-                               ( p_mg(k,j,i) - p_mg(k,j,i-1) ) )               &
-                               + ddy2_mg(l) *                                  &
-                               ( p_mg(k,j+1,i) + IBITS( flags(k,j,i), 3, 1 ) * &
-                               ( p_mg(k,j,i) - p_mg(k,j+1,i) ) +               &
-                               p_mg(k,j-1,i) + IBITS( flags(k,j,i), 2, 1 ) *   &
-                               ( p_mg(k,j,i) - p_mg(k,j-1,i) ) )               &
-                               + f2_mg(k,l) * p_mg(kp1,j,i)                    &
-                               + f3_mg(k,l) *                                  &
-                               ( p_mg(km1,j,i) + IBITS( flags(k,j,i), 0, 1 ) * &
-                               ( p_mg(k,j,i) - p_mg(km1,j,i) ) )               &
-                               - f_mg(k,j,i)               )
-                         ENDDO
-                      ENDDO
-                   ENDDO
-
-                   !$OMP DO
-                   DO  i = nxl_mg(l), nxr_mg(l), 2
-                      DO  j = nys_mg(l) + (color-1), nyn_mg(l), 2
-                         !DIR$ IVDEP
-                         DO  k = nzb+1, ind_even_odd
-                            km1 = k+ind_even_odd
-                            kp1 = k+ind_even_odd+1
-                            p_mg(k,j,i) = 1.0_wp / f1_mg(k,l) * (              &
-                               ddx2_mg(l) *                                    &
-                               ( p_mg(k,j,i+1) + IBITS( flags(k,j,i), 5, 1 ) * &
-                               ( p_mg(k,j,i) - p_mg(k,j,i+1) ) +               &
-                               p_mg(k,j,i-1) + IBITS( flags(k,j,i), 4, 1 ) *   &
-                               ( p_mg(k,j,i) - p_mg(k,j,i-1) ) )               &
-                               + ddy2_mg(l) *                                  &
-                               ( p_mg(k,j+1,i) + IBITS( flags(k,j,i), 3, 1 ) * &
-                               ( p_mg(k,j,i) - p_mg(k,j+1,i) ) +               &
-                               p_mg(k,j-1,i) + IBITS( flags(k,j,i), 2, 1 ) *   &
-                               ( p_mg(k,j,i) - p_mg(k,j-1,i) ) )               &
-                               + f2_mg(k,l) * p_mg(kp1,j,i)                    &
-                               + f3_mg(k,l) *                                  &
-                               ( p_mg(km1,j,i) + IBITS( flags(k,j,i), 0, 1 ) * &
-                               ( p_mg(k,j,i) - p_mg(km1,j,i) ) ) &
-                               - f_mg(k,j,i)               )
-                         ENDDO
-                      ENDDO
-                   ENDDO
-
-                   !$OMP DO
-                   DO  i = nxl_mg(l)+1, nxr_mg(l), 2
-                      DO  j = nys_mg(l) + 2 - color, nyn_mg(l), 2
-                         !DIR$ IVDEP
-                         DO  k = nzb+1, ind_even_odd
-                            km1 = k+ind_even_odd
-                            kp1 = k+ind_even_odd+1
-
-                            p_mg(k,j,i) = 1.0_wp / f1_mg(k,l) * (              &
-                               ddx2_mg(l) *                                    &
-                               ( p_mg(k,j,i+1) + IBITS( flags(k,j,i), 5, 1 ) * &
-                               ( p_mg(k,j,i) - p_mg(k,j,i+1) ) +               &
-                               p_mg(k,j,i-1) + IBITS( flags(k,j,i), 4, 1 ) *   &
-                               ( p_mg(k,j,i) - p_mg(k,j,i-1) ) )               &
-                               + ddy2_mg(l) *                                  &
-                               ( p_mg(k,j+1,i) + IBITS( flags(k,j,i), 3, 1 ) * &
-                               ( p_mg(k,j,i) - p_mg(k,j+1,i) ) +               &
-                               p_mg(k,j-1,i) + IBITS( flags(k,j,i), 2, 1 ) *   &
-                               ( p_mg(k,j,i) - p_mg(k,j-1,i) ) )               &
-                               + f2_mg(k,l) * p_mg(kp1,j,i)                    &
-                               + f3_mg(k,l) *                                  &
-                               ( p_mg(km1,j,i) + IBITS( flags(k,j,i), 0, 1 ) * &
-                               ( p_mg(k,j,i) - p_mg(km1,j,i) ) )               &
-                               - f_mg(k,j,i)               )
-                         ENDDO
-                      ENDDO
-                   ENDDO
-                   !$OMP END PARALLEL
-
-                   CALL cpu_log( log_point_s(36), 'redblack_no_unroll', 'stop' )
-
-                ELSE
-!
-!--                Loop unrolling along y, only one i loop for better cache use
-                   CALL cpu_log( log_point_s(38), 'redblack_unroll', 'start' )
-
-                   !$OMP PARALLEL PRIVATE (i,j,k,ic,jc,km1,kp1,jj)
-                   !$OMP DO
-                   DO  ic = nxl_mg(l), nxr_mg(l), 2
-                      DO  jc = nys_mg(l), nyn_mg(l), 4
-                         i  = ic
-                         jj = jc+2-color
-                         !DIR$ IVDEP
-                         DO  k = ind_even_odd+1, nzt_mg(l)
-
-                            km1 = k-ind_even_odd-1
-                            kp1 = k-ind_even_odd
-
-                            j = jj
-                            p_mg(k,j,i) = 1.0 / f1_mg(k,l) * (                               &
-                                ddx2_mg(l) *                                                 &
-                                ( MERGE(p_mg(k,j,i),p_mg(k,j,i+1),BTEST( flags(k,j,i), 5))   &
-                                + MERGE(p_mg(k,j,i),p_mg(k,j,i-1),BTEST( flags(k,j,i), 4)) ) &
-                                + ddy2_mg(l) *                                               &
-                                ( MERGE(p_mg(k,j,i),p_mg(k,j+1,i),BTEST( flags(k,j,i), 3))   &
-                                + MERGE(p_mg(k,j,i),p_mg(k,j-1,i),BTEST( flags(k,j,i), 2)) ) &
-                                + f2_mg(k,l) * p_mg(kp1,j,i)                                 &
-                                + f3_mg(k,l) *                                               &
-                                MERGE(p_mg(k,j,i),p_mg(km1,j,i),BTEST( flags(k,j,i), 0))     &
-                                - f_mg(k,j,i)               )
-                            j = jj+2
-                            p_mg(k,j,i) = 1.0 / f1_mg(k,l) * (                               &
-                                ddx2_mg(l) *                                                 &
-                                ( MERGE(p_mg(k,j,i),p_mg(k,j,i+1),BTEST( flags(k,j,i), 5))   &
-                                + MERGE(p_mg(k,j,i),p_mg(k,j,i-1),BTEST( flags(k,j,i), 4)) ) &
-                                + ddy2_mg(l) *                                               &
-                                ( MERGE(p_mg(k,j,i),p_mg(k,j+1,i),BTEST( flags(k,j,i), 3))   &
-                                + MERGE(p_mg(k,j,i),p_mg(k,j-1,i),BTEST( flags(k,j,i), 2)) ) &
-                                + f2_mg(k,l) * p_mg(kp1,j,i)                                 &
-                                + f3_mg(k,l) *                                               &
-                                MERGE(p_mg(k,j,i),p_mg(km1,j,i),BTEST( flags(k,j,i), 0))     &
-                                - f_mg(k,j,i)               )
-
-                         ENDDO
-
-                         i  = ic+1
-                         jj = jc+color-1
-                         !DIR$ IVDEP
-                         DO  k = ind_even_odd+1, nzt_mg(l)
-
-                            km1 = k-ind_even_odd-1
-                            kp1 = k-ind_even_odd
-
-                            j =jj
-                            p_mg(k,j,i) = 1.0 / f1_mg(k,l) * (                               &
-                                ddx2_mg(l) *                                                 &
-                                ( MERGE(p_mg(k,j,i),p_mg(k,j,i+1),BTEST( flags(k,j,i), 5))   &
-                                + MERGE(p_mg(k,j,i),p_mg(k,j,i-1),BTEST( flags(k,j,i), 4)) ) &
-                                + ddy2_mg(l) *                                               &
-                                ( MERGE(p_mg(k,j,i),p_mg(k,j+1,i),BTEST( flags(k,j,i), 3))   &
-                                + MERGE(p_mg(k,j,i),p_mg(k,j-1,i),BTEST( flags(k,j,i), 2)) ) &
-                                + f2_mg(k,l) * p_mg(kp1,j,i)                                 &
-                                + f3_mg(k,l) *                                               &
-                                MERGE(p_mg(k,j,i),p_mg(km1,j,i),BTEST( flags(k,j,i), 0))     &
-                                - f_mg(k,j,i)               )
-
-                            j = jj+2
-                            p_mg(k,j,i) = 1.0 / f1_mg(k,l) * (                               &
-                                ddx2_mg(l) *                                                 &
-                                ( MERGE(p_mg(k,j,i),p_mg(k,j,i+1),BTEST( flags(k,j,i), 5))   &
-                                + MERGE(p_mg(k,j,i),p_mg(k,j,i-1),BTEST( flags(k,j,i), 4)) ) &
-                                + ddy2_mg(l) *                                               &
-                                ( MERGE(p_mg(k,j,i),p_mg(k,j+1,i),BTEST( flags(k,j,i), 3))   &
-                                + MERGE(p_mg(k,j,i),p_mg(k,j-1,i),BTEST( flags(k,j,i), 2)) ) &
-                                + f2_mg(k,l) * p_mg(kp1,j,i)                                 &
-                                + f3_mg(k,l) *                                               &
-                                MERGE(p_mg(k,j,i),p_mg(km1,j,i),BTEST( flags(k,j,i), 0))     &
-                                - f_mg(k,j,i)               )
-
-                         ENDDO
-
-                         i  = ic
-                         jj = jc+color-1
-                         !DIR$ IVDEP
-                         DO  k = nzb+1, ind_even_odd
-
-                            km1 = k+ind_even_odd
-                            kp1 = k+ind_even_odd+1
-
-                            j =jj
-                            p_mg(k,j,i) = 1.0 / f1_mg(k,l) * (                               &
-                                ddx2_mg(l) *                                                 &
-                                ( MERGE(p_mg(k,j,i),p_mg(k,j,i+1),BTEST( flags(k,j,i), 5))   &
-                                + MERGE(p_mg(k,j,i),p_mg(k,j,i-1),BTEST( flags(k,j,i), 4)) ) &
-                                + ddy2_mg(l) *                                               &
-                                ( MERGE(p_mg(k,j,i),p_mg(k,j+1,i),BTEST( flags(k,j,i), 3))   &
-                                + MERGE(p_mg(k,j,i),p_mg(k,j-1,i),BTEST( flags(k,j,i), 2)) ) &
-                                + f2_mg(k,l) * p_mg(kp1,j,i)                                 &
-                                + f3_mg(k,l) *                                               &
-                                MERGE(p_mg(k,j,i),p_mg(km1,j,i),BTEST( flags(k,j,i), 0))     &
-                                - f_mg(k,j,i)               )
-
-                            j = jj+2
-                            p_mg(k,j,i) = 1.0 / f1_mg(k,l) * (                               &
-                                ddx2_mg(l) *                                                 &
-                                ( MERGE(p_mg(k,j,i),p_mg(k,j,i+1),BTEST( flags(k,j,i), 5))   &
-                                + MERGE(p_mg(k,j,i),p_mg(k,j,i-1),BTEST( flags(k,j,i), 4)) ) &
-                                + ddy2_mg(l) *                                               &
-                                ( MERGE(p_mg(k,j,i),p_mg(k,j+1,i),BTEST( flags(k,j,i), 3))   &
-                                + MERGE(p_mg(k,j,i),p_mg(k,j-1,i),BTEST( flags(k,j,i), 2)) ) &
-                                + f2_mg(k,l) * p_mg(kp1,j,i)                                 &
-                                + f3_mg(k,l) *                                               &
-                                MERGE(p_mg(k,j,i),p_mg(km1,j,i),BTEST( flags(k,j,i), 0))     &
-                                - f_mg(k,j,i)               )
-
-                         ENDDO
-
-                         i  = ic+1
-                         jj = jc+2-color
-                         !DIR$ IVDEP
-                         DO  k = nzb+1, ind_even_odd
-
-                            km1 = k+ind_even_odd
-                            kp1 = k+ind_even_odd+1
-
-                            j =jj
-                            p_mg(k,j,i) = 1.0 / f1_mg(k,l) * (                               &
-                                ddx2_mg(l) *                                                 &
-                                ( MERGE(p_mg(k,j,i),p_mg(k,j,i+1),BTEST( flags(k,j,i), 5))   &
-                                + MERGE(p_mg(k,j,i),p_mg(k,j,i-1),BTEST( flags(k,j,i), 4)) ) &
-                                + ddy2_mg(l) *                                               &
-                                ( MERGE(p_mg(k,j,i),p_mg(k,j+1,i),BTEST( flags(k,j,i), 3))   &
-                                + MERGE(p_mg(k,j,i),p_mg(k,j-1,i),BTEST( flags(k,j,i), 2)) ) &
-                                + f2_mg(k,l) * p_mg(kp1,j,i)                                 &
-                                + f3_mg(k,l) *                                               &
-                                MERGE(p_mg(k,j,i),p_mg(km1,j,i),BTEST( flags(k,j,i), 0))     &
-                                - f_mg(k,j,i)               )
-
-                            j = jj+2
-                            p_mg(k,j,i) = 1.0 / f1_mg(k,l) * (                               &
-                                ddx2_mg(l) *                                                 &
-                                ( MERGE(p_mg(k,j,i),p_mg(k,j,i+1),BTEST( flags(k,j,i), 5))   &
-                                + MERGE(p_mg(k,j,i),p_mg(k,j,i-1),BTEST( flags(k,j,i), 4)) ) &
-                                + ddy2_mg(l) *                                               &
-                                ( MERGE(p_mg(k,j,i),p_mg(k,j+1,i),BTEST( flags(k,j,i), 3))   &
-                                + MERGE(p_mg(k,j,i),p_mg(k,j-1,i),BTEST( flags(k,j,i), 2)) ) &
-                                + f2_mg(k,l) * p_mg(kp1,j,i)                                 &
-                                + f3_mg(k,l) *                                               &
-                                MERGE(p_mg(k,j,i),p_mg(km1,j,i),BTEST( flags(k,j,i), 0))     &
-                                - f_mg(k,j,i)               )
-
-                         ENDDO
-
-                      ENDDO
-                   ENDDO
-                   !$OMP END PARALLEL
-
-                   CALL cpu_log( log_point_s(38), 'redblack_unroll', 'stop' )
-
-                ENDIF
-
-             ENDIF
-
-!
-!--          Horizontal boundary conditions
-             CALL special_exchange_horiz( p_mg, color )
-
-             IF ( .NOT. bc_lr_cyc )  THEN
-                IF ( inflow_l .OR. outflow_l .OR. nest_bound_l )  THEN
-                   p_mg(:,:,nxl_mg(l)-1) = p_mg(:,:,nxl_mg(l))
-                ENDIF
-                IF ( inflow_r .OR. outflow_r .OR. nest_bound_r )  THEN
-                   p_mg(:,:,nxr_mg(l)+1) = p_mg(:,:,nxr_mg(l))
-                ENDIF
-             ENDIF
-
-             IF ( .NOT. bc_ns_cyc )  THEN
-                IF ( inflow_n .OR. outflow_n .OR. nest_bound_n )  THEN
-                   p_mg(:,nyn_mg(l)+1,:) = p_mg(:,nyn_mg(l),:)
-                ENDIF
-                IF ( inflow_s .OR. outflow_s .OR. nest_bound_s )  THEN
-                   p_mg(:,nys_mg(l)-1,:) = p_mg(:,nys_mg(l),:)
-                ENDIF
-             ENDIF
-
-!
-!--          Bottom and top boundary conditions
-             IF ( ibc_p_b == 1 )  THEN
-                p_mg(nzb,:,: ) = p_mg(ind_even_odd+1,:,:)
-             ELSE
-                p_mg(nzb,:,: ) = 0.0_wp
-             ENDIF
-
-             IF ( ibc_p_t == 1 )  THEN
-                p_mg(nzt_mg(l)+1,:,: ) = p_mg(ind_even_odd,:,:)
-             ELSE
-                p_mg(nzt_mg(l)+1,:,: ) = 0.0_wp
-             ENDIF
-
-          ENDDO
-       ENDDO
-!
-!--    Set pressure within topography and at the topography surfaces
-       IF ( topography /= 'flat'  .AND.  .NOT. masking_method )  THEN
-
-          !$OMP PARALLEL PRIVATE (i,j,k,kp1,wall_left,wall_north,wall_right,   &
-          !$OMP                   wall_south,wall_top,wall_total)
-          !$OMP DO
-          DO  i = nxl_mg(l), nxr_mg(l)
-             DO  j = nys_mg(l), nyn_mg(l)
-                !DIR$ IVDEP
-                DO  k = ind_even_odd+1, nzt_mg(l)
-                   km1 = k-ind_even_odd-1
-                   kp1 = k-ind_even_odd
-!
-!--                First, set pressure inside topography to zero
-                   p_mg(k,j,i) = p_mg(k,j,i) *                                 &
-                                 ( 1.0_wp - IBITS( flags(k,j,i), 6, 1 ) )
-!
-!--                Second, determine if the gridpoint inside topography is
-!--                adjacent to a wall and set its value to a value given by the
-!--                average of those values obtained from Neumann boundary
-!--                condition
-                   wall_left  = IBITS( flags(k,j,i-1), 5, 1 )
-                   wall_right = IBITS( flags(k,j,i+1), 4, 1 )
-                   wall_south = IBITS( flags(k,j-1,i), 3, 1 )
-                   wall_north = IBITS( flags(k,j+1,i), 2, 1 )
-                   wall_top   = IBITS( flags(kp1,j,i), 0, 1 )
-                   wall_total = wall_left + wall_right + wall_south +          &
-                                wall_north + wall_top
-
-                   IF ( wall_total > 0.0_wp )  THEN
-                      p_mg(k,j,i) = 1.0_wp / wall_total *                      &
-                                    ( wall_left  * p_mg(k,j,i-1) +             &
-                                      wall_right * p_mg(k,j,i+1) +             &
-                                      wall_south * p_mg(k,j-1,i) +             &
-                                      wall_north * p_mg(k,j+1,i) +             &
-                                      wall_top   * p_mg(kp1,j,i) )
-                   ENDIF
-                ENDDO
-
-                !DIR$ IVDEP
-                DO  k = nzb+1, ind_even_odd
-                   km1 = k+ind_even_odd
-                   kp1 = k+ind_even_odd+1
-!
-!--                First, set pressure inside topography to zero
-                   p_mg(k,j,i) = p_mg(k,j,i) *                                 &
-                                 ( 1.0_wp - IBITS( flags(k,j,i), 6, 1 ) )
-!
-!--                Second, determine if the gridpoint inside topography is
-!--                adjacent to a wall and set its value to a value given by the
-!--                average of those values obtained from Neumann boundary
-!--                condition
-                   wall_left  = IBITS( flags(k,j,i-1), 5, 1 )
-                   wall_right = IBITS( flags(k,j,i+1), 4, 1 )
-                   wall_south = IBITS( flags(k,j-1,i), 3, 1 )
-                   wall_north = IBITS( flags(k,j+1,i), 2, 1 )
-                   wall_top   = IBITS( flags(kp1,j,i), 0, 1 )
-                   wall_total = wall_left + wall_right + wall_south +          &
-                                wall_north + wall_top
-
-                   IF ( wall_total > 0.0_wp )  THEN
-                      p_mg(k,j,i) = 1.0_wp / wall_total *                      &
-                                    ( wall_left  * p_mg(k,j,i-1) +             &
-                                      wall_right * p_mg(k,j,i+1) +             &
-                                      wall_south * p_mg(k,j-1,i) +             &
-                                      wall_north * p_mg(k,j+1,i) +             &
-                                      wall_top   * p_mg(kp1,j,i) )
-                   ENDIF
-                ENDDO
-             ENDDO
-          ENDDO
-          !$OMP END PARALLEL
-
-!
-!--       One more time horizontal boundary conditions
-          CALL exchange_horiz( p_mg, 1)
-
-       ENDIF
-
-    END SUBROUTINE redblack_fast
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Sort k-Dimension from sequential into blocks of even and odd.
-!> This is required to vectorize the red-black subroutine.
-!> Version for 3D-REAL arrays
-!------------------------------------------------------------------------------!
-    SUBROUTINE sort_k_to_even_odd_blocks( p_mg , glevel )
-
-
-       USE control_parameters,                                                 &
-           ONLY:  grid_level
-
-       USE indices,                                                            &
-           ONLY:  nxl_mg, nxr_mg, nys_mg, nyn_mg, nzb, nzt_mg
-
-       IMPLICIT NONE
-
-       INTEGER(iwp), INTENT(IN) ::  glevel
-
-       REAL(wp), DIMENSION(nzb:nzt_mg(glevel)+1,                               &
-                           nys_mg(glevel)-1:nyn_mg(glevel)+1,                  &
-                           nxl_mg(glevel)-1:nxr_mg(glevel)+1) ::  p_mg  !<
-!
-!--    Local variables
-       INTEGER(iwp) :: i        !<
-       INTEGER(iwp) :: j        !<
-       INTEGER(iwp) :: k        !<
-       INTEGER(iwp) :: l        !<
-       INTEGER(iwp) :: ind      !<
-       REAL(wp), DIMENSION(nzb:nzt_mg(glevel)+1) ::  tmp  !<
-
-
-       CALL cpu_log( log_point_s(52), 'sort_k_to_even_odd', 'start' )
-
-       l = glevel
-       ind_even_odd = even_odd_level(l)
-
-       !$OMP PARALLEL PRIVATE (i,j,k,ind,tmp)
-       !$OMP DO
-       DO  i = nxl_mg(l)-1, nxr_mg(l)+1
-          DO  j = nys_mg(l)-1, nyn_mg(l)+1
-
-!
-!--          Sort the data with even k index
-             ind = nzb-1
-             DO  k = nzb, nzt_mg(l), 2
-                ind = ind + 1
-                tmp(ind) = p_mg(k,j,i)
-             ENDDO
-!
-!--          Sort the data with odd k index
-             DO  k = nzb+1, nzt_mg(l)+1, 2
-                ind = ind + 1
-                tmp(ind) = p_mg(k,j,i)
-             ENDDO
-
-             p_mg(:,j,i) = tmp
-
-          ENDDO
-       ENDDO
-       !$OMP END PARALLEL
-
-       CALL cpu_log( log_point_s(52), 'sort_k_to_even_odd', 'stop' )
-
-    END SUBROUTINE sort_k_to_even_odd_blocks
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Sort k-Dimension from sequential into blocks of even and odd.
-!> This is required to vectorize the red-black subroutine.
-!> Version for 1D-REAL arrays
-!------------------------------------------------------------------------------!
-    SUBROUTINE sort_k_to_even_odd_blocks_1d( f_mg, f_mg_b, glevel )
-
-
-       USE indices,                                                            &
-           ONLY:  nzb, nzt_mg
-
-       IMPLICIT NONE
-
-       INTEGER(iwp), INTENT(IN) ::  glevel
-
-       REAL(wp), DIMENSION(nzb+1:nzt_mg(glevel)) ::  f_mg
-       REAL(wp), DIMENSION(nzb:nzt_mg(glevel)+1) ::  f_mg_b
-
-!
-!--    Local variables
-       INTEGER(iwp) :: ind   !<
-       INTEGER(iwp) :: k     !<
-
-
-       ind = nzb - 1
-!
-!--    Sort the data with even k index
-       DO  k = nzb, nzt_mg(glevel), 2
-          ind = ind + 1
-          IF ( k >= nzb+1  .AND.  k <= nzt_mg(glevel) )  THEN
-             f_mg_b(ind) = f_mg(k)
-          ENDIF
-       ENDDO
-!
-!--    Sort the data with odd k index
-       DO  k = nzb+1, nzt_mg(glevel)+1, 2
-          ind = ind + 1
-          IF( k >= nzb+1  .AND.  k <= nzt_mg(glevel) )  THEN
-             f_mg_b(ind) = f_mg(k)
-          ENDIF
-       ENDDO
-
-    END SUBROUTINE sort_k_to_even_odd_blocks_1d
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Sort k-Dimension from sequential into blocks of even and odd.
-!> This is required to vectorize the red-black subroutine.
-!> Version for 2D-INTEGER arrays
-!------------------------------------------------------------------------------!
-    SUBROUTINE sort_k_to_even_odd_blocks_int( i_mg , glevel )
-
-
-       USE control_parameters,                                                 &
-           ONLY:  grid_level
-
-       USE indices,                                                            &
-           ONLY:  nxl_mg, nxr_mg, nys_mg, nyn_mg, nzb, nzt_mg
-
-       IMPLICIT NONE
-
-       INTEGER(iwp), INTENT(IN) ::  glevel
-
-       INTEGER(iwp), DIMENSION(nzb:nzt_mg(glevel)+1,                           &
-                               nys_mg(glevel)-1:nyn_mg(glevel)+1,              &
-                               nxl_mg(glevel)-1:nxr_mg(glevel)+1) ::  i_mg  !<
-!
-!--    Local variables
-       INTEGER(iwp) :: i        !<
-       INTEGER(iwp) :: j        !<
-       INTEGER(iwp) :: k        !<
-       INTEGER(iwp) :: l        !<
-       INTEGER(iwp) :: ind      !<
-       INTEGER(iwp),DIMENSION(nzb:nzt_mg(glevel)+1) ::  tmp
-
-
-       CALL cpu_log( log_point_s(52), 'sort_k_to_even_odd', 'start' )
-
-       l = glevel
-       ind_even_odd = even_odd_level(l)
-
-       DO  i = nxl_mg(l)-1, nxr_mg(l)+1
-          DO  j = nys_mg(l)-1, nyn_mg(l)+1
-
-!
-!--          Sort the data with even k index
-             ind = nzb-1
-             DO  k = nzb, nzt_mg(l), 2
-                ind = ind + 1
-                tmp(ind) = i_mg(k,j,i)
-             ENDDO
-!
-!++          ATTENTION: Check reason for this error. Remove it or replace WRITE
-!++                     by PALM message
-#if defined ( __parallel )
-             IF ( ind /= ind_even_odd )  THEN
-                WRITE (0,*) 'ERROR ==> illegal ind_even_odd ',ind,ind_even_odd,l
-                CALL MPI_ABORT(MPI_COMM_WORLD,i,j)
-             ENDIF
-#endif
-!
-!--          Sort the data with odd k index
-             DO  k = nzb+1, nzt_mg(l)+1, 2
-                ind = ind + 1
-                tmp(ind) = i_mg(k,j,i)
-             ENDDO
-
-             i_mg(:,j,i) = tmp
-
-          ENDDO
-       ENDDO
-
-       CALL cpu_log( log_point_s(52), 'sort_k_to_even_odd', 'stop' )
-
-    END SUBROUTINE sort_k_to_even_odd_blocks_int
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Sort k-dimension from blocks of even and odd into sequential
-!------------------------------------------------------------------------------!
-    SUBROUTINE sort_k_to_sequential( p_mg )
-
-
-       USE control_parameters,                                                 &
-           ONLY:  grid_level
-
-       USE indices,                                                            &
-           ONLY:  nxl_mg, nxr_mg, nys_mg, nyn_mg, nzb, nzt_mg
-
-       IMPLICIT NONE
-
-       REAL(wp), DIMENSION(nzb:nzt_mg(grid_level)+1,                           &
-                           nys_mg(grid_level)-1:nyn_mg(grid_level)+1,          &
-                           nxl_mg(grid_level)-1:nxr_mg(grid_level)+1) ::  p_mg  !<
-!
-!--    Local variables
-       INTEGER(iwp) :: i        !<
-       INTEGER(iwp) :: j        !<
-       INTEGER(iwp) :: k        !<
-       INTEGER(iwp) :: l        !<
-       INTEGER(iwp) :: ind      !<
-
-       REAL(wp),DIMENSION(nzb:nzt_mg(grid_level)+1) ::  tmp
-
-
-       l = grid_level
-
-       !$OMP PARALLEL PRIVATE (i,j,k,ind,tmp)
-       !$OMP DO
-       DO  i = nxl_mg(l)-1, nxr_mg(l)+1
-          DO  j = nys_mg(l)-1, nyn_mg(l)+1
-
-             ind = nzb - 1
-             tmp = p_mg(:,j,i)
-             DO  k = nzb, nzt_mg(l), 2
-                ind = ind + 1
-                p_mg(k,j,i) = tmp(ind)
-             ENDDO
-
-             DO  k = nzb+1, nzt_mg(l)+1, 2
-                ind = ind + 1
-                p_mg(k,j,i) = tmp(ind)
-             ENDDO
-          ENDDO
-       ENDDO
-       !$OMP END PARALLEL
-
-    END SUBROUTINE sort_k_to_sequential
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Gather subdomain data from all PEs.
-!------------------------------------------------------------------------------!
-    SUBROUTINE mg_gather_fast( f2, f2_sub )
-
-       USE control_parameters,                                                 &
-           ONLY:  grid_level
-
-       USE cpulog,                                                             &
-           ONLY:  cpu_log, log_point_s
-
-       USE indices,                                                            &
-           ONLY:  mg_loc_ind, nxl_mg, nxr_mg, nys_mg, nyn_mg, nzb, nzt_mg
-
-       IMPLICIT NONE
-
-       INTEGER(iwp) ::  i       !<
-       INTEGER(iwp) ::  il      !<
-       INTEGER(iwp) ::  ir      !<
-       INTEGER(iwp) ::  j       !<
-       INTEGER(iwp) ::  jn      !<
-       INTEGER(iwp) ::  js      !<
-       INTEGER(iwp) ::  k       !<
-       INTEGER(iwp) ::  nwords  !<
-
-       REAL(wp), DIMENSION(nzb:nzt_mg(grid_level)+1,                           &
-                       nys_mg(grid_level)-1:nyn_mg(grid_level)+1,              &
-                       nxl_mg(grid_level)-1:nxr_mg(grid_level)+1) ::  f2    !<
-       REAL(wp), DIMENSION(nzb:nzt_mg(grid_level)+1,                           &
-                       nys_mg(grid_level)-1:nyn_mg(grid_level)+1,              &
-                       nxl_mg(grid_level)-1:nxr_mg(grid_level)+1) ::  f2_l  !<
-
-       REAL(wp), DIMENSION(nzb:mg_loc_ind(5,myid)+1,                           &
-                           mg_loc_ind(3,myid)-1:mg_loc_ind(4,myid)+1,          &
-                           mg_loc_ind(1,myid)-1:mg_loc_ind(2,myid)+1) ::  f2_sub  !<
-
-
-#if defined( __parallel )
-       CALL cpu_log( log_point_s(34), 'mg_gather', 'start' )
-
-       f2_l = 0.0_wp
-
-!
-!--    Store the local subdomain array on the total array
-       js = mg_loc_ind(3,myid)
-       IF ( south_border_pe )  js = js - 1
-       jn = mg_loc_ind(4,myid)
-       IF ( north_border_pe )  jn = jn + 1
-       il = mg_loc_ind(1,myid)
-       IF ( left_border_pe )   il = il - 1
-       ir = mg_loc_ind(2,myid)
-       IF ( right_border_pe )  ir = ir + 1
-       DO  i = il, ir
-          DO  j = js, jn
-             DO  k = nzb, nzt_mg(grid_level)+1
-                f2_l(k,j,i) = f2_sub(k,j,i)
-             ENDDO
-          ENDDO
-       ENDDO
-
-!
-!--    Find out the number of array elements of the total array
-       nwords = SIZE( f2 )
-
-!
-!--    Gather subdomain data from all PEs
-       IF ( collective_wait )  CALL MPI_BARRIER( comm2d, ierr )
-       CALL MPI_ALLREDUCE( f2_l(nzb,nys_mg(grid_level)-1,nxl_mg(grid_level)-1), &
-                           f2(nzb,nys_mg(grid_level)-1,nxl_mg(grid_level)-1),   &
-                           nwords, MPI_REAL, MPI_SUM, comm2d, ierr )
-
-       CALL cpu_log( log_point_s(34), 'mg_gather', 'stop' )
-#endif
-    
-    END SUBROUTINE mg_gather_fast
-
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> @todo It might be possible to improve the speed of this routine by using
-!>       non-blocking communication
-!------------------------------------------------------------------------------!
-    SUBROUTINE mg_scatter_fast( p2, p2_sub )
-
-       USE control_parameters,                                                 &
-           ONLY:  grid_level
-
-       USE cpulog,                                                             &
-           ONLY:  cpu_log, log_point_s
-
-       USE indices,                                                            &
-           ONLY:  mg_loc_ind, nxl_mg, nxr_mg, nys_mg, nyn_mg, nzb, nzt_mg
-
-       IMPLICIT NONE
-
-       INTEGER(iwp) ::  nwords  !<
-
-       REAL(wp), DIMENSION(nzb:nzt_mg(grid_level-1)+1,                         &
-                           nys_mg(grid_level-1)-1:nyn_mg(grid_level-1)+1,      &
-                           nxl_mg(grid_level-1)-1:nxr_mg(grid_level-1)+1) ::  p2  !<
-
-       REAL(wp), DIMENSION(nzb:mg_loc_ind(5,myid)+1,                           &
-                           mg_loc_ind(3,myid)-1:mg_loc_ind(4,myid)+1,          &
-                           mg_loc_ind(1,myid)-1:mg_loc_ind(2,myid)+1) ::  p2_sub  !<
-
-!
-!--    Find out the number of array elements of the subdomain array
-       nwords = SIZE( p2_sub )
-
-#if defined( __parallel )
-       CALL cpu_log( log_point_s(35), 'mg_scatter', 'start' )
-
-       p2_sub = p2(:,mg_loc_ind(3,myid)-1:mg_loc_ind(4,myid)+1, &
-                     mg_loc_ind(1,myid)-1:mg_loc_ind(2,myid)+1)
-
-       CALL cpu_log( log_point_s(35), 'mg_scatter', 'stop' )
-#endif
-    
-    END SUBROUTINE mg_scatter_fast
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> This is where the multigrid technique takes place. V- and W- Cycle are
-!> implemented and steered by the parameter "gamma". Parameter "nue" determines
-!> the convergence of the multigrid iterative solution. There are nue times
-!> RB-GS iterations. It should be set to "1" or "2", considering the time effort
-!> one would like to invest. Last choice shows a very good converging factor,
-!> but leads to an increase in computing time.
-!------------------------------------------------------------------------------!
-    RECURSIVE SUBROUTINE next_mg_level_fast( f_mg, p_mg, p3, r )
-
-       USE control_parameters,                                                 &
-           ONLY:  bc_lr_dirrad, bc_lr_raddir, bc_ns_dirrad, bc_ns_raddir,      &
-                  gamma_mg, grid_level, grid_level_count, ibc_p_b, ibc_p_t,    &
-                  inflow_l, inflow_n, inflow_r, inflow_s, maximum_grid_level,  &
-                  mg_switch_to_pe0_level, mg_switch_to_pe0, nest_domain,       &
-                  nest_bound_l, nest_bound_n, nest_bound_r, nest_bound_s,      &
-                  ngsrb, outflow_l, outflow_n, outflow_r, outflow_s
-
-       USE indices,                                                            &
-           ONLY:  mg_loc_ind, nxl, nxl_mg, nxr, nxr_mg, nys, nys_mg, nyn,      &
-                  nyn_mg, nzb, nzt, nzt_mg
-
-       IMPLICIT NONE
-
-       INTEGER(iwp) ::  i            !<
-       INTEGER(iwp) ::  j            !<
-       INTEGER(iwp) ::  k            !<
-       INTEGER(iwp) ::  nxl_mg_save  !<
-       INTEGER(iwp) ::  nxr_mg_save  !<
-       INTEGER(iwp) ::  nyn_mg_save  !<
-       INTEGER(iwp) ::  nys_mg_save  !<
-       INTEGER(iwp) ::  nzt_mg_save  !<
-
-       REAL(wp), DIMENSION(nzb:nzt_mg(grid_level)+1,                           &
-                           nys_mg(grid_level)-1:nyn_mg(grid_level)+1,          &
-                           nxl_mg(grid_level)-1:nxr_mg(grid_level)+1) :: f_mg  !<
-       REAL(wp), DIMENSION(nzb:nzt_mg(grid_level)+1,                           &
-                           nys_mg(grid_level)-1:nyn_mg(grid_level)+1,          &
-                           nxl_mg(grid_level)-1:nxr_mg(grid_level)+1) :: p_mg  !<
-       REAL(wp), DIMENSION(nzb:nzt_mg(grid_level)+1,                           &
-                           nys_mg(grid_level)-1:nyn_mg(grid_level)+1,          &
-                           nxl_mg(grid_level)-1:nxr_mg(grid_level)+1) :: p3    !<
-       REAL(wp), DIMENSION(nzb:nzt_mg(grid_level)+1,                           &
-                           nys_mg(grid_level)-1:nyn_mg(grid_level)+1,          &
-                           nxl_mg(grid_level)-1:nxr_mg(grid_level)+1) :: r     !<
-
-       REAL(wp), DIMENSION(nzb:nzt_mg(grid_level-1)+1,                         &
-                           nys_mg(grid_level-1)-1:nyn_mg(grid_level-1)+1,      &
-                           nxl_mg(grid_level-1)-1:nxr_mg(grid_level-1)+1) ::  f2  !<
-       REAL(wp), DIMENSION(nzb:nzt_mg(grid_level-1)+1,                         &
-                           nys_mg(grid_level-1)-1:nyn_mg(grid_level-1)+1,      &
-                           nxl_mg(grid_level-1)-1:nxr_mg(grid_level-1)+1) ::  p2  !<
-
-       REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::  f2_sub  !<
-       REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::  p2_sub  !<
-
-!
-!--    Restriction to the coarsest grid
-    10 IF ( grid_level == 1 )  THEN
-
-!
-!--       Solution on the coarsest grid. Double the number of Gauss-Seidel
-!--       iterations in order to get a more accurate solution.
-          ngsrb = 2 * ngsrb
-
-          ind_even_odd = even_odd_level(grid_level)
-
-          CALL redblack_fast( f_mg, p_mg )
-
-          ngsrb = ngsrb / 2
-
-
-       ELSEIF ( grid_level /= 1 )  THEN
-
-          grid_level_count(grid_level) = grid_level_count(grid_level) + 1
-
-!
-!--       Solution on the actual grid level
-          ind_even_odd = even_odd_level(grid_level)
-
-          CALL redblack_fast( f_mg, p_mg )
-
-!
-!--       Determination of the actual residual
-          CALL resid_fast( f_mg, p_mg, r )
-
-!--       Restriction of the residual (finer grid values!) to the next coarser
-!--       grid. Therefore, the grid level has to be decremented now. nxl..nzt have
-!--       to be set to the coarse grid values, because these variables are needed
-!--       for the exchange of ghost points in routine exchange_horiz
-          grid_level = grid_level - 1
-
-          nxl = nxl_mg(grid_level)
-          nys = nys_mg(grid_level)
-          nxr = nxr_mg(grid_level)
-          nyn = nyn_mg(grid_level)
-          nzt = nzt_mg(grid_level)
-
-          IF ( grid_level == mg_switch_to_pe0_level )  THEN
-
-!
-!--          From this level on, calculations are done on PE0 only.
-!--          First, carry out restriction on the subdomain.
-!--          Therefore, indices of the level have to be changed to subdomain
-!--          values in between (otherwise, the restrict routine would expect
-!--          the gathered array)
-
-             nxl_mg_save = nxl_mg(grid_level)
-             nxr_mg_save = nxr_mg(grid_level)
-             nys_mg_save = nys_mg(grid_level)
-             nyn_mg_save = nyn_mg(grid_level)
-             nzt_mg_save = nzt_mg(grid_level)
-             nxl_mg(grid_level) = mg_loc_ind(1,myid)
-             nxr_mg(grid_level) = mg_loc_ind(2,myid)
-             nys_mg(grid_level) = mg_loc_ind(3,myid)
-             nyn_mg(grid_level) = mg_loc_ind(4,myid)
-             nzt_mg(grid_level) = mg_loc_ind(5,myid)
-             nxl = mg_loc_ind(1,myid)
-             nxr = mg_loc_ind(2,myid)
-             nys = mg_loc_ind(3,myid)
-             nyn = mg_loc_ind(4,myid)
-             nzt = mg_loc_ind(5,myid)
-
-             ALLOCATE( f2_sub(nzb:nzt_mg(grid_level)+1,                    &
-                              nys_mg(grid_level)-1:nyn_mg(grid_level)+1,   &
-                              nxl_mg(grid_level)-1:nxr_mg(grid_level)+1) )
-
-             CALL restrict_fast( f2_sub, r )
-
-!
-!--          Restore the correct indices of this level
-             nxl_mg(grid_level) = nxl_mg_save
-             nxr_mg(grid_level) = nxr_mg_save
-             nys_mg(grid_level) = nys_mg_save
-             nyn_mg(grid_level) = nyn_mg_save
-             nzt_mg(grid_level) = nzt_mg_save
-             nxl = nxl_mg(grid_level)
-             nxr = nxr_mg(grid_level)
-             nys = nys_mg(grid_level)
-             nyn = nyn_mg(grid_level)
-             nzt = nzt_mg(grid_level)
-!
-!--          Gather all arrays from the subdomains on PE0
-             CALL mg_gather_fast( f2, f2_sub )
-
-!
-!--          Set switch for routine exchange_horiz, that no ghostpoint exchange
-!--          has to be carried out from now on
-             mg_switch_to_pe0 = .TRUE.
-
-!
-!--          In case of non-cyclic lateral boundary conditions, both in- and
-!--          outflow conditions have to be used on all PEs after the switch,
-!--          because then they have the total domain.
-             IF ( bc_lr_dirrad )  THEN
-                inflow_l  = .TRUE.
-                inflow_r  = .FALSE.
-                outflow_l = .FALSE.
-                outflow_r = .TRUE.
-             ELSEIF ( bc_lr_raddir )  THEN
-                inflow_l  = .FALSE.
-                inflow_r  = .TRUE.
-                outflow_l = .TRUE.
-                outflow_r = .FALSE.
-             ELSEIF ( nest_domain )  THEN
-                nest_bound_l = .TRUE.
-                nest_bound_r = .TRUE.
-             ENDIF
-
-             IF ( bc_ns_dirrad )  THEN
-                inflow_n  = .TRUE.
-                inflow_s  = .FALSE.
-                outflow_n = .FALSE.
-                outflow_s = .TRUE.
-             ELSEIF ( bc_ns_raddir )  THEN
-                inflow_n  = .FALSE.
-                inflow_s  = .TRUE.
-                outflow_n = .TRUE.
-                outflow_s = .FALSE.
-             ELSEIF ( nest_domain )  THEN
-                nest_bound_s = .TRUE.
-                nest_bound_n = .TRUE.
-             ENDIF
-
-             DEALLOCATE( f2_sub )
-
-          ELSE
-
-             CALL restrict_fast( f2, r )
-
-             ind_even_odd = even_odd_level(grid_level)  ! must be after restrict
-
-          ENDIF
-
-          p2 = 0.0_wp
-
-!
-!--       Repeat the same procedure till the coarsest grid is reached
-          CALL next_mg_level_fast( f2, p2, p3, r )
-
-       ENDIF
-
-!
-!--    Now follows the prolongation
-       IF ( grid_level >= 2 )  THEN
-
-!
-!--       Prolongation of the new residual. The values are transferred
-!--       from the coarse to the next finer grid.
-          IF ( grid_level == mg_switch_to_pe0_level+1 )  THEN
-
-#if defined( __parallel )
-!
-!--          At this level, the new residual first has to be scattered from
-!--          PE0 to the other PEs
-             ALLOCATE( p2_sub(nzb:mg_loc_ind(5,myid)+1,             &
-                       mg_loc_ind(3,myid)-1:mg_loc_ind(4,myid)+1,   &
-                       mg_loc_ind(1,myid)-1:mg_loc_ind(2,myid)+1) )
-
-             CALL mg_scatter_fast( p2, p2_sub )
-
-!
-!--          Therefore, indices of the previous level have to be changed to
-!--          subdomain values in between (otherwise, the prolong routine would
-!--          expect the gathered array)
-             nxl_mg_save = nxl_mg(grid_level-1)
-             nxr_mg_save = nxr_mg(grid_level-1)
-             nys_mg_save = nys_mg(grid_level-1)
-             nyn_mg_save = nyn_mg(grid_level-1)
-             nzt_mg_save = nzt_mg(grid_level-1)
-             nxl_mg(grid_level-1) = mg_loc_ind(1,myid)
-             nxr_mg(grid_level-1) = mg_loc_ind(2,myid)
-             nys_mg(grid_level-1) = mg_loc_ind(3,myid)
-             nyn_mg(grid_level-1) = mg_loc_ind(4,myid)
-             nzt_mg(grid_level-1) = mg_loc_ind(5,myid)
-
-!
-!--          Set switch for routine exchange_horiz, that ghostpoint exchange
-!--          has to be carried again out from now on
-             mg_switch_to_pe0 = .FALSE.
-
-!
-!--          For non-cyclic lateral boundary conditions, restore the
-!--          in-/outflow conditions
-             inflow_l  = .FALSE.;  inflow_r  = .FALSE.
-             inflow_n  = .FALSE.;  inflow_s  = .FALSE.
-             outflow_l = .FALSE.;  outflow_r = .FALSE.
-             outflow_n = .FALSE.;  outflow_s = .FALSE.
-
-             IF ( pleft == MPI_PROC_NULL )  THEN
-                IF ( bc_lr_dirrad )  THEN
-                   inflow_l  = .TRUE.
-                ELSEIF ( bc_lr_raddir )  THEN
-                   outflow_l = .TRUE.
-                ELSEIF ( nest_domain )  THEN
-                   nest_bound_l = .TRUE.
-                ENDIF
-             ENDIF
-
-             IF ( pright == MPI_PROC_NULL )  THEN
-                IF ( bc_lr_dirrad )  THEN
-                   outflow_r = .TRUE.
-                ELSEIF ( bc_lr_raddir )  THEN
-                   inflow_r  = .TRUE.
-                ELSEIF ( nest_domain )  THEN
-                   nest_bound_r = .TRUE.
-                ENDIF
-             ENDIF
-
-             IF ( psouth == MPI_PROC_NULL )  THEN
-                IF ( bc_ns_dirrad )  THEN
-                   outflow_s = .TRUE.
-                ELSEIF ( bc_ns_raddir )  THEN
-                   inflow_s  = .TRUE.
-                ELSEIF ( nest_domain )  THEN
-                   nest_bound_s = .TRUE.
-                ENDIF
-             ENDIF
-
-             IF ( pnorth == MPI_PROC_NULL )  THEN
-                IF ( bc_ns_dirrad )  THEN
-                   inflow_n  = .TRUE.
-                ELSEIF ( bc_ns_raddir )  THEN
-                   outflow_n = .TRUE.
-                ELSEIF ( nest_domain )  THEN
-                   nest_bound_n = .TRUE.
-                ENDIF
-             ENDIF
-
-             CALL prolong_fast( p2_sub, p3 )
-
-!
-!--          Restore the correct indices of the previous level
-             nxl_mg(grid_level-1) = nxl_mg_save
-             nxr_mg(grid_level-1) = nxr_mg_save
-             nys_mg(grid_level-1) = nys_mg_save
-             nyn_mg(grid_level-1) = nyn_mg_save
-             nzt_mg(grid_level-1) = nzt_mg_save
-
-             DEALLOCATE( p2_sub )
-#endif
-
-          ELSE
-
-             CALL prolong_fast( p2, p3 )
-
-          ENDIF
-
-!
-!--       Computation of the new pressure correction. Therefore,
-!--       values from prior grids are added up automatically stage by stage.
-          DO  i = nxl_mg(grid_level)-1, nxr_mg(grid_level)+1
-             DO  j = nys_mg(grid_level)-1, nyn_mg(grid_level)+1
-                DO  k = nzb, nzt_mg(grid_level)+1
-                   p_mg(k,j,i) = p_mg(k,j,i) + p3(k,j,i)
-                ENDDO
-             ENDDO
-          ENDDO
-
-!
-!--       Relaxation of the new solution
-          CALL redblack_fast( f_mg, p_mg )
-
-       ENDIF
-
-
-!
-!--    The following few lines serve the steering of the multigrid scheme
-       IF ( grid_level == maximum_grid_level )  THEN
-
-          GOTO 20
-
-       ELSEIF ( grid_level /= maximum_grid_level  .AND.  grid_level /= 1  .AND. &
-                grid_level_count(grid_level) /= gamma_mg )  THEN
-
-          GOTO 10
-
-       ENDIF
-
-!
-!--    Reset counter for the next call of poismg_fast
-       grid_level_count(grid_level) = 0
-
-!
-!--    Continue with the next finer level. nxl..nzt have to be
-!--    set to the finer grid values, because these variables are needed for the
-!--    exchange of ghost points in routine exchange_horiz
-       grid_level = grid_level + 1
-       ind_even_odd = even_odd_level(grid_level)
-
-       nxl = nxl_mg(grid_level)
-       nxr = nxr_mg(grid_level)
-       nys = nys_mg(grid_level)
-       nyn = nyn_mg(grid_level)
-       nzt = nzt_mg(grid_level)
-
-    20 CONTINUE
-
-    END SUBROUTINE next_mg_level_fast
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Initial settings for sorting k-dimension from sequential order (alternate
-!> even/odd) into blocks of even and odd or vice versa
-!------------------------------------------------------------------------------!
-    SUBROUTINE init_even_odd_blocks
-
-
-       USE arrays_3d,                                                          &
-           ONLY:  f1_mg, f2_mg, f3_mg
-
-       USE control_parameters,                                                 &
-           ONLY:  grid_level, masking_method, maximum_grid_level, topography
-
-       USE indices,                                                            &
-           ONLY:  nzb, nzt, nzt_mg
-
-       USE indices,                                                            &
-           ONLY:  flags, wall_flags_1, wall_flags_2, wall_flags_3,             &
-                  wall_flags_4, wall_flags_5, wall_flags_6, wall_flags_7,      &
-                  wall_flags_8, wall_flags_9, wall_flags_10, nxl_mg, nxr_mg,   &
-                  nys_mg, nyn_mg, nzb, nzt_mg
-
-       IMPLICIT NONE
-!
-!--    Local variables
-       INTEGER(iwp) ::  i     !<
-       INTEGER(iwp) ::  l     !<
-
-       LOGICAL, SAVE ::  lfirst = .TRUE.
-
-
-       IF ( .NOT. lfirst )  RETURN
-
-       ALLOCATE( even_odd_level(maximum_grid_level) )
-
-       ALLOCATE( f1_mg_b(nzb:nzt+1,maximum_grid_level),                        &
-                 f2_mg_b(nzb:nzt+1,maximum_grid_level),                        &
-                 f3_mg_b(nzb:nzt+1,maximum_grid_level) )
-
-!
-!--    Set border index between the even and odd block
-       DO  i = maximum_grid_level, 1, -1
-          even_odd_level(i) = nzt_mg(i) / 2
-       ENDDO
-
-!
-!--    Sort grid coefficients used in red/black scheme and for calculating the
-!--    residual to block (even/odd) structure
-       DO  l = maximum_grid_level, 1 , -1
-          CALL sort_k_to_even_odd_blocks( f1_mg(nzb+1:nzt_mg(grid_level),l),   &
-                                          f1_mg_b(nzb:nzt_mg(grid_level)+1,l), &
-                                          l )
-          CALL sort_k_to_even_odd_blocks( f2_mg(nzb+1:nzt_mg(grid_level),l),   &
-                                          f2_mg_b(nzb:nzt_mg(grid_level)+1,l), &
-                                          l )
-          CALL sort_k_to_even_odd_blocks( f3_mg(nzb+1:nzt_mg(grid_level),l),   &
-                                          f3_mg_b(nzb:nzt_mg(grid_level)+1,l), &
-                                          l )
-       ENDDO
-
-!
-!--    Sort flags array for all levels to block (even/odd) structure
-       IF ( topography /= 'flat'  .AND.  .NOT. masking_method )  THEN
-
-          DO  l = maximum_grid_level, 1 , -1
-!
-!--          Assign the flag level to be calculated
-             SELECT CASE ( l )
-                CASE ( 1 )
-                   flags => wall_flags_1
-                CASE ( 2 )
-                   flags => wall_flags_2
-                CASE ( 3 )
-                   flags => wall_flags_3
-                CASE ( 4 )
-                   flags => wall_flags_4
-                CASE ( 5 )
-                   flags => wall_flags_5
-                CASE ( 6 )
-                   flags => wall_flags_6
-                CASE ( 7 )
-                   flags => wall_flags_7
-                CASE ( 8 )
-                   flags => wall_flags_8
-                CASE ( 9 )
-                   flags => wall_flags_9
-                CASE ( 10 )
-                   flags => wall_flags_10
-             END SELECT
-
-             CALL sort_k_to_even_odd_blocks( flags, l )
-
-          ENDDO
-
-       ENDIF
-
-       lfirst = .FALSE.
-
-     END SUBROUTINE init_even_odd_blocks
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Special exchange_horiz subroutine for use in redblack. Transfers only
-!> "red" or "black" data points.
-!------------------------------------------------------------------------------!
-     SUBROUTINE special_exchange_horiz ( p_mg, color )
-
-
-       USE control_parameters,                                                 &
-           ONLY:  bc_lr_cyc, bc_ns_cyc, grid_level, ibc_p_b, ibc_p_t,          &
-                  inflow_l, inflow_n, inflow_r, inflow_s, maximum_grid_level,  &
-                  outflow_l, outflow_n, outflow_r, outflow_s,                  &
-                  synchronous_exchange
-
-       USE indices,                                                            &
-           ONLY:  mg_loc_ind, nxl, nxl_mg, nxr, nxr_mg, nys, nys_mg, nyn,      &
-                  nyn_mg, nzb, nzt, nzt_mg
-
-       IMPLICIT NONE
-
-       REAL(wp), DIMENSION(nzb:nzt_mg(grid_level)+1,                           &
-                           nys_mg(grid_level)-1:nyn_mg(grid_level)+1,          &
-                           nxl_mg(grid_level)-1:nxr_mg(grid_level)+1) ::  p_mg  !<
-
-       INTEGER(iwp), intent(IN) ::  color  !<
-!
-!--    Local variables
-       INTEGER(iwp) ::  i,i1,i2  !<
-       INTEGER(iwp) ::  j,j1,j2  !<
-       INTEGER(iwp) ::  k        !<
-       INTEGER(iwp) ::  l        !<
-       INTEGER(iwp) ::  jys      !<
-       INTEGER(iwp) ::  jyn      !<
-       INTEGER(iwp) ::  ixl      !<
-       INTEGER(iwp) ::  ixr      !<
-       logical      ::  sendrecv_in_background_save  !<
-       logical      ::  synchronous_exchange_save    !<
-
-       REAL(wp), DIMENSION(nzb:nzt_mg(grid_level-1)+1,                         &
-                           nys_mg(grid_level-1)-1:nyn_mg(grid_level-1)+1,      &
-                           nxl_mg(grid_level-1)-1:nxr_mg(grid_level-1)+1) ::  temp  !<
-
-#if defined ( __parallel )
-       sendrecv_in_background_save = sendrecv_in_background
-       sendrecv_in_background      = .FALSE.
-       synchronous_exchange_save   = synchronous_exchange
-       synchronous_exchange        = .FALSE.
-
-       l = grid_level
-
-       ind_even_odd = even_odd_level(grid_level)
-
-       jys = nys_mg(grid_level-1)
-       jyn = nyn_mg(grid_level-1)
-       ixl = nxl_mg(grid_level-1)
-       ixr = nxr_mg(grid_level-1)
-
-!
-!--    Restricted transfer only on finer levels with enough data
-       IF ( ngp_xz(grid_level) >= 900 .OR. ngp_yz(grid_level) >= 900 )  THEN
-!
-!--       Handling the even k Values
-!--       Collecting data for the north - south exchange
-!--       Since only every second value has to be transfered, data are stored
-!--       on the next coarser grid level, because the arrays on that level
-!--       have just the required size
-          i1 = nxl_mg(grid_level-1)
-          i2 = nxl_mg(grid_level-1)
-
-          DO  i = nxl_mg(l), nxr_mg(l), 2
-             DO  j = nys_mg(l) + 2 - color, nyn_mg(l), 2
-
-                IF ( j == nys_mg(l) )  THEN
-                   !DIR$ IVDEP
-                   DO  k = ind_even_odd+1, nzt_mg(l)
-                      temp(k-ind_even_odd,jys,i1) = p_mg(k,j,i)
-                   ENDDO
-                   i1 = i1 + 1
-
-                ENDIF
-
-                IF ( j == nyn_mg(l) )  THEN
-                   !DIR$ IVDEP
-                   DO  k = ind_even_odd+1, nzt_mg(l)
-                      temp(k-ind_even_odd,jyn,i2) = p_mg(k,j,i)
-                   ENDDO
-                   i2 = i2 + 1
-
-                ENDIF
-
-             ENDDO
-          ENDDO
-
-          DO  i = nxl_mg(l)+1, nxr_mg(l), 2
-             DO  j = nys_mg(l) + (color-1), nyn_mg(l), 2
-
-                IF ( j == nys_mg(l) )  THEN
-                   !DIR$ IVDEP
-                   DO  k = ind_even_odd+1, nzt_mg(l)
-                      temp(k-ind_even_odd,jys,i1) = p_mg(k,j,i)
-                   ENDDO
-                   i1 = i1 + 1
-
-                ENDIF
-
-                IF ( j == nyn_mg(l) )  THEN
-                   !DIR$ IVDEP
-                   DO  k = ind_even_odd+1, nzt_mg(l)
-                      temp(k-ind_even_odd,jyn,i2) = p_mg(k,j,i)
-                   ENDDO
-                   i2 = i2 + 1
-
-                ENDIF
-
-             ENDDO
-          ENDDO
-
-          grid_level = grid_level-1
-
-          nxl = nxl_mg(grid_level)
-          nys = nys_mg(grid_level)
-          nxr = nxr_mg(grid_level)
-          nyn = nyn_mg(grid_level)
-          nzt = nzt_mg(grid_level)
-
-          send_receive = 'ns'
-          CALL exchange_horiz( temp, 1 )
-
-          grid_level = grid_level+1
-
-          i1 = nxl_mg(grid_level-1)
-          i2 = nxl_mg(grid_level-1)
-
-          DO  i = nxl_mg(l), nxr_mg(l), 2
-             DO  j = nys_mg(l) + 2 - color, nyn_mg(l), 2
-
-                IF ( j == nys_mg(l) )  THEN
-                   !DIR$ IVDEP
-                   DO  k = ind_even_odd+1, nzt_mg(l)
-                      p_mg(k,nyn_mg(l)+1,i) = temp(k-ind_even_odd,jyn+1,i1)
-                   ENDDO
-                   i1 = i1 + 1
-
-                ENDIF
-
-                IF ( j == nyn_mg(l) )  THEN
-                   !DIR$ IVDEP
-                   DO  k = ind_even_odd+1, nzt_mg(l)
-                      p_mg(k,nys_mg(l)-1,i) = temp(k-ind_even_odd,jys-1,i2)
-                   ENDDO
-                   i2 = i2 + 1
-
-                ENDIF
-
-             ENDDO
-          ENDDO
-
-          DO  i = nxl_mg(l)+1, nxr_mg(l), 2
-             DO  j = nys_mg(l) + (color-1), nyn_mg(l), 2
-
-                IF ( j == nys_mg(l) )  THEN
-                   !DIR$ IVDEP
-                   DO  k = ind_even_odd+1, nzt_mg(l)
-                      p_mg(k,nyn_mg(l)+1,i) = temp(k-ind_even_odd,jyn+1,i1)
-                   ENDDO
-                   i1 = i1 + 1
-
-                ENDIF
-
-                IF ( j == nyn_mg(l) )  THEN
-                   !DIR$ IVDEP
-                   DO  k = ind_even_odd+1, nzt_mg(l)
-                      p_mg(k,nys_mg(l)-1,i) = temp(k-ind_even_odd,jys-1,i2)
-                   ENDDO
-                   i2 = i2 + 1
-
-                ENDIF
-
-             ENDDO
-          ENDDO
-
-!
-!--       Collecting data for the left - right exchange
-!--       Since only every second value has to be transfered, data are stored
-!--       on the next coarser grid level, because the arrays on that level
-!--       have just the required size
-          j1 = nys_mg(grid_level-1)
-          j2 = nys_mg(grid_level-1)
-
-          DO j = nys_mg(l) + 2 - color, nyn_mg(l), 2
-             DO  i = nxl_mg(l), nxr_mg(l), 2
-
-                IF ( i == nxl_mg(l) )  THEN
-                   !DIR$ IVDEP
-                   DO  k = ind_even_odd+1, nzt_mg(l)
-                      temp(k-ind_even_odd,j1,ixl) = p_mg(k,j,i)
-                   ENDDO
-                   j1 = j1 + 1
-
-                ENDIF
-
-                IF ( i == nxr_mg(l) )  THEN
-                   !DIR$ IVDEP
-                   DO  k = ind_even_odd+1, nzt_mg(l)
-                      temp(k-ind_even_odd,j2,ixr) = p_mg(k,j,i)
-                   ENDDO
-                   j2 = j2 + 1
-
-                ENDIF
-
-             ENDDO
-          ENDDO
-
-          DO j = nys_mg(l) + (color-1), nyn_mg(l), 2
-             DO  i = nxl_mg(l)+1, nxr_mg(l), 2
-
-                IF ( i == nxl_mg(l) )  THEN
-                   !DIR$ IVDEP
-                   DO  k = ind_even_odd+1, nzt_mg(l)
-                      temp(k-ind_even_odd,j1,ixl) = p_mg(k,j,i)
-                   ENDDO
-                   j1 = j1 + 1
-
-                ENDIF
-
-                IF ( i == nxr_mg(l) )  THEN
-                   !DIR$ IVDEP
-                   DO  k = ind_even_odd+1, nzt_mg(l)
-                      temp(k-ind_even_odd,j2,ixr) = p_mg(k,j,i)
-                   ENDDO
-                   j2 = j2 + 1
-
-                ENDIF
-
-             ENDDO
-          ENDDO
-
-          grid_level = grid_level-1
-          send_receive = 'lr'
-
-          CALL exchange_horiz( temp, 1 )
-
-          grid_level = grid_level+1
-
-          j1 = nys_mg(grid_level-1)
-          j2 = nys_mg(grid_level-1)
-
-          DO j = nys_mg(l) + 2 - color, nyn_mg(l), 2
-             DO  i = nxl_mg(l), nxr_mg(l), 2
-
-                IF ( i == nxl_mg(l) )  THEN
-                   !DIR$ IVDEP
-                   DO  k = ind_even_odd+1, nzt_mg(l)
-                      p_mg(k,j,nxr_mg(l)+1)  = temp(k-ind_even_odd,j1,ixr+1)
-                   ENDDO
-                   j1 = j1 + 1
-
-                ENDIF
-
-                IF ( i == nxr_mg(l) )  THEN
-                   !DIR$ IVDEP
-                   DO  k = ind_even_odd+1, nzt_mg(l)
-                      p_mg(k,j,nxl_mg(l)-1)  = temp(k-ind_even_odd,j2,ixl-1)
-                   ENDDO
-                   j2 = j2 + 1
-
-                ENDIF
-
-             ENDDO
-          ENDDO
-
-          DO j = nys_mg(l) + (color-1), nyn_mg(l), 2
-             DO  i = nxl_mg(l)+1, nxr_mg(l), 2
-
-                IF ( i == nxl_mg(l) )  THEN
-                   !DIR$ IVDEP
-                   DO  k = ind_even_odd+1, nzt_mg(l)
-                      p_mg(k,j,nxr_mg(l)+1)  = temp(k-ind_even_odd,j1,ixr+1)
-                   ENDDO
-                   j1 = j1 + 1
-
-                ENDIF
-
-                IF ( i == nxr_mg(l) )  THEN
-                   !DIR$ IVDEP
-                   DO  k = ind_even_odd+1, nzt_mg(l)
-                      p_mg(k,j,nxl_mg(l)-1)  = temp(k-ind_even_odd,j2,ixl-1)
-                   ENDDO
-                   j2 = j2 + 1
-
-                ENDIF
-
-             ENDDO
-          ENDDO
-
-!
-!--       Now handling the even k values
-!--       Collecting data for the north - south exchange
-!--       Since only every second value has to be transfered, data are stored
-!--       on the next coarser grid level, because the arrays on that level
-!--       have just the required size
-          i1 = nxl_mg(grid_level-1)
-          i2 = nxl_mg(grid_level-1)
-
-          DO  i = nxl_mg(l), nxr_mg(l), 2
-             DO  j = nys_mg(l) + (color-1), nyn_mg(l), 2
-
-                IF ( j == nys_mg(l) )  THEN
-                   !DIR$ IVDEP
-                   DO  k = nzb+1, ind_even_odd
-                      temp(k,jys,i1) = p_mg(k,j,i)
-                   ENDDO
-                   i1 = i1 + 1
-
-                ENDIF
-
-                IF ( j == nyn_mg(l) )  THEN
-                   !DIR$ IVDEP
-                   DO  k = nzb+1, ind_even_odd
-                      temp(k,jyn,i2) = p_mg(k,j,i)
-                   ENDDO
-                   i2 = i2 + 1
-
-                ENDIF
-
-             ENDDO
-          ENDDO
-
-          DO  i = nxl_mg(l)+1, nxr_mg(l), 2
-             DO j = nys_mg(l) + 2 - color, nyn_mg(l), 2
-
-                IF ( j == nys_mg(l) )  THEN
-                   !DIR$ IVDEP
-                   DO  k = nzb+1, ind_even_odd
-                      temp(k,jys,i1) = p_mg(k,j,i)
-                   ENDDO
-                   i1 = i1 + 1
-
-                ENDIF
-
-                IF ( j == nyn_mg(l) )  THEN
-                   !DIR$ IVDEP
-                   DO  k = nzb+1, ind_even_odd
-                      temp(k,jyn,i2) = p_mg(k,j,i)
-                   ENDDO
-                   i2 = i2 + 1
-
-                ENDIF
-
-             ENDDO
-          ENDDO
-
-          grid_level = grid_level-1
-
-          send_receive = 'ns'
-          CALL exchange_horiz( temp, 1 )
-
-          grid_level = grid_level+1
-
-          i1 = nxl_mg(grid_level-1)
-          i2 = nxl_mg(grid_level-1)
-
-          DO  i = nxl_mg(l), nxr_mg(l), 2
-             DO  j = nys_mg(l) + (color-1), nyn_mg(l), 2
-
-                IF ( j == nys_mg(l) )  THEN
-                   !DIR$ IVDEP
-                   DO  k = nzb+1, ind_even_odd
-                      p_mg(k,nyn_mg(l)+1,i) = temp(k,jyn+1,i1)
-                   ENDDO
-                   i1 = i1 + 1
-
-                ENDIF
-
-                IF ( j == nyn_mg(l) )  THEN
-                   !DIR$ IVDEP
-                   DO  k = nzb+1, ind_even_odd
-                      p_mg(k,nys_mg(l)-1,i) = temp(k,jys-1,i2)
-                   ENDDO
-                   i2 = i2 + 1
-
-                ENDIF
-
-             ENDDO
-          ENDDO
-
-          DO  i = nxl_mg(l)+1, nxr_mg(l), 2
-             DO j = nys_mg(l) + 2 - color, nyn_mg(l), 2
-
-                IF ( j == nys_mg(l) )  THEN
-                   !DIR$ IVDEP
-                   DO  k = nzb+1, ind_even_odd
-                      p_mg(k,nyn_mg(l)+1,i) = temp(k,jyn+1,i1)
-                   ENDDO
-                   i1 = i1 + 1
-
-                ENDIF
-
-                IF ( j == nyn_mg(l) )  THEN
-                   !DIR$ IVDEP
-                   DO  k = nzb+1, ind_even_odd
-                      p_mg(k,nys_mg(l)-1,i) = temp(k,jys-1,i2)
-                   ENDDO
-                   i2 = i2 + 1
-
-                ENDIF
-
-             ENDDO
-          ENDDO
-
-          j1 = nys_mg(grid_level-1)
-          j2 = nys_mg(grid_level-1)
-
-          DO  i = nxl_mg(l), nxr_mg(l), 2
-             DO  j = nys_mg(l) + (color-1), nyn_mg(l), 2
-
-                IF ( i == nxl_mg(l) )  THEN
-                   !DIR$ IVDEP
-                   DO  k = nzb+1, ind_even_odd
-                      temp(k,j1,ixl) = p_mg(k,j,i)
-                   ENDDO
-                   j1 = j1 + 1
-
-                ENDIF
-
-                IF ( i == nxr_mg(l) )  THEN
-                   !DIR$ IVDEP
-                   DO  k = nzb+1, ind_even_odd
-                      temp(k,j2,ixr) = p_mg(k,j,i)
-                   ENDDO
-                   j2 = j2 + 1
-
-                ENDIF
-
-             ENDDO
-          ENDDO
-
-          DO  i = nxl_mg(l)+1, nxr_mg(l), 2
-             DO j = nys_mg(l) + 2 - color, nyn_mg(l), 2
-
-                IF ( i == nxl_mg(l) )  THEN
-                   !DIR$ IVDEP
-                   DO  k = nzb+1, ind_even_odd
-                      temp(k,j1,ixl) = p_mg(k,j,i)
-                   ENDDO
-                   j1 = j1 + 1
-
-                ENDIF
-
-                IF ( i == nxr_mg(l) )  THEN
-                   !DIR$ IVDEP
-                   DO  k = nzb+1, ind_even_odd
-                      temp(k,j2,ixr) = p_mg(k,j,i)
-                   ENDDO
-                   j2 = j2 + 1
-
-                ENDIF
-
-             ENDDO
-          ENDDO
-
-          grid_level = grid_level-1
-
-          send_receive = 'lr'
-          CALL exchange_horiz( temp, 1 )
-
-          grid_level = grid_level+1
-
-          nxl = nxl_mg(grid_level)
-          nys = nys_mg(grid_level)
-          nxr = nxr_mg(grid_level)
-          nyn = nyn_mg(grid_level)
-          nzt = nzt_mg(grid_level)
-
-          j1 = nys_mg(grid_level-1)
-          j2 = nys_mg(grid_level-1)
-
-          DO  i = nxl_mg(l), nxr_mg(l), 2
-             DO  j = nys_mg(l) + (color-1), nyn_mg(l), 2
-
-                IF ( i == nxl_mg(l) )  THEN
-                   !DIR$ IVDEP
-                   DO  k = nzb+1, ind_even_odd
-                      p_mg(k,j,nxr_mg(l)+1)  = temp(k,j1,ixr+1)
-                   ENDDO
-                   j1 = j1 + 1
-
-                ENDIF
-
-                IF ( i == nxr_mg(l) )  THEN
-                   !DIR$ IVDEP
-                   DO  k = nzb+1, ind_even_odd
-                      p_mg(k,j,nxl_mg(l)-1)  = temp(k,j2,ixl-1)
-                   ENDDO
-                   j2 = j2 + 1
-
-                ENDIF
-
-             ENDDO
-          ENDDO
-
-          DO  i = nxl_mg(l)+1, nxr_mg(l), 2
-             DO j = nys_mg(l) + 2 - color, nyn_mg(l), 2
-
-                IF ( i == nxl_mg(l) )  THEN
-                   !DIR$ IVDEP
-                   DO  k = nzb+1, ind_even_odd
-                      p_mg(k,j,nxr_mg(l)+1)  = temp(k,j1,ixr+1)
-                   ENDDO
-                   j1 = j1 + 1
-
-                ENDIF
-
-                IF ( i == nxr_mg(l) )  THEN
-                   !DIR$ IVDEP
-                   DO  k = nzb+1, ind_even_odd
-                      p_mg(k,j,nxl_mg(l)-1)  = temp(k,j2,ixl-1)
-                   ENDDO
-                   j2 = j2 + 1
-
-                ENDIF
-
-             ENDDO
-          ENDDO
-
-       ELSE
-
-!
-!--       Standard horizontal ghost boundary exchange for small coarse grid
-!--       levels, where the transfer time is latency bound
-          CALL exchange_horiz( p_mg, 1 )
-
-       ENDIF
-
-!
-!--    Reset values to default PALM setup
-       sendrecv_in_background = sendrecv_in_background_save
-       synchronous_exchange   = synchronous_exchange_save
-       send_receive = 'al'
-#else
-
-!
-!--    Standard horizontal ghost boundary exchange for small coarse grid
-!--    levels, where the transfer time is latency bound
-       CALL exchange_horiz( p_mg, 1 )
-#endif
-
-    END SUBROUTINE special_exchange_horiz
-
- END MODULE poismg_mod
Index: /palm/trunk/SOURCE/poismg_fast_mod.f90
===================================================================
--- /palm/trunk/SOURCE/poismg_fast_mod.f90	(revision 1850)
+++ /palm/trunk/SOURCE/poismg_fast_mod.f90	(revision 1850)
@@ -0,0 +1,2947 @@
+!> @file poismg_fast_mod.f90
+!--------------------------------------------------------------------------------!
+! This file is part of PALM.
+!
+! PALM is free software: you can redistribute it and/or modify it under the terms
+! of the GNU General Public License as published by the Free Software Foundation,
+! either version 3 of the License, or (at your option) any later version.
+!
+! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
+! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
+! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along with
+! PALM. If not, see <http://www.gnu.org/licenses/>.
+!
+! Copyright 1997-2016 Leibniz Universitaet Hannover
+!--------------------------------------------------------------------------------!
+!
+! Current revisions:
+! -----------------
+! Module renamed
+!
+! 
+! Former revisions:
+! -----------------
+! $Id$
+!
+! 1762 2016-02-25 12:31:13Z hellstea
+! Introduction of nested domain feature
+!
+! 1682 2015-10-07 23:56:08Z knoop
+! Code annotations made doxygen readable 
+! 
+! 1609 2015-07-03 15:37:58Z maronga
+! Bugfix: allow compilation without __parallel.
+!
+! 1575 2015-03-27 09:56:27Z raasch
+! Initial revision.
+! Routine re-written and optimised based on poismg.
+!
+! Following optimisations have been made:
+! - vectorisation (for Intel-CPUs) of the red-black algorithm by resorting
+!   array elements with even and odd indices
+! - explicit boundary conditions for building walls removed (solver is
+!   running through the buildings
+! - reduced data transfer in case of ghost point exchange, because only
+!   "red" or "black" data points need to be exchanged. This is not applied
+!   for coarser grid levels, since for then the transfer time is latency bound
+!
+!
+! Description:
+! ------------
+!> Solves the Poisson equation for the perturbation pressure with a multigrid
+!> V- or W-Cycle scheme.
+!>
+!> This multigrid method was originally developed for PALM by Joerg Uhlenbrock,
+!> September 2000 - July 2001. It has been optimised for speed by Klaus
+!> Ketelsen in November 2014.
+!> 
+!> @attention Loop unrolling and cache optimization in SOR-Red/Black method
+!>            still does not give the expected speedup! 
+!>
+!> @todo Further work required.
+!------------------------------------------------------------------------------!
+ MODULE poismg_mod
+ 
+
+    USE cpulog,                                                                &
+        ONLY:  cpu_log, log_point_s
+
+    USE kinds
+
+    USE pegrid
+
+    PRIVATE
+
+    INTEGER, SAVE                             ::  ind_even_odd    !< border index between even and odd k index
+    INTEGER, DIMENSION(:), SAVE, ALLOCATABLE  ::  even_odd_level  !< stores ind_even_odd for all MG levels
+
+    REAL(wp), DIMENSION(:,:), SAVE, ALLOCATABLE ::  f1_mg_b, f2_mg_b, f3_mg_b  !< blocked version of f1_mg ...
+
+    INTERFACE poismg_fast
+       MODULE PROCEDURE poismg_fast
+    END INTERFACE poismg_fast
+
+    INTERFACE sort_k_to_even_odd_blocks
+       MODULE PROCEDURE sort_k_to_even_odd_blocks
+       MODULE PROCEDURE sort_k_to_even_odd_blocks_int
+       MODULE PROCEDURE sort_k_to_even_odd_blocks_1d
+    END INTERFACE sort_k_to_even_odd_blocks
+
+    PUBLIC poismg_fast
+
+ CONTAINS
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Solves the Poisson equation for the perturbation pressure with a multigrid
+!> V- or W-Cycle scheme.
+!------------------------------------------------------------------------------!
+    SUBROUTINE poismg_fast( r )
+
+       USE arrays_3d,                                                          &
+           ONLY:  d, p_loc
+
+       USE control_parameters,                                                 &
+           ONLY:  gathered_size, grid_level, grid_level_count,                 &
+                  maximum_grid_level, message_string, mgcycles, mg_cycles,     &
+                  mg_switch_to_pe0_level, residual_limit, subdomain_size
+
+       USE cpulog,                                                             &
+           ONLY:  cpu_log, log_point_s
+
+       USE indices,                                                            &
+           ONLY:  nxl, nxlg, nxl_mg, nxr, nxrg, nxr_mg, nys, nysg, nys_mg, nyn,&
+                  nyng, nyn_mg, nzb, nzt, nzt_mg
+
+       IMPLICIT NONE
+
+       REAL(wp) ::  maxerror          !<
+       REAL(wp) ::  maximum_mgcycles  !<
+       REAL(wp) ::  residual_norm     !<
+
+       REAL(wp), DIMENSION(nzb:nzt+1,nys-1:nyn+1,nxl-1:nxr+1) ::  r  !<
+
+       REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::  p3  !<
+
+
+       CALL cpu_log( log_point_s(29), 'poismg_fast', 'start' )
+!
+!--    Initialize arrays and variables used in this subroutine
+
+!--    If the number of grid points of the gathered grid, which is collected
+!--    on PE0, is larger than the number of grid points of an PE, than array
+!--    p3 will be enlarged.
+       IF ( gathered_size > subdomain_size )  THEN
+          ALLOCATE( p3(nzb:nzt_mg(mg_switch_to_pe0_level)+1,nys_mg(            &
+                    mg_switch_to_pe0_level)-1:nyn_mg(mg_switch_to_pe0_level)+1,&
+                    nxl_mg(mg_switch_to_pe0_level)-1:nxr_mg(                   &
+                    mg_switch_to_pe0_level)+1) )
+       ELSE
+          ALLOCATE ( p3(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
+       ENDIF
+
+       p3 = 0.0_wp
+
+ 
+!
+!--    Ghost boundaries have to be added to divergence array.
+!--    Exchange routine needs to know the grid level!
+       grid_level = maximum_grid_level
+       CALL exchange_horiz( d, 1)
+       d(nzb,:,:) = d(nzb+1,:,:)
+
+!
+!--    Initiation of the multigrid scheme. Does n cycles until the
+!--    residual is smaller than the given limit. The accuracy of the solution
+!--    of the poisson equation will increase with the number of cycles.
+!--    If the number of cycles is preset by the user, this number will be
+!--    carried out regardless of the accuracy.
+       grid_level_count =  0
+       mgcycles         =  0
+       IF ( mg_cycles == -1 )  THEN
+          maximum_mgcycles = 0
+          residual_norm    = 1.0_wp
+       ELSE
+          maximum_mgcycles = mg_cycles
+          residual_norm    = 0.0_wp
+       ENDIF
+
+!
+!--    Initial settings for sorting k-dimension from sequential order (alternate
+!--    even/odd) into blocks of even and odd or vice versa
+       CALL init_even_odd_blocks
+
+!
+!--    Sort input arrays in even/odd blocks along k-dimension
+       CALL sort_k_to_even_odd_blocks( d, grid_level )
+       CALL sort_k_to_even_odd_blocks( p_loc, grid_level )
+
+!
+!--    The complete multigrid cycles are running in block mode, i.e. over
+!--    seperate data blocks of even and odd indices
+       DO WHILE ( residual_norm > residual_limit  .OR. &
+                  mgcycles < maximum_mgcycles )
+ 
+          CALL next_mg_level_fast( d, p_loc, p3, r)
+
+!
+!--       Calculate the residual if the user has not preset the number of
+!--       cycles to be performed
+          IF ( maximum_mgcycles == 0 )  THEN
+             CALL resid_fast( d, p_loc, r )
+             maxerror = SUM( r(nzb+1:nzt,nys:nyn,nxl:nxr)**2 )
+
+#if defined( __parallel )
+             IF ( collective_wait )  CALL MPI_BARRIER( comm2d, ierr )
+                CALL MPI_ALLREDUCE( maxerror, residual_norm, 1, MPI_REAL,      &
+                                    MPI_SUM, comm2d, ierr)
+#else
+                residual_norm = maxerror
+#endif
+             residual_norm = SQRT( residual_norm )
+          ENDIF
+
+          mgcycles = mgcycles + 1
+
+!
+!--       If the user has not limited the number of cycles, stop the run in case
+!--       of insufficient convergence
+          IF ( mgcycles > 1000  .AND.  mg_cycles == -1 )  THEN
+             message_string = 'no sufficient convergence within 1000 cycles'
+             CALL message( 'poismg_fast', 'PA0283', 1, 2, 0, 6, 0 )
+          ENDIF
+
+       ENDDO
+
+       DEALLOCATE( p3 )
+!
+!--    Result has to be sorted back from even/odd blocks to sequential order
+       CALL sort_k_to_sequential( p_loc )
+!
+!--    Unset the grid level. Variable is used to determine the MPI datatypes for
+!--    ghost point exchange
+       grid_level = 0
+
+       CALL cpu_log( log_point_s(29), 'poismg_fast', 'stop' )
+
+    END SUBROUTINE poismg_fast
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Computes the residual of the perturbation pressure.
+!------------------------------------------------------------------------------!
+    SUBROUTINE resid_fast( f_mg, p_mg, r )
+
+
+       USE arrays_3d,                                                          &
+           ONLY:  f1_mg, f2_mg, f3_mg
+
+       USE control_parameters,                                                 &
+           ONLY:  bc_lr_cyc, bc_ns_cyc, grid_level, ibc_p_b, ibc_p_t, inflow_l,&
+                  inflow_n, inflow_r, inflow_s, masking_method, nest_bound_l,  &
+                  nest_bound_n, nest_bound_r, nest_bound_s, outflow_l,         &
+                  outflow_n, outflow_r, outflow_s, topography
+
+       USE grid_variables,                                                     &
+           ONLY:  ddx2_mg, ddy2_mg
+
+       USE indices,                                                            &
+           ONLY:  flags, wall_flags_1, wall_flags_2, wall_flags_3,             &
+                  wall_flags_4, wall_flags_5, wall_flags_6, wall_flags_7,      &
+                  wall_flags_8, wall_flags_9, wall_flags_10, nxl_mg, nxr_mg,   &
+                  nys_mg, nyn_mg, nzb, nzt_mg
+
+       IMPLICIT NONE
+
+       INTEGER(iwp) ::  i
+       INTEGER(iwp) ::  j
+       INTEGER(iwp) ::  k
+       INTEGER(iwp) ::  l
+       INTEGER(iwp) :: km1      !<
+       INTEGER(iwp) :: kp1      !<
+
+       REAL(wp), DIMENSION(nzb:nzt_mg(grid_level)+1,                           &
+                       nys_mg(grid_level)-1:nyn_mg(grid_level)+1,              &
+                       nxl_mg(grid_level)-1:nxr_mg(grid_level)+1) ::  f_mg  !<
+       REAL(wp), DIMENSION(nzb:nzt_mg(grid_level)+1,                           &
+                       nys_mg(grid_level)-1:nyn_mg(grid_level)+1,              &
+                       nxl_mg(grid_level)-1:nxr_mg(grid_level)+1) ::  p_mg  !<
+       REAL(wp), DIMENSION(nzb:nzt_mg(grid_level)+1,                           &
+                       nys_mg(grid_level)-1:nyn_mg(grid_level)+1,              &
+                       nxl_mg(grid_level)-1:nxr_mg(grid_level)+1) ::  r     !<
+
+!
+!--    Calculate the residual
+       l = grid_level
+
+       CALL cpu_log( log_point_s(53), 'resid', 'start' )
+       IF ( topography == 'flat'  .OR.  masking_method )  THEN
+          !$OMP PARALLEL PRIVATE (i,j,k,km1,kp1)
+          !$OMP DO
+          DO  i = nxl_mg(l), nxr_mg(l)
+             DO  j = nys_mg(l), nyn_mg(l)
+                !DIR$ IVDEP
+                DO k = ind_even_odd+1, nzt_mg(l)
+                   km1 = k-ind_even_odd-1
+                   kp1 = k-ind_even_odd
+                   r(k,j,i) = f_mg(k,j,i)                                 &
+                      - ddx2_mg(l) *                                      &
+                      ( p_mg(k,j,i+1) +  p_mg(k,j,i-1)  )                 &
+                      - ddy2_mg(l) *                                      &
+                      ( p_mg(k,j+1,i) + p_mg(k,j-1,i)  )                  &
+                      - f2_mg_b(k,l) * p_mg(kp1,j,i)                      &
+                      - f3_mg_b(k,l) * p_mg(km1,j,i)                      &
+                      + f1_mg_b(k,l) * p_mg(k,j,i)
+                ENDDO
+                !DIR$ IVDEP
+                DO k = nzb+1, ind_even_odd
+                   km1 = k+ind_even_odd
+                   kp1 = k+ind_even_odd+1
+                   r(k,j,i) = f_mg(k,j,i)                                 &
+                      - ddx2_mg(l) *                                      &
+                      ( p_mg(k,j,i+1) +  p_mg(k,j,i-1)  )                 &
+                      - ddy2_mg(l) *                                      &
+                      ( p_mg(k,j+1,i) + p_mg(k,j-1,i)  )                  &
+                      - f2_mg_b(k,l) * p_mg(kp1,j,i)                      &
+                      - f3_mg_b(k,l) * p_mg(km1,j,i)                      &
+                      + f1_mg_b(k,l) * p_mg(k,j,i)
+                ENDDO
+             ENDDO
+          ENDDO
+          !$OMP END PARALLEL
+       ELSE
+!
+!--       Choose flag array of this level
+          SELECT CASE ( l )
+             CASE ( 1 )
+                flags => wall_flags_1
+             CASE ( 2 )
+                flags => wall_flags_2
+             CASE ( 3 )
+                flags => wall_flags_3
+             CASE ( 4 )
+                flags => wall_flags_4
+             CASE ( 5 )
+                flags => wall_flags_5
+             CASE ( 6 )
+                flags => wall_flags_6
+             CASE ( 7 )
+                flags => wall_flags_7
+             CASE ( 8 )
+                flags => wall_flags_8
+             CASE ( 9 )
+                flags => wall_flags_9
+             CASE ( 10 )
+                flags => wall_flags_10
+          END SELECT
+
+          !$OMP PARALLEL PRIVATE (i,j,k,km1,kp1)
+          !$OMP DO
+          DO  i = nxl_mg(l), nxr_mg(l)
+             DO  j = nys_mg(l), nyn_mg(l)
+
+                !DIR$ IVDEP
+                DO  k = ind_even_odd+1, nzt_mg(l)
+                   km1 = k-ind_even_odd-1
+                   kp1 = k-ind_even_odd
+
+                   r(k,j,i) = f_mg(k,j,i)                                         &
+                    - ddx2_mg(l) *                                                &
+                    ( MERGE(p_mg(k,j,i),p_mg(k,j,i+1),BTEST( flags(k,j,i), 5 ))   &
+                    + MERGE(p_mg(k,j,i),p_mg(k,j,i-1),BTEST( flags(k,j,i), 4 )) ) &
+                    - ddy2_mg(l)                                                  &
+                    * ( MERGE(p_mg(k,j,i),p_mg(k,j+1,i),BTEST( flags(k,j,i), 3 )) &
+                    + MERGE(p_mg(k,j,i),p_mg(k,j-1,i),BTEST( flags(k,j,i), 2 )) ) &
+                    - f2_mg(k,l) * p_mg(kp1,j,i)                                  &
+                    - f3_mg(k,l) *                                                &
+                      MERGE(p_mg(k,j,i),p_mg(km1,j,i),BTEST( flags(k,j,i), 0 ))   &
+                    + f1_mg(k,l) * p_mg(k,j,i)
+                ENDDO
+
+                !DIR$ IVDEP
+                DO  k = nzb+1, ind_even_odd
+                   km1 = k+ind_even_odd
+                   kp1 = k+ind_even_odd+1
+
+                   r(k,j,i) = f_mg(k,j,i)                                         &
+                    - ddx2_mg(l) *                                                &
+                    ( MERGE(p_mg(k,j,i),p_mg(k,j,i+1),BTEST( flags(k,j,i), 5 ))   &
+                    + MERGE(p_mg(k,j,i),p_mg(k,j,i-1),BTEST( flags(k,j,i), 4 )) ) &
+                    - ddy2_mg(l)                                                  &
+                    * ( MERGE(p_mg(k,j,i),p_mg(k,j+1,i),BTEST( flags(k,j,i), 3 )) &
+                    + MERGE(p_mg(k,j,i),p_mg(k,j-1,i),BTEST( flags(k,j,i), 2 )) ) &
+                    - f2_mg(k,l) * p_mg(kp1,j,i)                                  &
+                    - f3_mg(k,l) *                                                &
+                      MERGE(p_mg(k,j,i),p_mg(km1,j,i),BTEST( flags(k,j,i), 0 ))   &
+                    + f1_mg(k,l) * p_mg(k,j,i)
+                ENDDO
+!
+!--             The residual within topography should be zero
+                WHERE( BTEST(flags(nzb+1:nzt_mg(l),j,i), 6) )
+                   r(nzb+1:nzt_mg(l),j,i) = 0.0
+                END WHERE
+
+             ENDDO
+          ENDDO
+          !$OMP END PARALLEL
+
+       ENDIF
+
+!
+!--    Horizontal boundary conditions
+       CALL exchange_horiz( r, 1)
+
+       IF ( .NOT. bc_lr_cyc )  THEN
+          IF ( inflow_l .OR. outflow_l .OR. nest_bound_l )  THEN
+             r(:,:,nxl_mg(l)-1) = r(:,:,nxl_mg(l))
+          ENDIF
+          IF ( inflow_r .OR. outflow_r .OR. nest_bound_r )  THEN
+             r(:,:,nxr_mg(l)+1) = r(:,:,nxr_mg(l))
+          ENDIF
+       ENDIF
+
+       IF ( .NOT. bc_ns_cyc )  THEN
+          IF ( inflow_n .OR. outflow_n .OR. nest_bound_n )  THEN
+             r(:,nyn_mg(l)+1,:) = r(:,nyn_mg(l),:)
+          ENDIF
+          IF ( inflow_s .OR. outflow_s .OR. nest_bound_s )  THEN
+             r(:,nys_mg(l)-1,:) = r(:,nys_mg(l),:)
+          ENDIF
+       ENDIF
+
+!
+!--    Boundary conditions at bottom and top of the domain.outflow_l, outflow_n,
+!--    These points are not handled by the above loop. Points may be within
+!--    buildings, but that doesn't matter.
+       IF ( ibc_p_b == 1 )  THEN
+          r(nzb,:,: ) = r(nzb+1,:,:)
+       ELSE
+          r(nzb,:,: ) = 0.0_wp
+       ENDIF
+
+       IF ( ibc_p_t == 1 )  THEN
+          r(nzt_mg(l)+1,:,: ) = r(nzt_mg(l),:,:)
+       ELSE
+          r(nzt_mg(l)+1,:,: ) = 0.0_wp
+       ENDIF
+
+       CALL cpu_log( log_point_s(53), 'resid', 'stop' )
+
+    END SUBROUTINE resid_fast
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Interpolates the residual on the next coarser grid with "full weighting"
+!> scheme
+!------------------------------------------------------------------------------!
+    SUBROUTINE restrict_fast( f_mg, r )
+
+
+       USE control_parameters,                                                 &
+           ONLY:  bc_lr_cyc, bc_ns_cyc, grid_level, ibc_p_b, ibc_p_t, inflow_l,&
+                  inflow_n, inflow_r, inflow_s, masking_method, nest_bound_l,  &
+                  nest_bound_n, nest_bound_r, nest_bound_s, outflow_l,         &
+                  outflow_n, outflow_r, outflow_s, topography
+
+       USE indices,                                                            &
+           ONLY:  flags, wall_flags_1, wall_flags_2, wall_flags_3,             &
+                  wall_flags_4, wall_flags_5, wall_flags_6, wall_flags_7,      &
+                  wall_flags_8, wall_flags_9, wall_flags_10, nxl_mg, nxr_mg,   &
+                  nys_mg, nyn_mg, nzb, nzt_mg
+
+       IMPLICIT NONE
+
+       INTEGER(iwp) ::  i    !<
+       INTEGER(iwp) ::  ic   !<
+       INTEGER(iwp) ::  j    !<
+       INTEGER(iwp) ::  jc   !<
+       INTEGER(iwp) ::  k    !<
+       INTEGER(iwp) ::  kc   !<
+       INTEGER(iwp) ::  l    !<
+       INTEGER(iwp) ::  km1  !<
+       INTEGER(iwp) ::  kp1  !<
+
+       REAL(wp) ::  rkjim    !<
+       REAL(wp) ::  rkjip    !<
+       REAL(wp) ::  rkjmi    !<
+       REAL(wp) ::  rkjmim   !<
+       REAL(wp) ::  rkjmip   !<
+       REAL(wp) ::  rkjpi    !<
+       REAL(wp) ::  rkjpim   !<
+       REAL(wp) ::  rkjpip   !<
+       REAL(wp) ::  rkmji    !<
+       REAL(wp) ::  rkmjim   !<
+       REAL(wp) ::  rkmjip   !<
+       REAL(wp) ::  rkmjmi   !<
+       REAL(wp) ::  rkmjmim  !<
+       REAL(wp) ::  rkmjmip  !<
+       REAL(wp) ::  rkmjpi   !<
+       REAL(wp) ::  rkmjpim  !<
+       REAL(wp) ::  rkmjpip  !<
+
+       REAL(wp), DIMENSION(nzb:nzt_mg(grid_level)+1,                           &
+                           nys_mg(grid_level)-1:nyn_mg(grid_level)+1,          &
+                           nxl_mg(grid_level)-1:nxr_mg(grid_level)+1) ::  f_mg  !<
+
+       REAL(wp), DIMENSION(nzb:nzt_mg(grid_level+1)+1,                         &
+                           nys_mg(grid_level+1)-1:nyn_mg(grid_level+1)+1,      &
+                           nxl_mg(grid_level+1)-1:nxr_mg(grid_level+1)+1) ::  r !<
+
+!
+!--    Interpolate the residual
+       l = grid_level
+
+       CALL cpu_log( log_point_s(54), 'restrict', 'start' )
+
+       IF ( topography == 'flat'  .OR.  masking_method )  THEN
+!
+!--       No wall treatment
+          !$OMP PARALLEL PRIVATE (i,j,k,ic,jc,kc,km1,kp1)
+          DO  ic = nxl_mg(l), nxr_mg(l)
+             i = 2*ic
+             !$OMP DO SCHEDULE( STATIC )
+             DO  jc = nys_mg(l), nyn_mg(l)
+!
+!--             Calculation for the first point along k
+                j  = 2*jc
+                k   = ind_even_odd+1
+                kp1 = k-ind_even_odd
+                kc  = k-ind_even_odd
+                f_mg(kc,jc,ic) =  1.0_wp / 64.0_wp * (                         &
+                                  8.0_wp * r(k,j,i)                            &
+                               +  4.0_wp * ( r(k,j,i-1)     + r(k,j,i+1)     + &
+                                             r(k,j+1,i)     + r(k,j-1,i)     ) &
+                               +  2.0_wp * ( r(k,j-1,i-1)   + r(k,j+1,i-1)   + &
+                                             r(k,j-1,i+1)   + r(k,j+1,i+1)   ) &
+                               + 16.0_wp * r(k,j,i)                            &
+                               +  4.0_wp * r(kp1,j,i)                          &
+                               +  2.0_wp * ( r(kp1,j,i-1)   + r(kp1,j,i+1)   + &
+                                             r(kp1,j+1,i)   + r(kp1,j-1,i)   ) &
+                               +           ( r(kp1,j-1,i-1) + r(kp1,j+1,i-1) + &
+                                             r(kp1,j-1,i+1) + r(kp1,j+1,i+1) ) &
+                                                      )
+!
+!--             Calculation for the other points along k
+                !DIR$ IVDEP
+                DO k = ind_even_odd+2, nzt_mg(l+1)    ! Fine grid at this point
+                   km1 = k-ind_even_odd-1
+                   kp1 = k-ind_even_odd
+                   kc  = k-ind_even_odd               ! Coarse grid index
+
+                   f_mg(kc,jc,ic) = 1.0_wp / 64.0_wp * (                      &
+                                  8.0_wp * r(k,j,i)                            &
+                                + 4.0_wp * ( r(k,j,i-1)     + r(k,j,i+1)     + &
+                                             r(k,j+1,i)     + r(k,j-1,i)     ) &
+                                + 2.0_wp * ( r(k,j-1,i-1)   + r(k,j+1,i-1)   + &
+                                             r(k,j-1,i+1)   + r(k,j+1,i+1)   ) &
+                                + 4.0_wp * r(km1,j,i)                          &
+                                + 2.0_wp * ( r(km1,j,i-1)   + r(km1,j,i+1)   + &
+                                             r(km1,j+1,i)   + r(km1,j-1,i)   ) &
+                                +          ( r(km1,j-1,i-1) + r(km1,j+1,i-1) + &
+                                             r(km1,j-1,i+1) + r(km1,j+1,i+1) ) &
+                                + 4.0_wp * r(kp1,j,i)                          &
+                                + 2.0_wp * ( r(kp1,j,i-1)   + r(kp1,j,i+1)   + &
+                                             r(kp1,j+1,i)   + r(kp1,j-1,i)   ) &
+                                +          ( r(kp1,j-1,i-1) + r(kp1,j+1,i-1) + &
+                                             r(kp1,j-1,i+1) + r(kp1,j+1,i+1) ) &
+                                           )
+                ENDDO
+             ENDDO
+             !$OMP ENDDO nowait
+          ENDDO
+          !$OMP END PARALLEL
+
+       ELSE
+!
+!--       Choose flag array of the upper level
+          SELECT CASE ( l+1 )
+             CASE ( 1 )
+                flags => wall_flags_1
+             CASE ( 2 )
+                flags => wall_flags_2
+             CASE ( 3 )
+                flags => wall_flags_3
+             CASE ( 4 )
+                flags => wall_flags_4
+             CASE ( 5 )
+                flags => wall_flags_5
+             CASE ( 6 )
+                flags => wall_flags_6
+             CASE ( 7 )
+                flags => wall_flags_7
+             CASE ( 8 )
+                flags => wall_flags_8
+             CASE ( 9 )
+                flags => wall_flags_9
+             CASE ( 10 )
+                flags => wall_flags_10
+          END SELECT
+    
+          !$OMP PARALLEL PRIVATE (i,j,k,ic,jc,kc,km1,kp1,rkjim,rkjip,rkjpi,    &
+          !$OMP                   rkjmim,rkjpim,rkjmip,rkjpip,rkmji,rkmjim,    &
+          !$OMP                   rkmjip,rkmjpi,rkmjmi,rkmjmim,rkmjpim,        &
+          !$OMP                   rkmjmip,rkmjpip)
+          !$OMP DO
+          DO  ic = nxl_mg(l), nxr_mg(l)
+             i = 2*ic
+             DO  jc = nys_mg(l), nyn_mg(l)
+                j = 2*jc
+                !DIR$ IVDEP
+                DO k = ind_even_odd+1, nzt_mg(l+1)      !fine grid at this point
+
+                    km1 = k-ind_even_odd-1
+                    kp1 = k-ind_even_odd
+                    kc  = k-ind_even_odd                !Coarse grid index
+!
+!--                 Use implicit Neumann BCs if the respective gridpoint is
+!--                 inside the building
+                    rkjim   = MERGE(r(k,j,i),r(k,j,i-1),BTEST( flags(k,j,i-1), 6))
+                    rkjip   = MERGE(r(k,j,i),r(k,j,i+1),BTEST( flags(k,j,i+1), 6))
+                    rkjpi   = MERGE(r(k,j,i),r(k,j+1,i),BTEST( flags(k,j+1,i), 6))
+                    rkjmi   = MERGE(r(k,j,i),r(k,j-1,i),BTEST( flags(k,j-1,i), 6))
+
+                    rkjmim  = MERGE(r(k,j,i),r(k,j-1,i-1),BTEST( flags(k,j-1,i-1), 6))
+                    rkjpim  = MERGE(r(k,j,i),r(k,j+1,i-1),BTEST( flags(k,j+1,i-1), 6))
+                    rkjmip  = MERGE(r(k,j,i),r(k,j-1,i+1),BTEST( flags(k,j-1,i+1), 6))
+                    rkjpip  = MERGE(r(k,j,i),r(k,j+1,i+1),BTEST( flags(k,j+1,i+1), 6))
+
+                    rkmji   = MERGE(r(k,j,i),r(km1,j,i)  ,BTEST( flags(km1,j,i)  , 6))
+                    rkmjim  = MERGE(r(k,j,i),r(km1,j,i-1),BTEST( flags(km1,j,i-1), 6))
+                    rkmjip  = MERGE(r(k,j,i),r(km1,j,i+1),BTEST( flags(km1,j,i+1), 6))
+                    rkmjpi  = MERGE(r(k,j,i),r(km1,j+1,i),BTEST( flags(km1,j+1,i), 6))
+                    rkmjmi  = MERGE(r(k,j,i),r(km1,j-1,i),BTEST( flags(km1,j-1,i), 6))
+
+                    rkmjmim = MERGE(r(k,j,i),r(km1,j-1,i-1),BTEST( flags(km1,j-1,i-1), 6))
+                    rkmjpim = MERGE(r(k,j,i),r(km1,j+1,i-1),BTEST( flags(km1,j+1,i-1), 6))
+                    rkmjmip = MERGE(r(k,j,i),r(km1,j-1,i+1),BTEST( flags(km1,j-1,i+1), 6))
+                    rkmjpip = MERGE(r(k,j,i),r(km1,j+1,i+1),BTEST( flags(km1,j+1,i+1), 6))
+
+                    f_mg(kc,jc,ic) = 1.0_wp / 64.0_wp * (                      &
+                           8.0_wp * r(k,j,i)                                   &
+                         + 4.0_wp * ( rkjim   + rkjip   +  rkjpi   + rkjmi   ) &
+                         + 2.0_wp * ( rkjmim  + rkjpim  +  rkjmip  + rkjpip  ) &
+                         + 4.0_wp * rkmji                                      &
+                         + 2.0_wp * ( rkmjim  + rkmjip  +  rkmjpi  + rkmjmi  ) &
+                         +          ( rkmjmim + rkmjpim +  rkmjmip + rkmjpip ) &
+                         + 4.0_wp * r(kp1,j,i)                                 &
+                         + 2.0_wp * ( r(kp1,j,i-1)   + r(kp1,j,i+1)   +        &
+                                      r(kp1,j+1,i)   + r(kp1,j-1,i)   )        &
+                         +          ( r(kp1,j-1,i-1) + r(kp1,j+1,i-1) +        &
+                                      r(kp1,j-1,i+1) + r(kp1,j+1,i+1) )        &
+                                                        )
+                ENDDO
+             ENDDO
+          ENDDO
+          !$OMP END PARALLEL
+
+       ENDIF
+
+!
+!--    Horizontal boundary conditions
+       CALL exchange_horiz( f_mg, 1)
+
+       IF ( .NOT. bc_lr_cyc )  THEN
+          IF ( inflow_l .OR. outflow_l .OR. nest_bound_l )  THEN
+             f_mg(:,:,nxl_mg(l)-1) = f_mg(:,:,nxl_mg(l))
+          ENDIF
+          IF ( inflow_r .OR. outflow_r .OR. nest_bound_r )  THEN
+             f_mg(:,:,nxr_mg(l)+1) = f_mg(:,:,nxr_mg(l))
+          ENDIF
+       ENDIF
+
+       IF ( .NOT. bc_ns_cyc )  THEN
+          IF ( inflow_n .OR. outflow_n .OR. nest_bound_n )  THEN
+             f_mg(:,nyn_mg(l)+1,:) = f_mg(:,nyn_mg(l),:)
+          ENDIF
+          IF ( inflow_s .OR. outflow_s .OR. nest_bound_s )  THEN
+             f_mg(:,nys_mg(l)-1,:) = f_mg(:,nys_mg(l),:)
+          ENDIF
+       ENDIF
+
+!
+!--    Boundary conditions at bottom and top of the domain.
+!--    These points are not handled by the above loop. Points may be within
+!--    buildings, but that doesn't matter.
+       IF ( ibc_p_b == 1 )  THEN
+          f_mg(nzb,:,: ) = f_mg(nzb+1,:,:)
+       ELSE
+          f_mg(nzb,:,: ) = 0.0_wp
+       ENDIF
+
+       IF ( ibc_p_t == 1 )  THEN
+          f_mg(nzt_mg(l)+1,:,: ) = f_mg(nzt_mg(l),:,:)
+       ELSE
+          f_mg(nzt_mg(l)+1,:,: ) = 0.0_wp
+       ENDIF
+
+       CALL cpu_log( log_point_s(54), 'restrict', 'stop' )
+!
+!--    Why do we need a sorting here?
+       CALL sort_k_to_even_odd_blocks( f_mg , l)
+
+    END SUBROUTINE restrict_fast
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Interpolates the correction of the perturbation pressure 
+!> to the next finer grid.
+!------------------------------------------------------------------------------!
+    SUBROUTINE prolong_fast( p, temp )
+
+
+       USE control_parameters,                                                 &
+           ONLY:  bc_lr_cyc, bc_ns_cyc, grid_level, ibc_p_b, ibc_p_t, inflow_l,&
+                  inflow_n, inflow_r, inflow_s, nest_bound_l, nest_bound_n,    &
+                  nest_bound_r, nest_bound_s, outflow_l, outflow_n,            &
+                  outflow_r, outflow_s
+
+       USE indices,                                                            &
+           ONLY:  nxl_mg, nxr_mg, nys_mg, nyn_mg, nzb, nzt_mg
+
+       IMPLICIT NONE
+
+       INTEGER(iwp) ::  i   !<
+       INTEGER(iwp) ::  j   !<
+       INTEGER(iwp) ::  k   !<
+       INTEGER(iwp) ::  l   !<
+       INTEGER(iwp) ::  kp1 !<
+       INTEGER(iwp) ::  ke  !< Index for prolog even
+       INTEGER(iwp) ::  ko  !< Index for prolog odd
+
+       REAL(wp), DIMENSION(nzb:nzt_mg(grid_level-1)+1,                         &
+                           nys_mg(grid_level-1)-1:nyn_mg(grid_level-1)+1,      &
+                           nxl_mg(grid_level-1)-1:nxr_mg(grid_level-1)+1 ) ::  p  !<
+
+       REAL(wp), DIMENSION(nzb:nzt_mg(grid_level)+1,                           &
+                           nys_mg(grid_level)-1:nyn_mg(grid_level)+1,          &
+                           nxl_mg(grid_level)-1:nxr_mg(grid_level)+1) ::  temp  !<
+
+
+       CALL cpu_log( log_point_s(55), 'prolong', 'start' )
+
+!
+!--    First, store elements of the coarser grid on the next finer grid
+       l = grid_level
+       ind_even_odd = even_odd_level(grid_level-1)
+
+       !$OMP PARALLEL PRIVATE (i,j,k,kp1,ke,ko)
+       !$OMP DO
+       DO  i = nxl_mg(l-1), nxr_mg(l-1)
+          DO  j = nys_mg(l-1), nyn_mg(l-1)
+
+             !DIR$ IVDEP
+             DO k = ind_even_odd+1, nzt_mg(l-1)
+                kp1 = k - ind_even_odd
+                ke  = 2 * ( k-ind_even_odd - 1 ) + 1
+                ko  = 2 * k - 1
+!
+!--             Points of the coarse grid are directly stored on the next finer
+!--             grid
+                temp(ko,2*j,2*i)   = p(k,j,i)
+!
+!--             Points between two coarse-grid points
+                temp(ko,2*j,2*i+1) = 0.5_wp * ( p(k,j,i) + p(k,j,i+1) )
+                temp(ko,2*j+1,2*i) = 0.5_wp * ( p(k,j,i) + p(k,j+1,i) )
+                temp(ke,2*j,2*i)   = 0.5_wp * ( p(k,j,i) + p(kp1,j,i) )
+!
+!--             Points in the center of the planes stretched by four points
+!--             of the coarse grid cube
+                temp(ko,2*j+1,2*i+1) = 0.25_wp * ( p(k,j,i)   + p(k,j,i+1) +   &
+                                                   p(k,j+1,i) + p(k,j+1,i+1) )
+                temp(ke,2*j,2*i+1)   = 0.25_wp * ( p(k,j,i)   + p(k,j,i+1) +   &
+                                                   p(kp1,j,i) + p(kp1,j,i+1) )
+                temp(ke,2*j+1,2*i)   = 0.25_wp * ( p(k,j,i)   + p(k,j+1,i) +   &
+                                                   p(kp1,j,i) + p(kp1,j+1,i) )
+!
+!--             Points in the middle of coarse grid cube
+                temp(ke,2*j+1,2*i+1) = 0.125_wp *                              &
+                                               ( p(k,j,i)     + p(k,j,i+1)   + &
+                                                 p(k,j+1,i)   + p(k,j+1,i+1) + &
+                                                 p(kp1,j,i)   + p(kp1,j,i+1) + &
+                                                 p(kp1,j+1,i) + p(kp1,j+1,i+1) )
+             ENDDO
+
+             !DIR$ IVDEP
+             DO k = nzb+1, ind_even_odd
+                kp1 = k + ind_even_odd + 1
+                ke  = 2 * k
+                ko  = 2 * ( k + ind_even_odd )
+!
+!--             Points of the coarse grid are directly stored on the next finer
+!--             grid
+                temp(ko,2*j,2*i)   = p(k,j,i)
+!
+!--             Points between two coarse-grid points
+                temp(ko,2*j,2*i+1) = 0.5_wp * ( p(k,j,i) + p(k,j,i+1) )
+                temp(ko,2*j+1,2*i) = 0.5_wp * ( p(k,j,i) + p(k,j+1,i) )
+                temp(ke,2*j,2*i)   = 0.5_wp * ( p(k,j,i) + p(kp1,j,i) )
+!
+!--             Points in the center of the planes stretched by four points
+!--             of the coarse grid cube
+                temp(ko,2*j+1,2*i+1) = 0.25_wp * ( p(k,j,i)   + p(k,j,i+1) +   &
+                                                   p(k,j+1,i) + p(k,j+1,i+1) )
+                temp(ke,2*j,2*i+1)   = 0.25_wp * ( p(k,j,i)   + p(k,j,i+1) +   &
+                                                   p(kp1,j,i) + p(kp1,j,i+1) )
+                temp(ke,2*j+1,2*i)   = 0.25_wp * ( p(k,j,i)   + p(k,j+1,i) +   &
+                                                   p(kp1,j,i) + p(kp1,j+1,i) )
+!
+!--             Points in the middle of coarse grid cube
+                temp(ke,2*j+1,2*i+1) = 0.125_wp *                              &
+                                               ( p(k,j,i)     + p(k,j,i+1)   + &
+                                                 p(k,j+1,i)   + p(k,j+1,i+1) + &
+                                                 p(kp1,j,i)   + p(kp1,j,i+1) + &
+                                                 p(kp1,j+1,i) + p(kp1,j+1,i+1) )
+             ENDDO
+
+          ENDDO
+       ENDDO
+       !$OMP END PARALLEL
+
+       ind_even_odd = even_odd_level(grid_level)
+!
+!--    Horizontal boundary conditions
+       CALL exchange_horiz( temp, 1)
+
+       IF ( .NOT. bc_lr_cyc )  THEN
+          IF ( inflow_l .OR. outflow_l .OR. nest_bound_l )  THEN
+             temp(:,:,nxl_mg(l)-1) = temp(:,:,nxl_mg(l))
+          ENDIF
+          IF ( inflow_r .OR. outflow_r .OR. nest_bound_r )  THEN
+             temp(:,:,nxr_mg(l)+1) = temp(:,:,nxr_mg(l))
+          ENDIF
+       ENDIF
+
+       IF ( .NOT. bc_ns_cyc )  THEN
+          IF ( inflow_n .OR. outflow_n .OR. nest_bound_n )  THEN
+             temp(:,nyn_mg(l)+1,:) = temp(:,nyn_mg(l),:)
+          ENDIF
+          IF ( inflow_s .OR. outflow_s .OR. nest_bound_s )  THEN
+             temp(:,nys_mg(l)-1,:) = temp(:,nys_mg(l),:)
+          ENDIF
+       ENDIF
+
+!
+!--    Bottom and top boundary conditions
+       IF ( ibc_p_b == 1 )  THEN
+          temp(nzb,:,: ) = temp(ind_even_odd+1,:,:)
+       ELSE
+          temp(nzb,:,: ) = 0.0_wp
+       ENDIF
+
+       IF ( ibc_p_t == 1 )  THEN
+          temp(nzt_mg(l)+1,:,: ) = temp(ind_even_odd,:,:)
+       ELSE
+          temp(nzt_mg(l)+1,:,: ) = 0.0_wp
+       ENDIF
+
+       CALL cpu_log( log_point_s(55), 'prolong', 'stop' )
+
+    END SUBROUTINE prolong_fast
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Relaxation method for the multigrid scheme. A Gauss-Seidel iteration with
+!> 3D-Red-Black decomposition (GS-RB) is used.
+!------------------------------------------------------------------------------!
+    SUBROUTINE redblack_fast( f_mg, p_mg )
+
+
+       USE arrays_3d,                                                          &
+           ONLY:  f1_mg, f2_mg, f3_mg
+
+       USE control_parameters,                                                 &
+           ONLY:  bc_lr_cyc, bc_ns_cyc, grid_level, ibc_p_b, ibc_p_t, inflow_l,&
+                  inflow_n, inflow_r, inflow_s, masking_method, nest_bound_l,  &
+                  nest_bound_n, nest_bound_r, nest_bound_s, ngsrb,             &
+                  outflow_l, outflow_n, outflow_r, outflow_s, topography
+
+       USE grid_variables,                                                     &
+           ONLY:  ddx2_mg, ddy2_mg
+
+       USE indices,                                                            &
+           ONLY:  flags, wall_flags_1, wall_flags_2, wall_flags_3,             &
+                  wall_flags_4, wall_flags_5, wall_flags_6, wall_flags_7,      &
+                  wall_flags_8, wall_flags_9, wall_flags_10, nxl_mg, nxr_mg,   &
+                  nys_mg, nyn_mg, nzb, nzt_mg
+
+       IMPLICIT NONE
+
+       INTEGER(iwp) :: color    !<
+       INTEGER(iwp) :: i        !<
+       INTEGER(iwp) :: ic       !<
+       INTEGER(iwp) :: j        !<
+       INTEGER(iwp) :: jc       !<
+       INTEGER(iwp) :: jj       !<
+       INTEGER(iwp) :: k        !<
+       INTEGER(iwp) :: l        !<
+       INTEGER(iwp) :: n        !<
+       INTEGER(iwp) :: km1      !<
+       INTEGER(iwp) :: kp1      !<
+
+       LOGICAL :: unroll        !<
+
+       REAL(wp) ::  wall_left   !<
+       REAL(wp) ::  wall_north  !<
+       REAL(wp) ::  wall_right  !<
+       REAL(wp) ::  wall_south  !<
+       REAL(wp) ::  wall_total  !<
+       REAL(wp) ::  wall_top    !<
+
+       REAL(wp), DIMENSION(nzb:nzt_mg(grid_level)+1,                           &
+                           nys_mg(grid_level)-1:nyn_mg(grid_level)+1,          &
+                           nxl_mg(grid_level)-1:nxr_mg(grid_level)+1) ::  f_mg  !<
+       REAL(wp), DIMENSION(nzb:nzt_mg(grid_level)+1,                           &
+                           nys_mg(grid_level)-1:nyn_mg(grid_level)+1,          &
+                           nxl_mg(grid_level)-1:nxr_mg(grid_level)+1) ::  p_mg  !<
+
+       l = grid_level
+
+!
+!--    Choose flag array of this level
+       IF ( topography /= 'flat'  .AND.  .NOT. masking_method )  THEN
+
+          SELECT CASE ( l )
+             CASE ( 1 )
+                flags => wall_flags_1
+             CASE ( 2 )
+                flags => wall_flags_2
+             CASE ( 3 )
+                flags => wall_flags_3
+             CASE ( 4 )
+                flags => wall_flags_4
+             CASE ( 5 )
+                flags => wall_flags_5
+             CASE ( 6 )
+                flags => wall_flags_6
+             CASE ( 7 )
+                flags => wall_flags_7
+             CASE ( 8 )
+                flags => wall_flags_8
+             CASE ( 9 )
+                flags => wall_flags_9
+             CASE ( 10 )
+                flags => wall_flags_10
+          END SELECT
+
+       ENDIF
+
+       unroll = ( MOD( nyn_mg(l)-nys_mg(l)+1, 4 ) == 0  .AND. &
+                  MOD( nxr_mg(l)-nxl_mg(l)+1, 2 ) == 0 )
+
+       DO  n = 1, ngsrb
+       
+          DO  color = 1, 2
+!
+!--          No wall treatment in case of flat topography
+             IF ( topography == 'flat'  .OR.  masking_method )  THEN
+
+                IF ( .NOT. unroll )  THEN
+
+                   CALL cpu_log( log_point_s(36), 'redblack_no_unroll_f', 'start' )
+!
+!--                Without unrolling of loops, no cache optimization
+                   !$OMP PARALLEL PRIVATE (i,j,k,km1,kp1)
+                   !$OMP DO
+                   DO  i = nxl_mg(l), nxr_mg(l), 2
+                      DO  j = nys_mg(l) + 2 - color, nyn_mg(l), 2
+                         !DIR$ IVDEP
+                         DO  k = ind_even_odd+1, nzt_mg(l)
+                            km1 = k-ind_even_odd-1
+                            kp1 = k-ind_even_odd
+                            p_mg(k,j,i) = 1.0_wp / f1_mg_b(k,l) * (            &
+                               ddx2_mg(l) *                                    &
+                               ( p_mg(k,j,i+1) + p_mg(k,j,i-1)  )              &
+                               + ddy2_mg(l) *                                  &
+                               ( p_mg(k,j+1,i) + p_mg(k,j-1,i)  )              &
+                               + f2_mg_b(k,l) * p_mg(kp1,j,i)                  &
+                               + f3_mg_b(k,l) * p_mg(km1,j,i)                  &
+                               - f_mg(k,j,i)               )
+                         ENDDO
+                      ENDDO
+                   ENDDO
+   
+                   !$OMP DO
+                   DO  i = nxl_mg(l)+1, nxr_mg(l), 2
+                      DO  j = nys_mg(l) + (color-1), nyn_mg(l), 2
+                          !DIR$ IVDEP
+                          DO  k = ind_even_odd+1, nzt_mg(l)
+                            km1 = k-ind_even_odd-1
+                            kp1 = k-ind_even_odd
+                            p_mg(k,j,i) = 1.0_wp / f1_mg_b(k,l) * (            &
+                               ddx2_mg(l) *                                    &
+                               ( p_mg(k,j,i+1) + p_mg(k,j,i-1)  )              &
+                               + ddy2_mg(l) *                                  &
+                               ( p_mg(k,j+1,i) + p_mg(k,j-1,i) )               &
+                               + f2_mg_b(k,l) * p_mg(kp1,j,i)                  &
+                               + f3_mg_b(k,l) * p_mg(km1,j,i)                  &
+                               - f_mg(k,j,i)               )
+                         ENDDO
+                      ENDDO
+                   ENDDO
+  
+                   !$OMP DO
+                   DO  i = nxl_mg(l), nxr_mg(l), 2
+                      DO  j = nys_mg(l) + (color-1), nyn_mg(l), 2
+                         !DIR$ IVDEP
+                         DO  k = nzb+1, ind_even_odd
+                            km1 = k+ind_even_odd
+                            kp1 = k+ind_even_odd+1
+                            p_mg(k,j,i) = 1.0_wp / f1_mg_b(k,l) * (            &
+                               ddx2_mg(l) *                                    &
+                               ( p_mg(k,j,i+1) + p_mg(k,j,i-1) )               &
+                               + ddy2_mg(l) *                                  &
+                               ( p_mg(k,j+1,i) + p_mg(k,j-1,i) )               &
+                               + f2_mg_b(k,l) * p_mg(kp1,j,i)                  &
+                               + f3_mg_b(k,l) * p_mg(km1,j,i)                  &
+                               - f_mg(k,j,i)               )
+                         ENDDO
+                      ENDDO
+                   ENDDO
+
+                   !$OMP DO
+                   DO  i = nxl_mg(l)+1, nxr_mg(l), 2
+                      DO  j = nys_mg(l) + 2 - color, nyn_mg(l), 2
+                         !DIR$ IVDEP
+                         DO  k = nzb+1, ind_even_odd
+                            km1 = k+ind_even_odd
+                            kp1 = k+ind_even_odd+1
+                            p_mg(k,j,i) = 1.0_wp / f1_mg_b(k,l) * (            &
+                               ddx2_mg(l) *                                    &
+                               ( p_mg(k,j,i+1) + p_mg(k,j,i-1) )               &
+                               + ddy2_mg(l) *                                  &
+                               ( p_mg(k,j+1,i) + p_mg(k,j-1,i) )               &
+                               + f2_mg_b(k,l) * p_mg(kp1,j,i)                  &
+                               + f3_mg_b(k,l) * p_mg(km1,j,i)                  &
+                               - f_mg(k,j,i)               )
+                         ENDDO
+                      ENDDO
+                   ENDDO
+                   !$OMP END PARALLEL
+
+                   CALL cpu_log( log_point_s(36), 'redblack_no_unroll_f', 'stop' )
+
+                ELSE
+!
+!--                Loop unrolling along y, only one i loop for better cache use
+                   CALL cpu_log( log_point_s(38), 'redblack_unroll_f', 'start' )
+
+                   !$OMP PARALLEL PRIVATE (i,j,k,ic,jc,km1,kp1,jj)
+                   !$OMP DO
+                   DO  ic = nxl_mg(l), nxr_mg(l), 2
+                      DO  jc = nys_mg(l), nyn_mg(l), 4
+                         i  = ic
+                         jj = jc+2-color
+                         !DIR$ IVDEP
+                         DO  k = ind_even_odd+1, nzt_mg(l)
+                            km1 = k-ind_even_odd-1
+                            kp1 = k-ind_even_odd
+                            j   = jj
+                            p_mg(k,j,i) = 1.0_wp / f1_mg_b(k,l) * (            &
+                               ddx2_mg(l) *                                    &
+                               ( p_mg(k,j,i+1) + p_mg(k,j,i-1) )               &
+                               + ddy2_mg(l) *                                  &
+                               ( p_mg(k,j+1,i) + p_mg(k,j-1,i) )               &
+                               + f2_mg_b(k,l) * p_mg(kp1,j,i)                  &
+                               + f3_mg_b(k,l) * p_mg(km1,j,i)                  &
+                               - f_mg(k,j,i)               )
+                            j = jj+2
+                            p_mg(k,j,i) = 1.0_wp / f1_mg_b(k,l) * (            &
+                               ddx2_mg(l) *                                    &
+                               ( p_mg(k,j,i+1) + p_mg(k,j,i-1) )               &
+                               + ddy2_mg(l) *                                  &
+                               ( p_mg(k,j+1,i) + p_mg(k,j-1,i) )               &
+                               + f2_mg_b(k,l) * p_mg(kp1,j,i)                  &
+                               + f3_mg_b(k,l) * p_mg(km1,j,i)                  &
+                               - f_mg(k,j,i)               )
+                         ENDDO
+
+                         i  = ic+1
+                         jj = jc+color-1
+                         !DIR$ IVDEP
+                         DO  k = ind_even_odd+1, nzt_mg(l)
+                            km1 = k-ind_even_odd-1
+                            kp1 = k-ind_even_odd
+                            j   = jj
+                            p_mg(k,j,i) = 1.0_wp / f1_mg_b(k,l) * (            &
+                               ddx2_mg(l) *                                    &
+                               ( p_mg(k,j,i+1) + p_mg(k,j,i-1)  )              &
+                               + ddy2_mg(l) *                                  &
+                               ( p_mg(k,j+1,i) + p_mg(k,j-1,i) )               &
+                               + f2_mg_b(k,l) * p_mg(kp1,j,i)                  &
+                               + f3_mg_b(k,l) * p_mg(km1,j,i)                  &
+                               - f_mg(k,j,i)               )
+                            j = jj+2
+                            p_mg(k,j,i) = 1.0_wp / f1_mg_b(k,l) * (            &
+                               ddx2_mg(l) *                                    &
+                               ( p_mg(k,j,i+1) + p_mg(k,j,i-1)  )              &
+                               + ddy2_mg(l) *                                  &
+                               ( p_mg(k,j+1,i) + p_mg(k,j-1,i)  )              &
+                               + f2_mg_b(k,l) * p_mg(kp1,j,i)                  &
+                               + f3_mg_b(k,l) * p_mg(km1,j,i)                  &
+                               - f_mg(k,j,i)               )
+                         ENDDO
+
+                         i  = ic
+                         jj = jc+color-1
+                         !DIR$ IVDEP
+                         DO  k = nzb+1, ind_even_odd
+                            km1 = k+ind_even_odd
+                            kp1 = k+ind_even_odd+1
+                            j   = jj
+                            p_mg(k,j,i) = 1.0_wp / f1_mg_b(k,l) * (            &
+                               ddx2_mg(l) *                                    &
+                               ( p_mg(k,j,i+1) + p_mg(k,j,i-1)  )              &
+                               + ddy2_mg(l) *                                  &
+                               ( p_mg(k,j+1,i) + p_mg(k,j-1,i)  )              &
+                               + f2_mg_b(k,l) * p_mg(kp1,j,i)                  &
+                               + f3_mg_b(k,l) * p_mg(km1,j,i)                  &
+                               - f_mg(k,j,i)               )
+                            j = jj+2
+                            p_mg(k,j,i) = 1.0_wp / f1_mg_b(k,l) * (            &
+                               ddx2_mg(l) *                                    &
+                               ( p_mg(k,j,i+1) + p_mg(k,j,i-1) )               &
+                               + ddy2_mg(l) *                                  &
+                               ( p_mg(k,j+1,i) + p_mg(k,j-1,i) )               &
+                               + f2_mg_b(k,l) * p_mg(kp1,j,i)                  &
+                               + f3_mg_b(k,l) * p_mg(km1,j,i)                  &
+                               - f_mg(k,j,i)               )
+                         ENDDO
+
+                         i  = ic+1
+                         jj = jc+2-color
+                         !DIR$ IVDEP
+                         DO  k = nzb+1, ind_even_odd
+                            km1 = k+ind_even_odd
+                            kp1 = k+ind_even_odd+1
+                            j   = jj
+                            p_mg(k,j,i) = 1.0_wp / f1_mg_b(k,l) * (            &
+                               ddx2_mg(l) *                                    &
+                               ( p_mg(k,j,i+1) + p_mg(k,j,i-1)  )              &
+                               + ddy2_mg(l) *                                  &
+                               ( p_mg(k,j+1,i) + p_mg(k,j-1,i) )               &
+                               + f2_mg_b(k,l) * p_mg(kp1,j,i)                  &
+                               + f3_mg_b(k,l) * p_mg(km1,j,i)                  &
+                               - f_mg(k,j,i)               )
+                            j = jj+2
+                            p_mg(k,j,i) = 1.0_wp / f1_mg_b(k,l) * (            &
+                               ddx2_mg(l) *                                    &
+                               ( p_mg(k,j,i+1) + p_mg(k,j,i-1) )               &
+                               + ddy2_mg(l) *                                  &
+                               ( p_mg(k,j+1,i) + p_mg(k,j-1,i)  )              &
+                               + f2_mg_b(k,l) * p_mg(kp1,j,i)                  &
+                               + f3_mg_b(k,l) * p_mg(km1,j,i)                  &
+                               - f_mg(k,j,i)               )
+                         ENDDO
+
+                      ENDDO
+                   ENDDO
+                   !$OMP END PARALLEL
+
+                   CALL cpu_log( log_point_s(38), 'redblack_unroll_f', 'stop' )
+
+                ENDIF
+
+             ELSE
+
+                IF ( .NOT. unroll )  THEN
+
+                   CALL cpu_log( log_point_s(36), 'redblack_no_unroll', 'start' )
+!
+!--                Without unrolling of loops, no cache optimization /
+!--                vectorization. Therefore, the non-vectorized IBITS function
+!--                is still used.
+                   !$OMP PARALLEL PRIVATE (i,j,k,km1,kp1)
+                   !$OMP DO
+                   DO  i = nxl_mg(l), nxr_mg(l), 2
+                      DO  j = nys_mg(l) + 2 - color, nyn_mg(l), 2
+                         !DIR$ IVDEP
+                         DO  k = ind_even_odd+1, nzt_mg(l)
+                            km1 = k-ind_even_odd-1
+                            kp1 = k-ind_even_odd
+
+                            p_mg(k,j,i) = 1.0_wp / f1_mg(k,l) * (              &
+                               ddx2_mg(l) *                                    &
+                               ( p_mg(k,j,i+1) + IBITS( flags(k,j,i), 5, 1 ) * &
+                               ( p_mg(k,j,i) - p_mg(k,j,i+1) ) +               &
+                               p_mg(k,j,i-1) + IBITS( flags(k,j,i), 4, 1 ) *   &
+                               ( p_mg(k,j,i) - p_mg(k,j,i-1) ) )               &
+                               + ddy2_mg(l) *                                  &
+                               ( p_mg(k,j+1,i) + IBITS( flags(k,j,i), 3, 1 ) * &
+                               ( p_mg(k,j,i) - p_mg(k,j+1,i) ) +               &
+                               p_mg(k,j-1,i) + IBITS( flags(k,j,i), 2, 1 ) *   &
+                               ( p_mg(k,j,i) - p_mg(k,j-1,i) ) )               &
+                               + f2_mg(k,l) * p_mg(kp1,j,i)                    &
+                               + f3_mg(k,l) *                                  &
+                               ( p_mg(km1,j,i) + IBITS( flags(k,j,i), 0, 1 ) * &
+                               ( p_mg(k,j,i) - p_mg(km1,j,i) ) )               &
+                               - f_mg(k,j,i)               )
+                         ENDDO
+                      ENDDO
+                   ENDDO
+   
+                   !$OMP DO
+                   DO  i = nxl_mg(l)+1, nxr_mg(l), 2
+                      DO  j = nys_mg(l) + (color-1), nyn_mg(l), 2
+                          !DIR$ IVDEP
+                          DO  k = ind_even_odd+1, nzt_mg(l)
+                            km1 = k-ind_even_odd-1
+                            kp1 = k-ind_even_odd
+
+                            p_mg(k,j,i) = 1.0_wp / f1_mg(k,l) * (              &
+                               ddx2_mg(l) *                                    &
+                               ( p_mg(k,j,i+1) + IBITS( flags(k,j,i), 5, 1 ) * &
+                               ( p_mg(k,j,i) - p_mg(k,j,i+1) ) +               &
+                               p_mg(k,j,i-1) + IBITS( flags(k,j,i), 4, 1 ) *   &
+                               ( p_mg(k,j,i) - p_mg(k,j,i-1) ) )               &
+                               + ddy2_mg(l) *                                  &
+                               ( p_mg(k,j+1,i) + IBITS( flags(k,j,i), 3, 1 ) * &
+                               ( p_mg(k,j,i) - p_mg(k,j+1,i) ) +               &
+                               p_mg(k,j-1,i) + IBITS( flags(k,j,i), 2, 1 ) *   &
+                               ( p_mg(k,j,i) - p_mg(k,j-1,i) ) )               &
+                               + f2_mg(k,l) * p_mg(kp1,j,i)                    &
+                               + f3_mg(k,l) *                                  &
+                               ( p_mg(km1,j,i) + IBITS( flags(k,j,i), 0, 1 ) * &
+                               ( p_mg(k,j,i) - p_mg(km1,j,i) ) )               &
+                               - f_mg(k,j,i)               )
+                         ENDDO
+                      ENDDO
+                   ENDDO
+
+                   !$OMP DO
+                   DO  i = nxl_mg(l), nxr_mg(l), 2
+                      DO  j = nys_mg(l) + (color-1), nyn_mg(l), 2
+                         !DIR$ IVDEP
+                         DO  k = nzb+1, ind_even_odd
+                            km1 = k+ind_even_odd
+                            kp1 = k+ind_even_odd+1
+                            p_mg(k,j,i) = 1.0_wp / f1_mg(k,l) * (              &
+                               ddx2_mg(l) *                                    &
+                               ( p_mg(k,j,i+1) + IBITS( flags(k,j,i), 5, 1 ) * &
+                               ( p_mg(k,j,i) - p_mg(k,j,i+1) ) +               &
+                               p_mg(k,j,i-1) + IBITS( flags(k,j,i), 4, 1 ) *   &
+                               ( p_mg(k,j,i) - p_mg(k,j,i-1) ) )               &
+                               + ddy2_mg(l) *                                  &
+                               ( p_mg(k,j+1,i) + IBITS( flags(k,j,i), 3, 1 ) * &
+                               ( p_mg(k,j,i) - p_mg(k,j+1,i) ) +               &
+                               p_mg(k,j-1,i) + IBITS( flags(k,j,i), 2, 1 ) *   &
+                               ( p_mg(k,j,i) - p_mg(k,j-1,i) ) )               &
+                               + f2_mg(k,l) * p_mg(kp1,j,i)                    &
+                               + f3_mg(k,l) *                                  &
+                               ( p_mg(km1,j,i) + IBITS( flags(k,j,i), 0, 1 ) * &
+                               ( p_mg(k,j,i) - p_mg(km1,j,i) ) ) &
+                               - f_mg(k,j,i)               )
+                         ENDDO
+                      ENDDO
+                   ENDDO
+
+                   !$OMP DO
+                   DO  i = nxl_mg(l)+1, nxr_mg(l), 2
+                      DO  j = nys_mg(l) + 2 - color, nyn_mg(l), 2
+                         !DIR$ IVDEP
+                         DO  k = nzb+1, ind_even_odd
+                            km1 = k+ind_even_odd
+                            kp1 = k+ind_even_odd+1
+
+                            p_mg(k,j,i) = 1.0_wp / f1_mg(k,l) * (              &
+                               ddx2_mg(l) *                                    &
+                               ( p_mg(k,j,i+1) + IBITS( flags(k,j,i), 5, 1 ) * &
+                               ( p_mg(k,j,i) - p_mg(k,j,i+1) ) +               &
+                               p_mg(k,j,i-1) + IBITS( flags(k,j,i), 4, 1 ) *   &
+                               ( p_mg(k,j,i) - p_mg(k,j,i-1) ) )               &
+                               + ddy2_mg(l) *                                  &
+                               ( p_mg(k,j+1,i) + IBITS( flags(k,j,i), 3, 1 ) * &
+                               ( p_mg(k,j,i) - p_mg(k,j+1,i) ) +               &
+                               p_mg(k,j-1,i) + IBITS( flags(k,j,i), 2, 1 ) *   &
+                               ( p_mg(k,j,i) - p_mg(k,j-1,i) ) )               &
+                               + f2_mg(k,l) * p_mg(kp1,j,i)                    &
+                               + f3_mg(k,l) *                                  &
+                               ( p_mg(km1,j,i) + IBITS( flags(k,j,i), 0, 1 ) * &
+                               ( p_mg(k,j,i) - p_mg(km1,j,i) ) )               &
+                               - f_mg(k,j,i)               )
+                         ENDDO
+                      ENDDO
+                   ENDDO
+                   !$OMP END PARALLEL
+
+                   CALL cpu_log( log_point_s(36), 'redblack_no_unroll', 'stop' )
+
+                ELSE
+!
+!--                Loop unrolling along y, only one i loop for better cache use
+                   CALL cpu_log( log_point_s(38), 'redblack_unroll', 'start' )
+
+                   !$OMP PARALLEL PRIVATE (i,j,k,ic,jc,km1,kp1,jj)
+                   !$OMP DO
+                   DO  ic = nxl_mg(l), nxr_mg(l), 2
+                      DO  jc = nys_mg(l), nyn_mg(l), 4
+                         i  = ic
+                         jj = jc+2-color
+                         !DIR$ IVDEP
+                         DO  k = ind_even_odd+1, nzt_mg(l)
+
+                            km1 = k-ind_even_odd-1
+                            kp1 = k-ind_even_odd
+
+                            j = jj
+                            p_mg(k,j,i) = 1.0 / f1_mg(k,l) * (                               &
+                                ddx2_mg(l) *                                                 &
+                                ( MERGE(p_mg(k,j,i),p_mg(k,j,i+1),BTEST( flags(k,j,i), 5))   &
+                                + MERGE(p_mg(k,j,i),p_mg(k,j,i-1),BTEST( flags(k,j,i), 4)) ) &
+                                + ddy2_mg(l) *                                               &
+                                ( MERGE(p_mg(k,j,i),p_mg(k,j+1,i),BTEST( flags(k,j,i), 3))   &
+                                + MERGE(p_mg(k,j,i),p_mg(k,j-1,i),BTEST( flags(k,j,i), 2)) ) &
+                                + f2_mg(k,l) * p_mg(kp1,j,i)                                 &
+                                + f3_mg(k,l) *                                               &
+                                MERGE(p_mg(k,j,i),p_mg(km1,j,i),BTEST( flags(k,j,i), 0))     &
+                                - f_mg(k,j,i)               )
+                            j = jj+2
+                            p_mg(k,j,i) = 1.0 / f1_mg(k,l) * (                               &
+                                ddx2_mg(l) *                                                 &
+                                ( MERGE(p_mg(k,j,i),p_mg(k,j,i+1),BTEST( flags(k,j,i), 5))   &
+                                + MERGE(p_mg(k,j,i),p_mg(k,j,i-1),BTEST( flags(k,j,i), 4)) ) &
+                                + ddy2_mg(l) *                                               &
+                                ( MERGE(p_mg(k,j,i),p_mg(k,j+1,i),BTEST( flags(k,j,i), 3))   &
+                                + MERGE(p_mg(k,j,i),p_mg(k,j-1,i),BTEST( flags(k,j,i), 2)) ) &
+                                + f2_mg(k,l) * p_mg(kp1,j,i)                                 &
+                                + f3_mg(k,l) *                                               &
+                                MERGE(p_mg(k,j,i),p_mg(km1,j,i),BTEST( flags(k,j,i), 0))     &
+                                - f_mg(k,j,i)               )
+
+                         ENDDO
+
+                         i  = ic+1
+                         jj = jc+color-1
+                         !DIR$ IVDEP
+                         DO  k = ind_even_odd+1, nzt_mg(l)
+
+                            km1 = k-ind_even_odd-1
+                            kp1 = k-ind_even_odd
+
+                            j =jj
+                            p_mg(k,j,i) = 1.0 / f1_mg(k,l) * (                               &
+                                ddx2_mg(l) *                                                 &
+                                ( MERGE(p_mg(k,j,i),p_mg(k,j,i+1),BTEST( flags(k,j,i), 5))   &
+                                + MERGE(p_mg(k,j,i),p_mg(k,j,i-1),BTEST( flags(k,j,i), 4)) ) &
+                                + ddy2_mg(l) *                                               &
+                                ( MERGE(p_mg(k,j,i),p_mg(k,j+1,i),BTEST( flags(k,j,i), 3))   &
+                                + MERGE(p_mg(k,j,i),p_mg(k,j-1,i),BTEST( flags(k,j,i), 2)) ) &
+                                + f2_mg(k,l) * p_mg(kp1,j,i)                                 &
+                                + f3_mg(k,l) *                                               &
+                                MERGE(p_mg(k,j,i),p_mg(km1,j,i),BTEST( flags(k,j,i), 0))     &
+                                - f_mg(k,j,i)               )
+
+                            j = jj+2
+                            p_mg(k,j,i) = 1.0 / f1_mg(k,l) * (                               &
+                                ddx2_mg(l) *                                                 &
+                                ( MERGE(p_mg(k,j,i),p_mg(k,j,i+1),BTEST( flags(k,j,i), 5))   &
+                                + MERGE(p_mg(k,j,i),p_mg(k,j,i-1),BTEST( flags(k,j,i), 4)) ) &
+                                + ddy2_mg(l) *                                               &
+                                ( MERGE(p_mg(k,j,i),p_mg(k,j+1,i),BTEST( flags(k,j,i), 3))   &
+                                + MERGE(p_mg(k,j,i),p_mg(k,j-1,i),BTEST( flags(k,j,i), 2)) ) &
+                                + f2_mg(k,l) * p_mg(kp1,j,i)                                 &
+                                + f3_mg(k,l) *                                               &
+                                MERGE(p_mg(k,j,i),p_mg(km1,j,i),BTEST( flags(k,j,i), 0))     &
+                                - f_mg(k,j,i)               )
+
+                         ENDDO
+
+                         i  = ic
+                         jj = jc+color-1
+                         !DIR$ IVDEP
+                         DO  k = nzb+1, ind_even_odd
+
+                            km1 = k+ind_even_odd
+                            kp1 = k+ind_even_odd+1
+
+                            j =jj
+                            p_mg(k,j,i) = 1.0 / f1_mg(k,l) * (                               &
+                                ddx2_mg(l) *                                                 &
+                                ( MERGE(p_mg(k,j,i),p_mg(k,j,i+1),BTEST( flags(k,j,i), 5))   &
+                                + MERGE(p_mg(k,j,i),p_mg(k,j,i-1),BTEST( flags(k,j,i), 4)) ) &
+                                + ddy2_mg(l) *                                               &
+                                ( MERGE(p_mg(k,j,i),p_mg(k,j+1,i),BTEST( flags(k,j,i), 3))   &
+                                + MERGE(p_mg(k,j,i),p_mg(k,j-1,i),BTEST( flags(k,j,i), 2)) ) &
+                                + f2_mg(k,l) * p_mg(kp1,j,i)                                 &
+                                + f3_mg(k,l) *                                               &
+                                MERGE(p_mg(k,j,i),p_mg(km1,j,i),BTEST( flags(k,j,i), 0))     &
+                                - f_mg(k,j,i)               )
+
+                            j = jj+2
+                            p_mg(k,j,i) = 1.0 / f1_mg(k,l) * (                               &
+                                ddx2_mg(l) *                                                 &
+                                ( MERGE(p_mg(k,j,i),p_mg(k,j,i+1),BTEST( flags(k,j,i), 5))   &
+                                + MERGE(p_mg(k,j,i),p_mg(k,j,i-1),BTEST( flags(k,j,i), 4)) ) &
+                                + ddy2_mg(l) *                                               &
+                                ( MERGE(p_mg(k,j,i),p_mg(k,j+1,i),BTEST( flags(k,j,i), 3))   &
+                                + MERGE(p_mg(k,j,i),p_mg(k,j-1,i),BTEST( flags(k,j,i), 2)) ) &
+                                + f2_mg(k,l) * p_mg(kp1,j,i)                                 &
+                                + f3_mg(k,l) *                                               &
+                                MERGE(p_mg(k,j,i),p_mg(km1,j,i),BTEST( flags(k,j,i), 0))     &
+                                - f_mg(k,j,i)               )
+
+                         ENDDO
+
+                         i  = ic+1
+                         jj = jc+2-color
+                         !DIR$ IVDEP
+                         DO  k = nzb+1, ind_even_odd
+
+                            km1 = k+ind_even_odd
+                            kp1 = k+ind_even_odd+1
+
+                            j =jj
+                            p_mg(k,j,i) = 1.0 / f1_mg(k,l) * (                               &
+                                ddx2_mg(l) *                                                 &
+                                ( MERGE(p_mg(k,j,i),p_mg(k,j,i+1),BTEST( flags(k,j,i), 5))   &
+                                + MERGE(p_mg(k,j,i),p_mg(k,j,i-1),BTEST( flags(k,j,i), 4)) ) &
+                                + ddy2_mg(l) *                                               &
+                                ( MERGE(p_mg(k,j,i),p_mg(k,j+1,i),BTEST( flags(k,j,i), 3))   &
+                                + MERGE(p_mg(k,j,i),p_mg(k,j-1,i),BTEST( flags(k,j,i), 2)) ) &
+                                + f2_mg(k,l) * p_mg(kp1,j,i)                                 &
+                                + f3_mg(k,l) *                                               &
+                                MERGE(p_mg(k,j,i),p_mg(km1,j,i),BTEST( flags(k,j,i), 0))     &
+                                - f_mg(k,j,i)               )
+
+                            j = jj+2
+                            p_mg(k,j,i) = 1.0 / f1_mg(k,l) * (                               &
+                                ddx2_mg(l) *                                                 &
+                                ( MERGE(p_mg(k,j,i),p_mg(k,j,i+1),BTEST( flags(k,j,i), 5))   &
+                                + MERGE(p_mg(k,j,i),p_mg(k,j,i-1),BTEST( flags(k,j,i), 4)) ) &
+                                + ddy2_mg(l) *                                               &
+                                ( MERGE(p_mg(k,j,i),p_mg(k,j+1,i),BTEST( flags(k,j,i), 3))   &
+                                + MERGE(p_mg(k,j,i),p_mg(k,j-1,i),BTEST( flags(k,j,i), 2)) ) &
+                                + f2_mg(k,l) * p_mg(kp1,j,i)                                 &
+                                + f3_mg(k,l) *                                               &
+                                MERGE(p_mg(k,j,i),p_mg(km1,j,i),BTEST( flags(k,j,i), 0))     &
+                                - f_mg(k,j,i)               )
+
+                         ENDDO
+
+                      ENDDO
+                   ENDDO
+                   !$OMP END PARALLEL
+
+                   CALL cpu_log( log_point_s(38), 'redblack_unroll', 'stop' )
+
+                ENDIF
+
+             ENDIF
+
+!
+!--          Horizontal boundary conditions
+             CALL special_exchange_horiz( p_mg, color )
+
+             IF ( .NOT. bc_lr_cyc )  THEN
+                IF ( inflow_l .OR. outflow_l .OR. nest_bound_l )  THEN
+                   p_mg(:,:,nxl_mg(l)-1) = p_mg(:,:,nxl_mg(l))
+                ENDIF
+                IF ( inflow_r .OR. outflow_r .OR. nest_bound_r )  THEN
+                   p_mg(:,:,nxr_mg(l)+1) = p_mg(:,:,nxr_mg(l))
+                ENDIF
+             ENDIF
+
+             IF ( .NOT. bc_ns_cyc )  THEN
+                IF ( inflow_n .OR. outflow_n .OR. nest_bound_n )  THEN
+                   p_mg(:,nyn_mg(l)+1,:) = p_mg(:,nyn_mg(l),:)
+                ENDIF
+                IF ( inflow_s .OR. outflow_s .OR. nest_bound_s )  THEN
+                   p_mg(:,nys_mg(l)-1,:) = p_mg(:,nys_mg(l),:)
+                ENDIF
+             ENDIF
+
+!
+!--          Bottom and top boundary conditions
+             IF ( ibc_p_b == 1 )  THEN
+                p_mg(nzb,:,: ) = p_mg(ind_even_odd+1,:,:)
+             ELSE
+                p_mg(nzb,:,: ) = 0.0_wp
+             ENDIF
+
+             IF ( ibc_p_t == 1 )  THEN
+                p_mg(nzt_mg(l)+1,:,: ) = p_mg(ind_even_odd,:,:)
+             ELSE
+                p_mg(nzt_mg(l)+1,:,: ) = 0.0_wp
+             ENDIF
+
+          ENDDO
+       ENDDO
+!
+!--    Set pressure within topography and at the topography surfaces
+       IF ( topography /= 'flat'  .AND.  .NOT. masking_method )  THEN
+
+          !$OMP PARALLEL PRIVATE (i,j,k,kp1,wall_left,wall_north,wall_right,   &
+          !$OMP                   wall_south,wall_top,wall_total)
+          !$OMP DO
+          DO  i = nxl_mg(l), nxr_mg(l)
+             DO  j = nys_mg(l), nyn_mg(l)
+                !DIR$ IVDEP
+                DO  k = ind_even_odd+1, nzt_mg(l)
+                   km1 = k-ind_even_odd-1
+                   kp1 = k-ind_even_odd
+!
+!--                First, set pressure inside topography to zero
+                   p_mg(k,j,i) = p_mg(k,j,i) *                                 &
+                                 ( 1.0_wp - IBITS( flags(k,j,i), 6, 1 ) )
+!
+!--                Second, determine if the gridpoint inside topography is
+!--                adjacent to a wall and set its value to a value given by the
+!--                average of those values obtained from Neumann boundary
+!--                condition
+                   wall_left  = IBITS( flags(k,j,i-1), 5, 1 )
+                   wall_right = IBITS( flags(k,j,i+1), 4, 1 )
+                   wall_south = IBITS( flags(k,j-1,i), 3, 1 )
+                   wall_north = IBITS( flags(k,j+1,i), 2, 1 )
+                   wall_top   = IBITS( flags(kp1,j,i), 0, 1 )
+                   wall_total = wall_left + wall_right + wall_south +          &
+                                wall_north + wall_top
+
+                   IF ( wall_total > 0.0_wp )  THEN
+                      p_mg(k,j,i) = 1.0_wp / wall_total *                      &
+                                    ( wall_left  * p_mg(k,j,i-1) +             &
+                                      wall_right * p_mg(k,j,i+1) +             &
+                                      wall_south * p_mg(k,j-1,i) +             &
+                                      wall_north * p_mg(k,j+1,i) +             &
+                                      wall_top   * p_mg(kp1,j,i) )
+                   ENDIF
+                ENDDO
+
+                !DIR$ IVDEP
+                DO  k = nzb+1, ind_even_odd
+                   km1 = k+ind_even_odd
+                   kp1 = k+ind_even_odd+1
+!
+!--                First, set pressure inside topography to zero
+                   p_mg(k,j,i) = p_mg(k,j,i) *                                 &
+                                 ( 1.0_wp - IBITS( flags(k,j,i), 6, 1 ) )
+!
+!--                Second, determine if the gridpoint inside topography is
+!--                adjacent to a wall and set its value to a value given by the
+!--                average of those values obtained from Neumann boundary
+!--                condition
+                   wall_left  = IBITS( flags(k,j,i-1), 5, 1 )
+                   wall_right = IBITS( flags(k,j,i+1), 4, 1 )
+                   wall_south = IBITS( flags(k,j-1,i), 3, 1 )
+                   wall_north = IBITS( flags(k,j+1,i), 2, 1 )
+                   wall_top   = IBITS( flags(kp1,j,i), 0, 1 )
+                   wall_total = wall_left + wall_right + wall_south +          &
+                                wall_north + wall_top
+
+                   IF ( wall_total > 0.0_wp )  THEN
+                      p_mg(k,j,i) = 1.0_wp / wall_total *                      &
+                                    ( wall_left  * p_mg(k,j,i-1) +             &
+                                      wall_right * p_mg(k,j,i+1) +             &
+                                      wall_south * p_mg(k,j-1,i) +             &
+                                      wall_north * p_mg(k,j+1,i) +             &
+                                      wall_top   * p_mg(kp1,j,i) )
+                   ENDIF
+                ENDDO
+             ENDDO
+          ENDDO
+          !$OMP END PARALLEL
+
+!
+!--       One more time horizontal boundary conditions
+          CALL exchange_horiz( p_mg, 1)
+
+       ENDIF
+
+    END SUBROUTINE redblack_fast
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Sort k-Dimension from sequential into blocks of even and odd.
+!> This is required to vectorize the red-black subroutine.
+!> Version for 3D-REAL arrays
+!------------------------------------------------------------------------------!
+    SUBROUTINE sort_k_to_even_odd_blocks( p_mg , glevel )
+
+
+       USE control_parameters,                                                 &
+           ONLY:  grid_level
+
+       USE indices,                                                            &
+           ONLY:  nxl_mg, nxr_mg, nys_mg, nyn_mg, nzb, nzt_mg
+
+       IMPLICIT NONE
+
+       INTEGER(iwp), INTENT(IN) ::  glevel
+
+       REAL(wp), DIMENSION(nzb:nzt_mg(glevel)+1,                               &
+                           nys_mg(glevel)-1:nyn_mg(glevel)+1,                  &
+                           nxl_mg(glevel)-1:nxr_mg(glevel)+1) ::  p_mg  !<
+!
+!--    Local variables
+       INTEGER(iwp) :: i        !<
+       INTEGER(iwp) :: j        !<
+       INTEGER(iwp) :: k        !<
+       INTEGER(iwp) :: l        !<
+       INTEGER(iwp) :: ind      !<
+       REAL(wp), DIMENSION(nzb:nzt_mg(glevel)+1) ::  tmp  !<
+
+
+       CALL cpu_log( log_point_s(52), 'sort_k_to_even_odd', 'start' )
+
+       l = glevel
+       ind_even_odd = even_odd_level(l)
+
+       !$OMP PARALLEL PRIVATE (i,j,k,ind,tmp)
+       !$OMP DO
+       DO  i = nxl_mg(l)-1, nxr_mg(l)+1
+          DO  j = nys_mg(l)-1, nyn_mg(l)+1
+
+!
+!--          Sort the data with even k index
+             ind = nzb-1
+             DO  k = nzb, nzt_mg(l), 2
+                ind = ind + 1
+                tmp(ind) = p_mg(k,j,i)
+             ENDDO
+!
+!--          Sort the data with odd k index
+             DO  k = nzb+1, nzt_mg(l)+1, 2
+                ind = ind + 1
+                tmp(ind) = p_mg(k,j,i)
+             ENDDO
+
+             p_mg(:,j,i) = tmp
+
+          ENDDO
+       ENDDO
+       !$OMP END PARALLEL
+
+       CALL cpu_log( log_point_s(52), 'sort_k_to_even_odd', 'stop' )
+
+    END SUBROUTINE sort_k_to_even_odd_blocks
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Sort k-Dimension from sequential into blocks of even and odd.
+!> This is required to vectorize the red-black subroutine.
+!> Version for 1D-REAL arrays
+!------------------------------------------------------------------------------!
+    SUBROUTINE sort_k_to_even_odd_blocks_1d( f_mg, f_mg_b, glevel )
+
+
+       USE indices,                                                            &
+           ONLY:  nzb, nzt_mg
+
+       IMPLICIT NONE
+
+       INTEGER(iwp), INTENT(IN) ::  glevel
+
+       REAL(wp), DIMENSION(nzb+1:nzt_mg(glevel)) ::  f_mg
+       REAL(wp), DIMENSION(nzb:nzt_mg(glevel)+1) ::  f_mg_b
+
+!
+!--    Local variables
+       INTEGER(iwp) :: ind   !<
+       INTEGER(iwp) :: k     !<
+
+
+       ind = nzb - 1
+!
+!--    Sort the data with even k index
+       DO  k = nzb, nzt_mg(glevel), 2
+          ind = ind + 1
+          IF ( k >= nzb+1  .AND.  k <= nzt_mg(glevel) )  THEN
+             f_mg_b(ind) = f_mg(k)
+          ENDIF
+       ENDDO
+!
+!--    Sort the data with odd k index
+       DO  k = nzb+1, nzt_mg(glevel)+1, 2
+          ind = ind + 1
+          IF( k >= nzb+1  .AND.  k <= nzt_mg(glevel) )  THEN
+             f_mg_b(ind) = f_mg(k)
+          ENDIF
+       ENDDO
+
+    END SUBROUTINE sort_k_to_even_odd_blocks_1d
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Sort k-Dimension from sequential into blocks of even and odd.
+!> This is required to vectorize the red-black subroutine.
+!> Version for 2D-INTEGER arrays
+!------------------------------------------------------------------------------!
+    SUBROUTINE sort_k_to_even_odd_blocks_int( i_mg , glevel )
+
+
+       USE control_parameters,                                                 &
+           ONLY:  grid_level
+
+       USE indices,                                                            &
+           ONLY:  nxl_mg, nxr_mg, nys_mg, nyn_mg, nzb, nzt_mg
+
+       IMPLICIT NONE
+
+       INTEGER(iwp), INTENT(IN) ::  glevel
+
+       INTEGER(iwp), DIMENSION(nzb:nzt_mg(glevel)+1,                           &
+                               nys_mg(glevel)-1:nyn_mg(glevel)+1,              &
+                               nxl_mg(glevel)-1:nxr_mg(glevel)+1) ::  i_mg  !<
+!
+!--    Local variables
+       INTEGER(iwp) :: i        !<
+       INTEGER(iwp) :: j        !<
+       INTEGER(iwp) :: k        !<
+       INTEGER(iwp) :: l        !<
+       INTEGER(iwp) :: ind      !<
+       INTEGER(iwp),DIMENSION(nzb:nzt_mg(glevel)+1) ::  tmp
+
+
+       CALL cpu_log( log_point_s(52), 'sort_k_to_even_odd', 'start' )
+
+       l = glevel
+       ind_even_odd = even_odd_level(l)
+
+       DO  i = nxl_mg(l)-1, nxr_mg(l)+1
+          DO  j = nys_mg(l)-1, nyn_mg(l)+1
+
+!
+!--          Sort the data with even k index
+             ind = nzb-1
+             DO  k = nzb, nzt_mg(l), 2
+                ind = ind + 1
+                tmp(ind) = i_mg(k,j,i)
+             ENDDO
+!
+!++          ATTENTION: Check reason for this error. Remove it or replace WRITE
+!++                     by PALM message
+#if defined ( __parallel )
+             IF ( ind /= ind_even_odd )  THEN
+                WRITE (0,*) 'ERROR ==> illegal ind_even_odd ',ind,ind_even_odd,l
+                CALL MPI_ABORT(MPI_COMM_WORLD,i,j)
+             ENDIF
+#endif
+!
+!--          Sort the data with odd k index
+             DO  k = nzb+1, nzt_mg(l)+1, 2
+                ind = ind + 1
+                tmp(ind) = i_mg(k,j,i)
+             ENDDO
+
+             i_mg(:,j,i) = tmp
+
+          ENDDO
+       ENDDO
+
+       CALL cpu_log( log_point_s(52), 'sort_k_to_even_odd', 'stop' )
+
+    END SUBROUTINE sort_k_to_even_odd_blocks_int
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Sort k-dimension from blocks of even and odd into sequential
+!------------------------------------------------------------------------------!
+    SUBROUTINE sort_k_to_sequential( p_mg )
+
+
+       USE control_parameters,                                                 &
+           ONLY:  grid_level
+
+       USE indices,                                                            &
+           ONLY:  nxl_mg, nxr_mg, nys_mg, nyn_mg, nzb, nzt_mg
+
+       IMPLICIT NONE
+
+       REAL(wp), DIMENSION(nzb:nzt_mg(grid_level)+1,                           &
+                           nys_mg(grid_level)-1:nyn_mg(grid_level)+1,          &
+                           nxl_mg(grid_level)-1:nxr_mg(grid_level)+1) ::  p_mg  !<
+!
+!--    Local variables
+       INTEGER(iwp) :: i        !<
+       INTEGER(iwp) :: j        !<
+       INTEGER(iwp) :: k        !<
+       INTEGER(iwp) :: l        !<
+       INTEGER(iwp) :: ind      !<
+
+       REAL(wp),DIMENSION(nzb:nzt_mg(grid_level)+1) ::  tmp
+
+
+       l = grid_level
+
+       !$OMP PARALLEL PRIVATE (i,j,k,ind,tmp)
+       !$OMP DO
+       DO  i = nxl_mg(l)-1, nxr_mg(l)+1
+          DO  j = nys_mg(l)-1, nyn_mg(l)+1
+
+             ind = nzb - 1
+             tmp = p_mg(:,j,i)
+             DO  k = nzb, nzt_mg(l), 2
+                ind = ind + 1
+                p_mg(k,j,i) = tmp(ind)
+             ENDDO
+
+             DO  k = nzb+1, nzt_mg(l)+1, 2
+                ind = ind + 1
+                p_mg(k,j,i) = tmp(ind)
+             ENDDO
+          ENDDO
+       ENDDO
+       !$OMP END PARALLEL
+
+    END SUBROUTINE sort_k_to_sequential
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Gather subdomain data from all PEs.
+!------------------------------------------------------------------------------!
+    SUBROUTINE mg_gather_fast( f2, f2_sub )
+
+       USE control_parameters,                                                 &
+           ONLY:  grid_level
+
+       USE cpulog,                                                             &
+           ONLY:  cpu_log, log_point_s
+
+       USE indices,                                                            &
+           ONLY:  mg_loc_ind, nxl_mg, nxr_mg, nys_mg, nyn_mg, nzb, nzt_mg
+
+       IMPLICIT NONE
+
+       INTEGER(iwp) ::  i       !<
+       INTEGER(iwp) ::  il      !<
+       INTEGER(iwp) ::  ir      !<
+       INTEGER(iwp) ::  j       !<
+       INTEGER(iwp) ::  jn      !<
+       INTEGER(iwp) ::  js      !<
+       INTEGER(iwp) ::  k       !<
+       INTEGER(iwp) ::  nwords  !<
+
+       REAL(wp), DIMENSION(nzb:nzt_mg(grid_level)+1,                           &
+                       nys_mg(grid_level)-1:nyn_mg(grid_level)+1,              &
+                       nxl_mg(grid_level)-1:nxr_mg(grid_level)+1) ::  f2    !<
+       REAL(wp), DIMENSION(nzb:nzt_mg(grid_level)+1,                           &
+                       nys_mg(grid_level)-1:nyn_mg(grid_level)+1,              &
+                       nxl_mg(grid_level)-1:nxr_mg(grid_level)+1) ::  f2_l  !<
+
+       REAL(wp), DIMENSION(nzb:mg_loc_ind(5,myid)+1,                           &
+                           mg_loc_ind(3,myid)-1:mg_loc_ind(4,myid)+1,          &
+                           mg_loc_ind(1,myid)-1:mg_loc_ind(2,myid)+1) ::  f2_sub  !<
+
+
+#if defined( __parallel )
+       CALL cpu_log( log_point_s(34), 'mg_gather', 'start' )
+
+       f2_l = 0.0_wp
+
+!
+!--    Store the local subdomain array on the total array
+       js = mg_loc_ind(3,myid)
+       IF ( south_border_pe )  js = js - 1
+       jn = mg_loc_ind(4,myid)
+       IF ( north_border_pe )  jn = jn + 1
+       il = mg_loc_ind(1,myid)
+       IF ( left_border_pe )   il = il - 1
+       ir = mg_loc_ind(2,myid)
+       IF ( right_border_pe )  ir = ir + 1
+       DO  i = il, ir
+          DO  j = js, jn
+             DO  k = nzb, nzt_mg(grid_level)+1
+                f2_l(k,j,i) = f2_sub(k,j,i)
+             ENDDO
+          ENDDO
+       ENDDO
+
+!
+!--    Find out the number of array elements of the total array
+       nwords = SIZE( f2 )
+
+!
+!--    Gather subdomain data from all PEs
+       IF ( collective_wait )  CALL MPI_BARRIER( comm2d, ierr )
+       CALL MPI_ALLREDUCE( f2_l(nzb,nys_mg(grid_level)-1,nxl_mg(grid_level)-1), &
+                           f2(nzb,nys_mg(grid_level)-1,nxl_mg(grid_level)-1),   &
+                           nwords, MPI_REAL, MPI_SUM, comm2d, ierr )
+
+       CALL cpu_log( log_point_s(34), 'mg_gather', 'stop' )
+#endif
+    
+    END SUBROUTINE mg_gather_fast
+
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> @todo It might be possible to improve the speed of this routine by using
+!>       non-blocking communication
+!------------------------------------------------------------------------------!
+    SUBROUTINE mg_scatter_fast( p2, p2_sub )
+
+       USE control_parameters,                                                 &
+           ONLY:  grid_level
+
+       USE cpulog,                                                             &
+           ONLY:  cpu_log, log_point_s
+
+       USE indices,                                                            &
+           ONLY:  mg_loc_ind, nxl_mg, nxr_mg, nys_mg, nyn_mg, nzb, nzt_mg
+
+       IMPLICIT NONE
+
+       INTEGER(iwp) ::  nwords  !<
+
+       REAL(wp), DIMENSION(nzb:nzt_mg(grid_level-1)+1,                         &
+                           nys_mg(grid_level-1)-1:nyn_mg(grid_level-1)+1,      &
+                           nxl_mg(grid_level-1)-1:nxr_mg(grid_level-1)+1) ::  p2  !<
+
+       REAL(wp), DIMENSION(nzb:mg_loc_ind(5,myid)+1,                           &
+                           mg_loc_ind(3,myid)-1:mg_loc_ind(4,myid)+1,          &
+                           mg_loc_ind(1,myid)-1:mg_loc_ind(2,myid)+1) ::  p2_sub  !<
+
+!
+!--    Find out the number of array elements of the subdomain array
+       nwords = SIZE( p2_sub )
+
+#if defined( __parallel )
+       CALL cpu_log( log_point_s(35), 'mg_scatter', 'start' )
+
+       p2_sub = p2(:,mg_loc_ind(3,myid)-1:mg_loc_ind(4,myid)+1, &
+                     mg_loc_ind(1,myid)-1:mg_loc_ind(2,myid)+1)
+
+       CALL cpu_log( log_point_s(35), 'mg_scatter', 'stop' )
+#endif
+    
+    END SUBROUTINE mg_scatter_fast
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> This is where the multigrid technique takes place. V- and W- Cycle are
+!> implemented and steered by the parameter "gamma". Parameter "nue" determines
+!> the convergence of the multigrid iterative solution. There are nue times
+!> RB-GS iterations. It should be set to "1" or "2", considering the time effort
+!> one would like to invest. Last choice shows a very good converging factor,
+!> but leads to an increase in computing time.
+!------------------------------------------------------------------------------!
+    RECURSIVE SUBROUTINE next_mg_level_fast( f_mg, p_mg, p3, r )
+
+       USE control_parameters,                                                 &
+           ONLY:  bc_lr_dirrad, bc_lr_raddir, bc_ns_dirrad, bc_ns_raddir,      &
+                  gamma_mg, grid_level, grid_level_count, ibc_p_b, ibc_p_t,    &
+                  inflow_l, inflow_n, inflow_r, inflow_s, maximum_grid_level,  &
+                  mg_switch_to_pe0_level, mg_switch_to_pe0, nest_domain,       &
+                  nest_bound_l, nest_bound_n, nest_bound_r, nest_bound_s,      &
+                  ngsrb, outflow_l, outflow_n, outflow_r, outflow_s
+
+       USE indices,                                                            &
+           ONLY:  mg_loc_ind, nxl, nxl_mg, nxr, nxr_mg, nys, nys_mg, nyn,      &
+                  nyn_mg, nzb, nzt, nzt_mg
+
+       IMPLICIT NONE
+
+       INTEGER(iwp) ::  i            !<
+       INTEGER(iwp) ::  j            !<
+       INTEGER(iwp) ::  k            !<
+       INTEGER(iwp) ::  nxl_mg_save  !<
+       INTEGER(iwp) ::  nxr_mg_save  !<
+       INTEGER(iwp) ::  nyn_mg_save  !<
+       INTEGER(iwp) ::  nys_mg_save  !<
+       INTEGER(iwp) ::  nzt_mg_save  !<
+
+       REAL(wp), DIMENSION(nzb:nzt_mg(grid_level)+1,                           &
+                           nys_mg(grid_level)-1:nyn_mg(grid_level)+1,          &
+                           nxl_mg(grid_level)-1:nxr_mg(grid_level)+1) :: f_mg  !<
+       REAL(wp), DIMENSION(nzb:nzt_mg(grid_level)+1,                           &
+                           nys_mg(grid_level)-1:nyn_mg(grid_level)+1,          &
+                           nxl_mg(grid_level)-1:nxr_mg(grid_level)+1) :: p_mg  !<
+       REAL(wp), DIMENSION(nzb:nzt_mg(grid_level)+1,                           &
+                           nys_mg(grid_level)-1:nyn_mg(grid_level)+1,          &
+                           nxl_mg(grid_level)-1:nxr_mg(grid_level)+1) :: p3    !<
+       REAL(wp), DIMENSION(nzb:nzt_mg(grid_level)+1,                           &
+                           nys_mg(grid_level)-1:nyn_mg(grid_level)+1,          &
+                           nxl_mg(grid_level)-1:nxr_mg(grid_level)+1) :: r     !<
+
+       REAL(wp), DIMENSION(nzb:nzt_mg(grid_level-1)+1,                         &
+                           nys_mg(grid_level-1)-1:nyn_mg(grid_level-1)+1,      &
+                           nxl_mg(grid_level-1)-1:nxr_mg(grid_level-1)+1) ::  f2  !<
+       REAL(wp), DIMENSION(nzb:nzt_mg(grid_level-1)+1,                         &
+                           nys_mg(grid_level-1)-1:nyn_mg(grid_level-1)+1,      &
+                           nxl_mg(grid_level-1)-1:nxr_mg(grid_level-1)+1) ::  p2  !<
+
+       REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::  f2_sub  !<
+       REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::  p2_sub  !<
+
+!
+!--    Restriction to the coarsest grid
+    10 IF ( grid_level == 1 )  THEN
+
+!
+!--       Solution on the coarsest grid. Double the number of Gauss-Seidel
+!--       iterations in order to get a more accurate solution.
+          ngsrb = 2 * ngsrb
+
+          ind_even_odd = even_odd_level(grid_level)
+
+          CALL redblack_fast( f_mg, p_mg )
+
+          ngsrb = ngsrb / 2
+
+
+       ELSEIF ( grid_level /= 1 )  THEN
+
+          grid_level_count(grid_level) = grid_level_count(grid_level) + 1
+
+!
+!--       Solution on the actual grid level
+          ind_even_odd = even_odd_level(grid_level)
+
+          CALL redblack_fast( f_mg, p_mg )
+
+!
+!--       Determination of the actual residual
+          CALL resid_fast( f_mg, p_mg, r )
+
+!--       Restriction of the residual (finer grid values!) to the next coarser
+!--       grid. Therefore, the grid level has to be decremented now. nxl..nzt have
+!--       to be set to the coarse grid values, because these variables are needed
+!--       for the exchange of ghost points in routine exchange_horiz
+          grid_level = grid_level - 1
+
+          nxl = nxl_mg(grid_level)
+          nys = nys_mg(grid_level)
+          nxr = nxr_mg(grid_level)
+          nyn = nyn_mg(grid_level)
+          nzt = nzt_mg(grid_level)
+
+          IF ( grid_level == mg_switch_to_pe0_level )  THEN
+
+!
+!--          From this level on, calculations are done on PE0 only.
+!--          First, carry out restriction on the subdomain.
+!--          Therefore, indices of the level have to be changed to subdomain
+!--          values in between (otherwise, the restrict routine would expect
+!--          the gathered array)
+
+             nxl_mg_save = nxl_mg(grid_level)
+             nxr_mg_save = nxr_mg(grid_level)
+             nys_mg_save = nys_mg(grid_level)
+             nyn_mg_save = nyn_mg(grid_level)
+             nzt_mg_save = nzt_mg(grid_level)
+             nxl_mg(grid_level) = mg_loc_ind(1,myid)
+             nxr_mg(grid_level) = mg_loc_ind(2,myid)
+             nys_mg(grid_level) = mg_loc_ind(3,myid)
+             nyn_mg(grid_level) = mg_loc_ind(4,myid)
+             nzt_mg(grid_level) = mg_loc_ind(5,myid)
+             nxl = mg_loc_ind(1,myid)
+             nxr = mg_loc_ind(2,myid)
+             nys = mg_loc_ind(3,myid)
+             nyn = mg_loc_ind(4,myid)
+             nzt = mg_loc_ind(5,myid)
+
+             ALLOCATE( f2_sub(nzb:nzt_mg(grid_level)+1,                    &
+                              nys_mg(grid_level)-1:nyn_mg(grid_level)+1,   &
+                              nxl_mg(grid_level)-1:nxr_mg(grid_level)+1) )
+
+             CALL restrict_fast( f2_sub, r )
+
+!
+!--          Restore the correct indices of this level
+             nxl_mg(grid_level) = nxl_mg_save
+             nxr_mg(grid_level) = nxr_mg_save
+             nys_mg(grid_level) = nys_mg_save
+             nyn_mg(grid_level) = nyn_mg_save
+             nzt_mg(grid_level) = nzt_mg_save
+             nxl = nxl_mg(grid_level)
+             nxr = nxr_mg(grid_level)
+             nys = nys_mg(grid_level)
+             nyn = nyn_mg(grid_level)
+             nzt = nzt_mg(grid_level)
+!
+!--          Gather all arrays from the subdomains on PE0
+             CALL mg_gather_fast( f2, f2_sub )
+
+!
+!--          Set switch for routine exchange_horiz, that no ghostpoint exchange
+!--          has to be carried out from now on
+             mg_switch_to_pe0 = .TRUE.
+
+!
+!--          In case of non-cyclic lateral boundary conditions, both in- and
+!--          outflow conditions have to be used on all PEs after the switch,
+!--          because then they have the total domain.
+             IF ( bc_lr_dirrad )  THEN
+                inflow_l  = .TRUE.
+                inflow_r  = .FALSE.
+                outflow_l = .FALSE.
+                outflow_r = .TRUE.
+             ELSEIF ( bc_lr_raddir )  THEN
+                inflow_l  = .FALSE.
+                inflow_r  = .TRUE.
+                outflow_l = .TRUE.
+                outflow_r = .FALSE.
+             ELSEIF ( nest_domain )  THEN
+                nest_bound_l = .TRUE.
+                nest_bound_r = .TRUE.
+             ENDIF
+
+             IF ( bc_ns_dirrad )  THEN
+                inflow_n  = .TRUE.
+                inflow_s  = .FALSE.
+                outflow_n = .FALSE.
+                outflow_s = .TRUE.
+             ELSEIF ( bc_ns_raddir )  THEN
+                inflow_n  = .FALSE.
+                inflow_s  = .TRUE.
+                outflow_n = .TRUE.
+                outflow_s = .FALSE.
+             ELSEIF ( nest_domain )  THEN
+                nest_bound_s = .TRUE.
+                nest_bound_n = .TRUE.
+             ENDIF
+
+             DEALLOCATE( f2_sub )
+
+          ELSE
+
+             CALL restrict_fast( f2, r )
+
+             ind_even_odd = even_odd_level(grid_level)  ! must be after restrict
+
+          ENDIF
+
+          p2 = 0.0_wp
+
+!
+!--       Repeat the same procedure till the coarsest grid is reached
+          CALL next_mg_level_fast( f2, p2, p3, r )
+
+       ENDIF
+
+!
+!--    Now follows the prolongation
+       IF ( grid_level >= 2 )  THEN
+
+!
+!--       Prolongation of the new residual. The values are transferred
+!--       from the coarse to the next finer grid.
+          IF ( grid_level == mg_switch_to_pe0_level+1 )  THEN
+
+#if defined( __parallel )
+!
+!--          At this level, the new residual first has to be scattered from
+!--          PE0 to the other PEs
+             ALLOCATE( p2_sub(nzb:mg_loc_ind(5,myid)+1,             &
+                       mg_loc_ind(3,myid)-1:mg_loc_ind(4,myid)+1,   &
+                       mg_loc_ind(1,myid)-1:mg_loc_ind(2,myid)+1) )
+
+             CALL mg_scatter_fast( p2, p2_sub )
+
+!
+!--          Therefore, indices of the previous level have to be changed to
+!--          subdomain values in between (otherwise, the prolong routine would
+!--          expect the gathered array)
+             nxl_mg_save = nxl_mg(grid_level-1)
+             nxr_mg_save = nxr_mg(grid_level-1)
+             nys_mg_save = nys_mg(grid_level-1)
+             nyn_mg_save = nyn_mg(grid_level-1)
+             nzt_mg_save = nzt_mg(grid_level-1)
+             nxl_mg(grid_level-1) = mg_loc_ind(1,myid)
+             nxr_mg(grid_level-1) = mg_loc_ind(2,myid)
+             nys_mg(grid_level-1) = mg_loc_ind(3,myid)
+             nyn_mg(grid_level-1) = mg_loc_ind(4,myid)
+             nzt_mg(grid_level-1) = mg_loc_ind(5,myid)
+
+!
+!--          Set switch for routine exchange_horiz, that ghostpoint exchange
+!--          has to be carried again out from now on
+             mg_switch_to_pe0 = .FALSE.
+
+!
+!--          For non-cyclic lateral boundary conditions, restore the
+!--          in-/outflow conditions
+             inflow_l  = .FALSE.;  inflow_r  = .FALSE.
+             inflow_n  = .FALSE.;  inflow_s  = .FALSE.
+             outflow_l = .FALSE.;  outflow_r = .FALSE.
+             outflow_n = .FALSE.;  outflow_s = .FALSE.
+
+             IF ( pleft == MPI_PROC_NULL )  THEN
+                IF ( bc_lr_dirrad )  THEN
+                   inflow_l  = .TRUE.
+                ELSEIF ( bc_lr_raddir )  THEN
+                   outflow_l = .TRUE.
+                ELSEIF ( nest_domain )  THEN
+                   nest_bound_l = .TRUE.
+                ENDIF
+             ENDIF
+
+             IF ( pright == MPI_PROC_NULL )  THEN
+                IF ( bc_lr_dirrad )  THEN
+                   outflow_r = .TRUE.
+                ELSEIF ( bc_lr_raddir )  THEN
+                   inflow_r  = .TRUE.
+                ELSEIF ( nest_domain )  THEN
+                   nest_bound_r = .TRUE.
+                ENDIF
+             ENDIF
+
+             IF ( psouth == MPI_PROC_NULL )  THEN
+                IF ( bc_ns_dirrad )  THEN
+                   outflow_s = .TRUE.
+                ELSEIF ( bc_ns_raddir )  THEN
+                   inflow_s  = .TRUE.
+                ELSEIF ( nest_domain )  THEN
+                   nest_bound_s = .TRUE.
+                ENDIF
+             ENDIF
+
+             IF ( pnorth == MPI_PROC_NULL )  THEN
+                IF ( bc_ns_dirrad )  THEN
+                   inflow_n  = .TRUE.
+                ELSEIF ( bc_ns_raddir )  THEN
+                   outflow_n = .TRUE.
+                ELSEIF ( nest_domain )  THEN
+                   nest_bound_n = .TRUE.
+                ENDIF
+             ENDIF
+
+             CALL prolong_fast( p2_sub, p3 )
+
+!
+!--          Restore the correct indices of the previous level
+             nxl_mg(grid_level-1) = nxl_mg_save
+             nxr_mg(grid_level-1) = nxr_mg_save
+             nys_mg(grid_level-1) = nys_mg_save
+             nyn_mg(grid_level-1) = nyn_mg_save
+             nzt_mg(grid_level-1) = nzt_mg_save
+
+             DEALLOCATE( p2_sub )
+#endif
+
+          ELSE
+
+             CALL prolong_fast( p2, p3 )
+
+          ENDIF
+
+!
+!--       Computation of the new pressure correction. Therefore,
+!--       values from prior grids are added up automatically stage by stage.
+          DO  i = nxl_mg(grid_level)-1, nxr_mg(grid_level)+1
+             DO  j = nys_mg(grid_level)-1, nyn_mg(grid_level)+1
+                DO  k = nzb, nzt_mg(grid_level)+1
+                   p_mg(k,j,i) = p_mg(k,j,i) + p3(k,j,i)
+                ENDDO
+             ENDDO
+          ENDDO
+
+!
+!--       Relaxation of the new solution
+          CALL redblack_fast( f_mg, p_mg )
+
+       ENDIF
+
+
+!
+!--    The following few lines serve the steering of the multigrid scheme
+       IF ( grid_level == maximum_grid_level )  THEN
+
+          GOTO 20
+
+       ELSEIF ( grid_level /= maximum_grid_level  .AND.  grid_level /= 1  .AND. &
+                grid_level_count(grid_level) /= gamma_mg )  THEN
+
+          GOTO 10
+
+       ENDIF
+
+!
+!--    Reset counter for the next call of poismg_fast
+       grid_level_count(grid_level) = 0
+
+!
+!--    Continue with the next finer level. nxl..nzt have to be
+!--    set to the finer grid values, because these variables are needed for the
+!--    exchange of ghost points in routine exchange_horiz
+       grid_level = grid_level + 1
+       ind_even_odd = even_odd_level(grid_level)
+
+       nxl = nxl_mg(grid_level)
+       nxr = nxr_mg(grid_level)
+       nys = nys_mg(grid_level)
+       nyn = nyn_mg(grid_level)
+       nzt = nzt_mg(grid_level)
+
+    20 CONTINUE
+
+    END SUBROUTINE next_mg_level_fast
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Initial settings for sorting k-dimension from sequential order (alternate
+!> even/odd) into blocks of even and odd or vice versa
+!------------------------------------------------------------------------------!
+    SUBROUTINE init_even_odd_blocks
+
+
+       USE arrays_3d,                                                          &
+           ONLY:  f1_mg, f2_mg, f3_mg
+
+       USE control_parameters,                                                 &
+           ONLY:  grid_level, masking_method, maximum_grid_level, topography
+
+       USE indices,                                                            &
+           ONLY:  nzb, nzt, nzt_mg
+
+       USE indices,                                                            &
+           ONLY:  flags, wall_flags_1, wall_flags_2, wall_flags_3,             &
+                  wall_flags_4, wall_flags_5, wall_flags_6, wall_flags_7,      &
+                  wall_flags_8, wall_flags_9, wall_flags_10, nxl_mg, nxr_mg,   &
+                  nys_mg, nyn_mg, nzb, nzt_mg
+
+       IMPLICIT NONE
+!
+!--    Local variables
+       INTEGER(iwp) ::  i     !<
+       INTEGER(iwp) ::  l     !<
+
+       LOGICAL, SAVE ::  lfirst = .TRUE.
+
+
+       IF ( .NOT. lfirst )  RETURN
+
+       ALLOCATE( even_odd_level(maximum_grid_level) )
+
+       ALLOCATE( f1_mg_b(nzb:nzt+1,maximum_grid_level),                        &
+                 f2_mg_b(nzb:nzt+1,maximum_grid_level),                        &
+                 f3_mg_b(nzb:nzt+1,maximum_grid_level) )
+
+!
+!--    Set border index between the even and odd block
+       DO  i = maximum_grid_level, 1, -1
+          even_odd_level(i) = nzt_mg(i) / 2
+       ENDDO
+
+!
+!--    Sort grid coefficients used in red/black scheme and for calculating the
+!--    residual to block (even/odd) structure
+       DO  l = maximum_grid_level, 1 , -1
+          CALL sort_k_to_even_odd_blocks( f1_mg(nzb+1:nzt_mg(grid_level),l),   &
+                                          f1_mg_b(nzb:nzt_mg(grid_level)+1,l), &
+                                          l )
+          CALL sort_k_to_even_odd_blocks( f2_mg(nzb+1:nzt_mg(grid_level),l),   &
+                                          f2_mg_b(nzb:nzt_mg(grid_level)+1,l), &
+                                          l )
+          CALL sort_k_to_even_odd_blocks( f3_mg(nzb+1:nzt_mg(grid_level),l),   &
+                                          f3_mg_b(nzb:nzt_mg(grid_level)+1,l), &
+                                          l )
+       ENDDO
+
+!
+!--    Sort flags array for all levels to block (even/odd) structure
+       IF ( topography /= 'flat'  .AND.  .NOT. masking_method )  THEN
+
+          DO  l = maximum_grid_level, 1 , -1
+!
+!--          Assign the flag level to be calculated
+             SELECT CASE ( l )
+                CASE ( 1 )
+                   flags => wall_flags_1
+                CASE ( 2 )
+                   flags => wall_flags_2
+                CASE ( 3 )
+                   flags => wall_flags_3
+                CASE ( 4 )
+                   flags => wall_flags_4
+                CASE ( 5 )
+                   flags => wall_flags_5
+                CASE ( 6 )
+                   flags => wall_flags_6
+                CASE ( 7 )
+                   flags => wall_flags_7
+                CASE ( 8 )
+                   flags => wall_flags_8
+                CASE ( 9 )
+                   flags => wall_flags_9
+                CASE ( 10 )
+                   flags => wall_flags_10
+             END SELECT
+
+             CALL sort_k_to_even_odd_blocks( flags, l )
+
+          ENDDO
+
+       ENDIF
+
+       lfirst = .FALSE.
+
+     END SUBROUTINE init_even_odd_blocks
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Special exchange_horiz subroutine for use in redblack. Transfers only
+!> "red" or "black" data points.
+!------------------------------------------------------------------------------!
+     SUBROUTINE special_exchange_horiz ( p_mg, color )
+
+
+       USE control_parameters,                                                 &
+           ONLY:  bc_lr_cyc, bc_ns_cyc, grid_level, ibc_p_b, ibc_p_t,          &
+                  inflow_l, inflow_n, inflow_r, inflow_s, maximum_grid_level,  &
+                  outflow_l, outflow_n, outflow_r, outflow_s,                  &
+                  synchronous_exchange
+
+       USE indices,                                                            &
+           ONLY:  mg_loc_ind, nxl, nxl_mg, nxr, nxr_mg, nys, nys_mg, nyn,      &
+                  nyn_mg, nzb, nzt, nzt_mg
+
+       IMPLICIT NONE
+
+       REAL(wp), DIMENSION(nzb:nzt_mg(grid_level)+1,                           &
+                           nys_mg(grid_level)-1:nyn_mg(grid_level)+1,          &
+                           nxl_mg(grid_level)-1:nxr_mg(grid_level)+1) ::  p_mg  !<
+
+       INTEGER(iwp), intent(IN) ::  color  !<
+!
+!--    Local variables
+       INTEGER(iwp) ::  i,i1,i2  !<
+       INTEGER(iwp) ::  j,j1,j2  !<
+       INTEGER(iwp) ::  k        !<
+       INTEGER(iwp) ::  l        !<
+       INTEGER(iwp) ::  jys      !<
+       INTEGER(iwp) ::  jyn      !<
+       INTEGER(iwp) ::  ixl      !<
+       INTEGER(iwp) ::  ixr      !<
+       logical      ::  sendrecv_in_background_save  !<
+       logical      ::  synchronous_exchange_save    !<
+
+       REAL(wp), DIMENSION(nzb:nzt_mg(grid_level-1)+1,                         &
+                           nys_mg(grid_level-1)-1:nyn_mg(grid_level-1)+1,      &
+                           nxl_mg(grid_level-1)-1:nxr_mg(grid_level-1)+1) ::  temp  !<
+
+#if defined ( __parallel )
+       sendrecv_in_background_save = sendrecv_in_background
+       sendrecv_in_background      = .FALSE.
+       synchronous_exchange_save   = synchronous_exchange
+       synchronous_exchange        = .FALSE.
+
+       l = grid_level
+
+       ind_even_odd = even_odd_level(grid_level)
+
+       jys = nys_mg(grid_level-1)
+       jyn = nyn_mg(grid_level-1)
+       ixl = nxl_mg(grid_level-1)
+       ixr = nxr_mg(grid_level-1)
+
+!
+!--    Restricted transfer only on finer levels with enough data
+       IF ( ngp_xz(grid_level) >= 900 .OR. ngp_yz(grid_level) >= 900 )  THEN
+!
+!--       Handling the even k Values
+!--       Collecting data for the north - south exchange
+!--       Since only every second value has to be transfered, data are stored
+!--       on the next coarser grid level, because the arrays on that level
+!--       have just the required size
+          i1 = nxl_mg(grid_level-1)
+          i2 = nxl_mg(grid_level-1)
+
+          DO  i = nxl_mg(l), nxr_mg(l), 2
+             DO  j = nys_mg(l) + 2 - color, nyn_mg(l), 2
+
+                IF ( j == nys_mg(l) )  THEN
+                   !DIR$ IVDEP
+                   DO  k = ind_even_odd+1, nzt_mg(l)
+                      temp(k-ind_even_odd,jys,i1) = p_mg(k,j,i)
+                   ENDDO
+                   i1 = i1 + 1
+
+                ENDIF
+
+                IF ( j == nyn_mg(l) )  THEN
+                   !DIR$ IVDEP
+                   DO  k = ind_even_odd+1, nzt_mg(l)
+                      temp(k-ind_even_odd,jyn,i2) = p_mg(k,j,i)
+                   ENDDO
+                   i2 = i2 + 1
+
+                ENDIF
+
+             ENDDO
+          ENDDO
+
+          DO  i = nxl_mg(l)+1, nxr_mg(l), 2
+             DO  j = nys_mg(l) + (color-1), nyn_mg(l), 2
+
+                IF ( j == nys_mg(l) )  THEN
+                   !DIR$ IVDEP
+                   DO  k = ind_even_odd+1, nzt_mg(l)
+                      temp(k-ind_even_odd,jys,i1) = p_mg(k,j,i)
+                   ENDDO
+                   i1 = i1 + 1
+
+                ENDIF
+
+                IF ( j == nyn_mg(l) )  THEN
+                   !DIR$ IVDEP
+                   DO  k = ind_even_odd+1, nzt_mg(l)
+                      temp(k-ind_even_odd,jyn,i2) = p_mg(k,j,i)
+                   ENDDO
+                   i2 = i2 + 1
+
+                ENDIF
+
+             ENDDO
+          ENDDO
+
+          grid_level = grid_level-1
+
+          nxl = nxl_mg(grid_level)
+          nys = nys_mg(grid_level)
+          nxr = nxr_mg(grid_level)
+          nyn = nyn_mg(grid_level)
+          nzt = nzt_mg(grid_level)
+
+          send_receive = 'ns'
+          CALL exchange_horiz( temp, 1 )
+
+          grid_level = grid_level+1
+
+          i1 = nxl_mg(grid_level-1)
+          i2 = nxl_mg(grid_level-1)
+
+          DO  i = nxl_mg(l), nxr_mg(l), 2
+             DO  j = nys_mg(l) + 2 - color, nyn_mg(l), 2
+
+                IF ( j == nys_mg(l) )  THEN
+                   !DIR$ IVDEP
+                   DO  k = ind_even_odd+1, nzt_mg(l)
+                      p_mg(k,nyn_mg(l)+1,i) = temp(k-ind_even_odd,jyn+1,i1)
+                   ENDDO
+                   i1 = i1 + 1
+
+                ENDIF
+
+                IF ( j == nyn_mg(l) )  THEN
+                   !DIR$ IVDEP
+                   DO  k = ind_even_odd+1, nzt_mg(l)
+                      p_mg(k,nys_mg(l)-1,i) = temp(k-ind_even_odd,jys-1,i2)
+                   ENDDO
+                   i2 = i2 + 1
+
+                ENDIF
+
+             ENDDO
+          ENDDO
+
+          DO  i = nxl_mg(l)+1, nxr_mg(l), 2
+             DO  j = nys_mg(l) + (color-1), nyn_mg(l), 2
+
+                IF ( j == nys_mg(l) )  THEN
+                   !DIR$ IVDEP
+                   DO  k = ind_even_odd+1, nzt_mg(l)
+                      p_mg(k,nyn_mg(l)+1,i) = temp(k-ind_even_odd,jyn+1,i1)
+                   ENDDO
+                   i1 = i1 + 1
+
+                ENDIF
+
+                IF ( j == nyn_mg(l) )  THEN
+                   !DIR$ IVDEP
+                   DO  k = ind_even_odd+1, nzt_mg(l)
+                      p_mg(k,nys_mg(l)-1,i) = temp(k-ind_even_odd,jys-1,i2)
+                   ENDDO
+                   i2 = i2 + 1
+
+                ENDIF
+
+             ENDDO
+          ENDDO
+
+!
+!--       Collecting data for the left - right exchange
+!--       Since only every second value has to be transfered, data are stored
+!--       on the next coarser grid level, because the arrays on that level
+!--       have just the required size
+          j1 = nys_mg(grid_level-1)
+          j2 = nys_mg(grid_level-1)
+
+          DO j = nys_mg(l) + 2 - color, nyn_mg(l), 2
+             DO  i = nxl_mg(l), nxr_mg(l), 2
+
+                IF ( i == nxl_mg(l) )  THEN
+                   !DIR$ IVDEP
+                   DO  k = ind_even_odd+1, nzt_mg(l)
+                      temp(k-ind_even_odd,j1,ixl) = p_mg(k,j,i)
+                   ENDDO
+                   j1 = j1 + 1
+
+                ENDIF
+
+                IF ( i == nxr_mg(l) )  THEN
+                   !DIR$ IVDEP
+                   DO  k = ind_even_odd+1, nzt_mg(l)
+                      temp(k-ind_even_odd,j2,ixr) = p_mg(k,j,i)
+                   ENDDO
+                   j2 = j2 + 1
+
+                ENDIF
+
+             ENDDO
+          ENDDO
+
+          DO j = nys_mg(l) + (color-1), nyn_mg(l), 2
+             DO  i = nxl_mg(l)+1, nxr_mg(l), 2
+
+                IF ( i == nxl_mg(l) )  THEN
+                   !DIR$ IVDEP
+                   DO  k = ind_even_odd+1, nzt_mg(l)
+                      temp(k-ind_even_odd,j1,ixl) = p_mg(k,j,i)
+                   ENDDO
+                   j1 = j1 + 1
+
+                ENDIF
+
+                IF ( i == nxr_mg(l) )  THEN
+                   !DIR$ IVDEP
+                   DO  k = ind_even_odd+1, nzt_mg(l)
+                      temp(k-ind_even_odd,j2,ixr) = p_mg(k,j,i)
+                   ENDDO
+                   j2 = j2 + 1
+
+                ENDIF
+
+             ENDDO
+          ENDDO
+
+          grid_level = grid_level-1
+          send_receive = 'lr'
+
+          CALL exchange_horiz( temp, 1 )
+
+          grid_level = grid_level+1
+
+          j1 = nys_mg(grid_level-1)
+          j2 = nys_mg(grid_level-1)
+
+          DO j = nys_mg(l) + 2 - color, nyn_mg(l), 2
+             DO  i = nxl_mg(l), nxr_mg(l), 2
+
+                IF ( i == nxl_mg(l) )  THEN
+                   !DIR$ IVDEP
+                   DO  k = ind_even_odd+1, nzt_mg(l)
+                      p_mg(k,j,nxr_mg(l)+1)  = temp(k-ind_even_odd,j1,ixr+1)
+                   ENDDO
+                   j1 = j1 + 1
+
+                ENDIF
+
+                IF ( i == nxr_mg(l) )  THEN
+                   !DIR$ IVDEP
+                   DO  k = ind_even_odd+1, nzt_mg(l)
+                      p_mg(k,j,nxl_mg(l)-1)  = temp(k-ind_even_odd,j2,ixl-1)
+                   ENDDO
+                   j2 = j2 + 1
+
+                ENDIF
+
+             ENDDO
+          ENDDO
+
+          DO j = nys_mg(l) + (color-1), nyn_mg(l), 2
+             DO  i = nxl_mg(l)+1, nxr_mg(l), 2
+
+                IF ( i == nxl_mg(l) )  THEN
+                   !DIR$ IVDEP
+                   DO  k = ind_even_odd+1, nzt_mg(l)
+                      p_mg(k,j,nxr_mg(l)+1)  = temp(k-ind_even_odd,j1,ixr+1)
+                   ENDDO
+                   j1 = j1 + 1
+
+                ENDIF
+
+                IF ( i == nxr_mg(l) )  THEN
+                   !DIR$ IVDEP
+                   DO  k = ind_even_odd+1, nzt_mg(l)
+                      p_mg(k,j,nxl_mg(l)-1)  = temp(k-ind_even_odd,j2,ixl-1)
+                   ENDDO
+                   j2 = j2 + 1
+
+                ENDIF
+
+             ENDDO
+          ENDDO
+
+!
+!--       Now handling the even k values
+!--       Collecting data for the north - south exchange
+!--       Since only every second value has to be transfered, data are stored
+!--       on the next coarser grid level, because the arrays on that level
+!--       have just the required size
+          i1 = nxl_mg(grid_level-1)
+          i2 = nxl_mg(grid_level-1)
+
+          DO  i = nxl_mg(l), nxr_mg(l), 2
+             DO  j = nys_mg(l) + (color-1), nyn_mg(l), 2
+
+                IF ( j == nys_mg(l) )  THEN
+                   !DIR$ IVDEP
+                   DO  k = nzb+1, ind_even_odd
+                      temp(k,jys,i1) = p_mg(k,j,i)
+                   ENDDO
+                   i1 = i1 + 1
+
+                ENDIF
+
+                IF ( j == nyn_mg(l) )  THEN
+                   !DIR$ IVDEP
+                   DO  k = nzb+1, ind_even_odd
+                      temp(k,jyn,i2) = p_mg(k,j,i)
+                   ENDDO
+                   i2 = i2 + 1
+
+                ENDIF
+
+             ENDDO
+          ENDDO
+
+          DO  i = nxl_mg(l)+1, nxr_mg(l), 2
+             DO j = nys_mg(l) + 2 - color, nyn_mg(l), 2
+
+                IF ( j == nys_mg(l) )  THEN
+                   !DIR$ IVDEP
+                   DO  k = nzb+1, ind_even_odd
+                      temp(k,jys,i1) = p_mg(k,j,i)
+                   ENDDO
+                   i1 = i1 + 1
+
+                ENDIF
+
+                IF ( j == nyn_mg(l) )  THEN
+                   !DIR$ IVDEP
+                   DO  k = nzb+1, ind_even_odd
+                      temp(k,jyn,i2) = p_mg(k,j,i)
+                   ENDDO
+                   i2 = i2 + 1
+
+                ENDIF
+
+             ENDDO
+          ENDDO
+
+          grid_level = grid_level-1
+
+          send_receive = 'ns'
+          CALL exchange_horiz( temp, 1 )
+
+          grid_level = grid_level+1
+
+          i1 = nxl_mg(grid_level-1)
+          i2 = nxl_mg(grid_level-1)
+
+          DO  i = nxl_mg(l), nxr_mg(l), 2
+             DO  j = nys_mg(l) + (color-1), nyn_mg(l), 2
+
+                IF ( j == nys_mg(l) )  THEN
+                   !DIR$ IVDEP
+                   DO  k = nzb+1, ind_even_odd
+                      p_mg(k,nyn_mg(l)+1,i) = temp(k,jyn+1,i1)
+                   ENDDO
+                   i1 = i1 + 1
+
+                ENDIF
+
+                IF ( j == nyn_mg(l) )  THEN
+                   !DIR$ IVDEP
+                   DO  k = nzb+1, ind_even_odd
+                      p_mg(k,nys_mg(l)-1,i) = temp(k,jys-1,i2)
+                   ENDDO
+                   i2 = i2 + 1
+
+                ENDIF
+
+             ENDDO
+          ENDDO
+
+          DO  i = nxl_mg(l)+1, nxr_mg(l), 2
+             DO j = nys_mg(l) + 2 - color, nyn_mg(l), 2
+
+                IF ( j == nys_mg(l) )  THEN
+                   !DIR$ IVDEP
+                   DO  k = nzb+1, ind_even_odd
+                      p_mg(k,nyn_mg(l)+1,i) = temp(k,jyn+1,i1)
+                   ENDDO
+                   i1 = i1 + 1
+
+                ENDIF
+
+                IF ( j == nyn_mg(l) )  THEN
+                   !DIR$ IVDEP
+                   DO  k = nzb+1, ind_even_odd
+                      p_mg(k,nys_mg(l)-1,i) = temp(k,jys-1,i2)
+                   ENDDO
+                   i2 = i2 + 1
+
+                ENDIF
+
+             ENDDO
+          ENDDO
+
+          j1 = nys_mg(grid_level-1)
+          j2 = nys_mg(grid_level-1)
+
+          DO  i = nxl_mg(l), nxr_mg(l), 2
+             DO  j = nys_mg(l) + (color-1), nyn_mg(l), 2
+
+                IF ( i == nxl_mg(l) )  THEN
+                   !DIR$ IVDEP
+                   DO  k = nzb+1, ind_even_odd
+                      temp(k,j1,ixl) = p_mg(k,j,i)
+                   ENDDO
+                   j1 = j1 + 1
+
+                ENDIF
+
+                IF ( i == nxr_mg(l) )  THEN
+                   !DIR$ IVDEP
+                   DO  k = nzb+1, ind_even_odd
+                      temp(k,j2,ixr) = p_mg(k,j,i)
+                   ENDDO
+                   j2 = j2 + 1
+
+                ENDIF
+
+             ENDDO
+          ENDDO
+
+          DO  i = nxl_mg(l)+1, nxr_mg(l), 2
+             DO j = nys_mg(l) + 2 - color, nyn_mg(l), 2
+
+                IF ( i == nxl_mg(l) )  THEN
+                   !DIR$ IVDEP
+                   DO  k = nzb+1, ind_even_odd
+                      temp(k,j1,ixl) = p_mg(k,j,i)
+                   ENDDO
+                   j1 = j1 + 1
+
+                ENDIF
+
+                IF ( i == nxr_mg(l) )  THEN
+                   !DIR$ IVDEP
+                   DO  k = nzb+1, ind_even_odd
+                      temp(k,j2,ixr) = p_mg(k,j,i)
+                   ENDDO
+                   j2 = j2 + 1
+
+                ENDIF
+
+             ENDDO
+          ENDDO
+
+          grid_level = grid_level-1
+
+          send_receive = 'lr'
+          CALL exchange_horiz( temp, 1 )
+
+          grid_level = grid_level+1
+
+          nxl = nxl_mg(grid_level)
+          nys = nys_mg(grid_level)
+          nxr = nxr_mg(grid_level)
+          nyn = nyn_mg(grid_level)
+          nzt = nzt_mg(grid_level)
+
+          j1 = nys_mg(grid_level-1)
+          j2 = nys_mg(grid_level-1)
+
+          DO  i = nxl_mg(l), nxr_mg(l), 2
+             DO  j = nys_mg(l) + (color-1), nyn_mg(l), 2
+
+                IF ( i == nxl_mg(l) )  THEN
+                   !DIR$ IVDEP
+                   DO  k = nzb+1, ind_even_odd
+                      p_mg(k,j,nxr_mg(l)+1)  = temp(k,j1,ixr+1)
+                   ENDDO
+                   j1 = j1 + 1
+
+                ENDIF
+
+                IF ( i == nxr_mg(l) )  THEN
+                   !DIR$ IVDEP
+                   DO  k = nzb+1, ind_even_odd
+                      p_mg(k,j,nxl_mg(l)-1)  = temp(k,j2,ixl-1)
+                   ENDDO
+                   j2 = j2 + 1
+
+                ENDIF
+
+             ENDDO
+          ENDDO
+
+          DO  i = nxl_mg(l)+1, nxr_mg(l), 2
+             DO j = nys_mg(l) + 2 - color, nyn_mg(l), 2
+
+                IF ( i == nxl_mg(l) )  THEN
+                   !DIR$ IVDEP
+                   DO  k = nzb+1, ind_even_odd
+                      p_mg(k,j,nxr_mg(l)+1)  = temp(k,j1,ixr+1)
+                   ENDDO
+                   j1 = j1 + 1
+
+                ENDIF
+
+                IF ( i == nxr_mg(l) )  THEN
+                   !DIR$ IVDEP
+                   DO  k = nzb+1, ind_even_odd
+                      p_mg(k,j,nxl_mg(l)-1)  = temp(k,j2,ixl-1)
+                   ENDDO
+                   j2 = j2 + 1
+
+                ENDIF
+
+             ENDDO
+          ENDDO
+
+       ELSE
+
+!
+!--       Standard horizontal ghost boundary exchange for small coarse grid
+!--       levels, where the transfer time is latency bound
+          CALL exchange_horiz( p_mg, 1 )
+
+       ENDIF
+
+!
+!--    Reset values to default PALM setup
+       sendrecv_in_background = sendrecv_in_background_save
+       synchronous_exchange   = synchronous_exchange_save
+       send_receive = 'al'
+#else
+
+!
+!--    Standard horizontal ghost boundary exchange for small coarse grid
+!--    levels, where the transfer time is latency bound
+       CALL exchange_horiz( p_mg, 1 )
+#endif
+
+    END SUBROUTINE special_exchange_horiz
+
+ END MODULE poismg_mod
Index: lm/trunk/SOURCE/production_e.f90
===================================================================
--- /palm/trunk/SOURCE/production_e.f90	(revision 1849)
+++ 	(revision )
@@ -1,1994 +1,0 @@
-!> @file production_e.f90
-!--------------------------------------------------------------------------------!
-! This file is part of PALM.
-!
-! PALM is free software: you can redistribute it and/or modify it under the terms
-! of the GNU General Public License as published by the Free Software Foundation,
-! either version 3 of the License, or (at your option) any later version.
-!
-! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
-! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
-! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along with
-! PALM. If not, see <http://www.gnu.org/licenses/>.
-!
-! Copyright 1997-2016 Leibniz Universitaet Hannover
-!--------------------------------------------------------------------------------!
-!
-! Current revisions:
-! -----------------
-! 
-! 
-! Former revisions:
-! -----------------
-! $Id$
-!
-! 1691 2015-10-26 16:17:44Z maronga
-! Renamed prandtl_layer to constant_flux_layer.
-! 
-! 1682 2015-10-07 23:56:08Z knoop
-! Code annotations made doxygen readable 
-! 
-! 1374 2014-04-25 12:55:07Z raasch
-! nzb_s_outer removed from acc-present-list
-! 
-! 1353 2014-04-08 15:21:23Z heinze
-! REAL constants provided with KIND-attribute
-! 
-! 1342 2014-03-26 17:04:47Z kanani
-! REAL constants defined as wp-kind
-!
-! 1320 2014-03-20 08:40:49Z raasch
-! ONLY-attribute added to USE-statements,
-! kind-parameters added to all INTEGER and REAL declaration statements,
-! kinds are defined in new module kinds,
-! old module precision_kind is removed,
-! revision history before 2012 removed,
-! comment fields (!:) to be used for variable explanations added to
-! all variable declaration statements
-!
-! 1257 2013-11-08 15:18:40Z raasch
-! openacc loop and loop vector clauses removed, declare create moved after
-! the FORTRAN declaration statement
-!
-! 1179 2013-06-14 05:57:58Z raasch
-! use_reference renamed use_single_reference_value
-!
-! 1128 2013-04-12 06:19:32Z raasch
-! loop index bounds in accelerator version replaced by i_left, i_right, j_south,
-! j_north
-!
-! 1036 2012-10-22 13:43:42Z raasch
-! code put under GPL (PALM 3.9)
-!
-! 1015 2012-09-27 09:23:24Z raasch
-! accelerator version (*_acc) added
-!
-! 1007 2012-09-19 14:30:36Z franke
-! Bugfix: calculation of buoyancy production has to consider the liquid water
-! mixing ratio in case of cloud droplets
-!
-! 940 2012-07-09 14:31:00Z raasch
-! TKE production by buoyancy can be switched off in case of runs with pure
-! neutral stratification
-!
-! Revision 1.1  1997/09/19 07:45:35  raasch
-! Initial revision
-!
-!
-! Description:
-! ------------
-!> Production terms (shear + buoyancy) of the TKE.
-!> @warning The case with constant_flux_layer = F and use_surface_fluxes = T is
-!>          not considered well!
-!------------------------------------------------------------------------------!
- MODULE production_e_mod
- 
-
-    USE wall_fluxes_mod,                                                       &
-        ONLY:  wall_fluxes_e, wall_fluxes_e_acc
-
-    USE kinds
-
-    PRIVATE
-    PUBLIC production_e, production_e_acc, production_e_init
-
-    LOGICAL, SAVE ::  first_call = .TRUE.  !<
-
-    REAL(wp), DIMENSION(:,:), ALLOCATABLE, SAVE ::  u_0  !<
-    REAL(wp), DIMENSION(:,:), ALLOCATABLE, SAVE ::  v_0  !<
-
-    INTERFACE production_e
-       MODULE PROCEDURE production_e
-       MODULE PROCEDURE production_e_ij
-    END INTERFACE production_e
-    
-    INTERFACE production_e_acc
-       MODULE PROCEDURE production_e_acc
-    END INTERFACE production_e_acc
-
-    INTERFACE production_e_init
-       MODULE PROCEDURE production_e_init
-    END INTERFACE production_e_init
- 
- CONTAINS
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Call for all grid points
-!------------------------------------------------------------------------------!
-    SUBROUTINE production_e
-
-       USE arrays_3d,                                                          &
-           ONLY:  ddzw, dd2zu, kh, km, pt, q, ql, qsws, qswst, rho, shf,       &
-                  tend, tswst, u, v, vpt, w
-
-       USE cloud_parameters,                                                   &
-           ONLY:  l_d_cp, l_d_r, pt_d_t, t_d_pt
-
-       USE control_parameters,                                                 &
-           ONLY:  cloud_droplets, cloud_physics, constant_flux_layer, g,       &
-                  humidity, kappa, neutral, ocean, pt_reference,               &
-                  rho_reference, use_single_reference_value,                   &
-                  use_surface_fluxes, use_top_fluxes
-
-       USE grid_variables,                                                     &
-           ONLY:  ddx, dx, ddy, dy, wall_e_x, wall_e_y
-
-       USE indices,                                                            &
-           ONLY:  nxl, nxr, nys, nyn, nzb, nzb_diff_s_inner,                   &
-                   nzb_diff_s_outer, nzb_s_inner, nzt, nzt_diff
-
-       IMPLICIT NONE
-
-       INTEGER(iwp) ::  i           !<
-       INTEGER(iwp) ::  j           !<
-       INTEGER(iwp) ::  k           !<
-
-       REAL(wp)     ::  def         !<
-       REAL(wp)     ::  dudx        !<
-       REAL(wp)     ::  dudy        !<
-       REAL(wp)     ::  dudz        !<
-       REAL(wp)     ::  dvdx        !<
-       REAL(wp)     ::  dvdy        !<
-       REAL(wp)     ::  dvdz        !<
-       REAL(wp)     ::  dwdx        !<
-       REAL(wp)     ::  dwdy        !<
-       REAL(wp)     ::  dwdz        !<
-       REAL(wp)     ::  k1          !<
-       REAL(wp)     ::  k2          !<
-       REAL(wp)     ::  km_neutral  !<
-       REAL(wp)     ::  theta       !<
-       REAL(wp)     ::  temp        !<
-
-!       REAL(wp), DIMENSION(nzb:nzt+1,nys:nyn,nxl:nxr) ::  usvs, vsus, wsus, wsvs
-       REAL(wp), DIMENSION(nzb:nzt+1) ::  usvs  !<
-       REAL(wp), DIMENSION(nzb:nzt+1) ::  vsus  !<
-       REAL(wp), DIMENSION(nzb:nzt+1) ::  wsus  !<
-       REAL(wp), DIMENSION(nzb:nzt+1) ::  wsvs  !<
-
-!
-!--    First calculate horizontal momentum flux u'v', w'v', v'u', w'u' at
-!--    vertical walls, if neccessary
-!--    So far, results are slightly different from the ij-Version.
-!--    Therefore, ij-Version is called further below within the ij-loops.
-!       IF ( topography /= 'flat' )  THEN
-!          CALL wall_fluxes_e( usvs, 1.0_wp, 0.0_wp, 0.0_wp, 0.0_wp, wall_e_y )
-!          CALL wall_fluxes_e( wsvs, 0.0_wp, 0.0_wp, 1.0_wp, 0.0_wp, wall_e_y )
-!          CALL wall_fluxes_e( vsus, 0.0_wp, 1.0_wp, 0.0_wp, 0.0_wp, wall_e_x )
-!          CALL wall_fluxes_e( wsus, 0.0_wp, 0.0_wp, 0.0_wp, 1.0_wp, wall_e_x )
-!       ENDIF
-
-
-       DO  i = nxl, nxr
-
-!
-!--       Calculate TKE production by shear
-          DO  j = nys, nyn
-             DO  k = nzb_diff_s_outer(j,i), nzt
-
-                dudx  =           ( u(k,j,i+1) - u(k,j,i)     ) * ddx
-                dudy  = 0.25_wp * ( u(k,j+1,i) + u(k,j+1,i+1) - &
-                                    u(k,j-1,i) - u(k,j-1,i+1) ) * ddy
-                dudz  = 0.5_wp  * ( u(k+1,j,i) + u(k+1,j,i+1) - &
-                                    u(k-1,j,i) - u(k-1,j,i+1) ) * dd2zu(k)
-
-                dvdx  = 0.25_wp * ( v(k,j,i+1) + v(k,j+1,i+1) - &
-                                    v(k,j,i-1) - v(k,j+1,i-1) ) * ddx
-                dvdy  =           ( v(k,j+1,i) - v(k,j,i)     ) * ddy
-                dvdz  = 0.5_wp  * ( v(k+1,j,i) + v(k+1,j+1,i) - &
-                                    v(k-1,j,i) - v(k-1,j+1,i) ) * dd2zu(k)
-
-                dwdx  = 0.25_wp * ( w(k,j,i+1) + w(k-1,j,i+1) - &
-                                    w(k,j,i-1) - w(k-1,j,i-1) ) * ddx
-                dwdy  = 0.25_wp * ( w(k,j+1,i) + w(k-1,j+1,i) - &
-                                    w(k,j-1,i) - w(k-1,j-1,i) ) * ddy
-                dwdz  =           ( w(k,j,i)   - w(k-1,j,i)   ) * ddzw(k)
-
-                def = 2.0_wp * ( dudx**2 + dvdy**2 + dwdz**2 ) +           &
-                      dudy**2 + dvdx**2 + dwdx**2 + dwdy**2 + dudz**2 + &
-                      dvdz**2 + 2.0_wp * ( dvdx*dudy + dwdx*dudz + dwdy*dvdz )
-
-                IF ( def < 0.0_wp )  def = 0.0_wp
-
-                tend(k,j,i) = tend(k,j,i) + km(k,j,i) * def
-
-             ENDDO
-          ENDDO
-
-          IF ( constant_flux_layer )  THEN
-
-!
-!--          Position beneath wall
-!--          (2) - Will allways be executed.
-!--          'bottom and wall: use u_0,v_0 and wall functions'
-             DO  j = nys, nyn
-
-                IF ( ( wall_e_x(j,i) /= 0.0_wp ) .OR. ( wall_e_y(j,i) /= 0.0_wp ) ) &
-                THEN
-
-                   k = nzb_diff_s_inner(j,i) - 1
-                   dudx = ( u(k,j,i+1) - u(k,j,i) ) * ddx
-                   dudz = 0.5_wp * ( u(k+1,j,i) + u(k+1,j,i+1) - &
-                                     u_0(j,i)   - u_0(j,i+1)   ) * dd2zu(k)
-                   dvdy = ( v(k,j+1,i) - v(k,j,i) ) * ddy
-                   dvdz = 0.5_wp * ( v(k+1,j,i) + v(k+1,j+1,i) - &
-                                     v_0(j,i)   - v_0(j+1,i)   ) * dd2zu(k)
-                   dwdz = ( w(k,j,i) - w(k-1,j,i) ) * ddzw(k)
-
-                   IF ( wall_e_y(j,i) /= 0.0_wp )  THEN
-!
-!--                   Inconsistency removed: as the thermal stratification is 
-!--                   not taken into account for the evaluation of the wall 
-!--                   fluxes at vertical walls, the eddy viscosity km must not 
-!--                   be used for the evaluation of the velocity gradients dudy 
-!--                   and dwdy
-!--                   Note: The validity of the new method has not yet been 
-!--                         shown, as so far no suitable data for a validation 
-!--                         has been available
-                      CALL wall_fluxes_e( i, j, k, nzb_diff_s_outer(j,i)-2, &
-                                          usvs, 1.0_wp, 0.0_wp, 0.0_wp, 0.0_wp )
-                      CALL wall_fluxes_e( i, j, k, nzb_diff_s_outer(j,i)-2, &
-                                          wsvs, 0.0_wp, 0.0_wp, 1.0_wp, 0.0_wp )
-                      km_neutral = kappa * ( usvs(k)**2 + wsvs(k)**2 )**0.25_wp * &
-                                   0.5_wp * dy 
-                      IF ( km_neutral > 0.0_wp )  THEN
-                         dudy = - wall_e_y(j,i) * usvs(k) / km_neutral
-                         dwdy = - wall_e_y(j,i) * wsvs(k) / km_neutral
-                      ELSE
-                         dudy = 0.0_wp
-                         dwdy = 0.0_wp
-                      ENDIF
-                   ELSE
-                      dudy = 0.25_wp * ( u(k,j+1,i) + u(k,j+1,i+1) - &
-                                         u(k,j-1,i) - u(k,j-1,i+1) ) * ddy
-                      dwdy = 0.25_wp * ( w(k,j+1,i) + w(k-1,j+1,i) - &
-                                         w(k,j-1,i) - w(k-1,j-1,i) ) * ddy
-                   ENDIF
-
-                   IF ( wall_e_x(j,i) /= 0.0_wp )  THEN
-!
-!--                   Inconsistency removed: as the thermal stratification is 
-!--                   not taken into account for the evaluation of the wall 
-!--                   fluxes at vertical walls, the eddy viscosity km must not 
-!--                   be used for the evaluation of the velocity gradients dvdx 
-!--                   and dwdx
-!--                   Note: The validity of the new method has not yet been 
-!--                         shown, as so far no suitable data for a validation 
-!--                         has been available
-                      CALL wall_fluxes_e( i, j, k, nzb_diff_s_outer(j,i)-2, &
-                                          vsus, 0.0_wp, 1.0_wp, 0.0_wp, 0.0_wp )
-                      CALL wall_fluxes_e( i, j, k, nzb_diff_s_outer(j,i)-2, &
-                                          wsus, 0.0_wp, 0.0_wp, 0.0_wp, 1.0_wp )
-                      km_neutral = kappa * ( vsus(k)**2 + wsus(k)**2 )**0.25_wp * &
-                                   0.5_wp * dx
-                      IF ( km_neutral > 0.0_wp )  THEN
-                         dvdx = - wall_e_x(j,i) * vsus(k) / km_neutral
-                         dwdx = - wall_e_x(j,i) * wsus(k) / km_neutral
-                      ELSE
-                         dvdx = 0.0_wp
-                         dwdx = 0.0_wp
-                      ENDIF
-                   ELSE
-                      dvdx = 0.25_wp * ( v(k,j,i+1) + v(k,j+1,i+1) - &
-                                         v(k,j,i-1) - v(k,j+1,i-1) ) * ddx
-                      dwdx = 0.25_wp * ( w(k,j,i+1) + w(k-1,j,i+1) - &
-                                         w(k,j,i-1) - w(k-1,j,i-1) ) * ddx
-                   ENDIF
-
-                   def = 2.0_wp * ( dudx**2 + dvdy**2 + dwdz**2 ) +           &
-                         dudy**2 + dvdx**2 + dwdx**2 + dwdy**2 + dudz**2 + &
-                         dvdz**2 + 2.0_wp * ( dvdx*dudy + dwdx*dudz + dwdy*dvdz )
-
-                   IF ( def < 0.0_wp )  def = 0.0_wp
-
-                   tend(k,j,i) = tend(k,j,i) + km(k,j,i) * def
-
-
-!
-!--                (3) - will be executed only, if there is at least one level
-!--                between (2) and (4), i.e. the topography must have a
-!--                minimum height of 2 dz. Wall fluxes for this case have
-!--                already been calculated for (2).
-!--                'wall only: use wall functions'
-
-                   DO  k = nzb_diff_s_inner(j,i), nzb_diff_s_outer(j,i)-2
-
-                      dudx = ( u(k,j,i+1) - u(k,j,i) ) * ddx
-                      dudz = 0.5_wp * ( u(k+1,j,i) + u(k+1,j,i+1) - &
-                                        u(k-1,j,i) - u(k-1,j,i+1) ) * dd2zu(k)
-                      dvdy =          ( v(k,j+1,i) - v(k,j,i)     ) * ddy
-                      dvdz = 0.5_wp * ( v(k+1,j,i) + v(k+1,j+1,i) - &
-                                        v(k-1,j,i) - v(k-1,j+1,i) ) * dd2zu(k)
-                      dwdz = ( w(k,j,i) - w(k-1,j,i) ) * ddzw(k)
-
-                      IF ( wall_e_y(j,i) /= 0.0_wp )  THEN
-!
-!--                      Inconsistency removed: as the thermal stratification 
-!--                      is not taken into account for the evaluation of the 
-!--                      wall fluxes at vertical walls, the eddy viscosity km 
-!--                      must not be used for the evaluation of the velocity 
-!--                      gradients dudy and dwdy
-!--                      Note: The validity of the new method has not yet 
-!--                            been shown, as so far no suitable data for a 
-!--                            validation has been available
-                         km_neutral = kappa * ( usvs(k)**2 + & 
-                                                wsvs(k)**2 )**0.25_wp * 0.5_wp * dy
-                         IF ( km_neutral > 0.0_wp )  THEN
-                            dudy = - wall_e_y(j,i) * usvs(k) / km_neutral
-                            dwdy = - wall_e_y(j,i) * wsvs(k) / km_neutral
-                         ELSE
-                            dudy = 0.0_wp
-                            dwdy = 0.0_wp
-                         ENDIF
-                      ELSE
-                         dudy = 0.25_wp * ( u(k,j+1,i) + u(k,j+1,i+1) - &
-                                            u(k,j-1,i) - u(k,j-1,i+1) ) * ddy
-                         dwdy = 0.25_wp * ( w(k,j+1,i) + w(k-1,j+1,i) - &
-                                            w(k,j-1,i) - w(k-1,j-1,i) ) * ddy
-                      ENDIF
-
-                      IF ( wall_e_x(j,i) /= 0.0_wp )  THEN
-!
-!--                      Inconsistency removed: as the thermal stratification 
-!--                      is not taken into account for the evaluation of the 
-!--                      wall fluxes at vertical walls, the eddy viscosity km 
-!--                      must not be used for the evaluation of the velocity 
-!--                      gradients dvdx and dwdx
-!--                      Note: The validity of the new method has not yet 
-!--                            been shown, as so far no suitable data for a 
-!--                            validation has been available
-                         km_neutral = kappa * ( vsus(k)**2 + & 
-                                                wsus(k)**2 )**0.25_wp * 0.5_wp * dx
-                         IF ( km_neutral > 0.0_wp )  THEN
-                            dvdx = - wall_e_x(j,i) * vsus(k) / km_neutral
-                            dwdx = - wall_e_x(j,i) * wsus(k) / km_neutral
-                         ELSE
-                            dvdx = 0.0_wp
-                            dwdx = 0.0_wp
-                         ENDIF
-                      ELSE
-                         dvdx = 0.25_wp * ( v(k,j,i+1) + v(k,j+1,i+1) - &
-                                            v(k,j,i-1) - v(k,j+1,i-1) ) * ddx
-                         dwdx = 0.25_wp * ( w(k,j,i+1) + w(k-1,j,i+1) - &
-                                            w(k,j,i-1) - w(k-1,j,i-1) ) * ddx
-                      ENDIF
-
-                      def = 2.0_wp * ( dudx**2 + dvdy**2 + dwdz**2 ) +           &
-                           dudy**2 + dvdx**2 + dwdx**2 + dwdy**2 + dudz**2 +  &
-                           dvdz**2 + 2.0_wp * ( dvdx*dudy + dwdx*dudz + dwdy*dvdz )
-
-                      IF ( def < 0.0_wp )  def = 0.0_wp
-
-                      tend(k,j,i) = tend(k,j,i) + km(k,j,i) * def
-
-                   ENDDO
-
-                ENDIF
-
-             ENDDO
-
-!
-!--          (4) - will allways be executed.
-!--          'special case: free atmosphere' (as for case (0))
-             DO  j = nys, nyn
-
-                IF ( ( wall_e_x(j,i) /= 0.0_wp ) .OR. ( wall_e_y(j,i) /= 0.0_wp ) ) &
-                THEN
-
-                   k = nzb_diff_s_outer(j,i)-1
-
-                   dudx  =           ( u(k,j,i+1) - u(k,j,i)     ) * ddx
-                   dudy  = 0.25_wp * ( u(k,j+1,i) + u(k,j+1,i+1) - &
-                                       u(k,j-1,i) - u(k,j-1,i+1) ) * ddy
-                   dudz  = 0.5_wp  * ( u(k+1,j,i) + u(k+1,j,i+1) - &
-                                       u(k-1,j,i) - u(k-1,j,i+1) ) * dd2zu(k)
-
-                   dvdx  = 0.25_wp * ( v(k,j,i+1) + v(k,j+1,i+1) - &
-                                       v(k,j,i-1) - v(k,j+1,i-1) ) * ddx
-                   dvdy  =           ( v(k,j+1,i) - v(k,j,i)     ) * ddy
-                   dvdz  = 0.5_wp  * ( v(k+1,j,i) + v(k+1,j+1,i) - &
-                                       v(k-1,j,i) - v(k-1,j+1,i) ) * dd2zu(k)
-
-                   dwdx  = 0.25_wp * ( w(k,j,i+1) + w(k-1,j,i+1) - &
-                                       w(k,j,i-1) - w(k-1,j,i-1) ) * ddx
-                   dwdy  = 0.25_wp * ( w(k,j+1,i) + w(k-1,j+1,i) - &
-                                       w(k,j-1,i) - w(k-1,j-1,i) ) * ddy
-                   dwdz  =           ( w(k,j,i)   - w(k-1,j,i)   ) * ddzw(k)
-
-                   def = 2.0_wp * ( dudx**2 + dvdy**2 + dwdz**2 ) +           &
-                         dudy**2 + dvdx**2 + dwdx**2 + dwdy**2 + dudz**2 + &
-                         dvdz**2 + 2.0_wp * ( dvdx*dudy + dwdx*dudz + dwdy*dvdz )
-
-                   IF ( def < 0.0_wp )  def = 0.0_wp
-
-                   tend(k,j,i) = tend(k,j,i) + km(k,j,i) * def
-
-                ENDIF
-
-             ENDDO
-
-!
-!--          Position without adjacent wall
-!--          (1) - will allways be executed. 
-!--          'bottom only: use u_0,v_0'
-             DO  j = nys, nyn
-
-                IF ( ( wall_e_x(j,i) == 0.0_wp ) .AND. ( wall_e_y(j,i) == 0.0_wp ) ) &
-                THEN
-
-                   k = nzb_diff_s_inner(j,i)-1
-
-                   dudx  =           ( u(k,j,i+1) - u(k,j,i)     ) * ddx
-                   dudy  = 0.25_wp * ( u(k,j+1,i) + u(k,j+1,i+1) - &
-                                       u(k,j-1,i) - u(k,j-1,i+1) ) * ddy
-                   dudz  = 0.5_wp  * ( u(k+1,j,i) + u(k+1,j,i+1) - &
-                                       u_0(j,i)   - u_0(j,i+1)   ) * dd2zu(k)
-
-                   dvdx  = 0.25_wp * ( v(k,j,i+1) + v(k,j+1,i+1) - &
-                                       v(k,j,i-1) - v(k,j+1,i-1) ) * ddx
-                   dvdy  =           ( v(k,j+1,i) - v(k,j,i)     ) * ddy
-                   dvdz  = 0.5_wp  * ( v(k+1,j,i) + v(k+1,j+1,i) - &
-                                       v_0(j,i)   - v_0(j+1,i)   ) * dd2zu(k)
-
-                   dwdx  = 0.25_wp * ( w(k,j,i+1) + w(k-1,j,i+1) - &
-                                       w(k,j,i-1) - w(k-1,j,i-1) ) * ddx
-                   dwdy  = 0.25_wp * ( w(k,j+1,i) + w(k-1,j+1,i) - &
-                                       w(k,j-1,i) - w(k-1,j-1,i) ) * ddy
-                   dwdz  =           ( w(k,j,i)   - w(k-1,j,i)   ) * ddzw(k)
-
-                   def = 2.0_wp * ( dudx**2 + dvdy**2 + dwdz**2 ) +           &
-                         dudy**2 + dvdx**2 + dwdx**2 + dwdy**2 + dudz**2 + &
-                         dvdz**2 + 2.0_wp * ( dvdx*dudy + dwdx*dudz + dwdy*dvdz )
-
-                   IF ( def < 0.0_wp )  def = 0.0_wp
-
-                   tend(k,j,i) = tend(k,j,i) + km(k,j,i) * def
-
-                ENDIF
-
-             ENDDO
-
-          ELSEIF ( use_surface_fluxes )  THEN
-
-             DO  j = nys, nyn
-
-                k = nzb_diff_s_outer(j,i)-1
-
-                dudx  =           ( u(k,j,i+1) - u(k,j,i)     ) * ddx
-                dudy  = 0.25_wp * ( u(k,j+1,i) + u(k,j+1,i+1) - &
-                                    u(k,j-1,i) - u(k,j-1,i+1) ) * ddy
-                dudz  = 0.5_wp  * ( u(k+1,j,i) + u(k+1,j,i+1) - &
-                                   u(k-1,j,i) - u(k-1,j,i+1) ) * dd2zu(k)
-
-                dvdx  = 0.25_wp * ( v(k,j,i+1) + v(k,j+1,i+1) - &
-                                    v(k,j,i-1) - v(k,j+1,i-1) ) * ddx
-                dvdy  =           ( v(k,j+1,i) - v(k,j,i)     ) * ddy
-                dvdz  = 0.5_wp  * ( v(k+1,j,i) + v(k+1,j+1,i) - &
-                                    v(k-1,j,i) - v(k-1,j+1,i) ) * dd2zu(k)
-
-                dwdx  = 0.25_wp * ( w(k,j,i+1) + w(k-1,j,i+1) - &
-                                    w(k,j,i-1) - w(k-1,j,i-1) ) * ddx
-                dwdy  = 0.25_wp * ( w(k,j+1,i) + w(k-1,j+1,i) - &
-                                    w(k,j-1,i) - w(k-1,j-1,i) ) * ddy
-                dwdz  =           ( w(k,j,i)   - w(k-1,j,i)   ) * ddzw(k)
-
-                def = 2.0_wp * ( dudx**2 + dvdy**2 + dwdz**2 ) +           &
-                      dudy**2 + dvdx**2 + dwdx**2 + dwdy**2 + dudz**2 + &
-                      dvdz**2 + 2.0_wp * ( dvdx*dudy + dwdx*dudz + dwdy*dvdz )
-
-                IF ( def < 0.0_wp )  def = 0.0_wp
-
-                tend(k,j,i) = tend(k,j,i) + km(k,j,i) * def
-
-             ENDDO
-
-          ENDIF
-
-!
-!--       If required, calculate TKE production by buoyancy
-          IF ( .NOT. neutral )  THEN
-
-             IF ( .NOT. humidity )  THEN
-
-                IF ( use_single_reference_value )  THEN
-
-                   IF ( ocean )  THEN
-!
-!--                   So far in the ocean no special treatment of density flux
-!--                   in the bottom and top surface layer
-                      DO  j = nys, nyn
-                         DO  k = nzb_s_inner(j,i)+1, nzt
-                            tend(k,j,i) = tend(k,j,i) +                     &
-                                          kh(k,j,i) * g / rho_reference *   &
-                                          ( rho(k+1,j,i) - rho(k-1,j,i) ) * &
-                                          dd2zu(k)
-                         ENDDO
-                      ENDDO
-
-                   ELSE
-
-                      DO  j = nys, nyn
-                         DO  k = nzb_diff_s_inner(j,i), nzt_diff
-                            tend(k,j,i) = tend(k,j,i) -                   &
-                                          kh(k,j,i) * g / pt_reference *  &
-                                          ( pt(k+1,j,i) - pt(k-1,j,i) ) * &
-                                          dd2zu(k)
-                         ENDDO
-
-                         IF ( use_surface_fluxes )  THEN
-                            k = nzb_diff_s_inner(j,i)-1
-                            tend(k,j,i) = tend(k,j,i) + g / pt_reference * &
-                                                        shf(j,i)
-                         ENDIF
-
-                         IF ( use_top_fluxes )  THEN
-                            k = nzt
-                            tend(k,j,i) = tend(k,j,i) + g / pt_reference * &
-                                                        tswst(j,i)
-                         ENDIF
-                      ENDDO
-
-                   ENDIF
-
-                ELSE
-
-                   IF ( ocean )  THEN
-!
-!--                   So far in the ocean no special treatment of density flux
-!--                   in the bottom and top surface layer
-                      DO  j = nys, nyn
-                         DO  k = nzb_s_inner(j,i)+1, nzt
-                            tend(k,j,i) = tend(k,j,i) +                     &
-                                          kh(k,j,i) * g / rho(k,j,i) *      &
-                                          ( rho(k+1,j,i) - rho(k-1,j,i) ) * &
-                                          dd2zu(k)
-                         ENDDO
-                      ENDDO
-
-                   ELSE
-
-                      DO  j = nys, nyn
-                         DO  k = nzb_diff_s_inner(j,i), nzt_diff
-                            tend(k,j,i) = tend(k,j,i) -                   &
-                                          kh(k,j,i) * g / pt(k,j,i) *     &
-                                          ( pt(k+1,j,i) - pt(k-1,j,i) ) * &
-                                          dd2zu(k)
-                         ENDDO
-
-                         IF ( use_surface_fluxes )  THEN
-                            k = nzb_diff_s_inner(j,i)-1
-                            tend(k,j,i) = tend(k,j,i) + g / pt(k,j,i) * &
-                                                        shf(j,i)
-                         ENDIF
-
-                         IF ( use_top_fluxes )  THEN
-                            k = nzt
-                            tend(k,j,i) = tend(k,j,i) + g / pt(k,j,i) * &
-                                                        tswst(j,i)
-                         ENDIF
-                      ENDDO
-
-                   ENDIF
-
-                ENDIF
-
-             ELSE
-
-                DO  j = nys, nyn
-
-                   DO  k = nzb_diff_s_inner(j,i), nzt_diff
-
-                      IF ( .NOT. cloud_physics .AND. .NOT. cloud_droplets ) THEN
-                         k1 = 1.0_wp + 0.61_wp * q(k,j,i)
-                         k2 = 0.61_wp * pt(k,j,i)
-                         tend(k,j,i) = tend(k,j,i) - kh(k,j,i) *               &
-                                         g / vpt(k,j,i) *                      &
-                                         ( k1 * ( pt(k+1,j,i)-pt(k-1,j,i) ) +  &
-                                           k2 * ( q(k+1,j,i) - q(k-1,j,i) )    &
-                                         ) * dd2zu(k)
-                      ELSE IF ( cloud_physics )  THEN
-                         IF ( ql(k,j,i) == 0.0_wp )  THEN
-                            k1 = 1.0_wp + 0.61_wp * q(k,j,i)
-                            k2 = 0.61_wp * pt(k,j,i)
-                         ELSE
-                            theta = pt(k,j,i) + pt_d_t(k) * l_d_cp * ql(k,j,i)
-                            temp  = theta * t_d_pt(k)
-                            k1 = ( 1.0_wp - q(k,j,i) + 1.61_wp *               &
-                                          ( q(k,j,i) - ql(k,j,i) ) *          &
-                                 ( 1.0_wp + 0.622_wp * l_d_r / temp ) ) /        &
-                                 ( 1.0_wp + 0.622_wp * l_d_r * l_d_cp *          &
-                                 ( q(k,j,i) - ql(k,j,i) ) / ( temp * temp ) )
-                            k2 = theta * ( l_d_cp / temp * k1 - 1.0_wp )
-                         ENDIF
-                         tend(k,j,i) = tend(k,j,i) - kh(k,j,i) *               &
-                                         g / vpt(k,j,i) *                      &
-                                         ( k1 * ( pt(k+1,j,i)-pt(k-1,j,i) ) +  &
-                                           k2 * ( q(k+1,j,i) - q(k-1,j,i) )    &
-                                         ) * dd2zu(k)
-                      ELSE IF ( cloud_droplets )  THEN
-                         k1 = 1.0_wp + 0.61_wp * q(k,j,i) - ql(k,j,i)
-                         k2 = 0.61_wp * pt(k,j,i)
-                         tend(k,j,i) = tend(k,j,i) -                          & 
-                                       kh(k,j,i) * g / vpt(k,j,i) *           &
-                                       ( k1 * ( pt(k+1,j,i)- pt(k-1,j,i) ) +  &
-                                         k2 * ( q(k+1,j,i) -  q(k-1,j,i) ) -  &
-                                         pt(k,j,i) * ( ql(k+1,j,i) -          &
-                                         ql(k-1,j,i) ) ) * dd2zu(k)
-                      ENDIF
-
-                   ENDDO
-
-                ENDDO
-
-                IF ( use_surface_fluxes )  THEN
-
-                   DO  j = nys, nyn
-
-                      k = nzb_diff_s_inner(j,i)-1
-
-                      IF ( .NOT. cloud_physics .AND. .NOT. cloud_droplets ) THEN
-                         k1 = 1.0_wp + 0.61_wp * q(k,j,i)
-                         k2 = 0.61_wp * pt(k,j,i)
-                      ELSE IF ( cloud_physics )  THEN
-                         IF ( ql(k,j,i) == 0.0_wp )  THEN
-                            k1 = 1.0_wp + 0.61_wp * q(k,j,i)
-                            k2 = 0.61_wp * pt(k,j,i)
-                         ELSE
-                            theta = pt(k,j,i) + pt_d_t(k) * l_d_cp * ql(k,j,i)
-                            temp  = theta * t_d_pt(k)
-                            k1 = ( 1.0_wp - q(k,j,i) + 1.61_wp *               &
-                                          ( q(k,j,i) - ql(k,j,i) ) *           &
-                                 ( 1.0_wp + 0.622_wp * l_d_r / temp ) ) /      &
-                                 ( 1.0_wp + 0.622_wp * l_d_r * l_d_cp *        &
-                                 ( q(k,j,i) - ql(k,j,i) ) / ( temp * temp ) )
-                            k2 = theta * ( l_d_cp / temp * k1 - 1.0_wp )
-                         ENDIF
-                      ELSE IF ( cloud_droplets )  THEN
-                         k1 = 1.0_wp + 0.61_wp * q(k,j,i) - ql(k,j,i)
-                         k2 = 0.61_wp * pt(k,j,i)
-                      ENDIF
-
-                      tend(k,j,i) = tend(k,j,i) + g / vpt(k,j,i) * &
-                                            ( k1* shf(j,i) + k2 * qsws(j,i) )
-                   ENDDO
-
-                ENDIF
-
-                IF ( use_top_fluxes )  THEN
-
-                   DO  j = nys, nyn
-
-                      k = nzt
-
-                      IF ( .NOT. cloud_physics .AND. .NOT. cloud_droplets ) THEN
-                         k1 = 1.0_wp + 0.61_wp * q(k,j,i)
-                         k2 = 0.61_wp * pt(k,j,i)
-                      ELSE IF ( cloud_physics )  THEN
-                         IF ( ql(k,j,i) == 0.0_wp )  THEN
-                            k1 = 1.0_wp + 0.61_wp * q(k,j,i)
-                            k2 = 0.61_wp * pt(k,j,i)
-                         ELSE
-                            theta = pt(k,j,i) + pt_d_t(k) * l_d_cp * ql(k,j,i)
-                            temp  = theta * t_d_pt(k)
-                            k1 = ( 1.0_wp - q(k,j,i) + 1.61_wp *               &
-                                          ( q(k,j,i) - ql(k,j,i) ) *           &
-                                 ( 1.0_wp + 0.622_wp * l_d_r / temp ) ) /      &
-                                 ( 1.0_wp + 0.622_wp * l_d_r * l_d_cp *        &
-                                 ( q(k,j,i) - ql(k,j,i) ) / ( temp * temp ) )
-                            k2 = theta * ( l_d_cp / temp * k1 - 1.0_wp )
-                         ENDIF
-                      ELSE IF ( cloud_droplets )  THEN
-                         k1 = 1.0_wp + 0.61_wp * q(k,j,i) - ql(k,j,i)
-                         k2 = 0.61_wp * pt(k,j,i)
-                      ENDIF
-
-                      tend(k,j,i) = tend(k,j,i) + g / vpt(k,j,i) * &
-                                            ( k1* tswst(j,i) + k2 * qswst(j,i) )
-                   ENDDO
-
-                ENDIF
-
-             ENDIF
-
-          ENDIF
-
-       ENDDO
-
-    END SUBROUTINE production_e
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Call for all grid points - accelerator version
-!------------------------------------------------------------------------------!
-    SUBROUTINE production_e_acc
-
-       USE arrays_3d,                                                          &
-           ONLY:  ddzw, dd2zu, kh, km, pt, q, ql, qsws, qswst, rho, shf,       &
-                  tend, tswst, u, v, vpt, w
-
-       USE cloud_parameters,                                                   &
-           ONLY:  l_d_cp, l_d_r, pt_d_t, t_d_pt
-
-       USE control_parameters,                                                 &
-           ONLY:  cloud_droplets, cloud_physics, constant_flux_layer, g,       &
-                  humidity, kappa, neutral, ocean, pt_reference,               &
-                  rho_reference, topography, use_single_reference_value,       &
-                  use_surface_fluxes, use_top_fluxes
-
-       USE grid_variables,                                                     &
-           ONLY:  ddx, dx, ddy, dy, wall_e_x, wall_e_y
-
-       USE indices,                                                            &
-           ONLY:  i_left, i_right, j_north, j_south, nxl, nxr, nys, nyn, nzb,  &
-                  nzb_diff_s_inner, nzb_diff_s_outer, nzb_s_inner, nzt,        &
-                  nzt_diff
-
-       IMPLICIT NONE
-
-       INTEGER(iwp) ::  i           !<
-       INTEGER(iwp) ::  j           !<
-       INTEGER(iwp) ::  k           !<
-
-       REAL(wp)     ::  def         !<
-       REAL(wp)     ::  dudx        !<
-       REAL(wp)     ::  dudy        !<
-       REAL(wp)     ::  dudz        !<
-       REAL(wp)     ::  dvdx        !<
-       REAL(wp)     ::  dvdy        !<
-       REAL(wp)     ::  dvdz        !<
-       REAL(wp)     ::  dwdx        !<
-       REAL(wp)     ::  dwdy        !<
-       REAL(wp)     ::  dwdz        !<
-       REAL(wp)     ::  k1          !<
-       REAL(wp)     ::  k2          !<
-       REAL(wp)     ::  km_neutral  !<
-       REAL(wp)     ::  theta       !<
-       REAL(wp)     ::  temp        !<
-
-       REAL(wp), DIMENSION(nzb:nzt+1,nys:nyn,nxl:nxr) ::  usvs  !<
-       REAL(wp), DIMENSION(nzb:nzt+1,nys:nyn,nxl:nxr) ::  vsus  !<
-       REAL(wp), DIMENSION(nzb:nzt+1,nys:nyn,nxl:nxr) ::  wsus  !<
-       REAL(wp), DIMENSION(nzb:nzt+1,nys:nyn,nxl:nxr) ::  wsvs  !<
-       !$acc declare create ( usvs, vsus, wsus, wsvs )
-
-!
-!--    First calculate horizontal momentum flux u'v', w'v', v'u', w'u' at
-!--    vertical walls, if neccessary
-!--    CAUTION: results are slightly different from the ij-version!!
-!--    ij-version should be called further below within the ij-loops!!
-       IF ( topography /= 'flat' )  THEN
-          CALL wall_fluxes_e_acc( usvs, 1.0_wp, 0.0_wp, 0.0_wp, 0.0_wp, wall_e_y )
-          CALL wall_fluxes_e_acc( wsvs, 0.0_wp, 0.0_wp, 1.0_wp, 0.0_wp, wall_e_y )
-          CALL wall_fluxes_e_acc( vsus, 0.0_wp, 1.0_wp, 0.0_wp, 0.0_wp, wall_e_x )
-          CALL wall_fluxes_e_acc( wsus, 0.0_wp, 0.0_wp, 0.0_wp, 1.0_wp, wall_e_x )
-       ENDIF
-
-
-!
-!--    Calculate TKE production by shear
-       !$acc kernels present( ddzw, dd2zu, kh, km, nzb_diff_s_inner, nzb_diff_s_outer ) &
-       !$acc         present( nzb_s_inner, pt, q, ql, qsws, qswst, rho )                &
-       !$acc         present( shf, tend, tswst, u, v, vpt, w, wall_e_x, wall_e_y )      &
-       !$acc         copyin( u_0, v_0 )
-       DO  i = i_left, i_right
-          DO  j = j_south, j_north
-             DO  k = 1, nzt
-
-                IF ( k >= nzb_diff_s_outer(j,i) )  THEN
-
-                   dudx  =           ( u(k,j,i+1) - u(k,j,i)     ) * ddx
-                   dudy  = 0.25_wp * ( u(k,j+1,i) + u(k,j+1,i+1) - &
-                                       u(k,j-1,i) - u(k,j-1,i+1) ) * ddy
-                   dudz  = 0.5_wp  * ( u(k+1,j,i) + u(k+1,j,i+1) - &
-                                       u(k-1,j,i) - u(k-1,j,i+1) ) * dd2zu(k)
-
-                   dvdx  = 0.25_wp * ( v(k,j,i+1) + v(k,j+1,i+1) - &
-                                       v(k,j,i-1) - v(k,j+1,i-1) ) * ddx
-                   dvdy  =           ( v(k,j+1,i) - v(k,j,i)     ) * ddy
-                   dvdz  = 0.5_wp  * ( v(k+1,j,i) + v(k+1,j+1,i) - &
-                                       v(k-1,j,i) - v(k-1,j+1,i) ) * dd2zu(k)
-
-                   dwdx  = 0.25_wp * ( w(k,j,i+1) + w(k-1,j,i+1) - &
-                                       w(k,j,i-1) - w(k-1,j,i-1) ) * ddx
-                   dwdy  = 0.25_wp * ( w(k,j+1,i) + w(k-1,j+1,i) - &
-                                       w(k,j-1,i) - w(k-1,j-1,i) ) * ddy
-                   dwdz  =           ( w(k,j,i)   - w(k-1,j,i)   ) * ddzw(k)
-
-                   def = 2.0_wp * ( dudx**2 + dvdy**2 + dwdz**2 ) +           &
-                         dudy**2 + dvdx**2 + dwdx**2 + dwdy**2 + dudz**2 + &
-                         dvdz**2 + 2.0_wp * ( dvdx*dudy + dwdx*dudz + dwdy*dvdz )
-
-                   IF ( def < 0.0_wp )  def = 0.0_wp
-
-                   tend(k,j,i) = tend(k,j,i) + km(k,j,i) * def
-
-                ENDIF
-
-             ENDDO
-          ENDDO
-       ENDDO
-
-       IF ( constant_flux_layer )  THEN
-
-!
-!--       Position beneath wall
-!--       (2) - Will allways be executed.
-!--       'bottom and wall: use u_0,v_0 and wall functions'
-          DO  i = i_left, i_right
-             DO  j = j_south, j_north
-                DO  k = 1, nzt
-
-                   IF ( ( wall_e_x(j,i) /= 0.0_wp ).OR.( wall_e_y(j,i) /= 0.0_wp ) ) &
-                   THEN
-
-                      IF ( k == nzb_diff_s_inner(j,i) - 1 )  THEN
-                         dudx = ( u(k,j,i+1) - u(k,j,i) ) * ddx
-                         dudz = 0.5_wp * ( u(k+1,j,i) + u(k+1,j,i+1) - &
-                                           u_0(j,i)   - u_0(j,i+1)   ) * dd2zu(k)
-                         dvdy = ( v(k,j+1,i) - v(k,j,i) ) * ddy
-                         dvdz = 0.5_wp * ( v(k+1,j,i) + v(k+1,j+1,i) - &
-                                           v_0(j,i)   - v_0(j+1,i)   ) * dd2zu(k)
-                         dwdz = ( w(k,j,i) - w(k-1,j,i) ) * ddzw(k)
-
-                         IF ( wall_e_y(j,i) /= 0.0_wp )  THEN
-!
-!--                         Inconsistency removed: as the thermal stratification is
-!--                         not taken into account for the evaluation of the wall
-!--                         fluxes at vertical walls, the eddy viscosity km must not
-!--                         be used for the evaluation of the velocity gradients dudy
-!--                         and dwdy
-!--                         Note: The validity of the new method has not yet been
-!--                               shown, as so far no suitable data for a validation
-!--                               has been available
-!                            CALL wall_fluxes_e( i, j, k, nzb_diff_s_outer(j,i)-2, &
-!                                                usvs, 1.0_wp, 0.0_wp, 0.0_wp, 0.0_wp )
-!                            CALL wall_fluxes_e( i, j, k, nzb_diff_s_outer(j,i)-2, &
-!                                                wsvs, 0.0_wp, 0.0_wp, 1.0_wp, 0.0_wp )
-                            km_neutral = kappa *                                    &
-                                        ( usvs(k,j,i)**2 + wsvs(k,j,i)**2 )**0.25_wp * &
-                                         0.5_wp * dy
-                            IF ( km_neutral > 0.0_wp )  THEN
-                               dudy = - wall_e_y(j,i) * usvs(k,j,i) / km_neutral
-                               dwdy = - wall_e_y(j,i) * wsvs(k,j,i) / km_neutral
-                            ELSE
-                               dudy = 0.0_wp
-                               dwdy = 0.0_wp
-                            ENDIF
-                         ELSE
-                            dudy = 0.25_wp * ( u(k,j+1,i) + u(k,j+1,i+1) - &
-                                               u(k,j-1,i) - u(k,j-1,i+1) ) * ddy
-                            dwdy = 0.25_wp * ( w(k,j+1,i) + w(k-1,j+1,i) - &
-                                               w(k,j-1,i) - w(k-1,j-1,i) ) * ddy
-                         ENDIF
-
-                         IF ( wall_e_x(j,i) /= 0.0_wp )  THEN
-!
-!--                         Inconsistency removed: as the thermal stratification is
-!--                         not taken into account for the evaluation of the wall
-!--                         fluxes at vertical walls, the eddy viscosity km must not
-!--                         be used for the evaluation of the velocity gradients dvdx
-!--                         and dwdx
-!--                         Note: The validity of the new method has not yet been
-!--                               shown, as so far no suitable data for a validation
-!--                               has been available
-!                            CALL wall_fluxes_e( i, j, k, nzb_diff_s_outer(j,i)-2, &
-!                                                vsus, 0.0_wp, 1.0_wp, 0.0_wp, 0.0_wp )
-!                            CALL wall_fluxes_e( i, j, k, nzb_diff_s_outer(j,i)-2, &
-!                                                wsus, 0.0_wp, 0.0_wp, 0.0_wp, 1.0_wp )
-                            km_neutral = kappa *                                     &
-                                         ( vsus(k,j,i)**2 + wsus(k,j,i)**2 )**0.25_wp * &
-                                         0.5_wp * dx
-                            IF ( km_neutral > 0.0_wp )  THEN
-                               dvdx = - wall_e_x(j,i) * vsus(k,j,i) / km_neutral
-                               dwdx = - wall_e_x(j,i) * wsus(k,j,i) / km_neutral
-                            ELSE
-                               dvdx = 0.0_wp
-                               dwdx = 0.0_wp
-                            ENDIF
-                         ELSE
-                            dvdx = 0.25_wp * ( v(k,j,i+1) + v(k,j+1,i+1) - &
-                                               v(k,j,i-1) - v(k,j+1,i-1) ) * ddx
-                            dwdx = 0.25_wp * ( w(k,j,i+1) + w(k-1,j,i+1) - &
-                                               w(k,j,i-1) - w(k-1,j,i-1) ) * ddx
-                         ENDIF
-
-                         def = 2.0_wp * ( dudx**2 + dvdy**2 + dwdz**2 ) +           &
-                               dudy**2 + dvdx**2 + dwdx**2 + dwdy**2 + dudz**2 + &
-                               dvdz**2 + 2.0_wp * ( dvdx*dudy + dwdx*dudz + dwdy*dvdz )
-
-                         IF ( def < 0.0_wp )  def = 0.0_wp
-
-                         tend(k,j,i) = tend(k,j,i) + km(k,j,i) * def
-
-                      ENDIF
-!
-!--                   (3) - will be executed only, if there is at least one level
-!--                   between (2) and (4), i.e. the topography must have a
-!--                   minimum height of 2 dz. Wall fluxes for this case have
-!--                   already been calculated for (2).
-!--                   'wall only: use wall functions'
-
-                      IF ( k >= nzb_diff_s_inner(j,i)  .AND.  &
-                           k <= nzb_diff_s_outer(j,i)-2 )  THEN
-
-                         dudx = ( u(k,j,i+1) - u(k,j,i) ) * ddx
-                         dudz = 0.5_wp * ( u(k+1,j,i) + u(k+1,j,i+1) - &
-                                           u(k-1,j,i) - u(k-1,j,i+1) ) * dd2zu(k)
-                         dvdy =          ( v(k,j+1,i) - v(k,j,i)     ) * ddy
-                         dvdz = 0.5_wp * ( v(k+1,j,i) + v(k+1,j+1,i) - &
-                                           v(k-1,j,i) - v(k-1,j+1,i) ) * dd2zu(k)
-                         dwdz = ( w(k,j,i) - w(k-1,j,i) ) * ddzw(k)
-
-                         IF ( wall_e_y(j,i) /= 0.0_wp )  THEN
-!
-!--                         Inconsistency removed: as the thermal stratification
-!--                         is not taken into account for the evaluation of the
-!--                         wall fluxes at vertical walls, the eddy viscosity km
-!--                         must not be used for the evaluation of the velocity
-!--                         gradients dudy and dwdy
-!--                         Note: The validity of the new method has not yet
-!--                               been shown, as so far no suitable data for a
-!--                               validation has been available
-                            km_neutral = kappa * ( usvs(k,j,i)**2 + &
-                                                   wsvs(k,j,i)**2 )**0.25_wp * 0.5_wp * dy
-                            IF ( km_neutral > 0.0_wp )  THEN
-                               dudy = - wall_e_y(j,i) * usvs(k,j,i) / km_neutral
-                               dwdy = - wall_e_y(j,i) * wsvs(k,j,i) / km_neutral
-                            ELSE
-                               dudy = 0.0_wp
-                               dwdy = 0.0_wp
-                            ENDIF
-                         ELSE
-                            dudy = 0.25_wp * ( u(k,j+1,i) + u(k,j+1,i+1) - &
-                                               u(k,j-1,i) - u(k,j-1,i+1) ) * ddy
-                            dwdy = 0.25_wp * ( w(k,j+1,i) + w(k-1,j+1,i) - &
-                                               w(k,j-1,i) - w(k-1,j-1,i) ) * ddy
-                         ENDIF
-
-                         IF ( wall_e_x(j,i) /= 0.0_wp )  THEN
-!
-!--                         Inconsistency removed: as the thermal stratification
-!--                         is not taken into account for the evaluation of the
-!--                         wall fluxes at vertical walls, the eddy viscosity km
-!--                         must not be used for the evaluation of the velocity
-!--                         gradients dvdx and dwdx
-!--                         Note: The validity of the new method has not yet
-!--                               been shown, as so far no suitable data for a
-!--                               validation has been available
-                            km_neutral = kappa * ( vsus(k,j,i)**2 + &
-                                                   wsus(k,j,i)**2 )**0.25_wp * 0.5_wp * dx
-                            IF ( km_neutral > 0.0_wp )  THEN
-                               dvdx = - wall_e_x(j,i) * vsus(k,j,i) / km_neutral
-                               dwdx = - wall_e_x(j,i) * wsus(k,j,i) / km_neutral
-                            ELSE
-                               dvdx = 0.0_wp
-                               dwdx = 0.0_wp
-                            ENDIF
-                         ELSE
-                            dvdx = 0.25_wp * ( v(k,j,i+1) + v(k,j+1,i+1) - &
-                                               v(k,j,i-1) - v(k,j+1,i-1) ) * ddx
-                            dwdx = 0.25_wp * ( w(k,j,i+1) + w(k-1,j,i+1) - &
-                                               w(k,j,i-1) - w(k-1,j,i-1) ) * ddx
-                         ENDIF
-
-                         def = 2.0_wp * ( dudx**2 + dvdy**2 + dwdz**2 ) +           &
-                              dudy**2 + dvdx**2 + dwdx**2 + dwdy**2 + dudz**2 +  &
-                              dvdz**2 + 2.0_wp * ( dvdx*dudy + dwdx*dudz + dwdy*dvdz )
-
-                         IF ( def < 0.0_wp )  def = 0.0_wp
-
-                         tend(k,j,i) = tend(k,j,i) + km(k,j,i) * def
-
-                      ENDIF
-
-!
-!--                   (4) - will allways be executed.
-!--                   'special case: free atmosphere' (as for case (0))
-                      IF ( k == nzb_diff_s_outer(j,i)-1 )  THEN
-
-                         dudx  =           ( u(k,j,i+1) - u(k,j,i)     ) * ddx
-                         dudy  = 0.25_wp * ( u(k,j+1,i) + u(k,j+1,i+1) - &
-                                             u(k,j-1,i) - u(k,j-1,i+1) ) * ddy
-                         dudz  = 0.5_wp  * ( u(k+1,j,i) + u(k+1,j,i+1) - &
-                                             u(k-1,j,i) - u(k-1,j,i+1) ) * dd2zu(k)
-
-                         dvdx  = 0.25_wp * ( v(k,j,i+1) + v(k,j+1,i+1) - &
-                                             v(k,j,i-1) - v(k,j+1,i-1) ) * ddx
-                         dvdy  =           ( v(k,j+1,i) - v(k,j,i)     ) * ddy
-                         dvdz  = 0.5_wp  * ( v(k+1,j,i) + v(k+1,j+1,i) - &
-                                             v(k-1,j,i) - v(k-1,j+1,i) ) * dd2zu(k)
-
-                         dwdx  = 0.25_wp * ( w(k,j,i+1) + w(k-1,j,i+1) - &
-                                             w(k,j,i-1) - w(k-1,j,i-1) ) * ddx
-                         dwdy  = 0.25_wp * ( w(k,j+1,i) + w(k-1,j+1,i) - &
-                                             w(k,j-1,i) - w(k-1,j-1,i) ) * ddy
-                         dwdz  =           ( w(k,j,i)   - w(k-1,j,i)   ) * ddzw(k)
-
-                         def = 2.0_wp * ( dudx**2 + dvdy**2 + dwdz**2 ) +           &
-                               dudy**2 + dvdx**2 + dwdx**2 + dwdy**2 + dudz**2 + &
-                               dvdz**2 + 2.0_wp * ( dvdx*dudy + dwdx*dudz + dwdy*dvdz )
-
-                         IF ( def < 0.0_wp )  def = 0.0_wp
-
-                         tend(k,j,i) = tend(k,j,i) + km(k,j,i) * def
-
-                      ENDIF
-
-                   ENDIF
-
-                ENDDO
-             ENDDO
-          ENDDO
-
-!
-!--       Position without adjacent wall
-!--       (1) - will allways be executed.
-!--       'bottom only: use u_0,v_0'
-          DO  i = i_left, i_right
-             DO  j = j_south, j_north
-                DO  k = 1, nzt
-
-                   IF ( ( wall_e_x(j,i) == 0.0_wp ) .AND. ( wall_e_y(j,i) == 0.0_wp ) ) &
-                   THEN
-
-                      IF ( k == nzb_diff_s_inner(j,i)-1 )  THEN
-
-                         dudx  =           ( u(k,j,i+1) - u(k,j,i)     ) * ddx
-                         dudy  = 0.25_wp * ( u(k,j+1,i) + u(k,j+1,i+1) - &
-                                             u(k,j-1,i) - u(k,j-1,i+1) ) * ddy
-                         dudz  = 0.5_wp  * ( u(k+1,j,i) + u(k+1,j,i+1) - &
-                                             u_0(j,i)   - u_0(j,i+1)   ) * dd2zu(k)
-
-                         dvdx  = 0.25_wp * ( v(k,j,i+1) + v(k,j+1,i+1) - &
-                                             v(k,j,i-1) - v(k,j+1,i-1) ) * ddx
-                         dvdy  =           ( v(k,j+1,i) - v(k,j,i)     ) * ddy
-                         dvdz  = 0.5_wp  * ( v(k+1,j,i) + v(k+1,j+1,i) - &
-                                             v_0(j,i)   - v_0(j+1,i)   ) * dd2zu(k)
-
-                         dwdx  = 0.25_wp * ( w(k,j,i+1) + w(k-1,j,i+1) - &
-                                             w(k,j,i-1) - w(k-1,j,i-1) ) * ddx
-                         dwdy  = 0.25_wp * ( w(k,j+1,i) + w(k-1,j+1,i) - &
-                                             w(k,j-1,i) - w(k-1,j-1,i) ) * ddy
-                         dwdz  =           ( w(k,j,i)   - w(k-1,j,i)   ) * ddzw(k)
-
-                         def = 2.0_wp * ( dudx**2 + dvdy**2 + dwdz**2 ) +           &
-                               dudy**2 + dvdx**2 + dwdx**2 + dwdy**2 + dudz**2 + &
-                               dvdz**2 + 2.0_wp * ( dvdx*dudy + dwdx*dudz + dwdy*dvdz )
-
-                         IF ( def < 0.0_wp )  def = 0.0_wp
-
-                         tend(k,j,i) = tend(k,j,i) + km(k,j,i) * def
-
-                      ENDIF
-
-                   ENDIF
-
-                ENDDO
-             ENDDO
-          ENDDO
-
-       ELSEIF ( use_surface_fluxes )  THEN
-
-          DO  i = i_left, i_right
-             DO  j = j_south, j_north
-                 DO  k = 1, nzt
-
-                   IF ( k == nzb_diff_s_outer(j,i)-1 )  THEN
-
-                      dudx  =           ( u(k,j,i+1) - u(k,j,i)     ) * ddx
-                      dudy  = 0.25_wp * ( u(k,j+1,i) + u(k,j+1,i+1) - &
-                                          u(k,j-1,i) - u(k,j-1,i+1) ) * ddy
-                      dudz  = 0.5_wp  * ( u(k+1,j,i) + u(k+1,j,i+1) - &
-                                          u(k-1,j,i) - u(k-1,j,i+1) ) * dd2zu(k)
-
-                      dvdx  = 0.25_wp * ( v(k,j,i+1) + v(k,j+1,i+1) - &
-                                          v(k,j,i-1) - v(k,j+1,i-1) ) * ddx
-                      dvdy  =           ( v(k,j+1,i) - v(k,j,i)     ) * ddy
-                      dvdz  = 0.5_wp  * ( v(k+1,j,i) + v(k+1,j+1,i) - &
-                                          v(k-1,j,i) - v(k-1,j+1,i) ) * dd2zu(k)
-
-                      dwdx  = 0.25_wp * ( w(k,j,i+1) + w(k-1,j,i+1) - &
-                                          w(k,j,i-1) - w(k-1,j,i-1) ) * ddx
-                      dwdy  = 0.25_wp * ( w(k,j+1,i) + w(k-1,j+1,i) - &
-                                          w(k,j-1,i) - w(k-1,j-1,i) ) * ddy
-                      dwdz  =           ( w(k,j,i)   - w(k-1,j,i)   ) * ddzw(k)
-
-                      def = 2.0_wp * ( dudx**2 + dvdy**2 + dwdz**2 ) +           &
-                            dudy**2 + dvdx**2 + dwdx**2 + dwdy**2 + dudz**2 + &
-                            dvdz**2 + 2.0_wp * ( dvdx*dudy + dwdx*dudz + dwdy*dvdz )
-
-                      IF ( def < 0.0_wp )  def = 0.0_wp
-
-                      tend(k,j,i) = tend(k,j,i) + km(k,j,i) * def
-
-                   ENDIF
-
-                ENDDO
-             ENDDO
-          ENDDO
-
-       ENDIF
-
-!
-!--    If required, calculate TKE production by buoyancy
-       IF ( .NOT. neutral )  THEN
-
-          IF ( .NOT. humidity )  THEN
-
-             IF ( use_single_reference_value )  THEN
-
-                IF ( ocean )  THEN
-!
-!--                So far in the ocean no special treatment of density flux
-!--                in the bottom and top surface layer
-                   DO  i = i_left, i_right
-                      DO  j = j_south, j_north
-                         DO  k = 1, nzt
-                            IF ( k > nzb_s_inner(j,i) )  THEN
-                               tend(k,j,i) = tend(k,j,i) +                     &
-                                             kh(k,j,i) * g / rho_reference *   &
-                                             ( rho(k+1,j,i) - rho(k-1,j,i) ) * &
-                                             dd2zu(k)
-                            ENDIF
-                         ENDDO
-                      ENDDO
-                   ENDDO
-
-                ELSE
-
-                   DO  i = i_left, i_right
-                      DO  j = j_south, j_north
-                         DO  k = 1, nzt_diff
-                            IF ( k >= nzb_diff_s_inner(j,i) )  THEN
-                               tend(k,j,i) = tend(k,j,i) -                   &
-                                             kh(k,j,i) * g / pt_reference *  &
-                                             ( pt(k+1,j,i) - pt(k-1,j,i) ) * &
-                                             dd2zu(k)
-                            ENDIF
-
-                            IF ( k == nzb_diff_s_inner(j,i)-1  .AND.  &
-                                 use_surface_fluxes )  THEN
-                               tend(k,j,i) = tend(k,j,i) + g / pt_reference * &
-                                                           shf(j,i)
-                            ENDIF
-
-                            IF ( k == nzt  .AND.  use_top_fluxes )  THEN
-                               tend(k,j,i) = tend(k,j,i) + g / pt_reference * &
-                                                           tswst(j,i)
-                            ENDIF
-                         ENDDO
-                      ENDDO
-                   ENDDO
-
-                ENDIF
-
-             ELSE
-
-                IF ( ocean )  THEN
-!
-!--                So far in the ocean no special treatment of density flux
-!--                in the bottom and top surface layer
-                   DO  i = i_left, i_right
-                      DO  j = j_south, j_north
-                         DO  k = 1, nzt
-                            IF ( k > nzb_s_inner(j,i) )  THEN
-                               tend(k,j,i) = tend(k,j,i) +                     &
-                                             kh(k,j,i) * g / rho(k,j,i) *      &
-                                             ( rho(k+1,j,i) - rho(k-1,j,i) ) * &
-                                             dd2zu(k)
-                            ENDIF
-                         ENDDO
-                      ENDDO
-                   ENDDO
-
-                ELSE
-
-                   DO  i = i_left, i_right
-                      DO  j = j_south, j_north
-                         DO  k = 1, nzt_diff
-                            IF( k >= nzb_diff_s_inner(j,i) )  THEN
-                               tend(k,j,i) = tend(k,j,i) -                   &
-                                             kh(k,j,i) * g / pt(k,j,i) *     &
-                                             ( pt(k+1,j,i) - pt(k-1,j,i) ) * &
-                                             dd2zu(k)
-                            ENDIF
-
-                            IF (  k == nzb_diff_s_inner(j,i)-1  .AND.  &
-                                  use_surface_fluxes )  THEN
-                               tend(k,j,i) = tend(k,j,i) + g / pt(k,j,i) * &
-                                                           shf(j,i)
-                            ENDIF
-
-                            IF ( k == nzt  .AND.  use_top_fluxes )  THEN
-                               tend(k,j,i) = tend(k,j,i) + g / pt(k,j,i) * &
-                                                           tswst(j,i)
-                            ENDIF
-                         ENDDO
-                      ENDDO
-                   ENDDO
-
-                ENDIF
-
-             ENDIF
-
-          ELSE
-!
-!++          This part gives the PGI compiler problems in the previous loop
-!++          even without any acc statements????
-!             STOP '+++ production_e problems with acc-directives'
-!             !acc loop
-!             DO  i = nxl, nxr
-!                DO  j = nys, nyn
-!                   !acc loop vector
-!                   DO  k = 1, nzt_diff
-!
-!                      IF ( k >= nzb_diff_s_inner(j,i) )  THEN
-!
-!                         IF ( .NOT. cloud_physics .AND. .NOT. cloud_droplets ) THEN
-!                            k1 = 1.0_wp + 0.61_wp * q(k,j,i)
-!                            k2 = 0.61_wp * pt(k,j,i)
-!                            tend(k,j,i) = tend(k,j,i) - kh(k,j,i) *               &
-!                                            g / vpt(k,j,i) *                      &
-!                                            ( k1 * ( pt(k+1,j,i)-pt(k-1,j,i) ) +  &
-!                                              k2 * ( q(k+1,j,i) - q(k-1,j,i) )    &
-!                                            ) * dd2zu(k)
-!                         ELSE IF ( cloud_physics )  THEN
-!                            IF ( ql(k,j,i) == 0.0_wp )  THEN
-!                               k1 = 1.0_wp + 0.61_wp * q(k,j,i)
-!                               k2 = 0.61_wp * pt(k,j,i)
-!                            ELSE
-!                               theta = pt(k,j,i) + pt_d_t(k) * l_d_cp * ql(k,j,i)
-!                               temp  = theta * t_d_pt(k)
-!                               k1 = ( 1.0_wp - q(k,j,i) + 1.61_wp *                 &
-!                                             ( q(k,j,i) - ql(k,j,i) ) *          &
-!                                    ( 1.0_wp + 0.622_wp * l_d_r / temp ) ) /        &
-!                                    ( 1.0_wp + 0.622_wp * l_d_r * l_d_cp *          &
-!                                    ( q(k,j,i) - ql(k,j,i) ) / ( temp * temp ) )
-!                               k2 = theta * ( l_d_cp / temp * k1 - 1.0_wp )
-!                            ENDIF
-!                            tend(k,j,i) = tend(k,j,i) - kh(k,j,i) *               &
-!                                            g / vpt(k,j,i) *                      &
-!                                            ( k1 * ( pt(k+1,j,i)-pt(k-1,j,i) ) +  &
-!                                              k2 * ( q(k+1,j,i) - q(k-1,j,i) )    &
-!                                            ) * dd2zu(k)
-!                         ELSE IF ( cloud_droplets )  THEN
-!                            k1 = 1.0_wp + 0.61_wp * q(k,j,i) - ql(k,j,i)
-!                            k2 = 0.61_wp * pt(k,j,i)
-!                            tend(k,j,i) = tend(k,j,i) -                          &
-!                                          kh(k,j,i) * g / vpt(k,j,i) *           &
-!                                          ( k1 * ( pt(k+1,j,i)- pt(k-1,j,i) ) +  &
-!                                            k2 * ( q(k+1,j,i) -  q(k-1,j,i) ) -  &
-!                                            pt(k,j,i) * ( ql(k+1,j,i) -          &
-!                                            ql(k-1,j,i) ) ) * dd2zu(k)
-!                         ENDIF
-!
-!                      ENDIF
-!
-!                   ENDDO
-!                ENDDO
-!             ENDDO
-!
-
-!!++          Next two loops are probably very inefficiently parallellized
-!!++          and will require better optimization
-!             IF ( use_surface_fluxes )  THEN
-!
-!                !acc loop
-!                DO  i = nxl, nxr
-!                   DO  j = nys, nyn
-!                      !acc loop vector
-!                      DO  k = 1, nzt_diff
-!
-!                         IF ( k == nzb_diff_s_inner(j,i)-1 )  THEN
-!
-!                            IF ( .NOT. cloud_physics .AND. .NOT. cloud_droplets ) THEN
-!                               k1 = 1.0_wp + 0.61_wp * q(k,j,i)
-!                               k2 = 0.61_wp * pt(k,j,i)
-!                            ELSE IF ( cloud_physics )  THEN
-!                               IF ( ql(k,j,i) == 0.0_wp )  THEN
-!                                  k1 = 1.0_wp + 0.61_wp * q(k,j,i)
-!                                  k2 = 0.61_wp * pt(k,j,i)
-!                               ELSE
-!                                  theta = pt(k,j,i) + pt_d_t(k) * l_d_cp * ql(k,j,i)
-!                                  temp  = theta * t_d_pt(k)
-!                                  k1 = ( 1.0_wp - q(k,j,i) + 1.61_wp *        &
-!                                                ( q(k,j,i) - ql(k,j,i) ) *    &
-!                                       ( 1.0_wp + 0.622_wp * l_d_r / temp ) ) /&
-!                                       ( 1.0_wp + 0.622_wp * l_d_r * l_d_cp * &
-!                                       ( q(k,j,i) - ql(k,j,i) ) / ( temp * temp ) )
-!                                  k2 = theta * ( l_d_cp / temp * k1 - 1.0_wp )
-!                               ENDIF
-!                            ELSE IF ( cloud_droplets )  THEN
-!                               k1 = 1.0_wp + 0.61_wp * q(k,j,i) - ql(k,j,i)
-!                               k2 = 0.61_wp * pt(k,j,i)
-!                            ENDIF
-!
-!                            tend(k,j,i) = tend(k,j,i) + g / vpt(k,j,i) * &
-!                                                  ( k1* shf(j,i) + k2 * qsws(j,i) )
-!                         ENDIF
-!
-!                      ENDDO
-!                   ENDDO
-!                ENDDO
-!
-!             ENDIF
-!
-!             IF ( use_top_fluxes )  THEN
-!
-!                !acc loop
-!                DO  i = nxl, nxr
-!                   DO  j = nys, nyn
-!                      !acc loop vector
-!                      DO  k = 1, nzt
-!                         IF ( k == nzt )  THEN
-!
-!                            IF ( .NOT. cloud_physics .AND. .NOT. cloud_droplets ) THEN
-!                               k1 = 1.0_wp + 0.61_wp * q(k,j,i)
-!                               k2 = 0.61_wp * pt(k,j,i)
-!                            ELSE IF ( cloud_physics )  THEN
-!                               IF ( ql(k,j,i) == 0.0_wp )  THEN
-!                                  k1 = 1.0_wp + 0.61_wp * q(k,j,i)
-!                                  k2 = 0.61_wp * pt(k,j,i)
-!                               ELSE
-!                                  theta = pt(k,j,i) + pt_d_t(k) * l_d_cp * ql(k,j,i)
-!                                  temp  = theta * t_d_pt(k)
-!                                  k1 = ( 1.0_wp - q(k,j,i) + 1.61_wp *        &
-!                                                ( q(k,j,i) - ql(k,j,i) ) *    &
-!                                       ( 1.0_wp + 0.622_wp * l_d_r / temp ) ) /&
-!                                       ( 1.0_wp + 0.622_wp * l_d_r * l_d_cp * &
-!                                       ( q(k,j,i) - ql(k,j,i) ) / ( temp * temp ) )
-!                                  k2 = theta * ( l_d_cp / temp * k1 - 1.0_wp )
-!                               ENDIF
-!                            ELSE IF ( cloud_droplets )  THEN
-!                               k1 = 1.0_wp + 0.61_wp * q(k,j,i) - ql(k,j,i)
-!                               k2 = 0.61_wp * pt(k,j,i)
-!                            ENDIF
-!
-!                            tend(k,j,i) = tend(k,j,i) + g / vpt(k,j,i) * &
-!                                                  ( k1* tswst(j,i) + k2 * qswst(j,i) )
-!
-!                         ENDIF
-!
-!                      ENDDO
-!                   ENDDO
-!                ENDDO
-!
-!             ENDIF
-
-          ENDIF
-
-       ENDIF
-       !$acc end kernels
-
-    END SUBROUTINE production_e_acc
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Call for grid point i,j
-!------------------------------------------------------------------------------!
-    SUBROUTINE production_e_ij( i, j )
-
-       USE arrays_3d,                                                          &
-           ONLY:  ddzw, dd2zu, kh, km, pt, q, ql, qsws, qswst, rho, shf,       &
-                  tend, tswst, u, v, vpt, w
-
-       USE cloud_parameters,                                                   &
-           ONLY:  l_d_cp, l_d_r, pt_d_t, t_d_pt
-
-       USE control_parameters,                                                 &
-           ONLY:  cloud_droplets, cloud_physics, constant_flux_layer, g,       &
-                  humidity, kappa, neutral, ocean, pt_reference,               &
-                  rho_reference, use_single_reference_value,                   &
-                  use_surface_fluxes, use_top_fluxes
-
-       USE grid_variables,                                                     &
-           ONLY:  ddx, dx, ddy, dy, wall_e_x, wall_e_y
-
-       USE indices,                                                            &
-           ONLY:  nxl, nxr, nys, nyn, nzb, nzb_diff_s_inner,                   &
-                  nzb_diff_s_outer, nzb_s_inner, nzt, nzt_diff
-
-       IMPLICIT NONE
-
-       INTEGER(iwp) ::  i           !<
-       INTEGER(iwp) ::  j           !<
-       INTEGER(iwp) ::  k           !<
-
-       REAL(wp)     ::  def         !<
-       REAL(wp)     ::  dudx        !<
-       REAL(wp)     ::  dudy        !<
-       REAL(wp)     ::  dudz        !<
-       REAL(wp)     ::  dvdx        !<
-       REAL(wp)     ::  dvdy        !<
-       REAL(wp)     ::  dvdz        !<
-       REAL(wp)     ::  dwdx        !<
-       REAL(wp)     ::  dwdy        !<
-       REAL(wp)     ::  dwdz        !<
-       REAL(wp)     ::  k1          !<
-       REAL(wp)     ::  k2          !<
-       REAL(wp)     ::  km_neutral  !<
-       REAL(wp)     ::  theta       !<
-       REAL(wp)     ::  temp        !<
-
-       REAL(wp), DIMENSION(nzb:nzt+1) ::  usvs  !<
-       REAL(wp), DIMENSION(nzb:nzt+1) ::  vsus  !<
-       REAL(wp), DIMENSION(nzb:nzt+1) ::  wsus  !<
-       REAL(wp), DIMENSION(nzb:nzt+1) ::  wsvs  !<
-
-!
-!--    Calculate TKE production by shear
-       DO  k = nzb_diff_s_outer(j,i), nzt
-
-          dudx  =           ( u(k,j,i+1) - u(k,j,i)     ) * ddx
-          dudy  = 0.25_wp * ( u(k,j+1,i) + u(k,j+1,i+1) - &
-                              u(k,j-1,i) - u(k,j-1,i+1) ) * ddy
-          dudz  = 0.5_wp  * ( u(k+1,j,i) + u(k+1,j,i+1) - &
-                              u(k-1,j,i) - u(k-1,j,i+1) ) * dd2zu(k)
-
-          dvdx  = 0.25_wp * ( v(k,j,i+1) + v(k,j+1,i+1) - &
-                              v(k,j,i-1) - v(k,j+1,i-1) ) * ddx
-          dvdy  =           ( v(k,j+1,i) - v(k,j,i)     ) * ddy
-          dvdz  = 0.5_wp  * ( v(k+1,j,i) + v(k+1,j+1,i) - &
-                              v(k-1,j,i) - v(k-1,j+1,i) ) * dd2zu(k)
-
-          dwdx  = 0.25_wp * ( w(k,j,i+1) + w(k-1,j,i+1) - &
-                              w(k,j,i-1) - w(k-1,j,i-1) ) * ddx
-          dwdy  = 0.25_wp * ( w(k,j+1,i) + w(k-1,j+1,i) - &
-                              w(k,j-1,i) - w(k-1,j-1,i) ) * ddy
-          dwdz  =           ( w(k,j,i)   - w(k-1,j,i)   ) * ddzw(k)
-
-          def = 2.0_wp * ( dudx**2 + dvdy**2 + dwdz**2 )                       &
-                + dudy**2 + dvdx**2 + dwdx**2 + dwdy**2 + dudz**2 + dvdz**2    &
-                + 2.0_wp * ( dvdx*dudy + dwdx*dudz + dwdy*dvdz )
-
-          IF ( def < 0.0_wp )  def = 0.0_wp
-
-          tend(k,j,i) = tend(k,j,i) + km(k,j,i) * def
-
-       ENDDO
-
-       IF ( constant_flux_layer )  THEN
-
-          IF ( ( wall_e_x(j,i) /= 0.0_wp ) .OR. ( wall_e_y(j,i) /= 0.0_wp ) )  THEN
-
-!
-!--          Position beneath wall
-!--          (2) - Will allways be executed.
-!--          'bottom and wall: use u_0,v_0 and wall functions'
-             k = nzb_diff_s_inner(j,i)-1
-
-             dudx = ( u(k,j,i+1) - u(k,j,i) ) * ddx
-             dudz = 0.5_wp * ( u(k+1,j,i) + u(k+1,j,i+1) - &
-                               u_0(j,i)   - u_0(j,i+1)   ) * dd2zu(k)
-             dvdy =          ( v(k,j+1,i) - v(k,j,i)     ) * ddy
-             dvdz = 0.5_wp * ( v(k+1,j,i) + v(k+1,j+1,i) - &
-                               v_0(j,i)   - v_0(j+1,i)   ) * dd2zu(k)
-             dwdz = ( w(k,j,i) - w(k-1,j,i) ) * ddzw(k)
-
-             IF ( wall_e_y(j,i) /= 0.0_wp )  THEN
-!
-!--             Inconsistency removed: as the thermal stratification 
-!--             is not taken into account for the evaluation of the 
-!--             wall fluxes at vertical walls, the eddy viscosity km 
-!--             must not be used for the evaluation of the velocity 
-!--             gradients dudy and dwdy
-!--             Note: The validity of the new method has not yet 
-!--                   been shown, as so far no suitable data for a 
-!--                   validation has been available
-                CALL wall_fluxes_e( i, j, k, nzb_diff_s_outer(j,i)-2, &
-                                    usvs, 1.0_wp, 0.0_wp, 0.0_wp, 0.0_wp )
-                CALL wall_fluxes_e( i, j, k, nzb_diff_s_outer(j,i)-2, &
-                                    wsvs, 0.0_wp, 0.0_wp, 1.0_wp, 0.0_wp )
-                km_neutral = kappa * ( usvs(k)**2 + wsvs(k)**2 )**0.25_wp * &
-                             0.5_wp * dy
-                IF ( km_neutral > 0.0_wp )  THEN
-                   dudy = - wall_e_y(j,i) * usvs(k) / km_neutral
-                   dwdy = - wall_e_y(j,i) * wsvs(k) / km_neutral
-                ELSE
-                   dudy = 0.0_wp
-                   dwdy = 0.0_wp
-                ENDIF
-             ELSE
-                dudy = 0.25_wp * ( u(k,j+1,i) + u(k,j+1,i+1) - &
-                                   u(k,j-1,i) - u(k,j-1,i+1) ) * ddy
-                dwdy = 0.25_wp * ( w(k,j+1,i) + w(k-1,j+1,i) - &
-                                   w(k,j-1,i) - w(k-1,j-1,i) ) * ddy
-             ENDIF
-
-             IF ( wall_e_x(j,i) /= 0.0_wp )  THEN
-!
-!--             Inconsistency removed: as the thermal stratification 
-!--             is not taken into account for the evaluation of the 
-!--             wall fluxes at vertical walls, the eddy viscosity km 
-!--             must not be used for the evaluation of the velocity 
-!--             gradients dvdx and dwdx
-!--             Note: The validity of the new method has not yet 
-!--                   been shown, as so far no suitable data for a 
-!--                   validation has been available
-                CALL wall_fluxes_e( i, j, k, nzb_diff_s_outer(j,i)-2, &
-                                    vsus, 0.0_wp, 1.0_wp, 0.0_wp, 0.0_wp )
-                CALL wall_fluxes_e( i, j, k, nzb_diff_s_outer(j,i)-2, &
-                                    wsus, 0.0_wp, 0.0_wp, 0.0_wp, 1.0_wp )
-                km_neutral = kappa * ( vsus(k)**2 + wsus(k)**2 )**0.25_wp * & 
-                             0.5_wp * dx
-                IF ( km_neutral > 0.0_wp )  THEN
-                   dvdx = - wall_e_x(j,i) * vsus(k) / km_neutral
-                   dwdx = - wall_e_x(j,i) * wsus(k) / km_neutral
-                ELSE
-                   dvdx = 0.0_wp
-                   dwdx = 0.0_wp
-                ENDIF
-             ELSE
-                dvdx = 0.25_wp * ( v(k,j,i+1) + v(k,j+1,i+1) - &
-                                   v(k,j,i-1) - v(k,j+1,i-1) ) * ddx
-                dwdx = 0.25_wp * ( w(k,j,i+1) + w(k-1,j,i+1) - &
-                                   w(k,j,i-1) - w(k-1,j,i-1) ) * ddx
-             ENDIF
-
-             def = 2.0_wp * ( dudx**2 + dvdy**2 + dwdz**2 ) +           &
-                   dudy**2 + dvdx**2 + dwdx**2 + dwdy**2 + dudz**2 + &
-                   dvdz**2 + 2.0_wp * ( dvdx*dudy + dwdx*dudz + dwdy*dvdz )
-
-             IF ( def < 0.0_wp )  def = 0.0_wp
-
-             tend(k,j,i) = tend(k,j,i) + km(k,j,i) * def
-
-!
-!--          (3) - will be executed only, if there is at least one level
-!--          between (2) and (4), i.e. the topography must have a
-!--          minimum height of 2 dz. Wall fluxes for this case have
-!--          already been calculated for (2).
-!--          'wall only: use wall functions'
-             DO  k = nzb_diff_s_inner(j,i), nzb_diff_s_outer(j,i)-2
-
-                dudx = ( u(k,j,i+1) - u(k,j,i) ) * ddx
-                dudz = 0.5_wp * ( u(k+1,j,i) + u(k+1,j,i+1) - &
-                                  u(k-1,j,i) - u(k-1,j,i+1) ) * dd2zu(k)
-                dvdy =          ( v(k,j+1,i) - v(k,j,i)     ) * ddy
-                dvdz = 0.5_wp * ( v(k+1,j,i) + v(k+1,j+1,i) - &
-                                  v(k-1,j,i) - v(k-1,j+1,i) ) * dd2zu(k)
-                dwdz = ( w(k,j,i) - w(k-1,j,i) ) * ddzw(k)
-
-                IF ( wall_e_y(j,i) /= 0.0_wp )  THEN
-!
-!--                Inconsistency removed: as the thermal stratification 
-!--                is not taken into account for the evaluation of the 
-!--                wall fluxes at vertical walls, the eddy viscosity km 
-!--                must not be used for the evaluation of the velocity 
-!--                gradients dudy and dwdy
-!--                Note: The validity of the new method has not yet 
-!--                      been shown, as so far no suitable data for a 
-!--                      validation has been available
-                   km_neutral = kappa * ( usvs(k)**2 + & 
-                                          wsvs(k)**2 )**0.25_wp * 0.5_wp * dy
-                   IF ( km_neutral > 0.0_wp )  THEN
-                      dudy = - wall_e_y(j,i) * usvs(k) / km_neutral
-                      dwdy = - wall_e_y(j,i) * wsvs(k) / km_neutral
-                   ELSE
-                      dudy = 0.0_wp
-                      dwdy = 0.0_wp
-                   ENDIF
-                ELSE
-                   dudy = 0.25_wp * ( u(k,j+1,i) + u(k,j+1,i+1) - &
-                                      u(k,j-1,i) - u(k,j-1,i+1) ) * ddy
-                   dwdy = 0.25_wp * ( w(k,j+1,i) + w(k-1,j+1,i) - &
-                                      w(k,j-1,i) - w(k-1,j-1,i) ) * ddy
-                ENDIF
-
-                IF ( wall_e_x(j,i) /= 0.0_wp )  THEN
-!
-!--                Inconsistency removed: as the thermal stratification 
-!--                is not taken into account for the evaluation of the 
-!--                wall fluxes at vertical walls, the eddy viscosity km 
-!--                must not be used for the evaluation of the velocity 
-!--                gradients dvdx and dwdx
-!--                Note: The validity of the new method has not yet 
-!--                      been shown, as so far no suitable data for a 
-!--                      validation has been available
-                   km_neutral = kappa * ( vsus(k)**2 + & 
-                                          wsus(k)**2 )**0.25_wp * 0.5_wp * dx
-                   IF ( km_neutral > 0.0_wp )  THEN
-                      dvdx = - wall_e_x(j,i) * vsus(k) / km_neutral
-                      dwdx = - wall_e_x(j,i) * wsus(k) / km_neutral
-                   ELSE
-                      dvdx = 0.0_wp
-                      dwdx = 0.0_wp
-                   ENDIF
-                ELSE
-                   dvdx = 0.25_wp * ( v(k,j,i+1) + v(k,j+1,i+1) - &
-                                      v(k,j,i-1) - v(k,j+1,i-1) ) * ddx
-                   dwdx = 0.25_wp * ( w(k,j,i+1) + w(k-1,j,i+1) - &
-                                      w(k,j,i-1) - w(k-1,j,i-1) ) * ddx
-                ENDIF
-
-                def = 2.0_wp * ( dudx**2 + dvdy**2 + dwdz**2 ) +           &
-                      dudy**2 + dvdx**2 + dwdx**2 + dwdy**2 + dudz**2 + &
-                      dvdz**2 + 2.0_wp * ( dvdx*dudy + dwdx*dudz + dwdy*dvdz )
-
-                IF ( def < 0.0_wp )  def = 0.0_wp
-
-                tend(k,j,i) = tend(k,j,i) + km(k,j,i) * def
-
-             ENDDO
-
-!
-!--          (4) - will allways be executed.
-!--          'special case: free atmosphere' (as for case (0))
-             k = nzb_diff_s_outer(j,i)-1
-
-             dudx  =           ( u(k,j,i+1) - u(k,j,i)     ) * ddx
-             dudy  = 0.25_wp * ( u(k,j+1,i) + u(k,j+1,i+1) - &
-                                 u(k,j-1,i) - u(k,j-1,i+1) ) * ddy
-             dudz  = 0.5_wp  * ( u(k+1,j,i) + u(k+1,j,i+1) - &
-                                 u(k-1,j,i) - u(k-1,j,i+1) ) * dd2zu(k)
-
-             dvdx  = 0.25_wp * ( v(k,j,i+1) + v(k,j+1,i+1) - &
-                                 v(k,j,i-1) - v(k,j+1,i-1) ) * ddx
-             dvdy  =           ( v(k,j+1,i) - v(k,j,i)     ) * ddy
-             dvdz  = 0.5_wp  * ( v(k+1,j,i) + v(k+1,j+1,i) - &
-                                 v(k-1,j,i) - v(k-1,j+1,i) ) * dd2zu(k)
-
-             dwdx  = 0.25_wp * ( w(k,j,i+1) + w(k-1,j,i+1) - &
-                                 w(k,j,i-1) - w(k-1,j,i-1) ) * ddx
-             dwdy  = 0.25_wp * ( w(k,j+1,i) + w(k-1,j+1,i) - &
-                                 w(k,j-1,i) - w(k-1,j-1,i) ) * ddy
-             dwdz  =           ( w(k,j,i)   - w(k-1,j,i)   ) * ddzw(k)
-
-             def = 2.0_wp * ( dudx**2 + dvdy**2 + dwdz**2 ) +        &
-                   dudy**2 + dvdx**2 + dwdx**2 + dwdy**2 + dudz**2 + &
-                   dvdz**2 + 2.0_wp * ( dvdx*dudy + dwdx*dudz + dwdy*dvdz )
-
-             IF ( def < 0.0_wp )  def = 0.0_wp
-
-             tend(k,j,i) = tend(k,j,i) + km(k,j,i) * def
-
-          ELSE
-
-!
-!--          Position without adjacent wall
-!--          (1) - will allways be executed. 
-!--          'bottom only: use u_0,v_0'
-             k = nzb_diff_s_inner(j,i)-1
-
-             dudx  =           ( u(k,j,i+1) - u(k,j,i)     ) * ddx
-             dudy  = 0.25_wp * ( u(k,j+1,i) + u(k,j+1,i+1) - &
-                                 u(k,j-1,i) - u(k,j-1,i+1) ) * ddy
-             dudz  = 0.5_wp  * ( u(k+1,j,i) + u(k+1,j,i+1) - &
-                                 u_0(j,i)   - u_0(j,i+1)   ) * dd2zu(k)
-
-             dvdx  = 0.25_wp * ( v(k,j,i+1) + v(k,j+1,i+1) - &
-                                 v(k,j,i-1) - v(k,j+1,i-1) ) * ddx
-             dvdy  =           ( v(k,j+1,i) - v(k,j,i)     ) * ddy
-             dvdz  = 0.5_wp  * ( v(k+1,j,i) + v(k+1,j+1,i) - &
-                                 v_0(j,i)   - v_0(j+1,i)   ) * dd2zu(k)
-
-             dwdx  = 0.25_wp * ( w(k,j,i+1) + w(k-1,j,i+1) - &
-                                 w(k,j,i-1) - w(k-1,j,i-1) ) * ddx
-             dwdy  = 0.25_wp * ( w(k,j+1,i) + w(k-1,j+1,i) - &
-                                 w(k,j-1,i) - w(k-1,j-1,i) ) * ddy
-             dwdz  =           ( w(k,j,i)   - w(k-1,j,i)   ) * ddzw(k)
-
-             def = 2.0_wp * ( dudx**2 + dvdy**2 + dwdz**2 )                       &
-                   + dudy**2 + dvdx**2 + dwdx**2 + dwdy**2 + dudz**2 + dvdz**2 &
-                   + 2.0_wp * ( dvdx*dudy + dwdx*dudz + dwdy*dvdz )
-
-             IF ( def < 0.0_wp )  def = 0.0_wp
-
-             tend(k,j,i) = tend(k,j,i) + km(k,j,i) * def
-
-          ENDIF
-
-       ELSEIF ( use_surface_fluxes )  THEN
-
-          k = nzb_diff_s_outer(j,i)-1
-
-          dudx  =           ( u(k,j,i+1) - u(k,j,i)     ) * ddx
-          dudy  = 0.25_wp * ( u(k,j+1,i) + u(k,j+1,i+1) - &
-                              u(k,j-1,i) - u(k,j-1,i+1) ) * ddy
-          dudz  = 0.5_wp  * ( u(k+1,j,i) + u(k+1,j,i+1) - &
-                              u(k-1,j,i) - u(k-1,j,i+1) ) * dd2zu(k)
-
-          dvdx  = 0.25_wp * ( v(k,j,i+1) + v(k,j+1,i+1) - &
-                              v(k,j,i-1) - v(k,j+1,i-1) ) * ddx
-          dvdy  =           ( v(k,j+1,i) - v(k,j,i)     ) * ddy
-          dvdz  = 0.5_wp  * ( v(k+1,j,i) + v(k+1,j+1,i) - &
-                              v(k-1,j,i) - v(k-1,j+1,i) ) * dd2zu(k)
-
-          dwdx  = 0.25_wp * ( w(k,j,i+1) + w(k-1,j,i+1) - &
-                              w(k,j,i-1) - w(k-1,j,i-1) ) * ddx
-          dwdy  = 0.25_wp * ( w(k,j+1,i) + w(k-1,j+1,i) - &
-                              w(k,j-1,i) - w(k-1,j-1,i) ) * ddy
-          dwdz  =           ( w(k,j,i)   - w(k-1,j,i)   ) * ddzw(k)
-
-          def = 2.0_wp * ( dudx**2 + dvdy**2 + dwdz**2 ) +           &
-                dudy**2 + dvdx**2 + dwdx**2 + dwdy**2 + dudz**2 + &
-                dvdz**2 + 2.0_wp * ( dvdx*dudy + dwdx*dudz + dwdy*dvdz )
-
-          IF ( def < 0.0_wp )  def = 0.0_wp
-
-          tend(k,j,i) = tend(k,j,i) + km(k,j,i) * def
-
-       ENDIF
-
-!
-!--    If required, calculate TKE production by buoyancy
-       IF ( .NOT. neutral )  THEN
-
-          IF ( .NOT. humidity )  THEN
-
-             IF ( use_single_reference_value )  THEN
-
-                IF ( ocean )  THEN
-!
-!--                So far in the ocean no special treatment of density flux in
-!--                the bottom and top surface layer
-                   DO  k = nzb_s_inner(j,i)+1, nzt
-                      tend(k,j,i) = tend(k,j,i) +                   &
-                                    kh(k,j,i) * g / rho_reference * &
-                                    ( rho(k+1,j,i) - rho(k-1,j,i) ) * dd2zu(k)
-                   ENDDO
-
-                ELSE
-
-                   DO  k = nzb_diff_s_inner(j,i), nzt_diff
-                      tend(k,j,i) = tend(k,j,i) -                  &
-                                    kh(k,j,i) * g / pt_reference * &
-                                    ( pt(k+1,j,i) - pt(k-1,j,i) ) * dd2zu(k)
-                   ENDDO
-
-                   IF ( use_surface_fluxes )  THEN
-                      k = nzb_diff_s_inner(j,i)-1
-                      tend(k,j,i) = tend(k,j,i) + g / pt_reference * shf(j,i)
-                   ENDIF
-
-                   IF ( use_top_fluxes )  THEN
-                      k = nzt
-                      tend(k,j,i) = tend(k,j,i) + g / pt_reference * tswst(j,i)
-                   ENDIF
-
-                ENDIF
-
-             ELSE
-
-                IF ( ocean )  THEN
-!
-!--                So far in the ocean no special treatment of density flux in
-!--                the bottom and top surface layer
-                   DO  k = nzb_s_inner(j,i)+1, nzt
-                      tend(k,j,i) = tend(k,j,i) +                &
-                                    kh(k,j,i) * g / rho(k,j,i) * &
-                                    ( rho(k+1,j,i) - rho(k-1,j,i) ) * dd2zu(k)
-                   ENDDO
-
-                ELSE
-
-                   DO  k = nzb_diff_s_inner(j,i), nzt_diff
-                      tend(k,j,i) = tend(k,j,i) -               &
-                                    kh(k,j,i) * g / pt(k,j,i) * &
-                                    ( pt(k+1,j,i) - pt(k-1,j,i) ) * dd2zu(k)
-                   ENDDO
-
-                   IF ( use_surface_fluxes )  THEN
-                      k = nzb_diff_s_inner(j,i)-1
-                      tend(k,j,i) = tend(k,j,i) + g / pt(k,j,i) * shf(j,i)
-                   ENDIF
-
-                   IF ( use_top_fluxes )  THEN
-                      k = nzt
-                      tend(k,j,i) = tend(k,j,i) + g / pt(k,j,i) * tswst(j,i)
-                   ENDIF
-
-                ENDIF
-
-             ENDIF
-
-          ELSE
-
-             DO  k = nzb_diff_s_inner(j,i), nzt_diff
-
-                IF ( .NOT. cloud_physics .AND. .NOT. cloud_droplets )  THEN
-                   k1 = 1.0_wp + 0.61_wp * q(k,j,i)
-                   k2 = 0.61_wp * pt(k,j,i)
-                   tend(k,j,i) = tend(k,j,i) - kh(k,j,i) * g / vpt(k,j,i) *   &
-                                         ( k1 * ( pt(k+1,j,i)-pt(k-1,j,i) ) + &
-                                           k2 * ( q(k+1,j,i) - q(k-1,j,i) )   &
-                                         ) * dd2zu(k)
-                ELSE IF ( cloud_physics )  THEN
-                   IF ( ql(k,j,i) == 0.0_wp )  THEN
-                      k1 = 1.0_wp + 0.61_wp * q(k,j,i)
-                      k2 = 0.61_wp * pt(k,j,i)
-                   ELSE
-                      theta = pt(k,j,i) + pt_d_t(k) * l_d_cp * ql(k,j,i)
-                      temp  = theta * t_d_pt(k)
-                      k1 = ( 1.0_wp - q(k,j,i) + 1.61_wp *                 &
-                                    ( q(k,j,i) - ql(k,j,i) ) *          &
-                           ( 1.0_wp + 0.622_wp * l_d_r / temp ) ) /        &
-                           ( 1.0_wp + 0.622_wp * l_d_r * l_d_cp *          &
-                           ( q(k,j,i) - ql(k,j,i) ) / ( temp * temp ) )
-                      k2 = theta * ( l_d_cp / temp * k1 - 1.0_wp )
-                   ENDIF
-                   tend(k,j,i) = tend(k,j,i) - kh(k,j,i) * g / vpt(k,j,i) *   &
-                                         ( k1 * ( pt(k+1,j,i)-pt(k-1,j,i) ) + &
-                                           k2 * ( q(k+1,j,i) - q(k-1,j,i) )   &
-                                         ) * dd2zu(k)
-                ELSE IF ( cloud_droplets )  THEN
-                   k1 = 1.0_wp + 0.61_wp * q(k,j,i) - ql(k,j,i)
-                   k2 = 0.61_wp * pt(k,j,i)
-                   tend(k,j,i) = tend(k,j,i) - kh(k,j,i) * g / vpt(k,j,i) *  &
-                                     ( k1 * ( pt(k+1,j,i)-pt(k-1,j,i) ) +    &
-                                       k2 * ( q(k+1,j,i) - q(k-1,j,i) ) -    &
-                                       pt(k,j,i) * ( ql(k+1,j,i) -           &
-                                                     ql(k-1,j,i) ) ) * dd2zu(k)
-                ENDIF
-             ENDDO
-
-             IF ( use_surface_fluxes )  THEN
-                k = nzb_diff_s_inner(j,i)-1
-
-                IF ( .NOT. cloud_physics .AND. .NOT. cloud_droplets )  THEN
-                   k1 = 1.0_wp + 0.61_wp * q(k,j,i)
-                   k2 = 0.61_wp * pt(k,j,i)
-                ELSE IF ( cloud_physics )  THEN
-                   IF ( ql(k,j,i) == 0.0_wp )  THEN
-                      k1 = 1.0_wp + 0.61_wp * q(k,j,i)
-                      k2 = 0.61_wp * pt(k,j,i)
-                   ELSE
-                      theta = pt(k,j,i) + pt_d_t(k) * l_d_cp * ql(k,j,i)
-                      temp  = theta * t_d_pt(k)
-                      k1 = ( 1.0_wp - q(k,j,i) + 1.61_wp *                 &
-                                    ( q(k,j,i) - ql(k,j,i) ) *          &
-                           ( 1.0_wp + 0.622_wp * l_d_r / temp ) ) /        &
-                           ( 1.0_wp + 0.622_wp * l_d_r * l_d_cp *          &
-                           ( q(k,j,i) - ql(k,j,i) ) / ( temp * temp ) )
-                      k2 = theta * ( l_d_cp / temp * k1 - 1.0_wp )
-                   ENDIF
-                ELSE IF ( cloud_droplets )  THEN
-                   k1 = 1.0_wp + 0.61_wp * q(k,j,i) - ql(k,j,i)
-                   k2 = 0.61_wp * pt(k,j,i)
-                ENDIF
-
-                tend(k,j,i) = tend(k,j,i) + g / vpt(k,j,i) * &
-                                            ( k1* shf(j,i) + k2 * qsws(j,i) )
-             ENDIF
-
-             IF ( use_top_fluxes )  THEN
-                k = nzt
-
-                IF ( .NOT. cloud_physics .AND. .NOT. cloud_droplets )  THEN
-                   k1 = 1.0_wp + 0.61_wp * q(k,j,i)
-                   k2 = 0.61_wp * pt(k,j,i)
-                ELSE IF ( cloud_physics )  THEN
-                   IF ( ql(k,j,i) == 0.0_wp )  THEN
-                      k1 = 1.0_wp + 0.61_wp * q(k,j,i)
-                      k2 = 0.61_wp * pt(k,j,i)
-                   ELSE
-                      theta = pt(k,j,i) + pt_d_t(k) * l_d_cp * ql(k,j,i)
-                      temp  = theta * t_d_pt(k)
-                      k1 = ( 1.0_wp - q(k,j,i) + 1.61_wp *                 &
-                                    ( q(k,j,i) - ql(k,j,i) ) *          &
-                           ( 1.0_wp + 0.622_wp * l_d_r / temp ) ) /        &
-                           ( 1.0_wp + 0.622_wp * l_d_r * l_d_cp *          &
-                           ( q(k,j,i) - ql(k,j,i) ) / ( temp * temp ) )
-                      k2 = theta * ( l_d_cp / temp * k1 - 1.0_wp )
-                   ENDIF
-                ELSE IF ( cloud_droplets )  THEN
-                   k1 = 1.0_wp + 0.61_wp * q(k,j,i) - ql(k,j,i)
-                   k2 = 0.61_wp * pt(k,j,i)
-                ENDIF
-
-                tend(k,j,i) = tend(k,j,i) + g / vpt(k,j,i) * &
-                                            ( k1* tswst(j,i) + k2 * qswst(j,i) )
-             ENDIF
-
-          ENDIF
-
-       ENDIF
-
-    END SUBROUTINE production_e_ij
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> @todo Missing subroutine description.
-!------------------------------------------------------------------------------!
-    SUBROUTINE production_e_init
-
-       USE arrays_3d,                                                          &
-           ONLY:  kh, km, u, us, usws, v, vsws, zu
-
-       USE control_parameters,                                                 &
-           ONLY:  constant_flux_layer, kappa
-
-       USE indices,                                                            &
-           ONLY:  nxl, nxlg, nxr, nxrg, nys, nysg, nyn, nyng, nzb_u_inner,     &
-                  nzb_v_inner
-
-       IMPLICIT NONE
-
-       INTEGER(iwp) ::  i   !<
-       INTEGER(iwp) ::  j   !<
-       INTEGER(iwp) ::  ku  !<
-       INTEGER(iwp) ::  kv  !<
-
-       IF ( constant_flux_layer )  THEN
-
-          IF ( first_call )  THEN
-             ALLOCATE( u_0(nysg:nyng,nxlg:nxrg), v_0(nysg:nyng,nxlg:nxrg) )
-             u_0 = 0.0_wp   ! just to avoid access of uninitialized memory
-             v_0 = 0.0_wp   ! within exchange_horiz_2d
-             first_call = .FALSE.
-          ENDIF
-
-!
-!--       Calculate a virtual velocity at the surface in a way that the
-!--       vertical velocity gradient at k = 1 (u(k+1)-u_0) matches the
-!--       Prandtl law (-w'u'/km). This gradient is used in the TKE shear
-!--       production term at k=1 (see production_e_ij).
-!--       The velocity gradient has to be limited in case of too small km
-!--       (otherwise the timestep may be significantly reduced by large
-!--       surface winds).
-!--       Upper bounds are nxr+1 and nyn+1 because otherwise these values are
-!--       not available in case of non-cyclic boundary conditions.
-!--       WARNING: the exact analytical solution would require the determination
-!--                of the eddy diffusivity by km = u* * kappa * zp / phi_m.
-          !$OMP PARALLEL DO PRIVATE( ku, kv )
-          DO  i = nxl, nxr+1
-             DO  j = nys, nyn+1
-
-                ku = nzb_u_inner(j,i)+1
-                kv = nzb_v_inner(j,i)+1
-
-                u_0(j,i) = u(ku+1,j,i) + usws(j,i) * ( zu(ku+1) - zu(ku-1) ) / &
-                                 ( 0.5_wp * ( km(ku,j,i) + km(ku,j,i-1) ) +    &
-                                   1.0E-20_wp )
-!                                  ( us(j,i) * kappa * zu(1) )
-                v_0(j,i) = v(kv+1,j,i) + vsws(j,i) * ( zu(kv+1) - zu(kv-1) ) / &
-                                 ( 0.5_wp * ( km(kv,j,i) + km(kv,j-1,i) ) +    &
-                                   1.0E-20_wp )
-!                                  ( us(j,i) * kappa * zu(1) )
-
-                IF ( ABS( u(ku+1,j,i) - u_0(j,i) )  > &
-                     ABS( u(ku+1,j,i) - u(ku-1,j,i) ) )  u_0(j,i) = u(ku-1,j,i)
-                IF ( ABS( v(kv+1,j,i) - v_0(j,i) )  > &
-                     ABS( v(kv+1,j,i) - v(kv-1,j,i) ) )  v_0(j,i) = v(kv-1,j,i)
-
-             ENDDO
-          ENDDO
-
-          CALL exchange_horiz_2d( u_0 )
-          CALL exchange_horiz_2d( v_0 )
-
-       ENDIF
-
-    END SUBROUTINE production_e_init
-
- END MODULE production_e_mod
Index: /palm/trunk/SOURCE/production_e_mod.f90
===================================================================
--- /palm/trunk/SOURCE/production_e_mod.f90	(revision 1850)
+++ /palm/trunk/SOURCE/production_e_mod.f90	(revision 1850)
@@ -0,0 +1,1995 @@
+!> @file production_e_mod.f90
+!--------------------------------------------------------------------------------!
+! This file is part of PALM.
+!
+! PALM is free software: you can redistribute it and/or modify it under the terms
+! of the GNU General Public License as published by the Free Software Foundation,
+! either version 3 of the License, or (at your option) any later version.
+!
+! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
+! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
+! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along with
+! PALM. If not, see <http://www.gnu.org/licenses/>.
+!
+! Copyright 1997-2016 Leibniz Universitaet Hannover
+!--------------------------------------------------------------------------------!
+!
+! Current revisions:
+! -----------------
+! Module renamed
+! 
+! 
+! Former revisions:
+! -----------------
+! $Id$
+!
+! 1691 2015-10-26 16:17:44Z maronga
+! Renamed prandtl_layer to constant_flux_layer.
+! 
+! 1682 2015-10-07 23:56:08Z knoop
+! Code annotations made doxygen readable 
+! 
+! 1374 2014-04-25 12:55:07Z raasch
+! nzb_s_outer removed from acc-present-list
+! 
+! 1353 2014-04-08 15:21:23Z heinze
+! REAL constants provided with KIND-attribute
+! 
+! 1342 2014-03-26 17:04:47Z kanani
+! REAL constants defined as wp-kind
+!
+! 1320 2014-03-20 08:40:49Z raasch
+! ONLY-attribute added to USE-statements,
+! kind-parameters added to all INTEGER and REAL declaration statements,
+! kinds are defined in new module kinds,
+! old module precision_kind is removed,
+! revision history before 2012 removed,
+! comment fields (!:) to be used for variable explanations added to
+! all variable declaration statements
+!
+! 1257 2013-11-08 15:18:40Z raasch
+! openacc loop and loop vector clauses removed, declare create moved after
+! the FORTRAN declaration statement
+!
+! 1179 2013-06-14 05:57:58Z raasch
+! use_reference renamed use_single_reference_value
+!
+! 1128 2013-04-12 06:19:32Z raasch
+! loop index bounds in accelerator version replaced by i_left, i_right, j_south,
+! j_north
+!
+! 1036 2012-10-22 13:43:42Z raasch
+! code put under GPL (PALM 3.9)
+!
+! 1015 2012-09-27 09:23:24Z raasch
+! accelerator version (*_acc) added
+!
+! 1007 2012-09-19 14:30:36Z franke
+! Bugfix: calculation of buoyancy production has to consider the liquid water
+! mixing ratio in case of cloud droplets
+!
+! 940 2012-07-09 14:31:00Z raasch
+! TKE production by buoyancy can be switched off in case of runs with pure
+! neutral stratification
+!
+! Revision 1.1  1997/09/19 07:45:35  raasch
+! Initial revision
+!
+!
+! Description:
+! ------------
+!> Production terms (shear + buoyancy) of the TKE.
+!> @warning The case with constant_flux_layer = F and use_surface_fluxes = T is
+!>          not considered well!
+!------------------------------------------------------------------------------!
+ MODULE production_e_mod
+ 
+
+    USE wall_fluxes_mod,                                                       &
+        ONLY:  wall_fluxes_e, wall_fluxes_e_acc
+
+    USE kinds
+
+    PRIVATE
+    PUBLIC production_e, production_e_acc, production_e_init
+
+    LOGICAL, SAVE ::  first_call = .TRUE.  !<
+
+    REAL(wp), DIMENSION(:,:), ALLOCATABLE, SAVE ::  u_0  !<
+    REAL(wp), DIMENSION(:,:), ALLOCATABLE, SAVE ::  v_0  !<
+
+    INTERFACE production_e
+       MODULE PROCEDURE production_e
+       MODULE PROCEDURE production_e_ij
+    END INTERFACE production_e
+    
+    INTERFACE production_e_acc
+       MODULE PROCEDURE production_e_acc
+    END INTERFACE production_e_acc
+
+    INTERFACE production_e_init
+       MODULE PROCEDURE production_e_init
+    END INTERFACE production_e_init
+ 
+ CONTAINS
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Call for all grid points
+!------------------------------------------------------------------------------!
+    SUBROUTINE production_e
+
+       USE arrays_3d,                                                          &
+           ONLY:  ddzw, dd2zu, kh, km, pt, q, ql, qsws, qswst, rho, shf,       &
+                  tend, tswst, u, v, vpt, w
+
+       USE cloud_parameters,                                                   &
+           ONLY:  l_d_cp, l_d_r, pt_d_t, t_d_pt
+
+       USE control_parameters,                                                 &
+           ONLY:  cloud_droplets, cloud_physics, constant_flux_layer, g,       &
+                  humidity, kappa, neutral, ocean, pt_reference,               &
+                  rho_reference, use_single_reference_value,                   &
+                  use_surface_fluxes, use_top_fluxes
+
+       USE grid_variables,                                                     &
+           ONLY:  ddx, dx, ddy, dy, wall_e_x, wall_e_y
+
+       USE indices,                                                            &
+           ONLY:  nxl, nxr, nys, nyn, nzb, nzb_diff_s_inner,                   &
+                   nzb_diff_s_outer, nzb_s_inner, nzt, nzt_diff
+
+       IMPLICIT NONE
+
+       INTEGER(iwp) ::  i           !<
+       INTEGER(iwp) ::  j           !<
+       INTEGER(iwp) ::  k           !<
+
+       REAL(wp)     ::  def         !<
+       REAL(wp)     ::  dudx        !<
+       REAL(wp)     ::  dudy        !<
+       REAL(wp)     ::  dudz        !<
+       REAL(wp)     ::  dvdx        !<
+       REAL(wp)     ::  dvdy        !<
+       REAL(wp)     ::  dvdz        !<
+       REAL(wp)     ::  dwdx        !<
+       REAL(wp)     ::  dwdy        !<
+       REAL(wp)     ::  dwdz        !<
+       REAL(wp)     ::  k1          !<
+       REAL(wp)     ::  k2          !<
+       REAL(wp)     ::  km_neutral  !<
+       REAL(wp)     ::  theta       !<
+       REAL(wp)     ::  temp        !<
+
+!       REAL(wp), DIMENSION(nzb:nzt+1,nys:nyn,nxl:nxr) ::  usvs, vsus, wsus, wsvs
+       REAL(wp), DIMENSION(nzb:nzt+1) ::  usvs  !<
+       REAL(wp), DIMENSION(nzb:nzt+1) ::  vsus  !<
+       REAL(wp), DIMENSION(nzb:nzt+1) ::  wsus  !<
+       REAL(wp), DIMENSION(nzb:nzt+1) ::  wsvs  !<
+
+!
+!--    First calculate horizontal momentum flux u'v', w'v', v'u', w'u' at
+!--    vertical walls, if neccessary
+!--    So far, results are slightly different from the ij-Version.
+!--    Therefore, ij-Version is called further below within the ij-loops.
+!       IF ( topography /= 'flat' )  THEN
+!          CALL wall_fluxes_e( usvs, 1.0_wp, 0.0_wp, 0.0_wp, 0.0_wp, wall_e_y )
+!          CALL wall_fluxes_e( wsvs, 0.0_wp, 0.0_wp, 1.0_wp, 0.0_wp, wall_e_y )
+!          CALL wall_fluxes_e( vsus, 0.0_wp, 1.0_wp, 0.0_wp, 0.0_wp, wall_e_x )
+!          CALL wall_fluxes_e( wsus, 0.0_wp, 0.0_wp, 0.0_wp, 1.0_wp, wall_e_x )
+!       ENDIF
+
+
+       DO  i = nxl, nxr
+
+!
+!--       Calculate TKE production by shear
+          DO  j = nys, nyn
+             DO  k = nzb_diff_s_outer(j,i), nzt
+
+                dudx  =           ( u(k,j,i+1) - u(k,j,i)     ) * ddx
+                dudy  = 0.25_wp * ( u(k,j+1,i) + u(k,j+1,i+1) - &
+                                    u(k,j-1,i) - u(k,j-1,i+1) ) * ddy
+                dudz  = 0.5_wp  * ( u(k+1,j,i) + u(k+1,j,i+1) - &
+                                    u(k-1,j,i) - u(k-1,j,i+1) ) * dd2zu(k)
+
+                dvdx  = 0.25_wp * ( v(k,j,i+1) + v(k,j+1,i+1) - &
+                                    v(k,j,i-1) - v(k,j+1,i-1) ) * ddx
+                dvdy  =           ( v(k,j+1,i) - v(k,j,i)     ) * ddy
+                dvdz  = 0.5_wp  * ( v(k+1,j,i) + v(k+1,j+1,i) - &
+                                    v(k-1,j,i) - v(k-1,j+1,i) ) * dd2zu(k)
+
+                dwdx  = 0.25_wp * ( w(k,j,i+1) + w(k-1,j,i+1) - &
+                                    w(k,j,i-1) - w(k-1,j,i-1) ) * ddx
+                dwdy  = 0.25_wp * ( w(k,j+1,i) + w(k-1,j+1,i) - &
+                                    w(k,j-1,i) - w(k-1,j-1,i) ) * ddy
+                dwdz  =           ( w(k,j,i)   - w(k-1,j,i)   ) * ddzw(k)
+
+                def = 2.0_wp * ( dudx**2 + dvdy**2 + dwdz**2 ) +           &
+                      dudy**2 + dvdx**2 + dwdx**2 + dwdy**2 + dudz**2 + &
+                      dvdz**2 + 2.0_wp * ( dvdx*dudy + dwdx*dudz + dwdy*dvdz )
+
+                IF ( def < 0.0_wp )  def = 0.0_wp
+
+                tend(k,j,i) = tend(k,j,i) + km(k,j,i) * def
+
+             ENDDO
+          ENDDO
+
+          IF ( constant_flux_layer )  THEN
+
+!
+!--          Position beneath wall
+!--          (2) - Will allways be executed.
+!--          'bottom and wall: use u_0,v_0 and wall functions'
+             DO  j = nys, nyn
+
+                IF ( ( wall_e_x(j,i) /= 0.0_wp ) .OR. ( wall_e_y(j,i) /= 0.0_wp ) ) &
+                THEN
+
+                   k = nzb_diff_s_inner(j,i) - 1
+                   dudx = ( u(k,j,i+1) - u(k,j,i) ) * ddx
+                   dudz = 0.5_wp * ( u(k+1,j,i) + u(k+1,j,i+1) - &
+                                     u_0(j,i)   - u_0(j,i+1)   ) * dd2zu(k)
+                   dvdy = ( v(k,j+1,i) - v(k,j,i) ) * ddy
+                   dvdz = 0.5_wp * ( v(k+1,j,i) + v(k+1,j+1,i) - &
+                                     v_0(j,i)   - v_0(j+1,i)   ) * dd2zu(k)
+                   dwdz = ( w(k,j,i) - w(k-1,j,i) ) * ddzw(k)
+
+                   IF ( wall_e_y(j,i) /= 0.0_wp )  THEN
+!
+!--                   Inconsistency removed: as the thermal stratification is 
+!--                   not taken into account for the evaluation of the wall 
+!--                   fluxes at vertical walls, the eddy viscosity km must not 
+!--                   be used for the evaluation of the velocity gradients dudy 
+!--                   and dwdy
+!--                   Note: The validity of the new method has not yet been 
+!--                         shown, as so far no suitable data for a validation 
+!--                         has been available
+                      CALL wall_fluxes_e( i, j, k, nzb_diff_s_outer(j,i)-2, &
+                                          usvs, 1.0_wp, 0.0_wp, 0.0_wp, 0.0_wp )
+                      CALL wall_fluxes_e( i, j, k, nzb_diff_s_outer(j,i)-2, &
+                                          wsvs, 0.0_wp, 0.0_wp, 1.0_wp, 0.0_wp )
+                      km_neutral = kappa * ( usvs(k)**2 + wsvs(k)**2 )**0.25_wp * &
+                                   0.5_wp * dy 
+                      IF ( km_neutral > 0.0_wp )  THEN
+                         dudy = - wall_e_y(j,i) * usvs(k) / km_neutral
+                         dwdy = - wall_e_y(j,i) * wsvs(k) / km_neutral
+                      ELSE
+                         dudy = 0.0_wp
+                         dwdy = 0.0_wp
+                      ENDIF
+                   ELSE
+                      dudy = 0.25_wp * ( u(k,j+1,i) + u(k,j+1,i+1) - &
+                                         u(k,j-1,i) - u(k,j-1,i+1) ) * ddy
+                      dwdy = 0.25_wp * ( w(k,j+1,i) + w(k-1,j+1,i) - &
+                                         w(k,j-1,i) - w(k-1,j-1,i) ) * ddy
+                   ENDIF
+
+                   IF ( wall_e_x(j,i) /= 0.0_wp )  THEN
+!
+!--                   Inconsistency removed: as the thermal stratification is 
+!--                   not taken into account for the evaluation of the wall 
+!--                   fluxes at vertical walls, the eddy viscosity km must not 
+!--                   be used for the evaluation of the velocity gradients dvdx 
+!--                   and dwdx
+!--                   Note: The validity of the new method has not yet been 
+!--                         shown, as so far no suitable data for a validation 
+!--                         has been available
+                      CALL wall_fluxes_e( i, j, k, nzb_diff_s_outer(j,i)-2, &
+                                          vsus, 0.0_wp, 1.0_wp, 0.0_wp, 0.0_wp )
+                      CALL wall_fluxes_e( i, j, k, nzb_diff_s_outer(j,i)-2, &
+                                          wsus, 0.0_wp, 0.0_wp, 0.0_wp, 1.0_wp )
+                      km_neutral = kappa * ( vsus(k)**2 + wsus(k)**2 )**0.25_wp * &
+                                   0.5_wp * dx
+                      IF ( km_neutral > 0.0_wp )  THEN
+                         dvdx = - wall_e_x(j,i) * vsus(k) / km_neutral
+                         dwdx = - wall_e_x(j,i) * wsus(k) / km_neutral
+                      ELSE
+                         dvdx = 0.0_wp
+                         dwdx = 0.0_wp
+                      ENDIF
+                   ELSE
+                      dvdx = 0.25_wp * ( v(k,j,i+1) + v(k,j+1,i+1) - &
+                                         v(k,j,i-1) - v(k,j+1,i-1) ) * ddx
+                      dwdx = 0.25_wp * ( w(k,j,i+1) + w(k-1,j,i+1) - &
+                                         w(k,j,i-1) - w(k-1,j,i-1) ) * ddx
+                   ENDIF
+
+                   def = 2.0_wp * ( dudx**2 + dvdy**2 + dwdz**2 ) +           &
+                         dudy**2 + dvdx**2 + dwdx**2 + dwdy**2 + dudz**2 + &
+                         dvdz**2 + 2.0_wp * ( dvdx*dudy + dwdx*dudz + dwdy*dvdz )
+
+                   IF ( def < 0.0_wp )  def = 0.0_wp
+
+                   tend(k,j,i) = tend(k,j,i) + km(k,j,i) * def
+
+
+!
+!--                (3) - will be executed only, if there is at least one level
+!--                between (2) and (4), i.e. the topography must have a
+!--                minimum height of 2 dz. Wall fluxes for this case have
+!--                already been calculated for (2).
+!--                'wall only: use wall functions'
+
+                   DO  k = nzb_diff_s_inner(j,i), nzb_diff_s_outer(j,i)-2
+
+                      dudx = ( u(k,j,i+1) - u(k,j,i) ) * ddx
+                      dudz = 0.5_wp * ( u(k+1,j,i) + u(k+1,j,i+1) - &
+                                        u(k-1,j,i) - u(k-1,j,i+1) ) * dd2zu(k)
+                      dvdy =          ( v(k,j+1,i) - v(k,j,i)     ) * ddy
+                      dvdz = 0.5_wp * ( v(k+1,j,i) + v(k+1,j+1,i) - &
+                                        v(k-1,j,i) - v(k-1,j+1,i) ) * dd2zu(k)
+                      dwdz = ( w(k,j,i) - w(k-1,j,i) ) * ddzw(k)
+
+                      IF ( wall_e_y(j,i) /= 0.0_wp )  THEN
+!
+!--                      Inconsistency removed: as the thermal stratification 
+!--                      is not taken into account for the evaluation of the 
+!--                      wall fluxes at vertical walls, the eddy viscosity km 
+!--                      must not be used for the evaluation of the velocity 
+!--                      gradients dudy and dwdy
+!--                      Note: The validity of the new method has not yet 
+!--                            been shown, as so far no suitable data for a 
+!--                            validation has been available
+                         km_neutral = kappa * ( usvs(k)**2 + & 
+                                                wsvs(k)**2 )**0.25_wp * 0.5_wp * dy
+                         IF ( km_neutral > 0.0_wp )  THEN
+                            dudy = - wall_e_y(j,i) * usvs(k) / km_neutral
+                            dwdy = - wall_e_y(j,i) * wsvs(k) / km_neutral
+                         ELSE
+                            dudy = 0.0_wp
+                            dwdy = 0.0_wp
+                         ENDIF
+                      ELSE
+                         dudy = 0.25_wp * ( u(k,j+1,i) + u(k,j+1,i+1) - &
+                                            u(k,j-1,i) - u(k,j-1,i+1) ) * ddy
+                         dwdy = 0.25_wp * ( w(k,j+1,i) + w(k-1,j+1,i) - &
+                                            w(k,j-1,i) - w(k-1,j-1,i) ) * ddy
+                      ENDIF
+
+                      IF ( wall_e_x(j,i) /= 0.0_wp )  THEN
+!
+!--                      Inconsistency removed: as the thermal stratification 
+!--                      is not taken into account for the evaluation of the 
+!--                      wall fluxes at vertical walls, the eddy viscosity km 
+!--                      must not be used for the evaluation of the velocity 
+!--                      gradients dvdx and dwdx
+!--                      Note: The validity of the new method has not yet 
+!--                            been shown, as so far no suitable data for a 
+!--                            validation has been available
+                         km_neutral = kappa * ( vsus(k)**2 + & 
+                                                wsus(k)**2 )**0.25_wp * 0.5_wp * dx
+                         IF ( km_neutral > 0.0_wp )  THEN
+                            dvdx = - wall_e_x(j,i) * vsus(k) / km_neutral
+                            dwdx = - wall_e_x(j,i) * wsus(k) / km_neutral
+                         ELSE
+                            dvdx = 0.0_wp
+                            dwdx = 0.0_wp
+                         ENDIF
+                      ELSE
+                         dvdx = 0.25_wp * ( v(k,j,i+1) + v(k,j+1,i+1) - &
+                                            v(k,j,i-1) - v(k,j+1,i-1) ) * ddx
+                         dwdx = 0.25_wp * ( w(k,j,i+1) + w(k-1,j,i+1) - &
+                                            w(k,j,i-1) - w(k-1,j,i-1) ) * ddx
+                      ENDIF
+
+                      def = 2.0_wp * ( dudx**2 + dvdy**2 + dwdz**2 ) +           &
+                           dudy**2 + dvdx**2 + dwdx**2 + dwdy**2 + dudz**2 +  &
+                           dvdz**2 + 2.0_wp * ( dvdx*dudy + dwdx*dudz + dwdy*dvdz )
+
+                      IF ( def < 0.0_wp )  def = 0.0_wp
+
+                      tend(k,j,i) = tend(k,j,i) + km(k,j,i) * def
+
+                   ENDDO
+
+                ENDIF
+
+             ENDDO
+
+!
+!--          (4) - will allways be executed.
+!--          'special case: free atmosphere' (as for case (0))
+             DO  j = nys, nyn
+
+                IF ( ( wall_e_x(j,i) /= 0.0_wp ) .OR. ( wall_e_y(j,i) /= 0.0_wp ) ) &
+                THEN
+
+                   k = nzb_diff_s_outer(j,i)-1
+
+                   dudx  =           ( u(k,j,i+1) - u(k,j,i)     ) * ddx
+                   dudy  = 0.25_wp * ( u(k,j+1,i) + u(k,j+1,i+1) - &
+                                       u(k,j-1,i) - u(k,j-1,i+1) ) * ddy
+                   dudz  = 0.5_wp  * ( u(k+1,j,i) + u(k+1,j,i+1) - &
+                                       u(k-1,j,i) - u(k-1,j,i+1) ) * dd2zu(k)
+
+                   dvdx  = 0.25_wp * ( v(k,j,i+1) + v(k,j+1,i+1) - &
+                                       v(k,j,i-1) - v(k,j+1,i-1) ) * ddx
+                   dvdy  =           ( v(k,j+1,i) - v(k,j,i)     ) * ddy
+                   dvdz  = 0.5_wp  * ( v(k+1,j,i) + v(k+1,j+1,i) - &
+                                       v(k-1,j,i) - v(k-1,j+1,i) ) * dd2zu(k)
+
+                   dwdx  = 0.25_wp * ( w(k,j,i+1) + w(k-1,j,i+1) - &
+                                       w(k,j,i-1) - w(k-1,j,i-1) ) * ddx
+                   dwdy  = 0.25_wp * ( w(k,j+1,i) + w(k-1,j+1,i) - &
+                                       w(k,j-1,i) - w(k-1,j-1,i) ) * ddy
+                   dwdz  =           ( w(k,j,i)   - w(k-1,j,i)   ) * ddzw(k)
+
+                   def = 2.0_wp * ( dudx**2 + dvdy**2 + dwdz**2 ) +           &
+                         dudy**2 + dvdx**2 + dwdx**2 + dwdy**2 + dudz**2 + &
+                         dvdz**2 + 2.0_wp * ( dvdx*dudy + dwdx*dudz + dwdy*dvdz )
+
+                   IF ( def < 0.0_wp )  def = 0.0_wp
+
+                   tend(k,j,i) = tend(k,j,i) + km(k,j,i) * def
+
+                ENDIF
+
+             ENDDO
+
+!
+!--          Position without adjacent wall
+!--          (1) - will allways be executed. 
+!--          'bottom only: use u_0,v_0'
+             DO  j = nys, nyn
+
+                IF ( ( wall_e_x(j,i) == 0.0_wp ) .AND. ( wall_e_y(j,i) == 0.0_wp ) ) &
+                THEN
+
+                   k = nzb_diff_s_inner(j,i)-1
+
+                   dudx  =           ( u(k,j,i+1) - u(k,j,i)     ) * ddx
+                   dudy  = 0.25_wp * ( u(k,j+1,i) + u(k,j+1,i+1) - &
+                                       u(k,j-1,i) - u(k,j-1,i+1) ) * ddy
+                   dudz  = 0.5_wp  * ( u(k+1,j,i) + u(k+1,j,i+1) - &
+                                       u_0(j,i)   - u_0(j,i+1)   ) * dd2zu(k)
+
+                   dvdx  = 0.25_wp * ( v(k,j,i+1) + v(k,j+1,i+1) - &
+                                       v(k,j,i-1) - v(k,j+1,i-1) ) * ddx
+                   dvdy  =           ( v(k,j+1,i) - v(k,j,i)     ) * ddy
+                   dvdz  = 0.5_wp  * ( v(k+1,j,i) + v(k+1,j+1,i) - &
+                                       v_0(j,i)   - v_0(j+1,i)   ) * dd2zu(k)
+
+                   dwdx  = 0.25_wp * ( w(k,j,i+1) + w(k-1,j,i+1) - &
+                                       w(k,j,i-1) - w(k-1,j,i-1) ) * ddx
+                   dwdy  = 0.25_wp * ( w(k,j+1,i) + w(k-1,j+1,i) - &
+                                       w(k,j-1,i) - w(k-1,j-1,i) ) * ddy
+                   dwdz  =           ( w(k,j,i)   - w(k-1,j,i)   ) * ddzw(k)
+
+                   def = 2.0_wp * ( dudx**2 + dvdy**2 + dwdz**2 ) +           &
+                         dudy**2 + dvdx**2 + dwdx**2 + dwdy**2 + dudz**2 + &
+                         dvdz**2 + 2.0_wp * ( dvdx*dudy + dwdx*dudz + dwdy*dvdz )
+
+                   IF ( def < 0.0_wp )  def = 0.0_wp
+
+                   tend(k,j,i) = tend(k,j,i) + km(k,j,i) * def
+
+                ENDIF
+
+             ENDDO
+
+          ELSEIF ( use_surface_fluxes )  THEN
+
+             DO  j = nys, nyn
+
+                k = nzb_diff_s_outer(j,i)-1
+
+                dudx  =           ( u(k,j,i+1) - u(k,j,i)     ) * ddx
+                dudy  = 0.25_wp * ( u(k,j+1,i) + u(k,j+1,i+1) - &
+                                    u(k,j-1,i) - u(k,j-1,i+1) ) * ddy
+                dudz  = 0.5_wp  * ( u(k+1,j,i) + u(k+1,j,i+1) - &
+                                   u(k-1,j,i) - u(k-1,j,i+1) ) * dd2zu(k)
+
+                dvdx  = 0.25_wp * ( v(k,j,i+1) + v(k,j+1,i+1) - &
+                                    v(k,j,i-1) - v(k,j+1,i-1) ) * ddx
+                dvdy  =           ( v(k,j+1,i) - v(k,j,i)     ) * ddy
+                dvdz  = 0.5_wp  * ( v(k+1,j,i) + v(k+1,j+1,i) - &
+                                    v(k-1,j,i) - v(k-1,j+1,i) ) * dd2zu(k)
+
+                dwdx  = 0.25_wp * ( w(k,j,i+1) + w(k-1,j,i+1) - &
+                                    w(k,j,i-1) - w(k-1,j,i-1) ) * ddx
+                dwdy  = 0.25_wp * ( w(k,j+1,i) + w(k-1,j+1,i) - &
+                                    w(k,j-1,i) - w(k-1,j-1,i) ) * ddy
+                dwdz  =           ( w(k,j,i)   - w(k-1,j,i)   ) * ddzw(k)
+
+                def = 2.0_wp * ( dudx**2 + dvdy**2 + dwdz**2 ) +           &
+                      dudy**2 + dvdx**2 + dwdx**2 + dwdy**2 + dudz**2 + &
+                      dvdz**2 + 2.0_wp * ( dvdx*dudy + dwdx*dudz + dwdy*dvdz )
+
+                IF ( def < 0.0_wp )  def = 0.0_wp
+
+                tend(k,j,i) = tend(k,j,i) + km(k,j,i) * def
+
+             ENDDO
+
+          ENDIF
+
+!
+!--       If required, calculate TKE production by buoyancy
+          IF ( .NOT. neutral )  THEN
+
+             IF ( .NOT. humidity )  THEN
+
+                IF ( use_single_reference_value )  THEN
+
+                   IF ( ocean )  THEN
+!
+!--                   So far in the ocean no special treatment of density flux
+!--                   in the bottom and top surface layer
+                      DO  j = nys, nyn
+                         DO  k = nzb_s_inner(j,i)+1, nzt
+                            tend(k,j,i) = tend(k,j,i) +                     &
+                                          kh(k,j,i) * g / rho_reference *   &
+                                          ( rho(k+1,j,i) - rho(k-1,j,i) ) * &
+                                          dd2zu(k)
+                         ENDDO
+                      ENDDO
+
+                   ELSE
+
+                      DO  j = nys, nyn
+                         DO  k = nzb_diff_s_inner(j,i), nzt_diff
+                            tend(k,j,i) = tend(k,j,i) -                   &
+                                          kh(k,j,i) * g / pt_reference *  &
+                                          ( pt(k+1,j,i) - pt(k-1,j,i) ) * &
+                                          dd2zu(k)
+                         ENDDO
+
+                         IF ( use_surface_fluxes )  THEN
+                            k = nzb_diff_s_inner(j,i)-1
+                            tend(k,j,i) = tend(k,j,i) + g / pt_reference * &
+                                                        shf(j,i)
+                         ENDIF
+
+                         IF ( use_top_fluxes )  THEN
+                            k = nzt
+                            tend(k,j,i) = tend(k,j,i) + g / pt_reference * &
+                                                        tswst(j,i)
+                         ENDIF
+                      ENDDO
+
+                   ENDIF
+
+                ELSE
+
+                   IF ( ocean )  THEN
+!
+!--                   So far in the ocean no special treatment of density flux
+!--                   in the bottom and top surface layer
+                      DO  j = nys, nyn
+                         DO  k = nzb_s_inner(j,i)+1, nzt
+                            tend(k,j,i) = tend(k,j,i) +                     &
+                                          kh(k,j,i) * g / rho(k,j,i) *      &
+                                          ( rho(k+1,j,i) - rho(k-1,j,i) ) * &
+                                          dd2zu(k)
+                         ENDDO
+                      ENDDO
+
+                   ELSE
+
+                      DO  j = nys, nyn
+                         DO  k = nzb_diff_s_inner(j,i), nzt_diff
+                            tend(k,j,i) = tend(k,j,i) -                   &
+                                          kh(k,j,i) * g / pt(k,j,i) *     &
+                                          ( pt(k+1,j,i) - pt(k-1,j,i) ) * &
+                                          dd2zu(k)
+                         ENDDO
+
+                         IF ( use_surface_fluxes )  THEN
+                            k = nzb_diff_s_inner(j,i)-1
+                            tend(k,j,i) = tend(k,j,i) + g / pt(k,j,i) * &
+                                                        shf(j,i)
+                         ENDIF
+
+                         IF ( use_top_fluxes )  THEN
+                            k = nzt
+                            tend(k,j,i) = tend(k,j,i) + g / pt(k,j,i) * &
+                                                        tswst(j,i)
+                         ENDIF
+                      ENDDO
+
+                   ENDIF
+
+                ENDIF
+
+             ELSE
+
+                DO  j = nys, nyn
+
+                   DO  k = nzb_diff_s_inner(j,i), nzt_diff
+
+                      IF ( .NOT. cloud_physics .AND. .NOT. cloud_droplets ) THEN
+                         k1 = 1.0_wp + 0.61_wp * q(k,j,i)
+                         k2 = 0.61_wp * pt(k,j,i)
+                         tend(k,j,i) = tend(k,j,i) - kh(k,j,i) *               &
+                                         g / vpt(k,j,i) *                      &
+                                         ( k1 * ( pt(k+1,j,i)-pt(k-1,j,i) ) +  &
+                                           k2 * ( q(k+1,j,i) - q(k-1,j,i) )    &
+                                         ) * dd2zu(k)
+                      ELSE IF ( cloud_physics )  THEN
+                         IF ( ql(k,j,i) == 0.0_wp )  THEN
+                            k1 = 1.0_wp + 0.61_wp * q(k,j,i)
+                            k2 = 0.61_wp * pt(k,j,i)
+                         ELSE
+                            theta = pt(k,j,i) + pt_d_t(k) * l_d_cp * ql(k,j,i)
+                            temp  = theta * t_d_pt(k)
+                            k1 = ( 1.0_wp - q(k,j,i) + 1.61_wp *               &
+                                          ( q(k,j,i) - ql(k,j,i) ) *          &
+                                 ( 1.0_wp + 0.622_wp * l_d_r / temp ) ) /        &
+                                 ( 1.0_wp + 0.622_wp * l_d_r * l_d_cp *          &
+                                 ( q(k,j,i) - ql(k,j,i) ) / ( temp * temp ) )
+                            k2 = theta * ( l_d_cp / temp * k1 - 1.0_wp )
+                         ENDIF
+                         tend(k,j,i) = tend(k,j,i) - kh(k,j,i) *               &
+                                         g / vpt(k,j,i) *                      &
+                                         ( k1 * ( pt(k+1,j,i)-pt(k-1,j,i) ) +  &
+                                           k2 * ( q(k+1,j,i) - q(k-1,j,i) )    &
+                                         ) * dd2zu(k)
+                      ELSE IF ( cloud_droplets )  THEN
+                         k1 = 1.0_wp + 0.61_wp * q(k,j,i) - ql(k,j,i)
+                         k2 = 0.61_wp * pt(k,j,i)
+                         tend(k,j,i) = tend(k,j,i) -                          & 
+                                       kh(k,j,i) * g / vpt(k,j,i) *           &
+                                       ( k1 * ( pt(k+1,j,i)- pt(k-1,j,i) ) +  &
+                                         k2 * ( q(k+1,j,i) -  q(k-1,j,i) ) -  &
+                                         pt(k,j,i) * ( ql(k+1,j,i) -          &
+                                         ql(k-1,j,i) ) ) * dd2zu(k)
+                      ENDIF
+
+                   ENDDO
+
+                ENDDO
+
+                IF ( use_surface_fluxes )  THEN
+
+                   DO  j = nys, nyn
+
+                      k = nzb_diff_s_inner(j,i)-1
+
+                      IF ( .NOT. cloud_physics .AND. .NOT. cloud_droplets ) THEN
+                         k1 = 1.0_wp + 0.61_wp * q(k,j,i)
+                         k2 = 0.61_wp * pt(k,j,i)
+                      ELSE IF ( cloud_physics )  THEN
+                         IF ( ql(k,j,i) == 0.0_wp )  THEN
+                            k1 = 1.0_wp + 0.61_wp * q(k,j,i)
+                            k2 = 0.61_wp * pt(k,j,i)
+                         ELSE
+                            theta = pt(k,j,i) + pt_d_t(k) * l_d_cp * ql(k,j,i)
+                            temp  = theta * t_d_pt(k)
+                            k1 = ( 1.0_wp - q(k,j,i) + 1.61_wp *               &
+                                          ( q(k,j,i) - ql(k,j,i) ) *           &
+                                 ( 1.0_wp + 0.622_wp * l_d_r / temp ) ) /      &
+                                 ( 1.0_wp + 0.622_wp * l_d_r * l_d_cp *        &
+                                 ( q(k,j,i) - ql(k,j,i) ) / ( temp * temp ) )
+                            k2 = theta * ( l_d_cp / temp * k1 - 1.0_wp )
+                         ENDIF
+                      ELSE IF ( cloud_droplets )  THEN
+                         k1 = 1.0_wp + 0.61_wp * q(k,j,i) - ql(k,j,i)
+                         k2 = 0.61_wp * pt(k,j,i)
+                      ENDIF
+
+                      tend(k,j,i) = tend(k,j,i) + g / vpt(k,j,i) * &
+                                            ( k1* shf(j,i) + k2 * qsws(j,i) )
+                   ENDDO
+
+                ENDIF
+
+                IF ( use_top_fluxes )  THEN
+
+                   DO  j = nys, nyn
+
+                      k = nzt
+
+                      IF ( .NOT. cloud_physics .AND. .NOT. cloud_droplets ) THEN
+                         k1 = 1.0_wp + 0.61_wp * q(k,j,i)
+                         k2 = 0.61_wp * pt(k,j,i)
+                      ELSE IF ( cloud_physics )  THEN
+                         IF ( ql(k,j,i) == 0.0_wp )  THEN
+                            k1 = 1.0_wp + 0.61_wp * q(k,j,i)
+                            k2 = 0.61_wp * pt(k,j,i)
+                         ELSE
+                            theta = pt(k,j,i) + pt_d_t(k) * l_d_cp * ql(k,j,i)
+                            temp  = theta * t_d_pt(k)
+                            k1 = ( 1.0_wp - q(k,j,i) + 1.61_wp *               &
+                                          ( q(k,j,i) - ql(k,j,i) ) *           &
+                                 ( 1.0_wp + 0.622_wp * l_d_r / temp ) ) /      &
+                                 ( 1.0_wp + 0.622_wp * l_d_r * l_d_cp *        &
+                                 ( q(k,j,i) - ql(k,j,i) ) / ( temp * temp ) )
+                            k2 = theta * ( l_d_cp / temp * k1 - 1.0_wp )
+                         ENDIF
+                      ELSE IF ( cloud_droplets )  THEN
+                         k1 = 1.0_wp + 0.61_wp * q(k,j,i) - ql(k,j,i)
+                         k2 = 0.61_wp * pt(k,j,i)
+                      ENDIF
+
+                      tend(k,j,i) = tend(k,j,i) + g / vpt(k,j,i) * &
+                                            ( k1* tswst(j,i) + k2 * qswst(j,i) )
+                   ENDDO
+
+                ENDIF
+
+             ENDIF
+
+          ENDIF
+
+       ENDDO
+
+    END SUBROUTINE production_e
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Call for all grid points - accelerator version
+!------------------------------------------------------------------------------!
+    SUBROUTINE production_e_acc
+
+       USE arrays_3d,                                                          &
+           ONLY:  ddzw, dd2zu, kh, km, pt, q, ql, qsws, qswst, rho, shf,       &
+                  tend, tswst, u, v, vpt, w
+
+       USE cloud_parameters,                                                   &
+           ONLY:  l_d_cp, l_d_r, pt_d_t, t_d_pt
+
+       USE control_parameters,                                                 &
+           ONLY:  cloud_droplets, cloud_physics, constant_flux_layer, g,       &
+                  humidity, kappa, neutral, ocean, pt_reference,               &
+                  rho_reference, topography, use_single_reference_value,       &
+                  use_surface_fluxes, use_top_fluxes
+
+       USE grid_variables,                                                     &
+           ONLY:  ddx, dx, ddy, dy, wall_e_x, wall_e_y
+
+       USE indices,                                                            &
+           ONLY:  i_left, i_right, j_north, j_south, nxl, nxr, nys, nyn, nzb,  &
+                  nzb_diff_s_inner, nzb_diff_s_outer, nzb_s_inner, nzt,        &
+                  nzt_diff
+
+       IMPLICIT NONE
+
+       INTEGER(iwp) ::  i           !<
+       INTEGER(iwp) ::  j           !<
+       INTEGER(iwp) ::  k           !<
+
+       REAL(wp)     ::  def         !<
+       REAL(wp)     ::  dudx        !<
+       REAL(wp)     ::  dudy        !<
+       REAL(wp)     ::  dudz        !<
+       REAL(wp)     ::  dvdx        !<
+       REAL(wp)     ::  dvdy        !<
+       REAL(wp)     ::  dvdz        !<
+       REAL(wp)     ::  dwdx        !<
+       REAL(wp)     ::  dwdy        !<
+       REAL(wp)     ::  dwdz        !<
+       REAL(wp)     ::  k1          !<
+       REAL(wp)     ::  k2          !<
+       REAL(wp)     ::  km_neutral  !<
+       REAL(wp)     ::  theta       !<
+       REAL(wp)     ::  temp        !<
+
+       REAL(wp), DIMENSION(nzb:nzt+1,nys:nyn,nxl:nxr) ::  usvs  !<
+       REAL(wp), DIMENSION(nzb:nzt+1,nys:nyn,nxl:nxr) ::  vsus  !<
+       REAL(wp), DIMENSION(nzb:nzt+1,nys:nyn,nxl:nxr) ::  wsus  !<
+       REAL(wp), DIMENSION(nzb:nzt+1,nys:nyn,nxl:nxr) ::  wsvs  !<
+       !$acc declare create ( usvs, vsus, wsus, wsvs )
+
+!
+!--    First calculate horizontal momentum flux u'v', w'v', v'u', w'u' at
+!--    vertical walls, if neccessary
+!--    CAUTION: results are slightly different from the ij-version!!
+!--    ij-version should be called further below within the ij-loops!!
+       IF ( topography /= 'flat' )  THEN
+          CALL wall_fluxes_e_acc( usvs, 1.0_wp, 0.0_wp, 0.0_wp, 0.0_wp, wall_e_y )
+          CALL wall_fluxes_e_acc( wsvs, 0.0_wp, 0.0_wp, 1.0_wp, 0.0_wp, wall_e_y )
+          CALL wall_fluxes_e_acc( vsus, 0.0_wp, 1.0_wp, 0.0_wp, 0.0_wp, wall_e_x )
+          CALL wall_fluxes_e_acc( wsus, 0.0_wp, 0.0_wp, 0.0_wp, 1.0_wp, wall_e_x )
+       ENDIF
+
+
+!
+!--    Calculate TKE production by shear
+       !$acc kernels present( ddzw, dd2zu, kh, km, nzb_diff_s_inner, nzb_diff_s_outer ) &
+       !$acc         present( nzb_s_inner, pt, q, ql, qsws, qswst, rho )                &
+       !$acc         present( shf, tend, tswst, u, v, vpt, w, wall_e_x, wall_e_y )      &
+       !$acc         copyin( u_0, v_0 )
+       DO  i = i_left, i_right
+          DO  j = j_south, j_north
+             DO  k = 1, nzt
+
+                IF ( k >= nzb_diff_s_outer(j,i) )  THEN
+
+                   dudx  =           ( u(k,j,i+1) - u(k,j,i)     ) * ddx
+                   dudy  = 0.25_wp * ( u(k,j+1,i) + u(k,j+1,i+1) - &
+                                       u(k,j-1,i) - u(k,j-1,i+1) ) * ddy
+                   dudz  = 0.5_wp  * ( u(k+1,j,i) + u(k+1,j,i+1) - &
+                                       u(k-1,j,i) - u(k-1,j,i+1) ) * dd2zu(k)
+
+                   dvdx  = 0.25_wp * ( v(k,j,i+1) + v(k,j+1,i+1) - &
+                                       v(k,j,i-1) - v(k,j+1,i-1) ) * ddx
+                   dvdy  =           ( v(k,j+1,i) - v(k,j,i)     ) * ddy
+                   dvdz  = 0.5_wp  * ( v(k+1,j,i) + v(k+1,j+1,i) - &
+                                       v(k-1,j,i) - v(k-1,j+1,i) ) * dd2zu(k)
+
+                   dwdx  = 0.25_wp * ( w(k,j,i+1) + w(k-1,j,i+1) - &
+                                       w(k,j,i-1) - w(k-1,j,i-1) ) * ddx
+                   dwdy  = 0.25_wp * ( w(k,j+1,i) + w(k-1,j+1,i) - &
+                                       w(k,j-1,i) - w(k-1,j-1,i) ) * ddy
+                   dwdz  =           ( w(k,j,i)   - w(k-1,j,i)   ) * ddzw(k)
+
+                   def = 2.0_wp * ( dudx**2 + dvdy**2 + dwdz**2 ) +           &
+                         dudy**2 + dvdx**2 + dwdx**2 + dwdy**2 + dudz**2 + &
+                         dvdz**2 + 2.0_wp * ( dvdx*dudy + dwdx*dudz + dwdy*dvdz )
+
+                   IF ( def < 0.0_wp )  def = 0.0_wp
+
+                   tend(k,j,i) = tend(k,j,i) + km(k,j,i) * def
+
+                ENDIF
+
+             ENDDO
+          ENDDO
+       ENDDO
+
+       IF ( constant_flux_layer )  THEN
+
+!
+!--       Position beneath wall
+!--       (2) - Will allways be executed.
+!--       'bottom and wall: use u_0,v_0 and wall functions'
+          DO  i = i_left, i_right
+             DO  j = j_south, j_north
+                DO  k = 1, nzt
+
+                   IF ( ( wall_e_x(j,i) /= 0.0_wp ).OR.( wall_e_y(j,i) /= 0.0_wp ) ) &
+                   THEN
+
+                      IF ( k == nzb_diff_s_inner(j,i) - 1 )  THEN
+                         dudx = ( u(k,j,i+1) - u(k,j,i) ) * ddx
+                         dudz = 0.5_wp * ( u(k+1,j,i) + u(k+1,j,i+1) - &
+                                           u_0(j,i)   - u_0(j,i+1)   ) * dd2zu(k)
+                         dvdy = ( v(k,j+1,i) - v(k,j,i) ) * ddy
+                         dvdz = 0.5_wp * ( v(k+1,j,i) + v(k+1,j+1,i) - &
+                                           v_0(j,i)   - v_0(j+1,i)   ) * dd2zu(k)
+                         dwdz = ( w(k,j,i) - w(k-1,j,i) ) * ddzw(k)
+
+                         IF ( wall_e_y(j,i) /= 0.0_wp )  THEN
+!
+!--                         Inconsistency removed: as the thermal stratification is
+!--                         not taken into account for the evaluation of the wall
+!--                         fluxes at vertical walls, the eddy viscosity km must not
+!--                         be used for the evaluation of the velocity gradients dudy
+!--                         and dwdy
+!--                         Note: The validity of the new method has not yet been
+!--                               shown, as so far no suitable data for a validation
+!--                               has been available
+!                            CALL wall_fluxes_e( i, j, k, nzb_diff_s_outer(j,i)-2, &
+!                                                usvs, 1.0_wp, 0.0_wp, 0.0_wp, 0.0_wp )
+!                            CALL wall_fluxes_e( i, j, k, nzb_diff_s_outer(j,i)-2, &
+!                                                wsvs, 0.0_wp, 0.0_wp, 1.0_wp, 0.0_wp )
+                            km_neutral = kappa *                                    &
+                                        ( usvs(k,j,i)**2 + wsvs(k,j,i)**2 )**0.25_wp * &
+                                         0.5_wp * dy
+                            IF ( km_neutral > 0.0_wp )  THEN
+                               dudy = - wall_e_y(j,i) * usvs(k,j,i) / km_neutral
+                               dwdy = - wall_e_y(j,i) * wsvs(k,j,i) / km_neutral
+                            ELSE
+                               dudy = 0.0_wp
+                               dwdy = 0.0_wp
+                            ENDIF
+                         ELSE
+                            dudy = 0.25_wp * ( u(k,j+1,i) + u(k,j+1,i+1) - &
+                                               u(k,j-1,i) - u(k,j-1,i+1) ) * ddy
+                            dwdy = 0.25_wp * ( w(k,j+1,i) + w(k-1,j+1,i) - &
+                                               w(k,j-1,i) - w(k-1,j-1,i) ) * ddy
+                         ENDIF
+
+                         IF ( wall_e_x(j,i) /= 0.0_wp )  THEN
+!
+!--                         Inconsistency removed: as the thermal stratification is
+!--                         not taken into account for the evaluation of the wall
+!--                         fluxes at vertical walls, the eddy viscosity km must not
+!--                         be used for the evaluation of the velocity gradients dvdx
+!--                         and dwdx
+!--                         Note: The validity of the new method has not yet been
+!--                               shown, as so far no suitable data for a validation
+!--                               has been available
+!                            CALL wall_fluxes_e( i, j, k, nzb_diff_s_outer(j,i)-2, &
+!                                                vsus, 0.0_wp, 1.0_wp, 0.0_wp, 0.0_wp )
+!                            CALL wall_fluxes_e( i, j, k, nzb_diff_s_outer(j,i)-2, &
+!                                                wsus, 0.0_wp, 0.0_wp, 0.0_wp, 1.0_wp )
+                            km_neutral = kappa *                                     &
+                                         ( vsus(k,j,i)**2 + wsus(k,j,i)**2 )**0.25_wp * &
+                                         0.5_wp * dx
+                            IF ( km_neutral > 0.0_wp )  THEN
+                               dvdx = - wall_e_x(j,i) * vsus(k,j,i) / km_neutral
+                               dwdx = - wall_e_x(j,i) * wsus(k,j,i) / km_neutral
+                            ELSE
+                               dvdx = 0.0_wp
+                               dwdx = 0.0_wp
+                            ENDIF
+                         ELSE
+                            dvdx = 0.25_wp * ( v(k,j,i+1) + v(k,j+1,i+1) - &
+                                               v(k,j,i-1) - v(k,j+1,i-1) ) * ddx
+                            dwdx = 0.25_wp * ( w(k,j,i+1) + w(k-1,j,i+1) - &
+                                               w(k,j,i-1) - w(k-1,j,i-1) ) * ddx
+                         ENDIF
+
+                         def = 2.0_wp * ( dudx**2 + dvdy**2 + dwdz**2 ) +           &
+                               dudy**2 + dvdx**2 + dwdx**2 + dwdy**2 + dudz**2 + &
+                               dvdz**2 + 2.0_wp * ( dvdx*dudy + dwdx*dudz + dwdy*dvdz )
+
+                         IF ( def < 0.0_wp )  def = 0.0_wp
+
+                         tend(k,j,i) = tend(k,j,i) + km(k,j,i) * def
+
+                      ENDIF
+!
+!--                   (3) - will be executed only, if there is at least one level
+!--                   between (2) and (4), i.e. the topography must have a
+!--                   minimum height of 2 dz. Wall fluxes for this case have
+!--                   already been calculated for (2).
+!--                   'wall only: use wall functions'
+
+                      IF ( k >= nzb_diff_s_inner(j,i)  .AND.  &
+                           k <= nzb_diff_s_outer(j,i)-2 )  THEN
+
+                         dudx = ( u(k,j,i+1) - u(k,j,i) ) * ddx
+                         dudz = 0.5_wp * ( u(k+1,j,i) + u(k+1,j,i+1) - &
+                                           u(k-1,j,i) - u(k-1,j,i+1) ) * dd2zu(k)
+                         dvdy =          ( v(k,j+1,i) - v(k,j,i)     ) * ddy
+                         dvdz = 0.5_wp * ( v(k+1,j,i) + v(k+1,j+1,i) - &
+                                           v(k-1,j,i) - v(k-1,j+1,i) ) * dd2zu(k)
+                         dwdz = ( w(k,j,i) - w(k-1,j,i) ) * ddzw(k)
+
+                         IF ( wall_e_y(j,i) /= 0.0_wp )  THEN
+!
+!--                         Inconsistency removed: as the thermal stratification
+!--                         is not taken into account for the evaluation of the
+!--                         wall fluxes at vertical walls, the eddy viscosity km
+!--                         must not be used for the evaluation of the velocity
+!--                         gradients dudy and dwdy
+!--                         Note: The validity of the new method has not yet
+!--                               been shown, as so far no suitable data for a
+!--                               validation has been available
+                            km_neutral = kappa * ( usvs(k,j,i)**2 + &
+                                                   wsvs(k,j,i)**2 )**0.25_wp * 0.5_wp * dy
+                            IF ( km_neutral > 0.0_wp )  THEN
+                               dudy = - wall_e_y(j,i) * usvs(k,j,i) / km_neutral
+                               dwdy = - wall_e_y(j,i) * wsvs(k,j,i) / km_neutral
+                            ELSE
+                               dudy = 0.0_wp
+                               dwdy = 0.0_wp
+                            ENDIF
+                         ELSE
+                            dudy = 0.25_wp * ( u(k,j+1,i) + u(k,j+1,i+1) - &
+                                               u(k,j-1,i) - u(k,j-1,i+1) ) * ddy
+                            dwdy = 0.25_wp * ( w(k,j+1,i) + w(k-1,j+1,i) - &
+                                               w(k,j-1,i) - w(k-1,j-1,i) ) * ddy
+                         ENDIF
+
+                         IF ( wall_e_x(j,i) /= 0.0_wp )  THEN
+!
+!--                         Inconsistency removed: as the thermal stratification
+!--                         is not taken into account for the evaluation of the
+!--                         wall fluxes at vertical walls, the eddy viscosity km
+!--                         must not be used for the evaluation of the velocity
+!--                         gradients dvdx and dwdx
+!--                         Note: The validity of the new method has not yet
+!--                               been shown, as so far no suitable data for a
+!--                               validation has been available
+                            km_neutral = kappa * ( vsus(k,j,i)**2 + &
+                                                   wsus(k,j,i)**2 )**0.25_wp * 0.5_wp * dx
+                            IF ( km_neutral > 0.0_wp )  THEN
+                               dvdx = - wall_e_x(j,i) * vsus(k,j,i) / km_neutral
+                               dwdx = - wall_e_x(j,i) * wsus(k,j,i) / km_neutral
+                            ELSE
+                               dvdx = 0.0_wp
+                               dwdx = 0.0_wp
+                            ENDIF
+                         ELSE
+                            dvdx = 0.25_wp * ( v(k,j,i+1) + v(k,j+1,i+1) - &
+                                               v(k,j,i-1) - v(k,j+1,i-1) ) * ddx
+                            dwdx = 0.25_wp * ( w(k,j,i+1) + w(k-1,j,i+1) - &
+                                               w(k,j,i-1) - w(k-1,j,i-1) ) * ddx
+                         ENDIF
+
+                         def = 2.0_wp * ( dudx**2 + dvdy**2 + dwdz**2 ) +           &
+                              dudy**2 + dvdx**2 + dwdx**2 + dwdy**2 + dudz**2 +  &
+                              dvdz**2 + 2.0_wp * ( dvdx*dudy + dwdx*dudz + dwdy*dvdz )
+
+                         IF ( def < 0.0_wp )  def = 0.0_wp
+
+                         tend(k,j,i) = tend(k,j,i) + km(k,j,i) * def
+
+                      ENDIF
+
+!
+!--                   (4) - will allways be executed.
+!--                   'special case: free atmosphere' (as for case (0))
+                      IF ( k == nzb_diff_s_outer(j,i)-1 )  THEN
+
+                         dudx  =           ( u(k,j,i+1) - u(k,j,i)     ) * ddx
+                         dudy  = 0.25_wp * ( u(k,j+1,i) + u(k,j+1,i+1) - &
+                                             u(k,j-1,i) - u(k,j-1,i+1) ) * ddy
+                         dudz  = 0.5_wp  * ( u(k+1,j,i) + u(k+1,j,i+1) - &
+                                             u(k-1,j,i) - u(k-1,j,i+1) ) * dd2zu(k)
+
+                         dvdx  = 0.25_wp * ( v(k,j,i+1) + v(k,j+1,i+1) - &
+                                             v(k,j,i-1) - v(k,j+1,i-1) ) * ddx
+                         dvdy  =           ( v(k,j+1,i) - v(k,j,i)     ) * ddy
+                         dvdz  = 0.5_wp  * ( v(k+1,j,i) + v(k+1,j+1,i) - &
+                                             v(k-1,j,i) - v(k-1,j+1,i) ) * dd2zu(k)
+
+                         dwdx  = 0.25_wp * ( w(k,j,i+1) + w(k-1,j,i+1) - &
+                                             w(k,j,i-1) - w(k-1,j,i-1) ) * ddx
+                         dwdy  = 0.25_wp * ( w(k,j+1,i) + w(k-1,j+1,i) - &
+                                             w(k,j-1,i) - w(k-1,j-1,i) ) * ddy
+                         dwdz  =           ( w(k,j,i)   - w(k-1,j,i)   ) * ddzw(k)
+
+                         def = 2.0_wp * ( dudx**2 + dvdy**2 + dwdz**2 ) +           &
+                               dudy**2 + dvdx**2 + dwdx**2 + dwdy**2 + dudz**2 + &
+                               dvdz**2 + 2.0_wp * ( dvdx*dudy + dwdx*dudz + dwdy*dvdz )
+
+                         IF ( def < 0.0_wp )  def = 0.0_wp
+
+                         tend(k,j,i) = tend(k,j,i) + km(k,j,i) * def
+
+                      ENDIF
+
+                   ENDIF
+
+                ENDDO
+             ENDDO
+          ENDDO
+
+!
+!--       Position without adjacent wall
+!--       (1) - will allways be executed.
+!--       'bottom only: use u_0,v_0'
+          DO  i = i_left, i_right
+             DO  j = j_south, j_north
+                DO  k = 1, nzt
+
+                   IF ( ( wall_e_x(j,i) == 0.0_wp ) .AND. ( wall_e_y(j,i) == 0.0_wp ) ) &
+                   THEN
+
+                      IF ( k == nzb_diff_s_inner(j,i)-1 )  THEN
+
+                         dudx  =           ( u(k,j,i+1) - u(k,j,i)     ) * ddx
+                         dudy  = 0.25_wp * ( u(k,j+1,i) + u(k,j+1,i+1) - &
+                                             u(k,j-1,i) - u(k,j-1,i+1) ) * ddy
+                         dudz  = 0.5_wp  * ( u(k+1,j,i) + u(k+1,j,i+1) - &
+                                             u_0(j,i)   - u_0(j,i+1)   ) * dd2zu(k)
+
+                         dvdx  = 0.25_wp * ( v(k,j,i+1) + v(k,j+1,i+1) - &
+                                             v(k,j,i-1) - v(k,j+1,i-1) ) * ddx
+                         dvdy  =           ( v(k,j+1,i) - v(k,j,i)     ) * ddy
+                         dvdz  = 0.5_wp  * ( v(k+1,j,i) + v(k+1,j+1,i) - &
+                                             v_0(j,i)   - v_0(j+1,i)   ) * dd2zu(k)
+
+                         dwdx  = 0.25_wp * ( w(k,j,i+1) + w(k-1,j,i+1) - &
+                                             w(k,j,i-1) - w(k-1,j,i-1) ) * ddx
+                         dwdy  = 0.25_wp * ( w(k,j+1,i) + w(k-1,j+1,i) - &
+                                             w(k,j-1,i) - w(k-1,j-1,i) ) * ddy
+                         dwdz  =           ( w(k,j,i)   - w(k-1,j,i)   ) * ddzw(k)
+
+                         def = 2.0_wp * ( dudx**2 + dvdy**2 + dwdz**2 ) +           &
+                               dudy**2 + dvdx**2 + dwdx**2 + dwdy**2 + dudz**2 + &
+                               dvdz**2 + 2.0_wp * ( dvdx*dudy + dwdx*dudz + dwdy*dvdz )
+
+                         IF ( def < 0.0_wp )  def = 0.0_wp
+
+                         tend(k,j,i) = tend(k,j,i) + km(k,j,i) * def
+
+                      ENDIF
+
+                   ENDIF
+
+                ENDDO
+             ENDDO
+          ENDDO
+
+       ELSEIF ( use_surface_fluxes )  THEN
+
+          DO  i = i_left, i_right
+             DO  j = j_south, j_north
+                 DO  k = 1, nzt
+
+                   IF ( k == nzb_diff_s_outer(j,i)-1 )  THEN
+
+                      dudx  =           ( u(k,j,i+1) - u(k,j,i)     ) * ddx
+                      dudy  = 0.25_wp * ( u(k,j+1,i) + u(k,j+1,i+1) - &
+                                          u(k,j-1,i) - u(k,j-1,i+1) ) * ddy
+                      dudz  = 0.5_wp  * ( u(k+1,j,i) + u(k+1,j,i+1) - &
+                                          u(k-1,j,i) - u(k-1,j,i+1) ) * dd2zu(k)
+
+                      dvdx  = 0.25_wp * ( v(k,j,i+1) + v(k,j+1,i+1) - &
+                                          v(k,j,i-1) - v(k,j+1,i-1) ) * ddx
+                      dvdy  =           ( v(k,j+1,i) - v(k,j,i)     ) * ddy
+                      dvdz  = 0.5_wp  * ( v(k+1,j,i) + v(k+1,j+1,i) - &
+                                          v(k-1,j,i) - v(k-1,j+1,i) ) * dd2zu(k)
+
+                      dwdx  = 0.25_wp * ( w(k,j,i+1) + w(k-1,j,i+1) - &
+                                          w(k,j,i-1) - w(k-1,j,i-1) ) * ddx
+                      dwdy  = 0.25_wp * ( w(k,j+1,i) + w(k-1,j+1,i) - &
+                                          w(k,j-1,i) - w(k-1,j-1,i) ) * ddy
+                      dwdz  =           ( w(k,j,i)   - w(k-1,j,i)   ) * ddzw(k)
+
+                      def = 2.0_wp * ( dudx**2 + dvdy**2 + dwdz**2 ) +           &
+                            dudy**2 + dvdx**2 + dwdx**2 + dwdy**2 + dudz**2 + &
+                            dvdz**2 + 2.0_wp * ( dvdx*dudy + dwdx*dudz + dwdy*dvdz )
+
+                      IF ( def < 0.0_wp )  def = 0.0_wp
+
+                      tend(k,j,i) = tend(k,j,i) + km(k,j,i) * def
+
+                   ENDIF
+
+                ENDDO
+             ENDDO
+          ENDDO
+
+       ENDIF
+
+!
+!--    If required, calculate TKE production by buoyancy
+       IF ( .NOT. neutral )  THEN
+
+          IF ( .NOT. humidity )  THEN
+
+             IF ( use_single_reference_value )  THEN
+
+                IF ( ocean )  THEN
+!
+!--                So far in the ocean no special treatment of density flux
+!--                in the bottom and top surface layer
+                   DO  i = i_left, i_right
+                      DO  j = j_south, j_north
+                         DO  k = 1, nzt
+                            IF ( k > nzb_s_inner(j,i) )  THEN
+                               tend(k,j,i) = tend(k,j,i) +                     &
+                                             kh(k,j,i) * g / rho_reference *   &
+                                             ( rho(k+1,j,i) - rho(k-1,j,i) ) * &
+                                             dd2zu(k)
+                            ENDIF
+                         ENDDO
+                      ENDDO
+                   ENDDO
+
+                ELSE
+
+                   DO  i = i_left, i_right
+                      DO  j = j_south, j_north
+                         DO  k = 1, nzt_diff
+                            IF ( k >= nzb_diff_s_inner(j,i) )  THEN
+                               tend(k,j,i) = tend(k,j,i) -                   &
+                                             kh(k,j,i) * g / pt_reference *  &
+                                             ( pt(k+1,j,i) - pt(k-1,j,i) ) * &
+                                             dd2zu(k)
+                            ENDIF
+
+                            IF ( k == nzb_diff_s_inner(j,i)-1  .AND.  &
+                                 use_surface_fluxes )  THEN
+                               tend(k,j,i) = tend(k,j,i) + g / pt_reference * &
+                                                           shf(j,i)
+                            ENDIF
+
+                            IF ( k == nzt  .AND.  use_top_fluxes )  THEN
+                               tend(k,j,i) = tend(k,j,i) + g / pt_reference * &
+                                                           tswst(j,i)
+                            ENDIF
+                         ENDDO
+                      ENDDO
+                   ENDDO
+
+                ENDIF
+
+             ELSE
+
+                IF ( ocean )  THEN
+!
+!--                So far in the ocean no special treatment of density flux
+!--                in the bottom and top surface layer
+                   DO  i = i_left, i_right
+                      DO  j = j_south, j_north
+                         DO  k = 1, nzt
+                            IF ( k > nzb_s_inner(j,i) )  THEN
+                               tend(k,j,i) = tend(k,j,i) +                     &
+                                             kh(k,j,i) * g / rho(k,j,i) *      &
+                                             ( rho(k+1,j,i) - rho(k-1,j,i) ) * &
+                                             dd2zu(k)
+                            ENDIF
+                         ENDDO
+                      ENDDO
+                   ENDDO
+
+                ELSE
+
+                   DO  i = i_left, i_right
+                      DO  j = j_south, j_north
+                         DO  k = 1, nzt_diff
+                            IF( k >= nzb_diff_s_inner(j,i) )  THEN
+                               tend(k,j,i) = tend(k,j,i) -                   &
+                                             kh(k,j,i) * g / pt(k,j,i) *     &
+                                             ( pt(k+1,j,i) - pt(k-1,j,i) ) * &
+                                             dd2zu(k)
+                            ENDIF
+
+                            IF (  k == nzb_diff_s_inner(j,i)-1  .AND.  &
+                                  use_surface_fluxes )  THEN
+                               tend(k,j,i) = tend(k,j,i) + g / pt(k,j,i) * &
+                                                           shf(j,i)
+                            ENDIF
+
+                            IF ( k == nzt  .AND.  use_top_fluxes )  THEN
+                               tend(k,j,i) = tend(k,j,i) + g / pt(k,j,i) * &
+                                                           tswst(j,i)
+                            ENDIF
+                         ENDDO
+                      ENDDO
+                   ENDDO
+
+                ENDIF
+
+             ENDIF
+
+          ELSE
+!
+!++          This part gives the PGI compiler problems in the previous loop
+!++          even without any acc statements????
+!             STOP '+++ production_e problems with acc-directives'
+!             !acc loop
+!             DO  i = nxl, nxr
+!                DO  j = nys, nyn
+!                   !acc loop vector
+!                   DO  k = 1, nzt_diff
+!
+!                      IF ( k >= nzb_diff_s_inner(j,i) )  THEN
+!
+!                         IF ( .NOT. cloud_physics .AND. .NOT. cloud_droplets ) THEN
+!                            k1 = 1.0_wp + 0.61_wp * q(k,j,i)
+!                            k2 = 0.61_wp * pt(k,j,i)
+!                            tend(k,j,i) = tend(k,j,i) - kh(k,j,i) *               &
+!                                            g / vpt(k,j,i) *                      &
+!                                            ( k1 * ( pt(k+1,j,i)-pt(k-1,j,i) ) +  &
+!                                              k2 * ( q(k+1,j,i) - q(k-1,j,i) )    &
+!                                            ) * dd2zu(k)
+!                         ELSE IF ( cloud_physics )  THEN
+!                            IF ( ql(k,j,i) == 0.0_wp )  THEN
+!                               k1 = 1.0_wp + 0.61_wp * q(k,j,i)
+!                               k2 = 0.61_wp * pt(k,j,i)
+!                            ELSE
+!                               theta = pt(k,j,i) + pt_d_t(k) * l_d_cp * ql(k,j,i)
+!                               temp  = theta * t_d_pt(k)
+!                               k1 = ( 1.0_wp - q(k,j,i) + 1.61_wp *                 &
+!                                             ( q(k,j,i) - ql(k,j,i) ) *          &
+!                                    ( 1.0_wp + 0.622_wp * l_d_r / temp ) ) /        &
+!                                    ( 1.0_wp + 0.622_wp * l_d_r * l_d_cp *          &
+!                                    ( q(k,j,i) - ql(k,j,i) ) / ( temp * temp ) )
+!                               k2 = theta * ( l_d_cp / temp * k1 - 1.0_wp )
+!                            ENDIF
+!                            tend(k,j,i) = tend(k,j,i) - kh(k,j,i) *               &
+!                                            g / vpt(k,j,i) *                      &
+!                                            ( k1 * ( pt(k+1,j,i)-pt(k-1,j,i) ) +  &
+!                                              k2 * ( q(k+1,j,i) - q(k-1,j,i) )    &
+!                                            ) * dd2zu(k)
+!                         ELSE IF ( cloud_droplets )  THEN
+!                            k1 = 1.0_wp + 0.61_wp * q(k,j,i) - ql(k,j,i)
+!                            k2 = 0.61_wp * pt(k,j,i)
+!                            tend(k,j,i) = tend(k,j,i) -                          &
+!                                          kh(k,j,i) * g / vpt(k,j,i) *           &
+!                                          ( k1 * ( pt(k+1,j,i)- pt(k-1,j,i) ) +  &
+!                                            k2 * ( q(k+1,j,i) -  q(k-1,j,i) ) -  &
+!                                            pt(k,j,i) * ( ql(k+1,j,i) -          &
+!                                            ql(k-1,j,i) ) ) * dd2zu(k)
+!                         ENDIF
+!
+!                      ENDIF
+!
+!                   ENDDO
+!                ENDDO
+!             ENDDO
+!
+
+!!++          Next two loops are probably very inefficiently parallellized
+!!++          and will require better optimization
+!             IF ( use_surface_fluxes )  THEN
+!
+!                !acc loop
+!                DO  i = nxl, nxr
+!                   DO  j = nys, nyn
+!                      !acc loop vector
+!                      DO  k = 1, nzt_diff
+!
+!                         IF ( k == nzb_diff_s_inner(j,i)-1 )  THEN
+!
+!                            IF ( .NOT. cloud_physics .AND. .NOT. cloud_droplets ) THEN
+!                               k1 = 1.0_wp + 0.61_wp * q(k,j,i)
+!                               k2 = 0.61_wp * pt(k,j,i)
+!                            ELSE IF ( cloud_physics )  THEN
+!                               IF ( ql(k,j,i) == 0.0_wp )  THEN
+!                                  k1 = 1.0_wp + 0.61_wp * q(k,j,i)
+!                                  k2 = 0.61_wp * pt(k,j,i)
+!                               ELSE
+!                                  theta = pt(k,j,i) + pt_d_t(k) * l_d_cp * ql(k,j,i)
+!                                  temp  = theta * t_d_pt(k)
+!                                  k1 = ( 1.0_wp - q(k,j,i) + 1.61_wp *        &
+!                                                ( q(k,j,i) - ql(k,j,i) ) *    &
+!                                       ( 1.0_wp + 0.622_wp * l_d_r / temp ) ) /&
+!                                       ( 1.0_wp + 0.622_wp * l_d_r * l_d_cp * &
+!                                       ( q(k,j,i) - ql(k,j,i) ) / ( temp * temp ) )
+!                                  k2 = theta * ( l_d_cp / temp * k1 - 1.0_wp )
+!                               ENDIF
+!                            ELSE IF ( cloud_droplets )  THEN
+!                               k1 = 1.0_wp + 0.61_wp * q(k,j,i) - ql(k,j,i)
+!                               k2 = 0.61_wp * pt(k,j,i)
+!                            ENDIF
+!
+!                            tend(k,j,i) = tend(k,j,i) + g / vpt(k,j,i) * &
+!                                                  ( k1* shf(j,i) + k2 * qsws(j,i) )
+!                         ENDIF
+!
+!                      ENDDO
+!                   ENDDO
+!                ENDDO
+!
+!             ENDIF
+!
+!             IF ( use_top_fluxes )  THEN
+!
+!                !acc loop
+!                DO  i = nxl, nxr
+!                   DO  j = nys, nyn
+!                      !acc loop vector
+!                      DO  k = 1, nzt
+!                         IF ( k == nzt )  THEN
+!
+!                            IF ( .NOT. cloud_physics .AND. .NOT. cloud_droplets ) THEN
+!                               k1 = 1.0_wp + 0.61_wp * q(k,j,i)
+!                               k2 = 0.61_wp * pt(k,j,i)
+!                            ELSE IF ( cloud_physics )  THEN
+!                               IF ( ql(k,j,i) == 0.0_wp )  THEN
+!                                  k1 = 1.0_wp + 0.61_wp * q(k,j,i)
+!                                  k2 = 0.61_wp * pt(k,j,i)
+!                               ELSE
+!                                  theta = pt(k,j,i) + pt_d_t(k) * l_d_cp * ql(k,j,i)
+!                                  temp  = theta * t_d_pt(k)
+!                                  k1 = ( 1.0_wp - q(k,j,i) + 1.61_wp *        &
+!                                                ( q(k,j,i) - ql(k,j,i) ) *    &
+!                                       ( 1.0_wp + 0.622_wp * l_d_r / temp ) ) /&
+!                                       ( 1.0_wp + 0.622_wp * l_d_r * l_d_cp * &
+!                                       ( q(k,j,i) - ql(k,j,i) ) / ( temp * temp ) )
+!                                  k2 = theta * ( l_d_cp / temp * k1 - 1.0_wp )
+!                               ENDIF
+!                            ELSE IF ( cloud_droplets )  THEN
+!                               k1 = 1.0_wp + 0.61_wp * q(k,j,i) - ql(k,j,i)
+!                               k2 = 0.61_wp * pt(k,j,i)
+!                            ENDIF
+!
+!                            tend(k,j,i) = tend(k,j,i) + g / vpt(k,j,i) * &
+!                                                  ( k1* tswst(j,i) + k2 * qswst(j,i) )
+!
+!                         ENDIF
+!
+!                      ENDDO
+!                   ENDDO
+!                ENDDO
+!
+!             ENDIF
+
+          ENDIF
+
+       ENDIF
+       !$acc end kernels
+
+    END SUBROUTINE production_e_acc
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Call for grid point i,j
+!------------------------------------------------------------------------------!
+    SUBROUTINE production_e_ij( i, j )
+
+       USE arrays_3d,                                                          &
+           ONLY:  ddzw, dd2zu, kh, km, pt, q, ql, qsws, qswst, rho, shf,       &
+                  tend, tswst, u, v, vpt, w
+
+       USE cloud_parameters,                                                   &
+           ONLY:  l_d_cp, l_d_r, pt_d_t, t_d_pt
+
+       USE control_parameters,                                                 &
+           ONLY:  cloud_droplets, cloud_physics, constant_flux_layer, g,       &
+                  humidity, kappa, neutral, ocean, pt_reference,               &
+                  rho_reference, use_single_reference_value,                   &
+                  use_surface_fluxes, use_top_fluxes
+
+       USE grid_variables,                                                     &
+           ONLY:  ddx, dx, ddy, dy, wall_e_x, wall_e_y
+
+       USE indices,                                                            &
+           ONLY:  nxl, nxr, nys, nyn, nzb, nzb_diff_s_inner,                   &
+                  nzb_diff_s_outer, nzb_s_inner, nzt, nzt_diff
+
+       IMPLICIT NONE
+
+       INTEGER(iwp) ::  i           !<
+       INTEGER(iwp) ::  j           !<
+       INTEGER(iwp) ::  k           !<
+
+       REAL(wp)     ::  def         !<
+       REAL(wp)     ::  dudx        !<
+       REAL(wp)     ::  dudy        !<
+       REAL(wp)     ::  dudz        !<
+       REAL(wp)     ::  dvdx        !<
+       REAL(wp)     ::  dvdy        !<
+       REAL(wp)     ::  dvdz        !<
+       REAL(wp)     ::  dwdx        !<
+       REAL(wp)     ::  dwdy        !<
+       REAL(wp)     ::  dwdz        !<
+       REAL(wp)     ::  k1          !<
+       REAL(wp)     ::  k2          !<
+       REAL(wp)     ::  km_neutral  !<
+       REAL(wp)     ::  theta       !<
+       REAL(wp)     ::  temp        !<
+
+       REAL(wp), DIMENSION(nzb:nzt+1) ::  usvs  !<
+       REAL(wp), DIMENSION(nzb:nzt+1) ::  vsus  !<
+       REAL(wp), DIMENSION(nzb:nzt+1) ::  wsus  !<
+       REAL(wp), DIMENSION(nzb:nzt+1) ::  wsvs  !<
+
+!
+!--    Calculate TKE production by shear
+       DO  k = nzb_diff_s_outer(j,i), nzt
+
+          dudx  =           ( u(k,j,i+1) - u(k,j,i)     ) * ddx
+          dudy  = 0.25_wp * ( u(k,j+1,i) + u(k,j+1,i+1) - &
+                              u(k,j-1,i) - u(k,j-1,i+1) ) * ddy
+          dudz  = 0.5_wp  * ( u(k+1,j,i) + u(k+1,j,i+1) - &
+                              u(k-1,j,i) - u(k-1,j,i+1) ) * dd2zu(k)
+
+          dvdx  = 0.25_wp * ( v(k,j,i+1) + v(k,j+1,i+1) - &
+                              v(k,j,i-1) - v(k,j+1,i-1) ) * ddx
+          dvdy  =           ( v(k,j+1,i) - v(k,j,i)     ) * ddy
+          dvdz  = 0.5_wp  * ( v(k+1,j,i) + v(k+1,j+1,i) - &
+                              v(k-1,j,i) - v(k-1,j+1,i) ) * dd2zu(k)
+
+          dwdx  = 0.25_wp * ( w(k,j,i+1) + w(k-1,j,i+1) - &
+                              w(k,j,i-1) - w(k-1,j,i-1) ) * ddx
+          dwdy  = 0.25_wp * ( w(k,j+1,i) + w(k-1,j+1,i) - &
+                              w(k,j-1,i) - w(k-1,j-1,i) ) * ddy
+          dwdz  =           ( w(k,j,i)   - w(k-1,j,i)   ) * ddzw(k)
+
+          def = 2.0_wp * ( dudx**2 + dvdy**2 + dwdz**2 )                       &
+                + dudy**2 + dvdx**2 + dwdx**2 + dwdy**2 + dudz**2 + dvdz**2    &
+                + 2.0_wp * ( dvdx*dudy + dwdx*dudz + dwdy*dvdz )
+
+          IF ( def < 0.0_wp )  def = 0.0_wp
+
+          tend(k,j,i) = tend(k,j,i) + km(k,j,i) * def
+
+       ENDDO
+
+       IF ( constant_flux_layer )  THEN
+
+          IF ( ( wall_e_x(j,i) /= 0.0_wp ) .OR. ( wall_e_y(j,i) /= 0.0_wp ) )  THEN
+
+!
+!--          Position beneath wall
+!--          (2) - Will allways be executed.
+!--          'bottom and wall: use u_0,v_0 and wall functions'
+             k = nzb_diff_s_inner(j,i)-1
+
+             dudx = ( u(k,j,i+1) - u(k,j,i) ) * ddx
+             dudz = 0.5_wp * ( u(k+1,j,i) + u(k+1,j,i+1) - &
+                               u_0(j,i)   - u_0(j,i+1)   ) * dd2zu(k)
+             dvdy =          ( v(k,j+1,i) - v(k,j,i)     ) * ddy
+             dvdz = 0.5_wp * ( v(k+1,j,i) + v(k+1,j+1,i) - &
+                               v_0(j,i)   - v_0(j+1,i)   ) * dd2zu(k)
+             dwdz = ( w(k,j,i) - w(k-1,j,i) ) * ddzw(k)
+
+             IF ( wall_e_y(j,i) /= 0.0_wp )  THEN
+!
+!--             Inconsistency removed: as the thermal stratification 
+!--             is not taken into account for the evaluation of the 
+!--             wall fluxes at vertical walls, the eddy viscosity km 
+!--             must not be used for the evaluation of the velocity 
+!--             gradients dudy and dwdy
+!--             Note: The validity of the new method has not yet 
+!--                   been shown, as so far no suitable data for a 
+!--                   validation has been available
+                CALL wall_fluxes_e( i, j, k, nzb_diff_s_outer(j,i)-2, &
+                                    usvs, 1.0_wp, 0.0_wp, 0.0_wp, 0.0_wp )
+                CALL wall_fluxes_e( i, j, k, nzb_diff_s_outer(j,i)-2, &
+                                    wsvs, 0.0_wp, 0.0_wp, 1.0_wp, 0.0_wp )
+                km_neutral = kappa * ( usvs(k)**2 + wsvs(k)**2 )**0.25_wp * &
+                             0.5_wp * dy
+                IF ( km_neutral > 0.0_wp )  THEN
+                   dudy = - wall_e_y(j,i) * usvs(k) / km_neutral
+                   dwdy = - wall_e_y(j,i) * wsvs(k) / km_neutral
+                ELSE
+                   dudy = 0.0_wp
+                   dwdy = 0.0_wp
+                ENDIF
+             ELSE
+                dudy = 0.25_wp * ( u(k,j+1,i) + u(k,j+1,i+1) - &
+                                   u(k,j-1,i) - u(k,j-1,i+1) ) * ddy
+                dwdy = 0.25_wp * ( w(k,j+1,i) + w(k-1,j+1,i) - &
+                                   w(k,j-1,i) - w(k-1,j-1,i) ) * ddy
+             ENDIF
+
+             IF ( wall_e_x(j,i) /= 0.0_wp )  THEN
+!
+!--             Inconsistency removed: as the thermal stratification 
+!--             is not taken into account for the evaluation of the 
+!--             wall fluxes at vertical walls, the eddy viscosity km 
+!--             must not be used for the evaluation of the velocity 
+!--             gradients dvdx and dwdx
+!--             Note: The validity of the new method has not yet 
+!--                   been shown, as so far no suitable data for a 
+!--                   validation has been available
+                CALL wall_fluxes_e( i, j, k, nzb_diff_s_outer(j,i)-2, &
+                                    vsus, 0.0_wp, 1.0_wp, 0.0_wp, 0.0_wp )
+                CALL wall_fluxes_e( i, j, k, nzb_diff_s_outer(j,i)-2, &
+                                    wsus, 0.0_wp, 0.0_wp, 0.0_wp, 1.0_wp )
+                km_neutral = kappa * ( vsus(k)**2 + wsus(k)**2 )**0.25_wp * & 
+                             0.5_wp * dx
+                IF ( km_neutral > 0.0_wp )  THEN
+                   dvdx = - wall_e_x(j,i) * vsus(k) / km_neutral
+                   dwdx = - wall_e_x(j,i) * wsus(k) / km_neutral
+                ELSE
+                   dvdx = 0.0_wp
+                   dwdx = 0.0_wp
+                ENDIF
+             ELSE
+                dvdx = 0.25_wp * ( v(k,j,i+1) + v(k,j+1,i+1) - &
+                                   v(k,j,i-1) - v(k,j+1,i-1) ) * ddx
+                dwdx = 0.25_wp * ( w(k,j,i+1) + w(k-1,j,i+1) - &
+                                   w(k,j,i-1) - w(k-1,j,i-1) ) * ddx
+             ENDIF
+
+             def = 2.0_wp * ( dudx**2 + dvdy**2 + dwdz**2 ) +           &
+                   dudy**2 + dvdx**2 + dwdx**2 + dwdy**2 + dudz**2 + &
+                   dvdz**2 + 2.0_wp * ( dvdx*dudy + dwdx*dudz + dwdy*dvdz )
+
+             IF ( def < 0.0_wp )  def = 0.0_wp
+
+             tend(k,j,i) = tend(k,j,i) + km(k,j,i) * def
+
+!
+!--          (3) - will be executed only, if there is at least one level
+!--          between (2) and (4), i.e. the topography must have a
+!--          minimum height of 2 dz. Wall fluxes for this case have
+!--          already been calculated for (2).
+!--          'wall only: use wall functions'
+             DO  k = nzb_diff_s_inner(j,i), nzb_diff_s_outer(j,i)-2
+
+                dudx = ( u(k,j,i+1) - u(k,j,i) ) * ddx
+                dudz = 0.5_wp * ( u(k+1,j,i) + u(k+1,j,i+1) - &
+                                  u(k-1,j,i) - u(k-1,j,i+1) ) * dd2zu(k)
+                dvdy =          ( v(k,j+1,i) - v(k,j,i)     ) * ddy
+                dvdz = 0.5_wp * ( v(k+1,j,i) + v(k+1,j+1,i) - &
+                                  v(k-1,j,i) - v(k-1,j+1,i) ) * dd2zu(k)
+                dwdz = ( w(k,j,i) - w(k-1,j,i) ) * ddzw(k)
+
+                IF ( wall_e_y(j,i) /= 0.0_wp )  THEN
+!
+!--                Inconsistency removed: as the thermal stratification 
+!--                is not taken into account for the evaluation of the 
+!--                wall fluxes at vertical walls, the eddy viscosity km 
+!--                must not be used for the evaluation of the velocity 
+!--                gradients dudy and dwdy
+!--                Note: The validity of the new method has not yet 
+!--                      been shown, as so far no suitable data for a 
+!--                      validation has been available
+                   km_neutral = kappa * ( usvs(k)**2 + & 
+                                          wsvs(k)**2 )**0.25_wp * 0.5_wp * dy
+                   IF ( km_neutral > 0.0_wp )  THEN
+                      dudy = - wall_e_y(j,i) * usvs(k) / km_neutral
+                      dwdy = - wall_e_y(j,i) * wsvs(k) / km_neutral
+                   ELSE
+                      dudy = 0.0_wp
+                      dwdy = 0.0_wp
+                   ENDIF
+                ELSE
+                   dudy = 0.25_wp * ( u(k,j+1,i) + u(k,j+1,i+1) - &
+                                      u(k,j-1,i) - u(k,j-1,i+1) ) * ddy
+                   dwdy = 0.25_wp * ( w(k,j+1,i) + w(k-1,j+1,i) - &
+                                      w(k,j-1,i) - w(k-1,j-1,i) ) * ddy
+                ENDIF
+
+                IF ( wall_e_x(j,i) /= 0.0_wp )  THEN
+!
+!--                Inconsistency removed: as the thermal stratification 
+!--                is not taken into account for the evaluation of the 
+!--                wall fluxes at vertical walls, the eddy viscosity km 
+!--                must not be used for the evaluation of the velocity 
+!--                gradients dvdx and dwdx
+!--                Note: The validity of the new method has not yet 
+!--                      been shown, as so far no suitable data for a 
+!--                      validation has been available
+                   km_neutral = kappa * ( vsus(k)**2 + & 
+                                          wsus(k)**2 )**0.25_wp * 0.5_wp * dx
+                   IF ( km_neutral > 0.0_wp )  THEN
+                      dvdx = - wall_e_x(j,i) * vsus(k) / km_neutral
+                      dwdx = - wall_e_x(j,i) * wsus(k) / km_neutral
+                   ELSE
+                      dvdx = 0.0_wp
+                      dwdx = 0.0_wp
+                   ENDIF
+                ELSE
+                   dvdx = 0.25_wp * ( v(k,j,i+1) + v(k,j+1,i+1) - &
+                                      v(k,j,i-1) - v(k,j+1,i-1) ) * ddx
+                   dwdx = 0.25_wp * ( w(k,j,i+1) + w(k-1,j,i+1) - &
+                                      w(k,j,i-1) - w(k-1,j,i-1) ) * ddx
+                ENDIF
+
+                def = 2.0_wp * ( dudx**2 + dvdy**2 + dwdz**2 ) +           &
+                      dudy**2 + dvdx**2 + dwdx**2 + dwdy**2 + dudz**2 + &
+                      dvdz**2 + 2.0_wp * ( dvdx*dudy + dwdx*dudz + dwdy*dvdz )
+
+                IF ( def < 0.0_wp )  def = 0.0_wp
+
+                tend(k,j,i) = tend(k,j,i) + km(k,j,i) * def
+
+             ENDDO
+
+!
+!--          (4) - will allways be executed.
+!--          'special case: free atmosphere' (as for case (0))
+             k = nzb_diff_s_outer(j,i)-1
+
+             dudx  =           ( u(k,j,i+1) - u(k,j,i)     ) * ddx
+             dudy  = 0.25_wp * ( u(k,j+1,i) + u(k,j+1,i+1) - &
+                                 u(k,j-1,i) - u(k,j-1,i+1) ) * ddy
+             dudz  = 0.5_wp  * ( u(k+1,j,i) + u(k+1,j,i+1) - &
+                                 u(k-1,j,i) - u(k-1,j,i+1) ) * dd2zu(k)
+
+             dvdx  = 0.25_wp * ( v(k,j,i+1) + v(k,j+1,i+1) - &
+                                 v(k,j,i-1) - v(k,j+1,i-1) ) * ddx
+             dvdy  =           ( v(k,j+1,i) - v(k,j,i)     ) * ddy
+             dvdz  = 0.5_wp  * ( v(k+1,j,i) + v(k+1,j+1,i) - &
+                                 v(k-1,j,i) - v(k-1,j+1,i) ) * dd2zu(k)
+
+             dwdx  = 0.25_wp * ( w(k,j,i+1) + w(k-1,j,i+1) - &
+                                 w(k,j,i-1) - w(k-1,j,i-1) ) * ddx
+             dwdy  = 0.25_wp * ( w(k,j+1,i) + w(k-1,j+1,i) - &
+                                 w(k,j-1,i) - w(k-1,j-1,i) ) * ddy
+             dwdz  =           ( w(k,j,i)   - w(k-1,j,i)   ) * ddzw(k)
+
+             def = 2.0_wp * ( dudx**2 + dvdy**2 + dwdz**2 ) +        &
+                   dudy**2 + dvdx**2 + dwdx**2 + dwdy**2 + dudz**2 + &
+                   dvdz**2 + 2.0_wp * ( dvdx*dudy + dwdx*dudz + dwdy*dvdz )
+
+             IF ( def < 0.0_wp )  def = 0.0_wp
+
+             tend(k,j,i) = tend(k,j,i) + km(k,j,i) * def
+
+          ELSE
+
+!
+!--          Position without adjacent wall
+!--          (1) - will allways be executed. 
+!--          'bottom only: use u_0,v_0'
+             k = nzb_diff_s_inner(j,i)-1
+
+             dudx  =           ( u(k,j,i+1) - u(k,j,i)     ) * ddx
+             dudy  = 0.25_wp * ( u(k,j+1,i) + u(k,j+1,i+1) - &
+                                 u(k,j-1,i) - u(k,j-1,i+1) ) * ddy
+             dudz  = 0.5_wp  * ( u(k+1,j,i) + u(k+1,j,i+1) - &
+                                 u_0(j,i)   - u_0(j,i+1)   ) * dd2zu(k)
+
+             dvdx  = 0.25_wp * ( v(k,j,i+1) + v(k,j+1,i+1) - &
+                                 v(k,j,i-1) - v(k,j+1,i-1) ) * ddx
+             dvdy  =           ( v(k,j+1,i) - v(k,j,i)     ) * ddy
+             dvdz  = 0.5_wp  * ( v(k+1,j,i) + v(k+1,j+1,i) - &
+                                 v_0(j,i)   - v_0(j+1,i)   ) * dd2zu(k)
+
+             dwdx  = 0.25_wp * ( w(k,j,i+1) + w(k-1,j,i+1) - &
+                                 w(k,j,i-1) - w(k-1,j,i-1) ) * ddx
+             dwdy  = 0.25_wp * ( w(k,j+1,i) + w(k-1,j+1,i) - &
+                                 w(k,j-1,i) - w(k-1,j-1,i) ) * ddy
+             dwdz  =           ( w(k,j,i)   - w(k-1,j,i)   ) * ddzw(k)
+
+             def = 2.0_wp * ( dudx**2 + dvdy**2 + dwdz**2 )                       &
+                   + dudy**2 + dvdx**2 + dwdx**2 + dwdy**2 + dudz**2 + dvdz**2 &
+                   + 2.0_wp * ( dvdx*dudy + dwdx*dudz + dwdy*dvdz )
+
+             IF ( def < 0.0_wp )  def = 0.0_wp
+
+             tend(k,j,i) = tend(k,j,i) + km(k,j,i) * def
+
+          ENDIF
+
+       ELSEIF ( use_surface_fluxes )  THEN
+
+          k = nzb_diff_s_outer(j,i)-1
+
+          dudx  =           ( u(k,j,i+1) - u(k,j,i)     ) * ddx
+          dudy  = 0.25_wp * ( u(k,j+1,i) + u(k,j+1,i+1) - &
+                              u(k,j-1,i) - u(k,j-1,i+1) ) * ddy
+          dudz  = 0.5_wp  * ( u(k+1,j,i) + u(k+1,j,i+1) - &
+                              u(k-1,j,i) - u(k-1,j,i+1) ) * dd2zu(k)
+
+          dvdx  = 0.25_wp * ( v(k,j,i+1) + v(k,j+1,i+1) - &
+                              v(k,j,i-1) - v(k,j+1,i-1) ) * ddx
+          dvdy  =           ( v(k,j+1,i) - v(k,j,i)     ) * ddy
+          dvdz  = 0.5_wp  * ( v(k+1,j,i) + v(k+1,j+1,i) - &
+                              v(k-1,j,i) - v(k-1,j+1,i) ) * dd2zu(k)
+
+          dwdx  = 0.25_wp * ( w(k,j,i+1) + w(k-1,j,i+1) - &
+                              w(k,j,i-1) - w(k-1,j,i-1) ) * ddx
+          dwdy  = 0.25_wp * ( w(k,j+1,i) + w(k-1,j+1,i) - &
+                              w(k,j-1,i) - w(k-1,j-1,i) ) * ddy
+          dwdz  =           ( w(k,j,i)   - w(k-1,j,i)   ) * ddzw(k)
+
+          def = 2.0_wp * ( dudx**2 + dvdy**2 + dwdz**2 ) +           &
+                dudy**2 + dvdx**2 + dwdx**2 + dwdy**2 + dudz**2 + &
+                dvdz**2 + 2.0_wp * ( dvdx*dudy + dwdx*dudz + dwdy*dvdz )
+
+          IF ( def < 0.0_wp )  def = 0.0_wp
+
+          tend(k,j,i) = tend(k,j,i) + km(k,j,i) * def
+
+       ENDIF
+
+!
+!--    If required, calculate TKE production by buoyancy
+       IF ( .NOT. neutral )  THEN
+
+          IF ( .NOT. humidity )  THEN
+
+             IF ( use_single_reference_value )  THEN
+
+                IF ( ocean )  THEN
+!
+!--                So far in the ocean no special treatment of density flux in
+!--                the bottom and top surface layer
+                   DO  k = nzb_s_inner(j,i)+1, nzt
+                      tend(k,j,i) = tend(k,j,i) +                   &
+                                    kh(k,j,i) * g / rho_reference * &
+                                    ( rho(k+1,j,i) - rho(k-1,j,i) ) * dd2zu(k)
+                   ENDDO
+
+                ELSE
+
+                   DO  k = nzb_diff_s_inner(j,i), nzt_diff
+                      tend(k,j,i) = tend(k,j,i) -                  &
+                                    kh(k,j,i) * g / pt_reference * &
+                                    ( pt(k+1,j,i) - pt(k-1,j,i) ) * dd2zu(k)
+                   ENDDO
+
+                   IF ( use_surface_fluxes )  THEN
+                      k = nzb_diff_s_inner(j,i)-1
+                      tend(k,j,i) = tend(k,j,i) + g / pt_reference * shf(j,i)
+                   ENDIF
+
+                   IF ( use_top_fluxes )  THEN
+                      k = nzt
+                      tend(k,j,i) = tend(k,j,i) + g / pt_reference * tswst(j,i)
+                   ENDIF
+
+                ENDIF
+
+             ELSE
+
+                IF ( ocean )  THEN
+!
+!--                So far in the ocean no special treatment of density flux in
+!--                the bottom and top surface layer
+                   DO  k = nzb_s_inner(j,i)+1, nzt
+                      tend(k,j,i) = tend(k,j,i) +                &
+                                    kh(k,j,i) * g / rho(k,j,i) * &
+                                    ( rho(k+1,j,i) - rho(k-1,j,i) ) * dd2zu(k)
+                   ENDDO
+
+                ELSE
+
+                   DO  k = nzb_diff_s_inner(j,i), nzt_diff
+                      tend(k,j,i) = tend(k,j,i) -               &
+                                    kh(k,j,i) * g / pt(k,j,i) * &
+                                    ( pt(k+1,j,i) - pt(k-1,j,i) ) * dd2zu(k)
+                   ENDDO
+
+                   IF ( use_surface_fluxes )  THEN
+                      k = nzb_diff_s_inner(j,i)-1
+                      tend(k,j,i) = tend(k,j,i) + g / pt(k,j,i) * shf(j,i)
+                   ENDIF
+
+                   IF ( use_top_fluxes )  THEN
+                      k = nzt
+                      tend(k,j,i) = tend(k,j,i) + g / pt(k,j,i) * tswst(j,i)
+                   ENDIF
+
+                ENDIF
+
+             ENDIF
+
+          ELSE
+
+             DO  k = nzb_diff_s_inner(j,i), nzt_diff
+
+                IF ( .NOT. cloud_physics .AND. .NOT. cloud_droplets )  THEN
+                   k1 = 1.0_wp + 0.61_wp * q(k,j,i)
+                   k2 = 0.61_wp * pt(k,j,i)
+                   tend(k,j,i) = tend(k,j,i) - kh(k,j,i) * g / vpt(k,j,i) *   &
+                                         ( k1 * ( pt(k+1,j,i)-pt(k-1,j,i) ) + &
+                                           k2 * ( q(k+1,j,i) - q(k-1,j,i) )   &
+                                         ) * dd2zu(k)
+                ELSE IF ( cloud_physics )  THEN
+                   IF ( ql(k,j,i) == 0.0_wp )  THEN
+                      k1 = 1.0_wp + 0.61_wp * q(k,j,i)
+                      k2 = 0.61_wp * pt(k,j,i)
+                   ELSE
+                      theta = pt(k,j,i) + pt_d_t(k) * l_d_cp * ql(k,j,i)
+                      temp  = theta * t_d_pt(k)
+                      k1 = ( 1.0_wp - q(k,j,i) + 1.61_wp *                 &
+                                    ( q(k,j,i) - ql(k,j,i) ) *          &
+                           ( 1.0_wp + 0.622_wp * l_d_r / temp ) ) /        &
+                           ( 1.0_wp + 0.622_wp * l_d_r * l_d_cp *          &
+                           ( q(k,j,i) - ql(k,j,i) ) / ( temp * temp ) )
+                      k2 = theta * ( l_d_cp / temp * k1 - 1.0_wp )
+                   ENDIF
+                   tend(k,j,i) = tend(k,j,i) - kh(k,j,i) * g / vpt(k,j,i) *   &
+                                         ( k1 * ( pt(k+1,j,i)-pt(k-1,j,i) ) + &
+                                           k2 * ( q(k+1,j,i) - q(k-1,j,i) )   &
+                                         ) * dd2zu(k)
+                ELSE IF ( cloud_droplets )  THEN
+                   k1 = 1.0_wp + 0.61_wp * q(k,j,i) - ql(k,j,i)
+                   k2 = 0.61_wp * pt(k,j,i)
+                   tend(k,j,i) = tend(k,j,i) - kh(k,j,i) * g / vpt(k,j,i) *  &
+                                     ( k1 * ( pt(k+1,j,i)-pt(k-1,j,i) ) +    &
+                                       k2 * ( q(k+1,j,i) - q(k-1,j,i) ) -    &
+                                       pt(k,j,i) * ( ql(k+1,j,i) -           &
+                                                     ql(k-1,j,i) ) ) * dd2zu(k)
+                ENDIF
+             ENDDO
+
+             IF ( use_surface_fluxes )  THEN
+                k = nzb_diff_s_inner(j,i)-1
+
+                IF ( .NOT. cloud_physics .AND. .NOT. cloud_droplets )  THEN
+                   k1 = 1.0_wp + 0.61_wp * q(k,j,i)
+                   k2 = 0.61_wp * pt(k,j,i)
+                ELSE IF ( cloud_physics )  THEN
+                   IF ( ql(k,j,i) == 0.0_wp )  THEN
+                      k1 = 1.0_wp + 0.61_wp * q(k,j,i)
+                      k2 = 0.61_wp * pt(k,j,i)
+                   ELSE
+                      theta = pt(k,j,i) + pt_d_t(k) * l_d_cp * ql(k,j,i)
+                      temp  = theta * t_d_pt(k)
+                      k1 = ( 1.0_wp - q(k,j,i) + 1.61_wp *                 &
+                                    ( q(k,j,i) - ql(k,j,i) ) *          &
+                           ( 1.0_wp + 0.622_wp * l_d_r / temp ) ) /        &
+                           ( 1.0_wp + 0.622_wp * l_d_r * l_d_cp *          &
+                           ( q(k,j,i) - ql(k,j,i) ) / ( temp * temp ) )
+                      k2 = theta * ( l_d_cp / temp * k1 - 1.0_wp )
+                   ENDIF
+                ELSE IF ( cloud_droplets )  THEN
+                   k1 = 1.0_wp + 0.61_wp * q(k,j,i) - ql(k,j,i)
+                   k2 = 0.61_wp * pt(k,j,i)
+                ENDIF
+
+                tend(k,j,i) = tend(k,j,i) + g / vpt(k,j,i) * &
+                                            ( k1* shf(j,i) + k2 * qsws(j,i) )
+             ENDIF
+
+             IF ( use_top_fluxes )  THEN
+                k = nzt
+
+                IF ( .NOT. cloud_physics .AND. .NOT. cloud_droplets )  THEN
+                   k1 = 1.0_wp + 0.61_wp * q(k,j,i)
+                   k2 = 0.61_wp * pt(k,j,i)
+                ELSE IF ( cloud_physics )  THEN
+                   IF ( ql(k,j,i) == 0.0_wp )  THEN
+                      k1 = 1.0_wp + 0.61_wp * q(k,j,i)
+                      k2 = 0.61_wp * pt(k,j,i)
+                   ELSE
+                      theta = pt(k,j,i) + pt_d_t(k) * l_d_cp * ql(k,j,i)
+                      temp  = theta * t_d_pt(k)
+                      k1 = ( 1.0_wp - q(k,j,i) + 1.61_wp *                 &
+                                    ( q(k,j,i) - ql(k,j,i) ) *          &
+                           ( 1.0_wp + 0.622_wp * l_d_r / temp ) ) /        &
+                           ( 1.0_wp + 0.622_wp * l_d_r * l_d_cp *          &
+                           ( q(k,j,i) - ql(k,j,i) ) / ( temp * temp ) )
+                      k2 = theta * ( l_d_cp / temp * k1 - 1.0_wp )
+                   ENDIF
+                ELSE IF ( cloud_droplets )  THEN
+                   k1 = 1.0_wp + 0.61_wp * q(k,j,i) - ql(k,j,i)
+                   k2 = 0.61_wp * pt(k,j,i)
+                ENDIF
+
+                tend(k,j,i) = tend(k,j,i) + g / vpt(k,j,i) * &
+                                            ( k1* tswst(j,i) + k2 * qswst(j,i) )
+             ENDIF
+
+          ENDIF
+
+       ENDIF
+
+    END SUBROUTINE production_e_ij
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> @todo Missing subroutine description.
+!------------------------------------------------------------------------------!
+    SUBROUTINE production_e_init
+
+       USE arrays_3d,                                                          &
+           ONLY:  kh, km, u, us, usws, v, vsws, zu
+
+       USE control_parameters,                                                 &
+           ONLY:  constant_flux_layer, kappa
+
+       USE indices,                                                            &
+           ONLY:  nxl, nxlg, nxr, nxrg, nys, nysg, nyn, nyng, nzb_u_inner,     &
+                  nzb_v_inner
+
+       IMPLICIT NONE
+
+       INTEGER(iwp) ::  i   !<
+       INTEGER(iwp) ::  j   !<
+       INTEGER(iwp) ::  ku  !<
+       INTEGER(iwp) ::  kv  !<
+
+       IF ( constant_flux_layer )  THEN
+
+          IF ( first_call )  THEN
+             ALLOCATE( u_0(nysg:nyng,nxlg:nxrg), v_0(nysg:nyng,nxlg:nxrg) )
+             u_0 = 0.0_wp   ! just to avoid access of uninitialized memory
+             v_0 = 0.0_wp   ! within exchange_horiz_2d
+             first_call = .FALSE.
+          ENDIF
+
+!
+!--       Calculate a virtual velocity at the surface in a way that the
+!--       vertical velocity gradient at k = 1 (u(k+1)-u_0) matches the
+!--       Prandtl law (-w'u'/km). This gradient is used in the TKE shear
+!--       production term at k=1 (see production_e_ij).
+!--       The velocity gradient has to be limited in case of too small km
+!--       (otherwise the timestep may be significantly reduced by large
+!--       surface winds).
+!--       Upper bounds are nxr+1 and nyn+1 because otherwise these values are
+!--       not available in case of non-cyclic boundary conditions.
+!--       WARNING: the exact analytical solution would require the determination
+!--                of the eddy diffusivity by km = u* * kappa * zp / phi_m.
+          !$OMP PARALLEL DO PRIVATE( ku, kv )
+          DO  i = nxl, nxr+1
+             DO  j = nys, nyn+1
+
+                ku = nzb_u_inner(j,i)+1
+                kv = nzb_v_inner(j,i)+1
+
+                u_0(j,i) = u(ku+1,j,i) + usws(j,i) * ( zu(ku+1) - zu(ku-1) ) / &
+                                 ( 0.5_wp * ( km(ku,j,i) + km(ku,j,i-1) ) +    &
+                                   1.0E-20_wp )
+!                                  ( us(j,i) * kappa * zu(1) )
+                v_0(j,i) = v(kv+1,j,i) + vsws(j,i) * ( zu(kv+1) - zu(kv-1) ) / &
+                                 ( 0.5_wp * ( km(kv,j,i) + km(kv,j-1,i) ) +    &
+                                   1.0E-20_wp )
+!                                  ( us(j,i) * kappa * zu(1) )
+
+                IF ( ABS( u(ku+1,j,i) - u_0(j,i) )  > &
+                     ABS( u(ku+1,j,i) - u(ku-1,j,i) ) )  u_0(j,i) = u(ku-1,j,i)
+                IF ( ABS( v(kv+1,j,i) - v_0(j,i) )  > &
+                     ABS( v(kv+1,j,i) - v(kv-1,j,i) ) )  v_0(j,i) = v(kv-1,j,i)
+
+             ENDDO
+          ENDDO
+
+          CALL exchange_horiz_2d( u_0 )
+          CALL exchange_horiz_2d( v_0 )
+
+       ENDIF
+
+    END SUBROUTINE production_e_init
+
+ END MODULE production_e_mod
Index: lm/trunk/SOURCE/prognostic_equations.f90
===================================================================
--- /palm/trunk/SOURCE/prognostic_equations.f90	(revision 1849)
+++ 	(revision )
@@ -1,2481 +1,0 @@
-!> @file prognostic_equations.f90
-!--------------------------------------------------------------------------------!
-! This file is part of PALM.
-!
-! PALM is free software: you can redistribute it and/or modify it under the terms
-! of the GNU General Public License as published by the Free Software Foundation,
-! either version 3 of the License, or (at your option) any later version.
-!
-! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
-! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
-! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along with
-! PALM. If not, see <http://www.gnu.org/licenses/>.
-!
-! Copyright 1997-2016 Leibniz Universitaet Hannover
-!--------------------------------------------------------------------------------!
-!
-! Current revisions:
-! ------------------
-! 
-! 
-! Former revisions:
-! -----------------
-! $Id$
-!
-! 1826 2016-04-07 12:01:39Z maronga
-! Renamed canopy model calls.
-! 
-! 1822 2016-04-07 07:49:42Z hoffmann
-! Kessler microphysics scheme moved to microphysics.
-!
-! 1757 2016-02-22 15:49:32Z maronga
-! 
-! 
-! 1691 2015-10-26 16:17:44Z maronga
-! Added optional model spin-up without radiation / land surface model calls.
-! Formatting corrections.
-! 
-! 1682 2015-10-07 23:56:08Z knoop
-! Code annotations made doxygen readable 
-! 
-! 1585 2015-04-30 07:05:52Z maronga
-! Added call for temperature tendency calculation due to radiative flux divergence
-! 
-! 1517 2015-01-07 19:12:25Z hoffmann
-! advec_s_bc_mod addded, since advec_s_bc is now a module
-!
-! 1496 2014-12-02 17:25:50Z maronga
-! Renamed "radiation" -> "cloud_top_radiation"
-! 
-! 1484 2014-10-21 10:53:05Z kanani
-! Changes due to new module structure of the plant canopy model:
-!   parameters cthf and plant_canopy moved to module plant_canopy_model_mod.
-! Removed double-listing of use_upstream_for_tke in ONLY-list of module
-! control_parameters
-! 
-! 1409 2014-05-23 12:11:32Z suehring
-! Bugfix: i_omp_start changed for advec_u_ws at left inflow and outflow boundary. 
-! This ensures that left-hand side fluxes are also calculated for nxl in that
-! case, even though the solution at nxl is overwritten in boundary_conds() 
-! 
-! 1398 2014-05-07 11:15:00Z heinze
-! Rayleigh-damping for horizontal velocity components changed: instead of damping
-! against ug and vg, damping against u_init and v_init is used to allow for a 
-! homogenized treatment in case of nudging
-! 
-! 1380 2014-04-28 12:40:45Z heinze
-! Change order of calls for scalar prognostic quantities: 
-! ls_advec -> nudging -> subsidence since initial profiles 
-! 
-! 1374 2014-04-25 12:55:07Z raasch
-! missing variables added to ONLY lists
-! 
-! 1365 2014-04-22 15:03:56Z boeske
-! Calls of ls_advec for large scale advection added, 
-! subroutine subsidence is only called if use_subsidence_tendencies = .F.,
-! new argument ls_index added to the calls of subsidence
-! +ls_index
-! 
-! 1361 2014-04-16 15:17:48Z hoffmann
-! Two-moment microphysics moved to the start of prognostic equations. This makes
-! the 3d arrays for tend_q, tend_qr, tend_pt and tend_pt redundant.
-! Additionally, it is allowed to call the microphysics just once during the time
-! step (not at each sub-time step).
-!
-! Two-moment cloud physics added for vector and accelerator optimization.
-! 
-! 1353 2014-04-08 15:21:23Z heinze
-! REAL constants provided with KIND-attribute
-! 
-! 1337 2014-03-25 15:11:48Z heinze
-! Bugfix: REAL constants provided with KIND-attribute
-! 
-! 1332 2014-03-25 11:59:43Z suehring
-! Bugfix: call advec_ws or advec_pw for TKE only if NOT use_upstream_for_tke 
-! 
-! 1330 2014-03-24 17:29:32Z suehring
-! In case of SGS-particle velocity advection of TKE is also allowed with 
-! dissipative 5th-order scheme.
-!
-! 1320 2014-03-20 08:40:49Z raasch
-! ONLY-attribute added to USE-statements,
-! kind-parameters added to all INTEGER and REAL declaration statements,
-! kinds are defined in new module kinds,
-! old module precision_kind is removed,
-! revision history before 2012 removed,
-! comment fields (!:) to be used for variable explanations added to
-! all variable declaration statements
-!
-! 1318 2014-03-17 13:35:16Z raasch
-! module interfaces removed
-!
-! 1257 2013-11-08 15:18:40Z raasch
-! openacc loop vector clauses removed, independent clauses added
-!
-! 1246 2013-11-01 08:59:45Z heinze
-! enable nudging also for accelerator version
-!
-! 1241 2013-10-30 11:36:58Z heinze
-! usage of nudging enabled (so far not implemented for accelerator version)
-!
-! 1179 2013-06-14 05:57:58Z raasch
-! two arguments removed from routine buoyancy, ref_state updated on device
-!
-! 1128 2013-04-12 06:19:32Z raasch
-! those parts requiring global communication moved to time_integration,
-! loop index bounds in accelerator version replaced by i_left, i_right, j_south,
-! j_north
-!
-! 1115 2013-03-26 18:16:16Z hoffmann
-! optimized cloud physics: calculation of microphysical tendencies transfered 
-! to microphysics.f90; qr and nr are only calculated if precipitation is required
-!
-! 1111 2013-03-08 23:54:10Z raasch
-! update directives for prognostic quantities removed
-!
-! 1106 2013-03-04 05:31:38Z raasch
-! small changes in code formatting
-!
-! 1092 2013-02-02 11:24:22Z raasch
-! unused variables removed
-!
-! 1053 2012-11-13 17:11:03Z hoffmann
-! implementation of two new prognostic equations for rain drop concentration (nr)
-! and rain water content (qr)
-!
-! currently, only available for cache loop optimization
-!
-! 1036 2012-10-22 13:43:42Z raasch
-! code put under GPL (PALM 3.9)
-!
-! 1019 2012-09-28 06:46:45Z raasch
-! non-optimized version of prognostic_equations removed
-!
-! 1015 2012-09-27 09:23:24Z raasch
-! new branch prognostic_equations_acc
-! OpenACC statements added + code changes required for GPU optimization
-!
-! 1001 2012-09-13 14:08:46Z raasch
-! all actions concerning leapfrog- and upstream-spline-scheme removed
-!
-! 978 2012-08-09 08:28:32Z fricke
-! km_damp_x and km_damp_y removed in calls of diffusion_u and diffusion_v
-! add ptdf_x, ptdf_y for damping the potential temperature at the inflow
-! boundary in case of non-cyclic lateral boundaries
-! Bugfix: first thread index changes for WS-scheme at the inflow
-!
-! 940 2012-07-09 14:31:00Z raasch
-! temperature equation can be switched off
-!
-! Revision 1.1  2000/04/13 14:56:27  schroeter
-! Initial revision
-!
-!
-! Description:
-! ------------
-!> Solving the prognostic equations.
-!------------------------------------------------------------------------------!
- MODULE prognostic_equations_mod
-
- 
-
-    USE arrays_3d,                                                             &
-        ONLY:  diss_l_e, diss_l_nr, diss_l_pt, diss_l_q, diss_l_qr,            &
-               diss_l_sa, diss_s_e, diss_s_nr, diss_s_pt, diss_s_q,            &
-               diss_s_qr, diss_s_sa, e, e_p, flux_s_e, flux_s_nr, flux_s_pt,   &
-               flux_s_q, flux_s_qr, flux_s_sa, flux_l_e, flux_l_nr,            &
-               flux_l_pt, flux_l_q, flux_l_qr, flux_l_sa, nr, nr_p, nrsws,     &
-               nrswst, pt, ptdf_x, ptdf_y, pt_init, pt_p, prho, q, q_init,     &
-               q_p, qsws, qswst, qr, qr_p, qrsws, qrswst, rdf, rdf_sc,         &
-               ref_state, rho, sa, sa_init, sa_p, saswsb, saswst, shf, tend,   &
-               te_m, tnr_m, tpt_m, tq_m, tqr_m, tsa_m, tswst, tu_m, tv_m,      &
-               tw_m, u, ug, u_init, u_p, v, vg, vpt, v_init, v_p, w, w_p
-        
-    USE control_parameters,                                                    &
-        ONLY:  call_microphysics_at_all_substeps, cloud_physics,               &
-               cloud_top_radiation, constant_diffusion, dp_external,           &
-               dp_level_ind_b, dp_smooth_factor, dpdxy, dt_3d, humidity,       &
-               inflow_l, intermediate_timestep_count,                          &
-               intermediate_timestep_count_max, large_scale_forcing,           &
-               large_scale_subsidence, microphysics_seifert,                   &
-               microphysics_sat_adjust, neutral, nudging, ocean, outflow_l,    &
-               outflow_s, passive_scalar, prho_reference, prho_reference,      &
-               prho_reference, pt_reference, pt_reference, pt_reference,       &
-               scalar_advec, scalar_advec, simulated_time, sloping_surface,    &
-               timestep_scheme, tsc, use_subsidence_tendencies,                &
-               use_upstream_for_tke, wall_heatflux,                            &
-               wall_nrflux, wall_qflux, wall_qflux, wall_qflux, wall_qrflux,   &
-               wall_salinityflux, ws_scheme_mom, ws_scheme_sca
-
-    USE cpulog,                                                                &
-        ONLY:  cpu_log, log_point
-
-    USE eqn_state_seawater_mod,                                                &
-        ONLY:  eqn_state_seawater
-
-    USE indices,                                                               &
-        ONLY:  i_left, i_right, j_north, j_south, nxl, nxlu, nxr, nyn, nys,    &
-               nysv, nzb_s_inner, nzb_u_inner, nzb_v_inner, nzb_w_inner, nzt
-
-    USE advec_ws,                                                              &
-        ONLY:  advec_s_ws, advec_s_ws_acc, advec_u_ws, advec_u_ws_acc,         &
-               advec_v_ws, advec_v_ws_acc, advec_w_ws, advec_w_ws_acc
-
-    USE advec_s_bc_mod,                                                        &
-        ONLY:  advec_s_bc
-
-    USE advec_s_pw_mod,                                                        &
-        ONLY:  advec_s_pw
-
-    USE advec_s_up_mod,                                                        &
-        ONLY:  advec_s_up
-
-    USE advec_u_pw_mod,                                                        &
-        ONLY:  advec_u_pw
-
-    USE advec_u_up_mod,                                                        &
-        ONLY:  advec_u_up
-
-    USE advec_v_pw_mod,                                                        &
-        ONLY:  advec_v_pw
-
-    USE advec_v_up_mod,                                                        &
-        ONLY:  advec_v_up
-
-    USE advec_w_pw_mod,                                                        &
-        ONLY:  advec_w_pw
-
-    USE advec_w_up_mod,                                                        &
-        ONLY:  advec_w_up
-
-    USE buoyancy_mod,                                                          &
-        ONLY:  buoyancy, buoyancy_acc
-
-    USE calc_radiation_mod,                                                    &
-        ONLY:  calc_radiation
-  
-    USE coriolis_mod,                                                          &
-        ONLY:  coriolis, coriolis_acc
-
-    USE diffusion_e_mod,                                                       &
-        ONLY:  diffusion_e, diffusion_e_acc
-
-    USE diffusion_s_mod,                                                       &
-        ONLY:  diffusion_s, diffusion_s_acc
-
-    USE diffusion_u_mod,                                                       &
-        ONLY:  diffusion_u, diffusion_u_acc
-
-    USE diffusion_v_mod,                                                       &
-        ONLY:  diffusion_v, diffusion_v_acc
-
-    USE diffusion_w_mod,                                                       &
-        ONLY:  diffusion_w, diffusion_w_acc
-
-    USE kinds
-
-    USE ls_forcing_mod,                                                        &
-        ONLY:  ls_advec
-
-    USE microphysics_mod,                                                      &
-        ONLY:  microphysics_control
-
-    USE nudge_mod,                                                             &
-        ONLY:  nudge
-
-    USE plant_canopy_model_mod,                                                &
-        ONLY:  cthf, plant_canopy, pcm_tendency
-
-    USE production_e_mod,                                                      &
-        ONLY:  production_e, production_e_acc
-
-    USE radiation_model_mod,                                                   &
-        ONLY:  radiation, radiation_scheme, radiation_tendency,                &
-               skip_time_do_radiation
-
-    USE statistics,                                                            &
-        ONLY:  hom
-
-    USE subsidence_mod,                                                        &
-        ONLY:  subsidence
-
-    USE user_actions_mod,                                                      &
-        ONLY:  user_actions
-
-
-    PRIVATE
-    PUBLIC prognostic_equations_cache, prognostic_equations_vector, &
-           prognostic_equations_acc
-
-    INTERFACE prognostic_equations_cache
-       MODULE PROCEDURE prognostic_equations_cache
-    END INTERFACE prognostic_equations_cache
-
-    INTERFACE prognostic_equations_vector
-       MODULE PROCEDURE prognostic_equations_vector
-    END INTERFACE prognostic_equations_vector
-
-    INTERFACE prognostic_equations_acc
-       MODULE PROCEDURE prognostic_equations_acc
-    END INTERFACE prognostic_equations_acc
-
-
- CONTAINS
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Version with one optimized loop over all equations. It is only allowed to
-!> be called for the Wicker and Skamarock or Piascek-Williams advection scheme.
-!>
-!> Here the calls of most subroutines are embedded in two DO loops over i and j,
-!> so communication between CPUs is not allowed (does not make sense) within
-!> these loops.
-!>
-!> (Optimized to avoid cache missings, i.e. for Power4/5-architectures.)
-!------------------------------------------------------------------------------!
- 
- SUBROUTINE prognostic_equations_cache
-
-
-    IMPLICIT NONE
-
-    INTEGER(iwp) ::  i                   !<
-    INTEGER(iwp) ::  i_omp_start         !<
-    INTEGER(iwp) ::  j                   !<
-    INTEGER(iwp) ::  k                   !<
-    INTEGER(iwp) ::  omp_get_thread_num  !<
-    INTEGER(iwp) ::  tn = 0              !<
-    
-    LOGICAL      ::  loop_start          !<
-
-
-!
-!-- Time measurement can only be performed for the whole set of equations
-    CALL cpu_log( log_point(32), 'all progn.equations', 'start' )
-
-!
-!-- Loop over all prognostic equations
-!$OMP PARALLEL private (i,i_omp_start,j,k,loop_start,tn)
-
-!$  tn = omp_get_thread_num() 
-    loop_start = .TRUE.
-!$OMP DO
-    DO  i = nxl, nxr
-
-!
-!--    Store the first loop index. It differs for each thread and is required
-!--    later in advec_ws
-       IF ( loop_start )  THEN
-          loop_start  = .FALSE.
-          i_omp_start = i 
-       ENDIF
-
-       DO  j = nys, nyn
-!
-!--       If required, calculate cloud microphysics
-          IF ( cloud_physics  .AND.  .NOT. microphysics_sat_adjust  .AND.      &
-               ( intermediate_timestep_count == 1  .OR.                        &
-                 call_microphysics_at_all_substeps )                           &
-             )  THEN
-             CALL microphysics_control( i, j )
-          ENDIF
-!
-!--       Tendency terms for u-velocity component
-          IF ( .NOT. outflow_l  .OR.  i > nxl )  THEN
-
-             tend(:,j,i) = 0.0_wp
-             IF ( timestep_scheme(1:5) == 'runge' )  THEN
-                IF ( ws_scheme_mom )  THEN
-                   CALL advec_u_ws( i, j, i_omp_start, tn )
-                ELSE 
-                   CALL advec_u_pw( i, j )
-                ENDIF 
-             ELSE
-                CALL advec_u_up( i, j )
-             ENDIF
-             CALL diffusion_u( i, j )
-             CALL coriolis( i, j, 1 )
-             IF ( sloping_surface  .AND.  .NOT. neutral )  THEN
-                CALL buoyancy( i, j, pt, 1 )
-             ENDIF
-
-!
-!--          Drag by plant canopy
-             IF ( plant_canopy )  CALL pcm_tendency( i, j, 1 )
-
-!
-!--          External pressure gradient
-             IF ( dp_external )  THEN
-                DO  k = dp_level_ind_b+1, nzt
-                   tend(k,j,i) = tend(k,j,i) - dpdxy(1) * dp_smooth_factor(k)
-                ENDDO
-             ENDIF
-
-!
-!--          Nudging
-             IF ( nudging )  CALL nudge( i, j, simulated_time, 'u' )
-
-             CALL user_actions( i, j, 'u-tendency' )
-!
-!--          Prognostic equation for u-velocity component
-             DO  k = nzb_u_inner(j,i)+1, nzt
-                u_p(k,j,i) = u(k,j,i) + dt_3d * ( tsc(2) * tend(k,j,i) +       &
-                                                  tsc(3) * tu_m(k,j,i) )       &
-                                      - tsc(5) * rdf(k) * ( u(k,j,i) - u_init(k) )
-             ENDDO
-
-!
-!--          Calculate tendencies for the next Runge-Kutta step
-             IF ( timestep_scheme(1:5) == 'runge' )  THEN
-                IF ( intermediate_timestep_count == 1 )  THEN
-                   DO  k = nzb_u_inner(j,i)+1, nzt
-                      tu_m(k,j,i) = tend(k,j,i)
-                   ENDDO
-                ELSEIF ( intermediate_timestep_count < &
-                         intermediate_timestep_count_max )  THEN
-                   DO  k = nzb_u_inner(j,i)+1, nzt
-                      tu_m(k,j,i) = -9.5625_wp * tend(k,j,i) + 5.3125_wp * tu_m(k,j,i)
-                   ENDDO
-                ENDIF
-             ENDIF
-
-          ENDIF
-
-!
-!--       Tendency terms for v-velocity component
-          IF ( .NOT. outflow_s  .OR.  j > nys )  THEN
-
-             tend(:,j,i) = 0.0_wp
-             IF ( timestep_scheme(1:5) == 'runge' )  THEN
-                IF ( ws_scheme_mom )  THEN
-                    CALL advec_v_ws( i, j, i_omp_start, tn )
-                ELSE 
-                    CALL advec_v_pw( i, j )
-                ENDIF
-             ELSE
-                CALL advec_v_up( i, j )
-             ENDIF
-             CALL diffusion_v( i, j )
-             CALL coriolis( i, j, 2 )
-
-!
-!--          Drag by plant canopy
-             IF ( plant_canopy )  CALL pcm_tendency( i, j, 2 )        
-
-!
-!--          External pressure gradient
-             IF ( dp_external )  THEN
-                DO  k = dp_level_ind_b+1, nzt
-                   tend(k,j,i) = tend(k,j,i) - dpdxy(2) * dp_smooth_factor(k)
-                ENDDO
-             ENDIF
-
-!
-!--          Nudging
-             IF ( nudging )  CALL nudge( i, j, simulated_time, 'v' )
-
-             CALL user_actions( i, j, 'v-tendency' )
-!
-!--          Prognostic equation for v-velocity component
-             DO  k = nzb_v_inner(j,i)+1, nzt
-                v_p(k,j,i) = v(k,j,i) + dt_3d * ( tsc(2) * tend(k,j,i) +       &
-                                                  tsc(3) * tv_m(k,j,i) )       &
-                                      - tsc(5) * rdf(k) * ( v(k,j,i) - v_init(k) )
-             ENDDO
-
-!
-!--          Calculate tendencies for the next Runge-Kutta step
-             IF ( timestep_scheme(1:5) == 'runge' )  THEN
-                IF ( intermediate_timestep_count == 1 )  THEN
-                   DO  k = nzb_v_inner(j,i)+1, nzt
-                      tv_m(k,j,i) = tend(k,j,i)
-                   ENDDO
-                ELSEIF ( intermediate_timestep_count < &
-                         intermediate_timestep_count_max )  THEN
-                   DO  k = nzb_v_inner(j,i)+1, nzt
-                      tv_m(k,j,i) = -9.5625_wp * tend(k,j,i) + 5.3125_wp * tv_m(k,j,i)
-                   ENDDO
-                ENDIF
-             ENDIF
-
-          ENDIF
-
-!
-!--       Tendency terms for w-velocity component
-          tend(:,j,i) = 0.0_wp
-          IF ( timestep_scheme(1:5) == 'runge' )  THEN
-             IF ( ws_scheme_mom )  THEN
-                CALL advec_w_ws( i, j, i_omp_start, tn )
-             ELSE 
-                CALL advec_w_pw( i, j )
-             END IF
-          ELSE
-             CALL advec_w_up( i, j )
-          ENDIF
-          CALL diffusion_w( i, j )
-          CALL coriolis( i, j, 3 )
-
-          IF ( .NOT. neutral )  THEN
-             IF ( ocean )  THEN
-                CALL buoyancy( i, j, rho, 3 )
-             ELSE
-                IF ( .NOT. humidity )  THEN
-                   CALL buoyancy( i, j, pt, 3 )
-                ELSE
-                   CALL buoyancy( i, j, vpt, 3 )
-                ENDIF
-             ENDIF
-          ENDIF
-
-!
-!--       Drag by plant canopy
-          IF ( plant_canopy )  CALL pcm_tendency( i, j, 3 )
-
-          CALL user_actions( i, j, 'w-tendency' )
-
-!
-!--       Prognostic equation for w-velocity component
-          DO  k = nzb_w_inner(j,i)+1, nzt-1
-             w_p(k,j,i) = w(k,j,i) + dt_3d * ( tsc(2) * tend(k,j,i) +          &
-                                               tsc(3) * tw_m(k,j,i) )          &
-                                   - tsc(5) * rdf(k) * w(k,j,i)
-          ENDDO
-
-!
-!--       Calculate tendencies for the next Runge-Kutta step
-          IF ( timestep_scheme(1:5) == 'runge' )  THEN
-             IF ( intermediate_timestep_count == 1 )  THEN
-                DO  k = nzb_w_inner(j,i)+1, nzt-1
-                   tw_m(k,j,i) = tend(k,j,i)
-                ENDDO
-             ELSEIF ( intermediate_timestep_count < &
-                      intermediate_timestep_count_max )  THEN
-                DO  k = nzb_w_inner(j,i)+1, nzt-1
-                   tw_m(k,j,i) = -9.5625_wp * tend(k,j,i) + 5.3125_wp * tw_m(k,j,i)
-                ENDDO
-             ENDIF
-          ENDIF
-
-!
-!--       If required, compute prognostic equation for potential temperature
-          IF ( .NOT. neutral )  THEN
-!
-!--          Tendency terms for potential temperature
-             tend(:,j,i) = 0.0_wp
-             IF ( timestep_scheme(1:5) == 'runge' )  THEN
-                   IF ( ws_scheme_sca )  THEN
-                      CALL advec_s_ws( i, j, pt, 'pt', flux_s_pt, diss_s_pt, &
-                                       flux_l_pt, diss_l_pt, i_omp_start, tn )
-                   ELSE
-                      CALL advec_s_pw( i, j, pt )
-                   ENDIF
-             ELSE
-                CALL advec_s_up( i, j, pt )
-             ENDIF
-             CALL diffusion_s( i, j, pt, shf, tswst, wall_heatflux )
-
-!
-!--          If required compute heating/cooling due to long wave radiation
-!--          processes
-             IF ( cloud_top_radiation )  THEN
-                CALL calc_radiation( i, j )
-             ENDIF
-
-!
-!--          Consideration of heat sources within the plant canopy
-             IF ( plant_canopy  .AND.  cthf /= 0.0_wp )  THEN
-                CALL pcm_tendency( i, j, 4 )
-             ENDIF
-
-!
-!--          Large scale advection
-             IF ( large_scale_forcing )  THEN
-                CALL ls_advec( i, j, simulated_time, 'pt' )
-             ENDIF     
-
-!
-!--          Nudging
-             IF ( nudging )  CALL nudge( i, j, simulated_time, 'pt' ) 
-
-!
-!--          If required, compute effect of large-scale subsidence/ascent
-             IF ( large_scale_subsidence  .AND.                                &
-                  .NOT. use_subsidence_tendencies )  THEN
-                CALL subsidence( i, j, tend, pt, pt_init, 2 )
-             ENDIF
-
-!
-!--          If required, add tendency due to radiative heating/cooling
-             IF ( radiation .AND. radiation_scheme == 'rrtmg' .AND.            &
-                  simulated_time > skip_time_do_radiation )  THEN
-                CALL radiation_tendency ( i, j, tend )
-             ENDIF
-
-
-             CALL user_actions( i, j, 'pt-tendency' )
-
-!
-!--          Prognostic equation for potential temperature
-             DO  k = nzb_s_inner(j,i)+1, nzt
-                pt_p(k,j,i) = pt(k,j,i) + dt_3d * ( tsc(2) * tend(k,j,i) +     &
-                                                    tsc(3) * tpt_m(k,j,i) )    &
-                                        - tsc(5) * ( pt(k,j,i) - pt_init(k) ) *&
-                                          ( rdf_sc(k) + ptdf_x(i) + ptdf_y(j) )
-             ENDDO
-
-!
-!--          Calculate tendencies for the next Runge-Kutta step
-             IF ( timestep_scheme(1:5) == 'runge' )  THEN
-                IF ( intermediate_timestep_count == 1 )  THEN
-                   DO  k = nzb_s_inner(j,i)+1, nzt
-                      tpt_m(k,j,i) = tend(k,j,i)
-                   ENDDO
-                ELSEIF ( intermediate_timestep_count < &
-                         intermediate_timestep_count_max )  THEN
-                   DO  k = nzb_s_inner(j,i)+1, nzt
-                      tpt_m(k,j,i) = -9.5625_wp * tend(k,j,i) + &
-                                      5.3125_wp * tpt_m(k,j,i)
-                   ENDDO
-                ENDIF
-             ENDIF
-
-          ENDIF
-
-!
-!--       If required, compute prognostic equation for salinity
-          IF ( ocean )  THEN
-
-!
-!--          Tendency-terms for salinity
-             tend(:,j,i) = 0.0_wp
-             IF ( timestep_scheme(1:5) == 'runge' ) &
-             THEN
-                IF ( ws_scheme_sca )  THEN
-                    CALL advec_s_ws( i, j, sa, 'sa', flux_s_sa,  &
-                                diss_s_sa, flux_l_sa, diss_l_sa, i_omp_start, tn  )
-                ELSE 
-                    CALL advec_s_pw( i, j, sa )
-                ENDIF
-             ELSE
-                CALL advec_s_up( i, j, sa )
-             ENDIF
-             CALL diffusion_s( i, j, sa, saswsb, saswst, wall_salinityflux )
-
-             CALL user_actions( i, j, 'sa-tendency' )
-
-!
-!--          Prognostic equation for salinity
-             DO  k = nzb_s_inner(j,i)+1, nzt
-                sa_p(k,j,i) = sa(k,j,i) + dt_3d * ( tsc(2) * tend(k,j,i) +     &
-                                                    tsc(3) * tsa_m(k,j,i) )    &
-                                        - tsc(5) * rdf_sc(k) *                 &
-                                          ( sa(k,j,i) - sa_init(k) )
-                IF ( sa_p(k,j,i) < 0.0_wp )  sa_p(k,j,i) = 0.1_wp * sa(k,j,i)
-             ENDDO
-
-!
-!--          Calculate tendencies for the next Runge-Kutta step
-             IF ( timestep_scheme(1:5) == 'runge' )  THEN
-                IF ( intermediate_timestep_count == 1 )  THEN
-                   DO  k = nzb_s_inner(j,i)+1, nzt
-                      tsa_m(k,j,i) = tend(k,j,i)
-                   ENDDO
-                ELSEIF ( intermediate_timestep_count < &
-                         intermediate_timestep_count_max )  THEN
-                   DO  k = nzb_s_inner(j,i)+1, nzt
-                      tsa_m(k,j,i) = -9.5625_wp * tend(k,j,i) + &
-                                      5.3125_wp * tsa_m(k,j,i)
-                   ENDDO
-                ENDIF
-             ENDIF
-
-!
-!--          Calculate density by the equation of state for seawater
-             CALL eqn_state_seawater( i, j )
-
-          ENDIF
-
-!
-!--       If required, compute prognostic equation for total water content /
-!--       scalar
-          IF ( humidity  .OR.  passive_scalar )  THEN
-
-!
-!--          Tendency-terms for total water content / scalar
-             tend(:,j,i) = 0.0_wp
-             IF ( timestep_scheme(1:5) == 'runge' ) &
-             THEN
-                IF ( ws_scheme_sca )  THEN
-                   CALL advec_s_ws( i, j, q, 'q', flux_s_q, & 
-                                diss_s_q, flux_l_q, diss_l_q, i_omp_start, tn )
-                ELSE 
-                   CALL advec_s_pw( i, j, q )
-                ENDIF
-             ELSE
-                CALL advec_s_up( i, j, q )
-             ENDIF
-             CALL diffusion_s( i, j, q, qsws, qswst, wall_qflux )
-
-!
-!--          Sink or source of scalar concentration due to canopy elements
-             IF ( plant_canopy )  CALL pcm_tendency( i, j, 5 )
-
-!
-!--          Large scale advection
-             IF ( large_scale_forcing )  THEN
-                CALL ls_advec( i, j, simulated_time, 'q' )
-             ENDIF
-
-!
-!--          Nudging
-             IF ( nudging )  CALL nudge( i, j, simulated_time, 'q' ) 
-
-!
-!--          If required compute influence of large-scale subsidence/ascent
-             IF ( large_scale_subsidence  .AND.                                &
-                  .NOT. use_subsidence_tendencies )  THEN
-                CALL subsidence( i, j, tend, q, q_init, 3 )
-             ENDIF
-
-             CALL user_actions( i, j, 'q-tendency' )
-
-!
-!--          Prognostic equation for total water content / scalar
-             DO  k = nzb_s_inner(j,i)+1, nzt
-                q_p(k,j,i) = q(k,j,i) + dt_3d * ( tsc(2) * tend(k,j,i) +       &
-                                                  tsc(3) * tq_m(k,j,i) )       &
-                                      - tsc(5) * rdf_sc(k) *                   &
-                                        ( q(k,j,i) - q_init(k) )
-                IF ( q_p(k,j,i) < 0.0_wp )  q_p(k,j,i) = 0.1_wp * q(k,j,i)
-             ENDDO
-
-!
-!--          Calculate tendencies for the next Runge-Kutta step
-             IF ( timestep_scheme(1:5) == 'runge' )  THEN
-                IF ( intermediate_timestep_count == 1 )  THEN
-                   DO  k = nzb_s_inner(j,i)+1, nzt
-                      tq_m(k,j,i) = tend(k,j,i)
-                   ENDDO
-                ELSEIF ( intermediate_timestep_count < &
-                         intermediate_timestep_count_max )  THEN
-                   DO  k = nzb_s_inner(j,i)+1, nzt
-                      tq_m(k,j,i) = -9.5625_wp * tend(k,j,i) + &
-                                     5.3125_wp * tq_m(k,j,i)
-                   ENDDO
-                ENDIF
-             ENDIF
-
-!
-!--          If required, calculate prognostic equations for rain water content 
-!--          and rain drop concentration
-             IF ( cloud_physics  .AND.  microphysics_seifert )  THEN
-!
-!--             Calculate prognostic equation for rain water content
-                tend(:,j,i) = 0.0_wp
-                IF ( timestep_scheme(1:5) == 'runge' ) &
-                THEN
-                   IF ( ws_scheme_sca )  THEN
-                      CALL advec_s_ws( i, j, qr, 'qr', flux_s_qr,       & 
-                                       diss_s_qr, flux_l_qr, diss_l_qr, &
-                                       i_omp_start, tn )
-                   ELSE 
-                      CALL advec_s_pw( i, j, qr )
-                   ENDIF
-                ELSE
-                   CALL advec_s_up( i, j, qr )
-                ENDIF
-                CALL diffusion_s( i, j, qr, qrsws, qrswst, wall_qrflux )
-
-!
-!--             Prognostic equation for rain water content
-                DO  k = nzb_s_inner(j,i)+1, nzt
-                   qr_p(k,j,i) = qr(k,j,i) + dt_3d * ( tsc(2) * tend(k,j,i) +  &
-                                                       tsc(3) * tqr_m(k,j,i) ) &
-                                           - tsc(5) * rdf_sc(k) * qr(k,j,i)
-                   IF ( qr_p(k,j,i) < 0.0_wp )  qr_p(k,j,i) = 0.0_wp
-                ENDDO
-!
-!--             Calculate tendencies for the next Runge-Kutta step
-                IF ( timestep_scheme(1:5) == 'runge' )  THEN
-                   IF ( intermediate_timestep_count == 1 )  THEN
-                      DO  k = nzb_s_inner(j,i)+1, nzt
-                         tqr_m(k,j,i) = tend(k,j,i)
-                      ENDDO
-                   ELSEIF ( intermediate_timestep_count < &
-                            intermediate_timestep_count_max )  THEN
-                      DO  k = nzb_s_inner(j,i)+1, nzt
-                         tqr_m(k,j,i) = -9.5625_wp * tend(k,j,i) + &
-                                        5.3125_wp * tqr_m(k,j,i)
-                      ENDDO
-                   ENDIF
-                ENDIF
-
-!
-!--             Calculate prognostic equation for rain drop concentration.
-                tend(:,j,i) = 0.0_wp
-                IF ( timestep_scheme(1:5) == 'runge' )  THEN
-                   IF ( ws_scheme_sca )  THEN
-                      CALL advec_s_ws( i, j, nr, 'nr', flux_s_nr,    & 
-                                    diss_s_nr, flux_l_nr, diss_l_nr, &
-                                    i_omp_start, tn )
-                   ELSE 
-                      CALL advec_s_pw( i, j, nr )
-                   ENDIF
-                ELSE
-                   CALL advec_s_up( i, j, nr )
-                ENDIF
-                CALL diffusion_s( i, j, nr, nrsws, nrswst, wall_nrflux )
-
-!
-!--             Prognostic equation for rain drop concentration
-                DO  k = nzb_s_inner(j,i)+1, nzt
-                   nr_p(k,j,i) = nr(k,j,i) + dt_3d * ( tsc(2) * tend(k,j,i) +  &
-                                                       tsc(3) * tnr_m(k,j,i) ) &
-                                           - tsc(5) * rdf_sc(k) * nr(k,j,i)
-                   IF ( nr_p(k,j,i) < 0.0_wp )  nr_p(k,j,i) = 0.0_wp
-                ENDDO
-!
-!--             Calculate tendencies for the next Runge-Kutta step
-                IF ( timestep_scheme(1:5) == 'runge' )  THEN
-                   IF ( intermediate_timestep_count == 1 )  THEN
-                      DO  k = nzb_s_inner(j,i)+1, nzt
-                         tnr_m(k,j,i) = tend(k,j,i)
-                      ENDDO
-                   ELSEIF ( intermediate_timestep_count < &
-                            intermediate_timestep_count_max )  THEN
-                      DO  k = nzb_s_inner(j,i)+1, nzt
-                         tnr_m(k,j,i) = -9.5625_wp * tend(k,j,i) + &
-                                        5.3125_wp * tnr_m(k,j,i)
-                      ENDDO
-                   ENDIF
-                ENDIF
-
-             ENDIF
-
-          ENDIF
-
-!
-!--       If required, compute prognostic equation for turbulent kinetic 
-!--       energy (TKE)
-          IF ( .NOT. constant_diffusion )  THEN
-
-!
-!--          Tendency-terms for TKE
-             tend(:,j,i) = 0.0_wp
-             IF ( timestep_scheme(1:5) == 'runge'  &
-                 .AND.  .NOT. use_upstream_for_tke )  THEN 
-                 IF ( ws_scheme_sca )  THEN
-                     CALL advec_s_ws( i, j, e, 'e', flux_s_e, diss_s_e, &
-                                      flux_l_e, diss_l_e , i_omp_start, tn )
-                 ELSE
-                     CALL advec_s_pw( i, j, e )
-                 ENDIF
-             ELSE
-                CALL advec_s_up( i, j, e )
-             ENDIF
-             IF ( .NOT. humidity )  THEN
-                IF ( ocean )  THEN
-                   CALL diffusion_e( i, j, prho, prho_reference )
-                ELSE
-                   CALL diffusion_e( i, j, pt, pt_reference )
-                ENDIF
-             ELSE
-                CALL diffusion_e( i, j, vpt, pt_reference )
-             ENDIF
-             CALL production_e( i, j )
-
-!
-!--          Additional sink term for flows through plant canopies
-             IF ( plant_canopy )  CALL pcm_tendency( i, j, 6 ) 
-
-             CALL user_actions( i, j, 'e-tendency' )
-
-!
-!--          Prognostic equation for TKE.
-!--          Eliminate negative TKE values, which can occur due to numerical
-!--          reasons in the course of the integration. In such cases the old
-!--          TKE value is reduced by 90%.
-             DO  k = nzb_s_inner(j,i)+1, nzt
-                e_p(k,j,i) = e(k,j,i) + dt_3d * ( tsc(2) * tend(k,j,i) +       &
-                                                  tsc(3) * te_m(k,j,i) )
-                IF ( e_p(k,j,i) < 0.0_wp )  e_p(k,j,i) = 0.1_wp * e(k,j,i)
-             ENDDO
-
-!
-!--          Calculate tendencies for the next Runge-Kutta step
-             IF ( timestep_scheme(1:5) == 'runge' )  THEN
-                IF ( intermediate_timestep_count == 1 )  THEN
-                   DO  k = nzb_s_inner(j,i)+1, nzt
-                      te_m(k,j,i) = tend(k,j,i)
-                   ENDDO
-                ELSEIF ( intermediate_timestep_count < &
-                         intermediate_timestep_count_max )  THEN
-                   DO  k = nzb_s_inner(j,i)+1, nzt
-                      te_m(k,j,i) = -9.5625_wp * tend(k,j,i) + &
-                                     5.3125_wp * te_m(k,j,i)
-                   ENDDO
-                ENDIF
-             ENDIF
-
-          ENDIF   ! TKE equation
-
-       ENDDO
-    ENDDO
-!$OMP END PARALLEL
-
-    CALL cpu_log( log_point(32), 'all progn.equations', 'stop' )
-
-
- END SUBROUTINE prognostic_equations_cache
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Version for vector machines
-!------------------------------------------------------------------------------!
- 
- SUBROUTINE prognostic_equations_vector
-
-
-    IMPLICIT NONE
-
-    INTEGER(iwp) ::  i    !<
-    INTEGER(iwp) ::  j    !<
-    INTEGER(iwp) ::  k    !<
-
-    REAL(wp)     ::  sbt  !<
-
-
-!
-!-- If required, calculate cloud microphysical impacts
-    IF ( cloud_physics  .AND.  .NOT. microphysics_sat_adjust  .AND.            &
-         ( intermediate_timestep_count == 1  .OR.                              &
-           call_microphysics_at_all_substeps )                                 &
-       )  THEN
-       CALL cpu_log( log_point(51), 'microphysics', 'start' )
-       CALL microphysics_control
-       CALL cpu_log( log_point(51), 'microphysics', 'stop' )
-    ENDIF
-
-!
-!-- u-velocity component
-    CALL cpu_log( log_point(5), 'u-equation', 'start' )
-
-    tend = 0.0_wp
-    IF ( timestep_scheme(1:5) == 'runge' )  THEN
-       IF ( ws_scheme_mom )  THEN
-          CALL advec_u_ws
-       ELSE
-          CALL advec_u_pw
-       ENDIF
-    ELSE
-       CALL advec_u_up
-    ENDIF
-    CALL diffusion_u
-    CALL coriolis( 1 )
-    IF ( sloping_surface  .AND.  .NOT. neutral )  THEN
-       CALL buoyancy( pt, 1 )
-    ENDIF
-
-!
-!-- Drag by plant canopy
-    IF ( plant_canopy )  CALL pcm_tendency( 1 )
-
-!
-!-- External pressure gradient
-    IF ( dp_external )  THEN
-       DO  i = nxlu, nxr
-          DO  j = nys, nyn
-             DO  k = dp_level_ind_b+1, nzt
-                tend(k,j,i) = tend(k,j,i) - dpdxy(1) * dp_smooth_factor(k)
-             ENDDO
-          ENDDO
-       ENDDO
-    ENDIF
-
-!
-!-- Nudging
-    IF ( nudging )  CALL nudge( simulated_time, 'u' )
-
-    CALL user_actions( 'u-tendency' )
-
-!
-!-- Prognostic equation for u-velocity component
-    DO  i = nxlu, nxr
-       DO  j = nys, nyn
-          DO  k = nzb_u_inner(j,i)+1, nzt
-             u_p(k,j,i) = u(k,j,i) + dt_3d * ( tsc(2) * tend(k,j,i) +          &
-                                               tsc(3) * tu_m(k,j,i) )          &
-                                   - tsc(5) * rdf(k) * ( u(k,j,i) - u_init(k) )
-          ENDDO
-       ENDDO
-    ENDDO
-
-!
-!-- Calculate tendencies for the next Runge-Kutta step
-    IF ( timestep_scheme(1:5) == 'runge' )  THEN
-       IF ( intermediate_timestep_count == 1 )  THEN
-          DO  i = nxlu, nxr
-             DO  j = nys, nyn
-                DO  k = nzb_u_inner(j,i)+1, nzt
-                   tu_m(k,j,i) = tend(k,j,i)
-                ENDDO
-             ENDDO
-          ENDDO
-       ELSEIF ( intermediate_timestep_count < &
-                intermediate_timestep_count_max )  THEN
-          DO  i = nxlu, nxr
-             DO  j = nys, nyn
-                DO  k = nzb_u_inner(j,i)+1, nzt
-                   tu_m(k,j,i) = -9.5625_wp * tend(k,j,i) + 5.3125_wp * tu_m(k,j,i)
-                ENDDO
-             ENDDO
-          ENDDO
-       ENDIF
-    ENDIF
-
-    CALL cpu_log( log_point(5), 'u-equation', 'stop' )
-
-!
-!-- v-velocity component
-    CALL cpu_log( log_point(6), 'v-equation', 'start' )
-
-    tend = 0.0_wp
-    IF ( timestep_scheme(1:5) == 'runge' )  THEN
-       IF ( ws_scheme_mom )  THEN
-          CALL advec_v_ws
-       ELSE 
-          CALL advec_v_pw
-       END IF
-    ELSE
-       CALL advec_v_up
-    ENDIF
-    CALL diffusion_v
-    CALL coriolis( 2 )
-
-!
-!-- Drag by plant canopy
-    IF ( plant_canopy )  CALL pcm_tendency( 2 )
-
-!
-!-- External pressure gradient
-    IF ( dp_external )  THEN
-       DO  i = nxl, nxr
-          DO  j = nysv, nyn
-             DO  k = dp_level_ind_b+1, nzt
-                tend(k,j,i) = tend(k,j,i) - dpdxy(2) * dp_smooth_factor(k)
-             ENDDO
-          ENDDO
-       ENDDO
-    ENDIF
-
-!
-!-- Nudging
-    IF ( nudging )  CALL nudge( simulated_time, 'v' )
-
-    CALL user_actions( 'v-tendency' )
-
-!
-!-- Prognostic equation for v-velocity component
-    DO  i = nxl, nxr
-       DO  j = nysv, nyn
-          DO  k = nzb_v_inner(j,i)+1, nzt
-             v_p(k,j,i) = v(k,j,i) + dt_3d * ( tsc(2) * tend(k,j,i) +          &
-                                               tsc(3) * tv_m(k,j,i) )          &
-                                   - tsc(5) * rdf(k) * ( v(k,j,i) - v_init(k) )
-          ENDDO
-       ENDDO
-    ENDDO
-
-!
-!-- Calculate tendencies for the next Runge-Kutta step
-    IF ( timestep_scheme(1:5) == 'runge' )  THEN
-       IF ( intermediate_timestep_count == 1 )  THEN
-          DO  i = nxl, nxr
-             DO  j = nysv, nyn
-                DO  k = nzb_v_inner(j,i)+1, nzt
-                   tv_m(k,j,i) = tend(k,j,i)
-                ENDDO
-             ENDDO
-          ENDDO
-       ELSEIF ( intermediate_timestep_count < &
-                intermediate_timestep_count_max )  THEN
-          DO  i = nxl, nxr
-             DO  j = nysv, nyn
-                DO  k = nzb_v_inner(j,i)+1, nzt
-                   tv_m(k,j,i) = -9.5625_wp * tend(k,j,i) + 5.3125_wp * tv_m(k,j,i)
-                ENDDO
-             ENDDO
-          ENDDO
-       ENDIF
-    ENDIF
-
-    CALL cpu_log( log_point(6), 'v-equation', 'stop' )
-
-!
-!-- w-velocity component
-    CALL cpu_log( log_point(7), 'w-equation', 'start' )
-
-    tend = 0.0_wp
-    IF ( timestep_scheme(1:5) == 'runge' )  THEN
-       IF ( ws_scheme_mom )  THEN
-          CALL advec_w_ws
-       ELSE
-          CALL advec_w_pw
-       ENDIF
-    ELSE
-       CALL advec_w_up
-    ENDIF
-    CALL diffusion_w
-    CALL coriolis( 3 )
-
-    IF ( .NOT. neutral )  THEN
-       IF ( ocean )  THEN
-          CALL buoyancy( rho, 3 )
-       ELSE
-          IF ( .NOT. humidity )  THEN
-             CALL buoyancy( pt, 3 )
-          ELSE
-             CALL buoyancy( vpt, 3 )
-          ENDIF
-       ENDIF
-    ENDIF
-
-!
-!-- Drag by plant canopy
-    IF ( plant_canopy )  CALL pcm_tendency( 3 )
-
-    CALL user_actions( 'w-tendency' )
-
-!
-!-- Prognostic equation for w-velocity component
-    DO  i = nxl, nxr
-       DO  j = nys, nyn
-          DO  k = nzb_w_inner(j,i)+1, nzt-1
-             w_p(k,j,i) = w(k,j,i) + dt_3d * ( tsc(2) * tend(k,j,i) +          &
-                                               tsc(3) * tw_m(k,j,i) )          &
-                                   - tsc(5) * rdf(k) * w(k,j,i)
-          ENDDO
-       ENDDO
-    ENDDO
-
-!
-!-- Calculate tendencies for the next Runge-Kutta step
-    IF ( timestep_scheme(1:5) == 'runge' )  THEN
-       IF ( intermediate_timestep_count == 1 )  THEN
-          DO  i = nxl, nxr
-             DO  j = nys, nyn
-                DO  k = nzb_w_inner(j,i)+1, nzt-1
-                   tw_m(k,j,i) = tend(k,j,i)
-                ENDDO
-             ENDDO
-          ENDDO
-       ELSEIF ( intermediate_timestep_count < &
-                intermediate_timestep_count_max )  THEN
-          DO  i = nxl, nxr
-             DO  j = nys, nyn
-                DO  k = nzb_w_inner(j,i)+1, nzt-1
-                   tw_m(k,j,i) = -9.5625_wp * tend(k,j,i) + 5.3125_wp * tw_m(k,j,i)
-                ENDDO
-             ENDDO
-          ENDDO
-       ENDIF
-    ENDIF
-
-    CALL cpu_log( log_point(7), 'w-equation', 'stop' )
-
-
-!
-!-- If required, compute prognostic equation for potential temperature
-    IF ( .NOT. neutral )  THEN
-
-       CALL cpu_log( log_point(13), 'pt-equation', 'start' )
-
-!
-!--    pt-tendency terms with communication
-       sbt = tsc(2)
-       IF ( scalar_advec == 'bc-scheme' )  THEN
-
-          IF ( timestep_scheme(1:5) /= 'runge' )  THEN
-!
-!--          Bott-Chlond scheme always uses Euler time step. Thus:
-             sbt = 1.0_wp
-          ENDIF
-          tend = 0.0_wp
-          CALL advec_s_bc( pt, 'pt' )
-
-       ENDIF
-
-!
-!--    pt-tendency terms with no communication
-       IF ( scalar_advec /= 'bc-scheme' )  THEN
-          tend = 0.0_wp
-          IF ( timestep_scheme(1:5) == 'runge' )  THEN
-             IF ( ws_scheme_sca )  THEN
-                CALL advec_s_ws( pt, 'pt' )
-             ELSE
-                CALL advec_s_pw( pt )
-             ENDIF
-          ELSE
-             CALL advec_s_up( pt )
-          ENDIF
-       ENDIF
-
-       CALL diffusion_s( pt, shf, tswst, wall_heatflux )
-
-!
-!--    If required compute heating/cooling due to long wave radiation processes
-       IF ( cloud_top_radiation )  THEN
-          CALL calc_radiation
-       ENDIF
-
-!
-!--    Consideration of heat sources within the plant canopy
-       IF ( plant_canopy .AND. ( cthf /= 0.0_wp ) ) THEN
-          CALL pcm_tendency( 4 )
-       ENDIF
-
-!
-!--    Large scale advection
-       IF ( large_scale_forcing )  THEN
-          CALL ls_advec( simulated_time, 'pt' )
-       ENDIF
-
-!
-!--    Nudging
-       IF ( nudging )  CALL nudge( simulated_time, 'pt' ) 
-
-!
-!--    If required compute influence of large-scale subsidence/ascent
-       IF ( large_scale_subsidence  .AND.                                      &
-            .NOT. use_subsidence_tendencies )  THEN
-          CALL subsidence( tend, pt, pt_init, 2 )
-       ENDIF
-
-!
-!--    If required, add tendency due to radiative heating/cooling
-       IF ( radiation .AND. radiation_scheme == 'rrtmg' .AND.                  &
-            simulated_time > skip_time_do_radiation )  THEN
-            CALL radiation_tendency ( tend )
-       ENDIF
-
-       CALL user_actions( 'pt-tendency' )
-
-!
-!--    Prognostic equation for potential temperature
-       DO  i = nxl, nxr
-          DO  j = nys, nyn
-             DO  k = nzb_s_inner(j,i)+1, nzt
-                pt_p(k,j,i) = pt(k,j,i) + dt_3d * ( sbt * tend(k,j,i) +        &
-                                                    tsc(3) * tpt_m(k,j,i) )    &
-                                        - tsc(5) * ( pt(k,j,i) - pt_init(k) ) *&
-                                          ( rdf_sc(k) + ptdf_x(i) + ptdf_y(j) )
-             ENDDO
-          ENDDO
-       ENDDO
-
-!
-!--    Calculate tendencies for the next Runge-Kutta step
-       IF ( timestep_scheme(1:5) == 'runge' )  THEN
-          IF ( intermediate_timestep_count == 1 )  THEN
-             DO  i = nxl, nxr
-                DO  j = nys, nyn
-                   DO  k = nzb_s_inner(j,i)+1, nzt
-                      tpt_m(k,j,i) = tend(k,j,i)
-                   ENDDO
-                ENDDO
-             ENDDO
-          ELSEIF ( intermediate_timestep_count < &
-                   intermediate_timestep_count_max )  THEN
-             DO  i = nxl, nxr
-                DO  j = nys, nyn
-                   DO  k = nzb_s_inner(j,i)+1, nzt
-                      tpt_m(k,j,i) = -9.5625_wp * tend(k,j,i) + &
-                                      5.3125_wp * tpt_m(k,j,i)
-                   ENDDO
-                ENDDO
-             ENDDO
-          ENDIF
-       ENDIF
-
-       CALL cpu_log( log_point(13), 'pt-equation', 'stop' )
-
-    ENDIF
-
-!
-!-- If required, compute prognostic equation for salinity
-    IF ( ocean )  THEN
-
-       CALL cpu_log( log_point(37), 'sa-equation', 'start' )
-
-!
-!--    sa-tendency terms with communication
-       sbt = tsc(2)
-       IF ( scalar_advec == 'bc-scheme' )  THEN
-
-          IF ( timestep_scheme(1:5) /= 'runge' )  THEN
-!
-!--          Bott-Chlond scheme always uses Euler time step. Thus:
-             sbt = 1.0_wp
-          ENDIF
-          tend = 0.0_wp
-          CALL advec_s_bc( sa, 'sa' )
-
-       ENDIF
-
-!
-!--    sa-tendency terms with no communication
-       IF ( scalar_advec /= 'bc-scheme' )  THEN
-          tend = 0.0_wp
-          IF ( timestep_scheme(1:5) == 'runge' )  THEN
-             IF ( ws_scheme_sca )  THEN
-                 CALL advec_s_ws( sa, 'sa' )
-             ELSE
-                 CALL advec_s_pw( sa )
-             ENDIF
-          ELSE
-             CALL advec_s_up( sa )
-          ENDIF
-       ENDIF
-
-       CALL diffusion_s( sa, saswsb, saswst, wall_salinityflux )
-       
-       CALL user_actions( 'sa-tendency' )
-
-!
-!--    Prognostic equation for salinity
-       DO  i = nxl, nxr
-          DO  j = nys, nyn
-             DO  k = nzb_s_inner(j,i)+1, nzt
-                sa_p(k,j,i) = sa(k,j,i) + dt_3d * ( sbt * tend(k,j,i) +        &
-                                                    tsc(3) * tsa_m(k,j,i) )    &
-                                        - tsc(5) * rdf_sc(k) *                 &
-                                          ( sa(k,j,i) - sa_init(k) )
-                IF ( sa_p(k,j,i) < 0.0_wp )  sa_p(k,j,i) = 0.1_wp * sa(k,j,i)
-             ENDDO
-          ENDDO
-       ENDDO
-
-!
-!--    Calculate tendencies for the next Runge-Kutta step
-       IF ( timestep_scheme(1:5) == 'runge' )  THEN
-          IF ( intermediate_timestep_count == 1 )  THEN
-             DO  i = nxl, nxr
-                DO  j = nys, nyn
-                   DO  k = nzb_s_inner(j,i)+1, nzt
-                      tsa_m(k,j,i) = tend(k,j,i)
-                   ENDDO
-                ENDDO
-             ENDDO
-          ELSEIF ( intermediate_timestep_count < &
-                   intermediate_timestep_count_max )  THEN
-             DO  i = nxl, nxr
-                DO  j = nys, nyn
-                   DO  k = nzb_s_inner(j,i)+1, nzt
-                      tsa_m(k,j,i) = -9.5625_wp * tend(k,j,i) + &
-                                      5.3125_wp * tsa_m(k,j,i)
-                   ENDDO
-                ENDDO
-             ENDDO
-          ENDIF
-       ENDIF
-
-       CALL cpu_log( log_point(37), 'sa-equation', 'stop' )
-
-!
-!--    Calculate density by the equation of state for seawater
-       CALL cpu_log( log_point(38), 'eqns-seawater', 'start' )
-       CALL eqn_state_seawater
-       CALL cpu_log( log_point(38), 'eqns-seawater', 'stop' )
-
-    ENDIF
-
-!
-!-- If required, compute prognostic equation for total water content / scalar
-    IF ( humidity  .OR.  passive_scalar )  THEN
-
-       CALL cpu_log( log_point(29), 'q/s-equation', 'start' )
-
-!
-!--    Scalar/q-tendency terms with communication
-       sbt = tsc(2)
-       IF ( scalar_advec == 'bc-scheme' )  THEN
-
-          IF ( timestep_scheme(1:5) /= 'runge' )  THEN
-!
-!--          Bott-Chlond scheme always uses Euler time step. Thus:
-             sbt = 1.0_wp
-          ENDIF
-          tend = 0.0_wp
-          CALL advec_s_bc( q, 'q' )
-
-       ENDIF
-
-!
-!--    Scalar/q-tendency terms with no communication
-       IF ( scalar_advec /= 'bc-scheme' )  THEN
-          tend = 0.0_wp
-          IF ( timestep_scheme(1:5) == 'runge' )  THEN
-             IF ( ws_scheme_sca )  THEN
-                CALL advec_s_ws( q, 'q' )
-             ELSE
-                CALL advec_s_pw( q )
-             ENDIF
-          ELSE
-             CALL advec_s_up( q )
-          ENDIF
-       ENDIF
-
-       CALL diffusion_s( q, qsws, qswst, wall_qflux )
-       
-!
-!--    Sink or source of scalar concentration due to canopy elements
-       IF ( plant_canopy ) CALL pcm_tendency( 5 )
-
-!
-!--    Large scale advection
-       IF ( large_scale_forcing )  THEN
-          CALL ls_advec( simulated_time, 'q' )
-       ENDIF
-
-!
-!--    Nudging
-       IF ( nudging )  CALL nudge( simulated_time, 'q' ) 
-
-!
-!--    If required compute influence of large-scale subsidence/ascent
-       IF ( large_scale_subsidence  .AND.                                      &
-            .NOT. use_subsidence_tendencies )  THEN
-         CALL subsidence( tend, q, q_init, 3 )
-       ENDIF
-
-       CALL user_actions( 'q-tendency' )
-
-!
-!--    Prognostic equation for total water content / scalar
-       DO  i = nxl, nxr
-          DO  j = nys, nyn
-             DO  k = nzb_s_inner(j,i)+1, nzt
-                q_p(k,j,i) = q(k,j,i) + dt_3d * ( sbt * tend(k,j,i) +          &
-                                                  tsc(3) * tq_m(k,j,i) )       &
-                                      - tsc(5) * rdf_sc(k) *                   &
-                                        ( q(k,j,i) - q_init(k) )
-                IF ( q_p(k,j,i) < 0.0_wp )  q_p(k,j,i) = 0.1_wp * q(k,j,i)
-             ENDDO
-          ENDDO
-       ENDDO
-
-!
-!--    Calculate tendencies for the next Runge-Kutta step
-       IF ( timestep_scheme(1:5) == 'runge' )  THEN
-          IF ( intermediate_timestep_count == 1 )  THEN
-             DO  i = nxl, nxr
-                DO  j = nys, nyn
-                   DO  k = nzb_s_inner(j,i)+1, nzt
-                      tq_m(k,j,i) = tend(k,j,i)
-                   ENDDO
-                ENDDO
-             ENDDO
-          ELSEIF ( intermediate_timestep_count < &
-                   intermediate_timestep_count_max )  THEN
-             DO  i = nxl, nxr
-                DO  j = nys, nyn
-                   DO  k = nzb_s_inner(j,i)+1, nzt
-                      tq_m(k,j,i) = -9.5625_wp * tend(k,j,i) + 5.3125_wp * tq_m(k,j,i)
-                   ENDDO
-                ENDDO
-             ENDDO
-          ENDIF
-       ENDIF
-
-       CALL cpu_log( log_point(29), 'q/s-equation', 'stop' )
-
-!
-!--    If required, calculate prognostic equations for rain water content 
-!--    and rain drop concentration
-       IF ( cloud_physics  .AND.  microphysics_seifert )  THEN
-
-          CALL cpu_log( log_point(52), 'qr-equation', 'start' )
-
-!
-!--       Calculate prognostic equation for rain water content
-          sbt = tsc(2)
-          IF ( scalar_advec == 'bc-scheme' )  THEN
-
-             IF ( timestep_scheme(1:5) /= 'runge' )  THEN
-!
-!--             Bott-Chlond scheme always uses Euler time step. Thus:
-                sbt = 1.0_wp
-             ENDIF
-             tend = 0.0_wp
-             CALL advec_s_bc( qr, 'qr' )
-
-          ENDIF
-
-!
-!--       qr-tendency terms with no communication
-          IF ( scalar_advec /= 'bc-scheme' )  THEN
-             tend = 0.0_wp
-             IF ( timestep_scheme(1:5) == 'runge' )  THEN
-                IF ( ws_scheme_sca )  THEN
-                   CALL advec_s_ws( qr, 'qr' )
-                ELSE
-                   CALL advec_s_pw( qr )
-                ENDIF
-             ELSE
-                CALL advec_s_up( qr )
-             ENDIF
-          ENDIF
-
-          CALL diffusion_s( qr, qrsws, qrswst, wall_qrflux )
-
-          CALL user_actions( 'qr-tendency' )
-
-!
-!--       Prognostic equation for rain water content
-          DO  i = nxl, nxr
-             DO  j = nys, nyn
-                DO  k = nzb_s_inner(j,i)+1, nzt
-                   qr_p(k,j,i) = qr(k,j,i) + dt_3d * ( sbt * tend(k,j,i) +     &
-                                                     tsc(3) * tqr_m(k,j,i) )   &
-                                           - tsc(5) * rdf_sc(k) * qr(k,j,i)
-                   IF ( qr_p(k,j,i) < 0.0_wp )  qr_p(k,j,i) = 0.0_wp
-                ENDDO
-             ENDDO
-          ENDDO
-
-!
-!--       Calculate tendencies for the next Runge-Kutta step
-          IF ( timestep_scheme(1:5) == 'runge' )  THEN
-             IF ( intermediate_timestep_count == 1 )  THEN
-                DO  i = nxl, nxr
-                   DO  j = nys, nyn
-                      DO  k = nzb_s_inner(j,i)+1, nzt
-                         tqr_m(k,j,i) = tend(k,j,i)
-                      ENDDO
-                   ENDDO
-                ENDDO
-             ELSEIF ( intermediate_timestep_count < &
-                      intermediate_timestep_count_max )  THEN
-                DO  i = nxl, nxr
-                   DO  j = nys, nyn
-                      DO  k = nzb_s_inner(j,i)+1, nzt
-                         tqr_m(k,j,i) = -9.5625_wp * tend(k,j,i) + 5.3125_wp * &
-                                                                   tqr_m(k,j,i)
-                      ENDDO
-                   ENDDO
-                ENDDO
-             ENDIF
-          ENDIF
-
-          CALL cpu_log( log_point(52), 'qr-equation', 'stop' )
-          CALL cpu_log( log_point(53), 'nr-equation', 'start' )
-
-!
-!--       Calculate prognostic equation for rain drop concentration
-          sbt = tsc(2)
-          IF ( scalar_advec == 'bc-scheme' )  THEN
-
-             IF ( timestep_scheme(1:5) /= 'runge' )  THEN
-!
-!--             Bott-Chlond scheme always uses Euler time step. Thus:
-                sbt = 1.0_wp
-             ENDIF
-             tend = 0.0_wp
-             CALL advec_s_bc( nr, 'nr' )
-
-          ENDIF
-
-!
-!--       nr-tendency terms with no communication
-          IF ( scalar_advec /= 'bc-scheme' )  THEN
-             tend = 0.0_wp
-             IF ( timestep_scheme(1:5) == 'runge' )  THEN
-                IF ( ws_scheme_sca )  THEN
-                   CALL advec_s_ws( nr, 'nr' )
-                ELSE
-                   CALL advec_s_pw( nr )
-                ENDIF
-             ELSE
-                CALL advec_s_up( nr )
-             ENDIF
-          ENDIF
-
-          CALL diffusion_s( nr, nrsws, nrswst, wall_nrflux )
-
-!
-!--       Prognostic equation for rain drop concentration
-          DO  i = nxl, nxr
-             DO  j = nys, nyn
-                DO  k = nzb_s_inner(j,i)+1, nzt
-                   nr_p(k,j,i) = nr(k,j,i) + dt_3d * ( sbt * tend(k,j,i) +     &
-                                                     tsc(3) * tnr_m(k,j,i) )   &
-                                           - tsc(5) * rdf_sc(k) * nr(k,j,i)
-                   IF ( nr_p(k,j,i) < 0.0_wp )  nr_p(k,j,i) = 0.0_wp
-                ENDDO
-             ENDDO
-          ENDDO
-
-!
-!--       Calculate tendencies for the next Runge-Kutta step
-          IF ( timestep_scheme(1:5) == 'runge' )  THEN
-             IF ( intermediate_timestep_count == 1 )  THEN
-                DO  i = nxl, nxr
-                   DO  j = nys, nyn
-                      DO  k = nzb_s_inner(j,i)+1, nzt
-                         tnr_m(k,j,i) = tend(k,j,i)
-                      ENDDO
-                   ENDDO
-                ENDDO
-             ELSEIF ( intermediate_timestep_count < &
-                      intermediate_timestep_count_max )  THEN
-                DO  i = nxl, nxr
-                   DO  j = nys, nyn
-                      DO  k = nzb_s_inner(j,i)+1, nzt
-                         tnr_m(k,j,i) = -9.5625_wp * tend(k,j,i) + 5.3125_wp * &
-                                                                   tnr_m(k,j,i)
-                      ENDDO
-                   ENDDO
-                ENDDO
-             ENDIF
-          ENDIF
-
-          CALL cpu_log( log_point(53), 'nr-equation', 'stop' )
-
-       ENDIF
-
-    ENDIF
-
-!
-!-- If required, compute prognostic equation for turbulent kinetic 
-!-- energy (TKE)
-    IF ( .NOT. constant_diffusion )  THEN
-
-       CALL cpu_log( log_point(16), 'tke-equation', 'start' )
-
-       sbt = tsc(2)
-       IF ( .NOT. use_upstream_for_tke )  THEN
-          IF ( scalar_advec == 'bc-scheme' )  THEN
-
-             IF ( timestep_scheme(1:5) /= 'runge' )  THEN
-!
-!--             Bott-Chlond scheme always uses Euler time step. Thus:
-                sbt = 1.0_wp
-             ENDIF
-             tend = 0.0_wp
-             CALL advec_s_bc( e, 'e' )
-
-          ENDIF
-       ENDIF
-
-!
-!--    TKE-tendency terms with no communication
-       IF ( scalar_advec /= 'bc-scheme'  .OR.  use_upstream_for_tke )  THEN
-          IF ( use_upstream_for_tke )  THEN
-             tend = 0.0_wp
-             CALL advec_s_up( e )
-          ELSE
-             tend = 0.0_wp
-             IF ( timestep_scheme(1:5) == 'runge' )  THEN
-                IF ( ws_scheme_sca )  THEN
-                   CALL advec_s_ws( e, 'e' )
-                ELSE 
-                   CALL advec_s_pw( e )
-                ENDIF
-             ELSE
-                CALL advec_s_up( e )
-             ENDIF
-          ENDIF
-       ENDIF
-
-       IF ( .NOT. humidity )  THEN
-          IF ( ocean )  THEN
-             CALL diffusion_e( prho, prho_reference )
-          ELSE
-             CALL diffusion_e( pt, pt_reference )
-          ENDIF
-       ELSE
-          CALL diffusion_e( vpt, pt_reference )
-       ENDIF
-
-       CALL production_e
-
-!
-!--    Additional sink term for flows through plant canopies
-       IF ( plant_canopy )  CALL pcm_tendency( 6 )
-       CALL user_actions( 'e-tendency' )
-
-!
-!--    Prognostic equation for TKE.
-!--    Eliminate negative TKE values, which can occur due to numerical
-!--    reasons in the course of the integration. In such cases the old TKE
-!--    value is reduced by 90%.
-       DO  i = nxl, nxr
-          DO  j = nys, nyn
-             DO  k = nzb_s_inner(j,i)+1, nzt
-                e_p(k,j,i) = e(k,j,i) + dt_3d * ( sbt * tend(k,j,i) +          &
-                                                  tsc(3) * te_m(k,j,i) )
-                IF ( e_p(k,j,i) < 0.0_wp )  e_p(k,j,i) = 0.1_wp * e(k,j,i)
-             ENDDO
-          ENDDO
-       ENDDO
-
-!
-!--    Calculate tendencies for the next Runge-Kutta step
-       IF ( timestep_scheme(1:5) == 'runge' )  THEN
-          IF ( intermediate_timestep_count == 1 )  THEN
-             DO  i = nxl, nxr
-                DO  j = nys, nyn
-                   DO  k = nzb_s_inner(j,i)+1, nzt
-                      te_m(k,j,i) = tend(k,j,i)
-                   ENDDO
-                ENDDO
-             ENDDO
-          ELSEIF ( intermediate_timestep_count < &
-                   intermediate_timestep_count_max )  THEN
-             DO  i = nxl, nxr
-                DO  j = nys, nyn
-                   DO  k = nzb_s_inner(j,i)+1, nzt
-                      te_m(k,j,i) = -9.5625_wp * tend(k,j,i) + 5.3125_wp * te_m(k,j,i)
-                   ENDDO
-                ENDDO
-             ENDDO
-          ENDIF
-       ENDIF
-
-       CALL cpu_log( log_point(16), 'tke-equation', 'stop' )
-
-    ENDIF
-
- END SUBROUTINE prognostic_equations_vector
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Version for accelerator boards
-!------------------------------------------------------------------------------!
- 
- SUBROUTINE prognostic_equations_acc
-
-
-    IMPLICIT NONE
-
-    INTEGER(iwp) ::  i           !<
-    INTEGER(iwp) ::  j           !<
-    INTEGER(iwp) ::  k           !<
-    INTEGER(iwp) ::  runge_step  !<
-
-    REAL(wp)     ::  sbt         !<
-
-!
-!-- Set switch for intermediate Runge-Kutta step
-    runge_step = 0
-    IF ( timestep_scheme(1:5) == 'runge' )  THEN
-       IF ( intermediate_timestep_count == 1 )  THEN
-          runge_step = 1
-       ELSEIF ( intermediate_timestep_count < &
-                intermediate_timestep_count_max )  THEN
-          runge_step = 2
-       ENDIF
-    ENDIF
-
-!
-!-- If required, calculate cloud microphysical impacts (two-moment scheme)
-    IF ( cloud_physics  .AND.  .NOT. microphysics_sat_adjust  .AND.            &
-         ( intermediate_timestep_count == 1  .OR.                              &
-           call_microphysics_at_all_substeps )                                 &
-       )  THEN
-       CALL cpu_log( log_point(51), 'microphysics', 'start' )
-       CALL microphysics_control
-       CALL cpu_log( log_point(51), 'microphysics', 'stop' )
-    ENDIF
-
-!
-!-- u-velocity component
-!++ Statistics still not completely ported to accelerators
-    !$acc update device( hom, ref_state )
-    CALL cpu_log( log_point(5), 'u-equation', 'start' )
-
-    IF ( timestep_scheme(1:5) == 'runge' )  THEN
-       IF ( ws_scheme_mom )  THEN
-          CALL advec_u_ws_acc
-       ELSE
-          tend = 0.0_wp   ! to be removed later??
-          CALL advec_u_pw
-       ENDIF
-    ELSE
-       CALL advec_u_up
-    ENDIF
-    CALL diffusion_u_acc
-    CALL coriolis_acc( 1 )
-    IF ( sloping_surface  .AND.  .NOT. neutral )  THEN
-       CALL buoyancy( pt, 1 )
-    ENDIF
-
-!
-!-- Drag by plant canopy
-    IF ( plant_canopy )  CALL pcm_tendency( 1 )
-
-!
-!-- External pressure gradient
-    IF ( dp_external )  THEN
-       DO  i = i_left, i_right
-          DO  j = j_south, j_north
-             DO  k = dp_level_ind_b+1, nzt
-                tend(k,j,i) = tend(k,j,i) - dpdxy(1) * dp_smooth_factor(k)
-             ENDDO
-          ENDDO
-       ENDDO
-    ENDIF
-
-!
-!-- Nudging
-    IF ( nudging )  CALL nudge( simulated_time, 'u' )
-
-    CALL user_actions( 'u-tendency' )
-
-!
-!-- Prognostic equation for u-velocity component
-    !$acc kernels present( nzb_u_inner, rdf, tend, tu_m, u, u_init, u_p )
-    !$acc loop independent
-    DO  i = i_left, i_right
-       !$acc loop independent
-       DO  j = j_south, j_north
-          !$acc loop independent
-          DO  k = 1, nzt
-             IF ( k > nzb_u_inner(j,i) )  THEN
-                u_p(k,j,i) = u(k,j,i) + dt_3d * ( tsc(2) * tend(k,j,i) +       &
-                                                  tsc(3) * tu_m(k,j,i) )       &
-                                      - tsc(5) * rdf(k) * ( u(k,j,i) - u_init(k) )
-!
-!--             Tendencies for the next Runge-Kutta step
-                IF ( runge_step == 1 )  THEN
-                   tu_m(k,j,i) = tend(k,j,i)
-                ELSEIF ( runge_step == 2 )  THEN
-                   tu_m(k,j,i) = -9.5625_wp * tend(k,j,i) + 5.3125_wp * tu_m(k,j,i)
-                ENDIF
-             ENDIF
-          ENDDO
-       ENDDO
-    ENDDO
-    !$acc end kernels
-
-    CALL cpu_log( log_point(5), 'u-equation', 'stop' )
-
-!
-!-- v-velocity component
-    CALL cpu_log( log_point(6), 'v-equation', 'start' )
-
-    IF ( timestep_scheme(1:5) == 'runge' )  THEN
-       IF ( ws_scheme_mom )  THEN
-          CALL advec_v_ws_acc
-       ELSE
-          tend = 0.0_wp    ! to be removed later??
-          CALL advec_v_pw
-       END IF
-    ELSE
-       CALL advec_v_up
-    ENDIF
-    CALL diffusion_v_acc
-    CALL coriolis_acc( 2 )
-
-!
-!-- Drag by plant canopy
-    IF ( plant_canopy )  CALL pcm_tendency( 2 )
-
-!
-!-- External pressure gradient
-    IF ( dp_external )  THEN
-       DO  i = i_left, i_right
-          DO  j = j_south, j_north
-             DO  k = dp_level_ind_b+1, nzt
-                tend(k,j,i) = tend(k,j,i) - dpdxy(2) * dp_smooth_factor(k)
-             ENDDO
-          ENDDO
-       ENDDO
-    ENDIF
-
-!
-!-- Nudging
-    IF ( nudging )  CALL nudge( simulated_time, 'v' )
-
-    CALL user_actions( 'v-tendency' )
-
-!
-!-- Prognostic equation for v-velocity component
-    !$acc kernels present( nzb_v_inner, rdf, tend, tv_m, v, v_init, v_p )
-    !$acc loop independent
-    DO  i = i_left, i_right
-       !$acc loop independent
-       DO  j = j_south, j_north
-          !$acc loop independent
-          DO  k = 1, nzt
-             IF ( k > nzb_v_inner(j,i) )  THEN
-                v_p(k,j,i) = v(k,j,i) + dt_3d * ( tsc(2) * tend(k,j,i) +       &
-                                                  tsc(3) * tv_m(k,j,i) )       &
-                                      - tsc(5) * rdf(k) * ( v(k,j,i) - v_init(k) )
-!
-!--             Tendencies for the next Runge-Kutta step
-                IF ( runge_step == 1 )  THEN
-                   tv_m(k,j,i) = tend(k,j,i)
-                ELSEIF ( runge_step == 2 )  THEN
-                   tv_m(k,j,i) = -9.5625_wp * tend(k,j,i) + 5.3125_wp * tv_m(k,j,i)
-                ENDIF
-             ENDIF
-          ENDDO
-       ENDDO
-    ENDDO
-    !$acc end kernels
-
-    CALL cpu_log( log_point(6), 'v-equation', 'stop' )
-
-!
-!-- w-velocity component
-    CALL cpu_log( log_point(7), 'w-equation', 'start' )
-
-    IF ( timestep_scheme(1:5) == 'runge' )  THEN
-       IF ( ws_scheme_mom )  THEN
-          CALL advec_w_ws_acc
-       ELSE
-          tend = 0.0_wp    ! to be removed later??
-          CALL advec_w_pw
-       ENDIF
-    ELSE
-       CALL advec_w_up
-    ENDIF
-    CALL diffusion_w_acc
-    CALL coriolis_acc( 3 )
-
-    IF ( .NOT. neutral )  THEN
-       IF ( ocean )  THEN
-          CALL buoyancy( rho, 3 )
-       ELSE
-          IF ( .NOT. humidity )  THEN
-             CALL buoyancy_acc( pt, 3 )
-          ELSE
-             CALL buoyancy( vpt, 3 )
-          ENDIF
-       ENDIF
-    ENDIF
-
-!
-!-- Drag by plant canopy
-    IF ( plant_canopy )  CALL pcm_tendency( 3 )
-
-    CALL user_actions( 'w-tendency' )
-
-!
-!-- Prognostic equation for w-velocity component
-    !$acc kernels present( nzb_w_inner, rdf, tend, tw_m, w, w_p )
-    !$acc loop independent
-    DO  i = i_left, i_right
-       !$acc loop independent
-       DO  j = j_south, j_north
-          !$acc loop independent
-          DO  k = 1, nzt-1
-             IF ( k > nzb_w_inner(j,i) )  THEN
-                w_p(k,j,i) = w(k,j,i) + dt_3d * ( tsc(2) * tend(k,j,i) +       &
-                                                  tsc(3) * tw_m(k,j,i) )       &
-                                      - tsc(5) * rdf(k) * w(k,j,i)
-   !
-   !--          Tendencies for the next Runge-Kutta step
-                IF ( runge_step == 1 )  THEN
-                   tw_m(k,j,i) = tend(k,j,i)
-                ELSEIF ( runge_step == 2 )  THEN
-                   tw_m(k,j,i) = -9.5625_wp * tend(k,j,i) + 5.3125_wp * tw_m(k,j,i)
-                ENDIF
-             ENDIF
-          ENDDO
-       ENDDO
-    ENDDO
-    !$acc end kernels
-
-    CALL cpu_log( log_point(7), 'w-equation', 'stop' )
-
-
-!
-!-- If required, compute prognostic equation for potential temperature
-    IF ( .NOT. neutral )  THEN
-
-       CALL cpu_log( log_point(13), 'pt-equation', 'start' )
-
-!
-!--    pt-tendency terms with communication
-       sbt = tsc(2)
-       IF ( scalar_advec == 'bc-scheme' )  THEN
-
-          IF ( timestep_scheme(1:5) /= 'runge' )  THEN
-!
-!--          Bott-Chlond scheme always uses Euler time step. Thus:
-             sbt = 1.0_wp
-          ENDIF
-          tend = 0.0_wp
-          CALL advec_s_bc( pt, 'pt' )
-
-       ENDIF
-
-!
-!--    pt-tendency terms with no communication
-       IF ( scalar_advec /= 'bc-scheme' )  THEN
-          tend = 0.0_wp
-          IF ( timestep_scheme(1:5) == 'runge' )  THEN
-             IF ( ws_scheme_sca )  THEN
-                CALL advec_s_ws_acc( pt, 'pt' )
-             ELSE
-                tend = 0.0_wp    ! to be removed later??
-                CALL advec_s_pw( pt )
-             ENDIF
-          ELSE
-             CALL advec_s_up( pt )
-          ENDIF
-       ENDIF
-
-       CALL diffusion_s_acc( pt, shf, tswst, wall_heatflux )
-
-!
-!--    If required compute heating/cooling due to long wave radiation processes
-       IF ( cloud_top_radiation )  THEN
-          CALL calc_radiation
-       ENDIF
-
-!
-!--    Consideration of heat sources within the plant canopy
-       IF ( plant_canopy .AND. ( cthf /= 0.0_wp ) ) THEN
-          CALL pcm_tendency( 4 )
-       ENDIF
-
-!
-!--    Large scale advection
-       IF ( large_scale_forcing )  THEN
-          CALL ls_advec( simulated_time, 'pt' )
-       ENDIF
-
-!
-!--    Nudging
-       IF ( nudging )  CALL nudge( simulated_time, 'pt' ) 
-
-!
-!--    If required compute influence of large-scale subsidence/ascent
-       IF ( large_scale_subsidence  .AND.                                      &
-            .NOT. use_subsidence_tendencies )  THEN
-          CALL subsidence( tend, pt, pt_init, 2 )
-       ENDIF
-
-       IF ( radiation .AND. radiation_scheme == 'rrtmg' .AND.                  &
-            simulated_time > skip_time_do_radiation )  THEN
-            CALL radiation_tendency ( tend )
-       ENDIF
-
-       CALL user_actions( 'pt-tendency' )
-
-!
-!--    Prognostic equation for potential temperature
-       !$acc kernels present( nzb_s_inner, rdf_sc, ptdf_x, ptdf_y, pt_init ) &
-       !$acc         present( tend, tpt_m, pt, pt_p )
-       !$acc loop independent
-       DO  i = i_left, i_right
-          !$acc loop independent
-          DO  j = j_south, j_north
-             !$acc loop independent
-             DO  k = 1, nzt
-                IF ( k > nzb_s_inner(j,i) )  THEN
-                   pt_p(k,j,i) = pt(k,j,i) + dt_3d * ( sbt * tend(k,j,i) +        &
-                                                       tsc(3) * tpt_m(k,j,i) )    &
-                                           - tsc(5) * ( pt(k,j,i) - pt_init(k) ) *&
-                                             ( rdf_sc(k) + ptdf_x(i) + ptdf_y(j) )
-!
-!--                Tendencies for the next Runge-Kutta step
-                   IF ( runge_step == 1 )  THEN
-                      tpt_m(k,j,i) = tend(k,j,i)
-                   ELSEIF ( runge_step == 2 )  THEN
-                      tpt_m(k,j,i) = -9.5625_wp * tend(k,j,i) + 5.3125_wp * tpt_m(k,j,i)
-                   ENDIF
-                ENDIF
-             ENDDO
-          ENDDO
-       ENDDO
-       !$acc end kernels
-
-       CALL cpu_log( log_point(13), 'pt-equation', 'stop' )
-
-    ENDIF
-
-!
-!-- If required, compute prognostic equation for salinity
-    IF ( ocean )  THEN
-
-       CALL cpu_log( log_point(37), 'sa-equation', 'start' )
-
-!
-!--    sa-tendency terms with communication
-       sbt = tsc(2)
-       IF ( scalar_advec == 'bc-scheme' )  THEN
-
-          IF ( timestep_scheme(1:5) /= 'runge' )  THEN
-!
-!--          Bott-Chlond scheme always uses Euler time step. Thus:
-             sbt = 1.0_wp
-          ENDIF
-          tend = 0.0_wp
-          CALL advec_s_bc( sa, 'sa' )
-
-       ENDIF
-
-!
-!--    sa-tendency terms with no communication
-       IF ( scalar_advec /= 'bc-scheme' )  THEN
-          tend = 0.0_wp
-          IF ( timestep_scheme(1:5) == 'runge' )  THEN
-             IF ( ws_scheme_sca )  THEN
-                 CALL advec_s_ws( sa, 'sa' )
-             ELSE
-                 CALL advec_s_pw( sa )
-             ENDIF
-          ELSE
-             CALL advec_s_up( sa )
-          ENDIF
-       ENDIF
-
-       CALL diffusion_s( sa, saswsb, saswst, wall_salinityflux )
-
-       CALL user_actions( 'sa-tendency' )
-
-!
-!--    Prognostic equation for salinity
-       DO  i = i_left, i_right
-          DO  j = j_south, j_north
-             DO  k = nzb_s_inner(j,i)+1, nzt
-                sa_p(k,j,i) = sa(k,j,i) + dt_3d * ( sbt * tend(k,j,i) +        &
-                                                    tsc(3) * tsa_m(k,j,i) )    &
-                                        - tsc(5) * rdf_sc(k) *                 &
-                                          ( sa(k,j,i) - sa_init(k) )
-                IF ( sa_p(k,j,i) < 0.0_wp )  sa_p(k,j,i) = 0.1_wp * sa(k,j,i)
-!
-!--             Tendencies for the next Runge-Kutta step
-                IF ( runge_step == 1 )  THEN
-                   tsa_m(k,j,i) = tend(k,j,i)
-                ELSEIF ( runge_step == 2 )  THEN
-                   tsa_m(k,j,i) = -9.5625_wp * tend(k,j,i) + 5.3125_wp * tsa_m(k,j,i)
-                ENDIF
-             ENDDO
-          ENDDO
-       ENDDO
-
-       CALL cpu_log( log_point(37), 'sa-equation', 'stop' )
-
-!
-!--    Calculate density by the equation of state for seawater
-       CALL cpu_log( log_point(38), 'eqns-seawater', 'start' )
-       CALL eqn_state_seawater
-       CALL cpu_log( log_point(38), 'eqns-seawater', 'stop' )
-
-    ENDIF
-
-!
-!-- If required, compute prognostic equation for total water content / scalar
-    IF ( humidity  .OR.  passive_scalar )  THEN
-
-       CALL cpu_log( log_point(29), 'q/s-equation', 'start' )
-
-!
-!--    Scalar/q-tendency terms with communication
-       sbt = tsc(2)
-       IF ( scalar_advec == 'bc-scheme' )  THEN
-
-          IF ( timestep_scheme(1:5) /= 'runge' )  THEN
-!
-!--          Bott-Chlond scheme always uses Euler time step. Thus:
-             sbt = 1.0_wp
-          ENDIF
-          tend = 0.0_wp
-          CALL advec_s_bc( q, 'q' )
-
-       ENDIF
-
-!
-!--    Scalar/q-tendency terms with no communication
-       IF ( scalar_advec /= 'bc-scheme' )  THEN
-          tend = 0.0_wp
-          IF ( timestep_scheme(1:5) == 'runge' )  THEN
-             IF ( ws_scheme_sca )  THEN
-                CALL advec_s_ws( q, 'q' )
-             ELSE
-                CALL advec_s_pw( q )
-             ENDIF
-          ELSE
-             CALL advec_s_up( q )
-          ENDIF
-       ENDIF
-
-       CALL diffusion_s( q, qsws, qswst, wall_qflux )
-
-!
-!--    Sink or source of scalar concentration due to canopy elements
-       IF ( plant_canopy ) CALL pcm_tendency( 5 )
-
-!
-!--    Large scale advection
-       IF ( large_scale_forcing )  THEN
-          CALL ls_advec( simulated_time, 'q' )
-       ENDIF
-
-!
-!--    Nudging
-       IF ( nudging )  CALL nudge( simulated_time, 'q' ) 
-
-!
-!--    If required compute influence of large-scale subsidence/ascent
-       IF ( large_scale_subsidence  .AND.                                      &
-            .NOT. use_subsidence_tendencies )  THEN
-         CALL subsidence( tend, q, q_init, 3 )
-       ENDIF
-
-       CALL user_actions( 'q-tendency' )
-
-!
-!--    Prognostic equation for total water content / scalar
-       DO  i = i_left, i_right
-          DO  j = j_south, j_north
-             DO  k = nzb_s_inner(j,i)+1, nzt
-                q_p(k,j,i) = q(k,j,i) + dt_3d * ( sbt * tend(k,j,i) +          &
-                                                  tsc(3) * tq_m(k,j,i) )       &
-                                      - tsc(5) * rdf_sc(k) *                   &
-                                        ( q(k,j,i) - q_init(k) )
-                IF ( q_p(k,j,i) < 0.0_wp )  q_p(k,j,i) = 0.1_wp * q(k,j,i)
-!
-!--             Tendencies for the next Runge-Kutta step
-                IF ( runge_step == 1 )  THEN
-                   tq_m(k,j,i) = tend(k,j,i)
-                ELSEIF ( runge_step == 2 )  THEN
-                   tq_m(k,j,i) = -9.5625_wp * tend(k,j,i) + 5.3125_wp * tq_m(k,j,i)
-                ENDIF
-             ENDDO
-          ENDDO
-       ENDDO
-
-       CALL cpu_log( log_point(29), 'q/s-equation', 'stop' )
-
-!
-!--    If required, calculate prognostic equations for rain water content 
-!--    and rain drop concentration
-       IF ( cloud_physics  .AND.  microphysics_seifert )  THEN
-
-          CALL cpu_log( log_point(52), 'qr-equation', 'start' )
-!
-!--       qr-tendency terms with communication
-          sbt = tsc(2)
-          IF ( scalar_advec == 'bc-scheme' )  THEN
-
-             IF ( timestep_scheme(1:5) /= 'runge' )  THEN
-!
-!--             Bott-Chlond scheme always uses Euler time step. Thus:
-                sbt = 1.0_wp
-             ENDIF
-             tend = 0.0_wp
-             CALL advec_s_bc( qr, 'qr' )
-
-          ENDIF
-
-!
-!--       qr-tendency terms with no communication
-          IF ( scalar_advec /= 'bc-scheme' )  THEN
-             tend = 0.0_wp
-             IF ( timestep_scheme(1:5) == 'runge' )  THEN
-                IF ( ws_scheme_sca )  THEN
-                   CALL advec_s_ws( qr, 'qr' )
-                ELSE
-                   CALL advec_s_pw( qr )
-                ENDIF
-             ELSE
-                CALL advec_s_up( qr )
-             ENDIF
-          ENDIF
-
-          CALL diffusion_s( qr, qrsws, qrswst, wall_qrflux )
-
-!
-!--       Prognostic equation for rain water content
-          DO  i = i_left, i_right
-             DO  j = j_south, j_north
-                DO  k = nzb_s_inner(j,i)+1, nzt
-                   qr_p(k,j,i) = qr(k,j,i) + dt_3d * ( sbt * tend(k,j,i) +     &
-                                                       tsc(3) * tqr_m(k,j,i) ) &
-                                           - tsc(5) * rdf_sc(k) * qr(k,j,i)
-                   IF ( qr_p(k,j,i) < 0.0_wp )  qr_p(k,j,i) = 0.0_wp
-!
-!--                Tendencies for the next Runge-Kutta step
-                   IF ( runge_step == 1 )  THEN
-                      tqr_m(k,j,i) = tend(k,j,i)
-                   ELSEIF ( runge_step == 2 )  THEN
-                      tqr_m(k,j,i) = -9.5625_wp * tend(k,j,i) + 5.3125_wp *    &
-                                                                tqr_m(k,j,i)
-                   ENDIF
-                ENDDO
-             ENDDO
-          ENDDO
-
-          CALL cpu_log( log_point(52), 'qr-equation', 'stop' )
-          CALL cpu_log( log_point(53), 'nr-equation', 'start' )
-
-!
-!--       nr-tendency terms with communication
-          sbt = tsc(2)
-          IF ( scalar_advec == 'bc-scheme' )  THEN
-
-             IF ( timestep_scheme(1:5) /= 'runge' )  THEN
-!
-!--             Bott-Chlond scheme always uses Euler time step. Thus:
-                sbt = 1.0_wp
-             ENDIF
-             tend = 0.0_wp
-             CALL advec_s_bc( nr, 'nr' )
-
-          ENDIF
-
-!
-!--       nr-tendency terms with no communication
-          IF ( scalar_advec /= 'bc-scheme' )  THEN
-             tend = 0.0_wp
-             IF ( timestep_scheme(1:5) == 'runge' )  THEN
-                IF ( ws_scheme_sca )  THEN
-                   CALL advec_s_ws( nr, 'nr' )
-                ELSE
-                   CALL advec_s_pw( nr )
-                ENDIF
-             ELSE
-                CALL advec_s_up( nr )
-             ENDIF
-          ENDIF
-
-          CALL diffusion_s( nr, nrsws, nrswst, wall_nrflux )
-
-!
-!--       Prognostic equation for rain drop concentration
-          DO  i = i_left, i_right
-             DO  j = j_south, j_north
-                DO  k = nzb_s_inner(j,i)+1, nzt
-                   nr_p(k,j,i) = nr(k,j,i) + dt_3d * ( sbt * tend(k,j,i) +     &
-                                                       tsc(3) * tnr_m(k,j,i) ) &
-                                           - tsc(5) * rdf_sc(k) * nr(k,j,i)
-                   IF ( nr_p(k,j,i) < 0.0_wp )  nr_p(k,j,i) = 0.0_wp
-!
-!--                Tendencies for the next Runge-Kutta step
-                   IF ( runge_step == 1 )  THEN
-                      tnr_m(k,j,i) = tend(k,j,i)
-                   ELSEIF ( runge_step == 2 )  THEN
-                      tnr_m(k,j,i) = -9.5625_wp * tend(k,j,i) + 5.3125_wp *    &
-                                                                tnr_m(k,j,i)
-                   ENDIF
-                ENDDO
-             ENDDO
-          ENDDO
-
-          CALL cpu_log( log_point(53), 'nr-equation', 'stop' )
-
-       ENDIF
-
-    ENDIF
-
-!
-!-- If required, compute prognostic equation for turbulent kinetic
-!-- energy (TKE)
-    IF ( .NOT. constant_diffusion )  THEN
-
-       CALL cpu_log( log_point(16), 'tke-equation', 'start' )
-
-       sbt = tsc(2)
-       IF ( .NOT. use_upstream_for_tke )  THEN
-          IF ( scalar_advec == 'bc-scheme' )  THEN
-
-             IF ( timestep_scheme(1:5) /= 'runge' )  THEN
-!
-!--             Bott-Chlond scheme always uses Euler time step. Thus:
-                sbt = 1.0_wp
-             ENDIF
-             tend = 0.0_wp
-             CALL advec_s_bc( e, 'e' )
-
-          ENDIF
-       ENDIF
-
-!
-!--    TKE-tendency terms with no communication
-       IF ( scalar_advec /= 'bc-scheme'  .OR.  use_upstream_for_tke )  THEN
-          IF ( use_upstream_for_tke )  THEN
-             tend = 0.0_wp
-             CALL advec_s_up( e )
-          ELSE
-             IF ( timestep_scheme(1:5) == 'runge' )  THEN
-                IF ( ws_scheme_sca )  THEN
-                   CALL advec_s_ws_acc( e, 'e' )
-                ELSE
-                   tend = 0.0_wp    ! to be removed later??
-                   CALL advec_s_pw( e )
-                ENDIF
-             ELSE
-                tend = 0.0_wp    ! to be removed later??
-                CALL advec_s_up( e )
-             ENDIF
-          ENDIF
-       ENDIF
-
-       IF ( .NOT. humidity )  THEN
-          IF ( ocean )  THEN
-             CALL diffusion_e( prho, prho_reference )
-          ELSE
-             CALL diffusion_e_acc( pt, pt_reference )
-          ENDIF
-       ELSE
-          CALL diffusion_e( vpt, pt_reference )
-       ENDIF
-
-       CALL production_e_acc
-
-!
-!--    Additional sink term for flows through plant canopies
-       IF ( plant_canopy )  CALL pcm_tendency( 6 )
-       CALL user_actions( 'e-tendency' )
-
-!
-!--    Prognostic equation for TKE.
-!--    Eliminate negative TKE values, which can occur due to numerical
-!--    reasons in the course of the integration. In such cases the old TKE
-!--    value is reduced by 90%.
-       !$acc kernels present( e, e_p, nzb_s_inner, tend, te_m )
-       !$acc loop independent
-       DO  i = i_left, i_right
-          !$acc loop independent
-          DO  j = j_south, j_north
-             !$acc loop independent
-             DO  k = 1, nzt
-                IF ( k > nzb_s_inner(j,i) )  THEN
-                   e_p(k,j,i) = e(k,j,i) + dt_3d * ( sbt * tend(k,j,i) +          &
-                                                     tsc(3) * te_m(k,j,i) )
-                   IF ( e_p(k,j,i) < 0.0_wp )  e_p(k,j,i) = 0.1_wp * e(k,j,i)
-!
-!--                Tendencies for the next Runge-Kutta step
-                   IF ( runge_step == 1 )  THEN
-                      te_m(k,j,i) = tend(k,j,i)
-                   ELSEIF ( runge_step == 2 )  THEN
-                      te_m(k,j,i) = -9.5625_wp * tend(k,j,i) + 5.3125_wp * te_m(k,j,i)
-                   ENDIF
-                ENDIF
-             ENDDO
-          ENDDO
-       ENDDO
-       !$acc end kernels
-
-       CALL cpu_log( log_point(16), 'tke-equation', 'stop' )
-
-    ENDIF
-
- END SUBROUTINE prognostic_equations_acc
-
-
- END MODULE prognostic_equations_mod
Index: /palm/trunk/SOURCE/prognostic_equations_mod.f90
===================================================================
--- /palm/trunk/SOURCE/prognostic_equations_mod.f90	(revision 1850)
+++ /palm/trunk/SOURCE/prognostic_equations_mod.f90	(revision 1850)
@@ -0,0 +1,2482 @@
+!> @file prognostic_equations_mod.f90
+!--------------------------------------------------------------------------------!
+! This file is part of PALM.
+!
+! PALM is free software: you can redistribute it and/or modify it under the terms
+! of the GNU General Public License as published by the Free Software Foundation,
+! either version 3 of the License, or (at your option) any later version.
+!
+! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
+! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
+! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along with
+! PALM. If not, see <http://www.gnu.org/licenses/>.
+!
+! Copyright 1997-2016 Leibniz Universitaet Hannover
+!--------------------------------------------------------------------------------!
+!
+! Current revisions:
+! ------------------
+! Module renamed
+! 
+! 
+! Former revisions:
+! -----------------
+! $Id$
+!
+! 1826 2016-04-07 12:01:39Z maronga
+! Renamed canopy model calls.
+! 
+! 1822 2016-04-07 07:49:42Z hoffmann
+! Kessler microphysics scheme moved to microphysics.
+!
+! 1757 2016-02-22 15:49:32Z maronga
+! 
+! 
+! 1691 2015-10-26 16:17:44Z maronga
+! Added optional model spin-up without radiation / land surface model calls.
+! Formatting corrections.
+! 
+! 1682 2015-10-07 23:56:08Z knoop
+! Code annotations made doxygen readable 
+! 
+! 1585 2015-04-30 07:05:52Z maronga
+! Added call for temperature tendency calculation due to radiative flux divergence
+! 
+! 1517 2015-01-07 19:12:25Z hoffmann
+! advec_s_bc_mod addded, since advec_s_bc is now a module
+!
+! 1496 2014-12-02 17:25:50Z maronga
+! Renamed "radiation" -> "cloud_top_radiation"
+! 
+! 1484 2014-10-21 10:53:05Z kanani
+! Changes due to new module structure of the plant canopy model:
+!   parameters cthf and plant_canopy moved to module plant_canopy_model_mod.
+! Removed double-listing of use_upstream_for_tke in ONLY-list of module
+! control_parameters
+! 
+! 1409 2014-05-23 12:11:32Z suehring
+! Bugfix: i_omp_start changed for advec_u_ws at left inflow and outflow boundary. 
+! This ensures that left-hand side fluxes are also calculated for nxl in that
+! case, even though the solution at nxl is overwritten in boundary_conds() 
+! 
+! 1398 2014-05-07 11:15:00Z heinze
+! Rayleigh-damping for horizontal velocity components changed: instead of damping
+! against ug and vg, damping against u_init and v_init is used to allow for a 
+! homogenized treatment in case of nudging
+! 
+! 1380 2014-04-28 12:40:45Z heinze
+! Change order of calls for scalar prognostic quantities: 
+! ls_advec -> nudging -> subsidence since initial profiles 
+! 
+! 1374 2014-04-25 12:55:07Z raasch
+! missing variables added to ONLY lists
+! 
+! 1365 2014-04-22 15:03:56Z boeske
+! Calls of ls_advec for large scale advection added, 
+! subroutine subsidence is only called if use_subsidence_tendencies = .F.,
+! new argument ls_index added to the calls of subsidence
+! +ls_index
+! 
+! 1361 2014-04-16 15:17:48Z hoffmann
+! Two-moment microphysics moved to the start of prognostic equations. This makes
+! the 3d arrays for tend_q, tend_qr, tend_pt and tend_pt redundant.
+! Additionally, it is allowed to call the microphysics just once during the time
+! step (not at each sub-time step).
+!
+! Two-moment cloud physics added for vector and accelerator optimization.
+! 
+! 1353 2014-04-08 15:21:23Z heinze
+! REAL constants provided with KIND-attribute
+! 
+! 1337 2014-03-25 15:11:48Z heinze
+! Bugfix: REAL constants provided with KIND-attribute
+! 
+! 1332 2014-03-25 11:59:43Z suehring
+! Bugfix: call advec_ws or advec_pw for TKE only if NOT use_upstream_for_tke 
+! 
+! 1330 2014-03-24 17:29:32Z suehring
+! In case of SGS-particle velocity advection of TKE is also allowed with 
+! dissipative 5th-order scheme.
+!
+! 1320 2014-03-20 08:40:49Z raasch
+! ONLY-attribute added to USE-statements,
+! kind-parameters added to all INTEGER and REAL declaration statements,
+! kinds are defined in new module kinds,
+! old module precision_kind is removed,
+! revision history before 2012 removed,
+! comment fields (!:) to be used for variable explanations added to
+! all variable declaration statements
+!
+! 1318 2014-03-17 13:35:16Z raasch
+! module interfaces removed
+!
+! 1257 2013-11-08 15:18:40Z raasch
+! openacc loop vector clauses removed, independent clauses added
+!
+! 1246 2013-11-01 08:59:45Z heinze
+! enable nudging also for accelerator version
+!
+! 1241 2013-10-30 11:36:58Z heinze
+! usage of nudging enabled (so far not implemented for accelerator version)
+!
+! 1179 2013-06-14 05:57:58Z raasch
+! two arguments removed from routine buoyancy, ref_state updated on device
+!
+! 1128 2013-04-12 06:19:32Z raasch
+! those parts requiring global communication moved to time_integration,
+! loop index bounds in accelerator version replaced by i_left, i_right, j_south,
+! j_north
+!
+! 1115 2013-03-26 18:16:16Z hoffmann
+! optimized cloud physics: calculation of microphysical tendencies transfered 
+! to microphysics.f90; qr and nr are only calculated if precipitation is required
+!
+! 1111 2013-03-08 23:54:10Z raasch
+! update directives for prognostic quantities removed
+!
+! 1106 2013-03-04 05:31:38Z raasch
+! small changes in code formatting
+!
+! 1092 2013-02-02 11:24:22Z raasch
+! unused variables removed
+!
+! 1053 2012-11-13 17:11:03Z hoffmann
+! implementation of two new prognostic equations for rain drop concentration (nr)
+! and rain water content (qr)
+!
+! currently, only available for cache loop optimization
+!
+! 1036 2012-10-22 13:43:42Z raasch
+! code put under GPL (PALM 3.9)
+!
+! 1019 2012-09-28 06:46:45Z raasch
+! non-optimized version of prognostic_equations removed
+!
+! 1015 2012-09-27 09:23:24Z raasch
+! new branch prognostic_equations_acc
+! OpenACC statements added + code changes required for GPU optimization
+!
+! 1001 2012-09-13 14:08:46Z raasch
+! all actions concerning leapfrog- and upstream-spline-scheme removed
+!
+! 978 2012-08-09 08:28:32Z fricke
+! km_damp_x and km_damp_y removed in calls of diffusion_u and diffusion_v
+! add ptdf_x, ptdf_y for damping the potential temperature at the inflow
+! boundary in case of non-cyclic lateral boundaries
+! Bugfix: first thread index changes for WS-scheme at the inflow
+!
+! 940 2012-07-09 14:31:00Z raasch
+! temperature equation can be switched off
+!
+! Revision 1.1  2000/04/13 14:56:27  schroeter
+! Initial revision
+!
+!
+! Description:
+! ------------
+!> Solving the prognostic equations.
+!------------------------------------------------------------------------------!
+ MODULE prognostic_equations_mod
+
+ 
+
+    USE arrays_3d,                                                             &
+        ONLY:  diss_l_e, diss_l_nr, diss_l_pt, diss_l_q, diss_l_qr,            &
+               diss_l_sa, diss_s_e, diss_s_nr, diss_s_pt, diss_s_q,            &
+               diss_s_qr, diss_s_sa, e, e_p, flux_s_e, flux_s_nr, flux_s_pt,   &
+               flux_s_q, flux_s_qr, flux_s_sa, flux_l_e, flux_l_nr,            &
+               flux_l_pt, flux_l_q, flux_l_qr, flux_l_sa, nr, nr_p, nrsws,     &
+               nrswst, pt, ptdf_x, ptdf_y, pt_init, pt_p, prho, q, q_init,     &
+               q_p, qsws, qswst, qr, qr_p, qrsws, qrswst, rdf, rdf_sc,         &
+               ref_state, rho, sa, sa_init, sa_p, saswsb, saswst, shf, tend,   &
+               te_m, tnr_m, tpt_m, tq_m, tqr_m, tsa_m, tswst, tu_m, tv_m,      &
+               tw_m, u, ug, u_init, u_p, v, vg, vpt, v_init, v_p, w, w_p
+        
+    USE control_parameters,                                                    &
+        ONLY:  call_microphysics_at_all_substeps, cloud_physics,               &
+               cloud_top_radiation, constant_diffusion, dp_external,           &
+               dp_level_ind_b, dp_smooth_factor, dpdxy, dt_3d, humidity,       &
+               inflow_l, intermediate_timestep_count,                          &
+               intermediate_timestep_count_max, large_scale_forcing,           &
+               large_scale_subsidence, microphysics_seifert,                   &
+               microphysics_sat_adjust, neutral, nudging, ocean, outflow_l,    &
+               outflow_s, passive_scalar, prho_reference, prho_reference,      &
+               prho_reference, pt_reference, pt_reference, pt_reference,       &
+               scalar_advec, scalar_advec, simulated_time, sloping_surface,    &
+               timestep_scheme, tsc, use_subsidence_tendencies,                &
+               use_upstream_for_tke, wall_heatflux,                            &
+               wall_nrflux, wall_qflux, wall_qflux, wall_qflux, wall_qrflux,   &
+               wall_salinityflux, ws_scheme_mom, ws_scheme_sca
+
+    USE cpulog,                                                                &
+        ONLY:  cpu_log, log_point
+
+    USE eqn_state_seawater_mod,                                                &
+        ONLY:  eqn_state_seawater
+
+    USE indices,                                                               &
+        ONLY:  i_left, i_right, j_north, j_south, nxl, nxlu, nxr, nyn, nys,    &
+               nysv, nzb_s_inner, nzb_u_inner, nzb_v_inner, nzb_w_inner, nzt
+
+    USE advec_ws,                                                              &
+        ONLY:  advec_s_ws, advec_s_ws_acc, advec_u_ws, advec_u_ws_acc,         &
+               advec_v_ws, advec_v_ws_acc, advec_w_ws, advec_w_ws_acc
+
+    USE advec_s_bc_mod,                                                        &
+        ONLY:  advec_s_bc
+
+    USE advec_s_pw_mod,                                                        &
+        ONLY:  advec_s_pw
+
+    USE advec_s_up_mod,                                                        &
+        ONLY:  advec_s_up
+
+    USE advec_u_pw_mod,                                                        &
+        ONLY:  advec_u_pw
+
+    USE advec_u_up_mod,                                                        &
+        ONLY:  advec_u_up
+
+    USE advec_v_pw_mod,                                                        &
+        ONLY:  advec_v_pw
+
+    USE advec_v_up_mod,                                                        &
+        ONLY:  advec_v_up
+
+    USE advec_w_pw_mod,                                                        &
+        ONLY:  advec_w_pw
+
+    USE advec_w_up_mod,                                                        &
+        ONLY:  advec_w_up
+
+    USE buoyancy_mod,                                                          &
+        ONLY:  buoyancy, buoyancy_acc
+
+    USE calc_radiation_mod,                                                    &
+        ONLY:  calc_radiation
+  
+    USE coriolis_mod,                                                          &
+        ONLY:  coriolis, coriolis_acc
+
+    USE diffusion_e_mod,                                                       &
+        ONLY:  diffusion_e, diffusion_e_acc
+
+    USE diffusion_s_mod,                                                       &
+        ONLY:  diffusion_s, diffusion_s_acc
+
+    USE diffusion_u_mod,                                                       &
+        ONLY:  diffusion_u, diffusion_u_acc
+
+    USE diffusion_v_mod,                                                       &
+        ONLY:  diffusion_v, diffusion_v_acc
+
+    USE diffusion_w_mod,                                                       &
+        ONLY:  diffusion_w, diffusion_w_acc
+
+    USE kinds
+
+    USE ls_forcing_mod,                                                        &
+        ONLY:  ls_advec
+
+    USE microphysics_mod,                                                      &
+        ONLY:  microphysics_control
+
+    USE nudge_mod,                                                             &
+        ONLY:  nudge
+
+    USE plant_canopy_model_mod,                                                &
+        ONLY:  cthf, plant_canopy, pcm_tendency
+
+    USE production_e_mod,                                                      &
+        ONLY:  production_e, production_e_acc
+
+    USE radiation_model_mod,                                                   &
+        ONLY:  radiation, radiation_scheme, radiation_tendency,                &
+               skip_time_do_radiation
+
+    USE statistics,                                                            &
+        ONLY:  hom
+
+    USE subsidence_mod,                                                        &
+        ONLY:  subsidence
+
+    USE user_actions_mod,                                                      &
+        ONLY:  user_actions
+
+
+    PRIVATE
+    PUBLIC prognostic_equations_cache, prognostic_equations_vector, &
+           prognostic_equations_acc
+
+    INTERFACE prognostic_equations_cache
+       MODULE PROCEDURE prognostic_equations_cache
+    END INTERFACE prognostic_equations_cache
+
+    INTERFACE prognostic_equations_vector
+       MODULE PROCEDURE prognostic_equations_vector
+    END INTERFACE prognostic_equations_vector
+
+    INTERFACE prognostic_equations_acc
+       MODULE PROCEDURE prognostic_equations_acc
+    END INTERFACE prognostic_equations_acc
+
+
+ CONTAINS
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Version with one optimized loop over all equations. It is only allowed to
+!> be called for the Wicker and Skamarock or Piascek-Williams advection scheme.
+!>
+!> Here the calls of most subroutines are embedded in two DO loops over i and j,
+!> so communication between CPUs is not allowed (does not make sense) within
+!> these loops.
+!>
+!> (Optimized to avoid cache missings, i.e. for Power4/5-architectures.)
+!------------------------------------------------------------------------------!
+ 
+ SUBROUTINE prognostic_equations_cache
+
+
+    IMPLICIT NONE
+
+    INTEGER(iwp) ::  i                   !<
+    INTEGER(iwp) ::  i_omp_start         !<
+    INTEGER(iwp) ::  j                   !<
+    INTEGER(iwp) ::  k                   !<
+    INTEGER(iwp) ::  omp_get_thread_num  !<
+    INTEGER(iwp) ::  tn = 0              !<
+    
+    LOGICAL      ::  loop_start          !<
+
+
+!
+!-- Time measurement can only be performed for the whole set of equations
+    CALL cpu_log( log_point(32), 'all progn.equations', 'start' )
+
+!
+!-- Loop over all prognostic equations
+!$OMP PARALLEL private (i,i_omp_start,j,k,loop_start,tn)
+
+!$  tn = omp_get_thread_num() 
+    loop_start = .TRUE.
+!$OMP DO
+    DO  i = nxl, nxr
+
+!
+!--    Store the first loop index. It differs for each thread and is required
+!--    later in advec_ws
+       IF ( loop_start )  THEN
+          loop_start  = .FALSE.
+          i_omp_start = i 
+       ENDIF
+
+       DO  j = nys, nyn
+!
+!--       If required, calculate cloud microphysics
+          IF ( cloud_physics  .AND.  .NOT. microphysics_sat_adjust  .AND.      &
+               ( intermediate_timestep_count == 1  .OR.                        &
+                 call_microphysics_at_all_substeps )                           &
+             )  THEN
+             CALL microphysics_control( i, j )
+          ENDIF
+!
+!--       Tendency terms for u-velocity component
+          IF ( .NOT. outflow_l  .OR.  i > nxl )  THEN
+
+             tend(:,j,i) = 0.0_wp
+             IF ( timestep_scheme(1:5) == 'runge' )  THEN
+                IF ( ws_scheme_mom )  THEN
+                   CALL advec_u_ws( i, j, i_omp_start, tn )
+                ELSE 
+                   CALL advec_u_pw( i, j )
+                ENDIF 
+             ELSE
+                CALL advec_u_up( i, j )
+             ENDIF
+             CALL diffusion_u( i, j )
+             CALL coriolis( i, j, 1 )
+             IF ( sloping_surface  .AND.  .NOT. neutral )  THEN
+                CALL buoyancy( i, j, pt, 1 )
+             ENDIF
+
+!
+!--          Drag by plant canopy
+             IF ( plant_canopy )  CALL pcm_tendency( i, j, 1 )
+
+!
+!--          External pressure gradient
+             IF ( dp_external )  THEN
+                DO  k = dp_level_ind_b+1, nzt
+                   tend(k,j,i) = tend(k,j,i) - dpdxy(1) * dp_smooth_factor(k)
+                ENDDO
+             ENDIF
+
+!
+!--          Nudging
+             IF ( nudging )  CALL nudge( i, j, simulated_time, 'u' )
+
+             CALL user_actions( i, j, 'u-tendency' )
+!
+!--          Prognostic equation for u-velocity component
+             DO  k = nzb_u_inner(j,i)+1, nzt
+                u_p(k,j,i) = u(k,j,i) + dt_3d * ( tsc(2) * tend(k,j,i) +       &
+                                                  tsc(3) * tu_m(k,j,i) )       &
+                                      - tsc(5) * rdf(k) * ( u(k,j,i) - u_init(k) )
+             ENDDO
+
+!
+!--          Calculate tendencies for the next Runge-Kutta step
+             IF ( timestep_scheme(1:5) == 'runge' )  THEN
+                IF ( intermediate_timestep_count == 1 )  THEN
+                   DO  k = nzb_u_inner(j,i)+1, nzt
+                      tu_m(k,j,i) = tend(k,j,i)
+                   ENDDO
+                ELSEIF ( intermediate_timestep_count < &
+                         intermediate_timestep_count_max )  THEN
+                   DO  k = nzb_u_inner(j,i)+1, nzt
+                      tu_m(k,j,i) = -9.5625_wp * tend(k,j,i) + 5.3125_wp * tu_m(k,j,i)
+                   ENDDO
+                ENDIF
+             ENDIF
+
+          ENDIF
+
+!
+!--       Tendency terms for v-velocity component
+          IF ( .NOT. outflow_s  .OR.  j > nys )  THEN
+
+             tend(:,j,i) = 0.0_wp
+             IF ( timestep_scheme(1:5) == 'runge' )  THEN
+                IF ( ws_scheme_mom )  THEN
+                    CALL advec_v_ws( i, j, i_omp_start, tn )
+                ELSE 
+                    CALL advec_v_pw( i, j )
+                ENDIF
+             ELSE
+                CALL advec_v_up( i, j )
+             ENDIF
+             CALL diffusion_v( i, j )
+             CALL coriolis( i, j, 2 )
+
+!
+!--          Drag by plant canopy
+             IF ( plant_canopy )  CALL pcm_tendency( i, j, 2 )        
+
+!
+!--          External pressure gradient
+             IF ( dp_external )  THEN
+                DO  k = dp_level_ind_b+1, nzt
+                   tend(k,j,i) = tend(k,j,i) - dpdxy(2) * dp_smooth_factor(k)
+                ENDDO
+             ENDIF
+
+!
+!--          Nudging
+             IF ( nudging )  CALL nudge( i, j, simulated_time, 'v' )
+
+             CALL user_actions( i, j, 'v-tendency' )
+!
+!--          Prognostic equation for v-velocity component
+             DO  k = nzb_v_inner(j,i)+1, nzt
+                v_p(k,j,i) = v(k,j,i) + dt_3d * ( tsc(2) * tend(k,j,i) +       &
+                                                  tsc(3) * tv_m(k,j,i) )       &
+                                      - tsc(5) * rdf(k) * ( v(k,j,i) - v_init(k) )
+             ENDDO
+
+!
+!--          Calculate tendencies for the next Runge-Kutta step
+             IF ( timestep_scheme(1:5) == 'runge' )  THEN
+                IF ( intermediate_timestep_count == 1 )  THEN
+                   DO  k = nzb_v_inner(j,i)+1, nzt
+                      tv_m(k,j,i) = tend(k,j,i)
+                   ENDDO
+                ELSEIF ( intermediate_timestep_count < &
+                         intermediate_timestep_count_max )  THEN
+                   DO  k = nzb_v_inner(j,i)+1, nzt
+                      tv_m(k,j,i) = -9.5625_wp * tend(k,j,i) + 5.3125_wp * tv_m(k,j,i)
+                   ENDDO
+                ENDIF
+             ENDIF
+
+          ENDIF
+
+!
+!--       Tendency terms for w-velocity component
+          tend(:,j,i) = 0.0_wp
+          IF ( timestep_scheme(1:5) == 'runge' )  THEN
+             IF ( ws_scheme_mom )  THEN
+                CALL advec_w_ws( i, j, i_omp_start, tn )
+             ELSE 
+                CALL advec_w_pw( i, j )
+             END IF
+          ELSE
+             CALL advec_w_up( i, j )
+          ENDIF
+          CALL diffusion_w( i, j )
+          CALL coriolis( i, j, 3 )
+
+          IF ( .NOT. neutral )  THEN
+             IF ( ocean )  THEN
+                CALL buoyancy( i, j, rho, 3 )
+             ELSE
+                IF ( .NOT. humidity )  THEN
+                   CALL buoyancy( i, j, pt, 3 )
+                ELSE
+                   CALL buoyancy( i, j, vpt, 3 )
+                ENDIF
+             ENDIF
+          ENDIF
+
+!
+!--       Drag by plant canopy
+          IF ( plant_canopy )  CALL pcm_tendency( i, j, 3 )
+
+          CALL user_actions( i, j, 'w-tendency' )
+
+!
+!--       Prognostic equation for w-velocity component
+          DO  k = nzb_w_inner(j,i)+1, nzt-1
+             w_p(k,j,i) = w(k,j,i) + dt_3d * ( tsc(2) * tend(k,j,i) +          &
+                                               tsc(3) * tw_m(k,j,i) )          &
+                                   - tsc(5) * rdf(k) * w(k,j,i)
+          ENDDO
+
+!
+!--       Calculate tendencies for the next Runge-Kutta step
+          IF ( timestep_scheme(1:5) == 'runge' )  THEN
+             IF ( intermediate_timestep_count == 1 )  THEN
+                DO  k = nzb_w_inner(j,i)+1, nzt-1
+                   tw_m(k,j,i) = tend(k,j,i)
+                ENDDO
+             ELSEIF ( intermediate_timestep_count < &
+                      intermediate_timestep_count_max )  THEN
+                DO  k = nzb_w_inner(j,i)+1, nzt-1
+                   tw_m(k,j,i) = -9.5625_wp * tend(k,j,i) + 5.3125_wp * tw_m(k,j,i)
+                ENDDO
+             ENDIF
+          ENDIF
+
+!
+!--       If required, compute prognostic equation for potential temperature
+          IF ( .NOT. neutral )  THEN
+!
+!--          Tendency terms for potential temperature
+             tend(:,j,i) = 0.0_wp
+             IF ( timestep_scheme(1:5) == 'runge' )  THEN
+                   IF ( ws_scheme_sca )  THEN
+                      CALL advec_s_ws( i, j, pt, 'pt', flux_s_pt, diss_s_pt, &
+                                       flux_l_pt, diss_l_pt, i_omp_start, tn )
+                   ELSE
+                      CALL advec_s_pw( i, j, pt )
+                   ENDIF
+             ELSE
+                CALL advec_s_up( i, j, pt )
+             ENDIF
+             CALL diffusion_s( i, j, pt, shf, tswst, wall_heatflux )
+
+!
+!--          If required compute heating/cooling due to long wave radiation
+!--          processes
+             IF ( cloud_top_radiation )  THEN
+                CALL calc_radiation( i, j )
+             ENDIF
+
+!
+!--          Consideration of heat sources within the plant canopy
+             IF ( plant_canopy  .AND.  cthf /= 0.0_wp )  THEN
+                CALL pcm_tendency( i, j, 4 )
+             ENDIF
+
+!
+!--          Large scale advection
+             IF ( large_scale_forcing )  THEN
+                CALL ls_advec( i, j, simulated_time, 'pt' )
+             ENDIF     
+
+!
+!--          Nudging
+             IF ( nudging )  CALL nudge( i, j, simulated_time, 'pt' ) 
+
+!
+!--          If required, compute effect of large-scale subsidence/ascent
+             IF ( large_scale_subsidence  .AND.                                &
+                  .NOT. use_subsidence_tendencies )  THEN
+                CALL subsidence( i, j, tend, pt, pt_init, 2 )
+             ENDIF
+
+!
+!--          If required, add tendency due to radiative heating/cooling
+             IF ( radiation .AND. radiation_scheme == 'rrtmg' .AND.            &
+                  simulated_time > skip_time_do_radiation )  THEN
+                CALL radiation_tendency ( i, j, tend )
+             ENDIF
+
+
+             CALL user_actions( i, j, 'pt-tendency' )
+
+!
+!--          Prognostic equation for potential temperature
+             DO  k = nzb_s_inner(j,i)+1, nzt
+                pt_p(k,j,i) = pt(k,j,i) + dt_3d * ( tsc(2) * tend(k,j,i) +     &
+                                                    tsc(3) * tpt_m(k,j,i) )    &
+                                        - tsc(5) * ( pt(k,j,i) - pt_init(k) ) *&
+                                          ( rdf_sc(k) + ptdf_x(i) + ptdf_y(j) )
+             ENDDO
+
+!
+!--          Calculate tendencies for the next Runge-Kutta step
+             IF ( timestep_scheme(1:5) == 'runge' )  THEN
+                IF ( intermediate_timestep_count == 1 )  THEN
+                   DO  k = nzb_s_inner(j,i)+1, nzt
+                      tpt_m(k,j,i) = tend(k,j,i)
+                   ENDDO
+                ELSEIF ( intermediate_timestep_count < &
+                         intermediate_timestep_count_max )  THEN
+                   DO  k = nzb_s_inner(j,i)+1, nzt
+                      tpt_m(k,j,i) = -9.5625_wp * tend(k,j,i) + &
+                                      5.3125_wp * tpt_m(k,j,i)
+                   ENDDO
+                ENDIF
+             ENDIF
+
+          ENDIF
+
+!
+!--       If required, compute prognostic equation for salinity
+          IF ( ocean )  THEN
+
+!
+!--          Tendency-terms for salinity
+             tend(:,j,i) = 0.0_wp
+             IF ( timestep_scheme(1:5) == 'runge' ) &
+             THEN
+                IF ( ws_scheme_sca )  THEN
+                    CALL advec_s_ws( i, j, sa, 'sa', flux_s_sa,  &
+                                diss_s_sa, flux_l_sa, diss_l_sa, i_omp_start, tn  )
+                ELSE 
+                    CALL advec_s_pw( i, j, sa )
+                ENDIF
+             ELSE
+                CALL advec_s_up( i, j, sa )
+             ENDIF
+             CALL diffusion_s( i, j, sa, saswsb, saswst, wall_salinityflux )
+
+             CALL user_actions( i, j, 'sa-tendency' )
+
+!
+!--          Prognostic equation for salinity
+             DO  k = nzb_s_inner(j,i)+1, nzt
+                sa_p(k,j,i) = sa(k,j,i) + dt_3d * ( tsc(2) * tend(k,j,i) +     &
+                                                    tsc(3) * tsa_m(k,j,i) )    &
+                                        - tsc(5) * rdf_sc(k) *                 &
+                                          ( sa(k,j,i) - sa_init(k) )
+                IF ( sa_p(k,j,i) < 0.0_wp )  sa_p(k,j,i) = 0.1_wp * sa(k,j,i)
+             ENDDO
+
+!
+!--          Calculate tendencies for the next Runge-Kutta step
+             IF ( timestep_scheme(1:5) == 'runge' )  THEN
+                IF ( intermediate_timestep_count == 1 )  THEN
+                   DO  k = nzb_s_inner(j,i)+1, nzt
+                      tsa_m(k,j,i) = tend(k,j,i)
+                   ENDDO
+                ELSEIF ( intermediate_timestep_count < &
+                         intermediate_timestep_count_max )  THEN
+                   DO  k = nzb_s_inner(j,i)+1, nzt
+                      tsa_m(k,j,i) = -9.5625_wp * tend(k,j,i) + &
+                                      5.3125_wp * tsa_m(k,j,i)
+                   ENDDO
+                ENDIF
+             ENDIF
+
+!
+!--          Calculate density by the equation of state for seawater
+             CALL eqn_state_seawater( i, j )
+
+          ENDIF
+
+!
+!--       If required, compute prognostic equation for total water content /
+!--       scalar
+          IF ( humidity  .OR.  passive_scalar )  THEN
+
+!
+!--          Tendency-terms for total water content / scalar
+             tend(:,j,i) = 0.0_wp
+             IF ( timestep_scheme(1:5) == 'runge' ) &
+             THEN
+                IF ( ws_scheme_sca )  THEN
+                   CALL advec_s_ws( i, j, q, 'q', flux_s_q, & 
+                                diss_s_q, flux_l_q, diss_l_q, i_omp_start, tn )
+                ELSE 
+                   CALL advec_s_pw( i, j, q )
+                ENDIF
+             ELSE
+                CALL advec_s_up( i, j, q )
+             ENDIF
+             CALL diffusion_s( i, j, q, qsws, qswst, wall_qflux )
+
+!
+!--          Sink or source of scalar concentration due to canopy elements
+             IF ( plant_canopy )  CALL pcm_tendency( i, j, 5 )
+
+!
+!--          Large scale advection
+             IF ( large_scale_forcing )  THEN
+                CALL ls_advec( i, j, simulated_time, 'q' )
+             ENDIF
+
+!
+!--          Nudging
+             IF ( nudging )  CALL nudge( i, j, simulated_time, 'q' ) 
+
+!
+!--          If required compute influence of large-scale subsidence/ascent
+             IF ( large_scale_subsidence  .AND.                                &
+                  .NOT. use_subsidence_tendencies )  THEN
+                CALL subsidence( i, j, tend, q, q_init, 3 )
+             ENDIF
+
+             CALL user_actions( i, j, 'q-tendency' )
+
+!
+!--          Prognostic equation for total water content / scalar
+             DO  k = nzb_s_inner(j,i)+1, nzt
+                q_p(k,j,i) = q(k,j,i) + dt_3d * ( tsc(2) * tend(k,j,i) +       &
+                                                  tsc(3) * tq_m(k,j,i) )       &
+                                      - tsc(5) * rdf_sc(k) *                   &
+                                        ( q(k,j,i) - q_init(k) )
+                IF ( q_p(k,j,i) < 0.0_wp )  q_p(k,j,i) = 0.1_wp * q(k,j,i)
+             ENDDO
+
+!
+!--          Calculate tendencies for the next Runge-Kutta step
+             IF ( timestep_scheme(1:5) == 'runge' )  THEN
+                IF ( intermediate_timestep_count == 1 )  THEN
+                   DO  k = nzb_s_inner(j,i)+1, nzt
+                      tq_m(k,j,i) = tend(k,j,i)
+                   ENDDO
+                ELSEIF ( intermediate_timestep_count < &
+                         intermediate_timestep_count_max )  THEN
+                   DO  k = nzb_s_inner(j,i)+1, nzt
+                      tq_m(k,j,i) = -9.5625_wp * tend(k,j,i) + &
+                                     5.3125_wp * tq_m(k,j,i)
+                   ENDDO
+                ENDIF
+             ENDIF
+
+!
+!--          If required, calculate prognostic equations for rain water content 
+!--          and rain drop concentration
+             IF ( cloud_physics  .AND.  microphysics_seifert )  THEN
+!
+!--             Calculate prognostic equation for rain water content
+                tend(:,j,i) = 0.0_wp
+                IF ( timestep_scheme(1:5) == 'runge' ) &
+                THEN
+                   IF ( ws_scheme_sca )  THEN
+                      CALL advec_s_ws( i, j, qr, 'qr', flux_s_qr,       & 
+                                       diss_s_qr, flux_l_qr, diss_l_qr, &
+                                       i_omp_start, tn )
+                   ELSE 
+                      CALL advec_s_pw( i, j, qr )
+                   ENDIF
+                ELSE
+                   CALL advec_s_up( i, j, qr )
+                ENDIF
+                CALL diffusion_s( i, j, qr, qrsws, qrswst, wall_qrflux )
+
+!
+!--             Prognostic equation for rain water content
+                DO  k = nzb_s_inner(j,i)+1, nzt
+                   qr_p(k,j,i) = qr(k,j,i) + dt_3d * ( tsc(2) * tend(k,j,i) +  &
+                                                       tsc(3) * tqr_m(k,j,i) ) &
+                                           - tsc(5) * rdf_sc(k) * qr(k,j,i)
+                   IF ( qr_p(k,j,i) < 0.0_wp )  qr_p(k,j,i) = 0.0_wp
+                ENDDO
+!
+!--             Calculate tendencies for the next Runge-Kutta step
+                IF ( timestep_scheme(1:5) == 'runge' )  THEN
+                   IF ( intermediate_timestep_count == 1 )  THEN
+                      DO  k = nzb_s_inner(j,i)+1, nzt
+                         tqr_m(k,j,i) = tend(k,j,i)
+                      ENDDO
+                   ELSEIF ( intermediate_timestep_count < &
+                            intermediate_timestep_count_max )  THEN
+                      DO  k = nzb_s_inner(j,i)+1, nzt
+                         tqr_m(k,j,i) = -9.5625_wp * tend(k,j,i) + &
+                                        5.3125_wp * tqr_m(k,j,i)
+                      ENDDO
+                   ENDIF
+                ENDIF
+
+!
+!--             Calculate prognostic equation for rain drop concentration.
+                tend(:,j,i) = 0.0_wp
+                IF ( timestep_scheme(1:5) == 'runge' )  THEN
+                   IF ( ws_scheme_sca )  THEN
+                      CALL advec_s_ws( i, j, nr, 'nr', flux_s_nr,    & 
+                                    diss_s_nr, flux_l_nr, diss_l_nr, &
+                                    i_omp_start, tn )
+                   ELSE 
+                      CALL advec_s_pw( i, j, nr )
+                   ENDIF
+                ELSE
+                   CALL advec_s_up( i, j, nr )
+                ENDIF
+                CALL diffusion_s( i, j, nr, nrsws, nrswst, wall_nrflux )
+
+!
+!--             Prognostic equation for rain drop concentration
+                DO  k = nzb_s_inner(j,i)+1, nzt
+                   nr_p(k,j,i) = nr(k,j,i) + dt_3d * ( tsc(2) * tend(k,j,i) +  &
+                                                       tsc(3) * tnr_m(k,j,i) ) &
+                                           - tsc(5) * rdf_sc(k) * nr(k,j,i)
+                   IF ( nr_p(k,j,i) < 0.0_wp )  nr_p(k,j,i) = 0.0_wp
+                ENDDO
+!
+!--             Calculate tendencies for the next Runge-Kutta step
+                IF ( timestep_scheme(1:5) == 'runge' )  THEN
+                   IF ( intermediate_timestep_count == 1 )  THEN
+                      DO  k = nzb_s_inner(j,i)+1, nzt
+                         tnr_m(k,j,i) = tend(k,j,i)
+                      ENDDO
+                   ELSEIF ( intermediate_timestep_count < &
+                            intermediate_timestep_count_max )  THEN
+                      DO  k = nzb_s_inner(j,i)+1, nzt
+                         tnr_m(k,j,i) = -9.5625_wp * tend(k,j,i) + &
+                                        5.3125_wp * tnr_m(k,j,i)
+                      ENDDO
+                   ENDIF
+                ENDIF
+
+             ENDIF
+
+          ENDIF
+
+!
+!--       If required, compute prognostic equation for turbulent kinetic 
+!--       energy (TKE)
+          IF ( .NOT. constant_diffusion )  THEN
+
+!
+!--          Tendency-terms for TKE
+             tend(:,j,i) = 0.0_wp
+             IF ( timestep_scheme(1:5) == 'runge'  &
+                 .AND.  .NOT. use_upstream_for_tke )  THEN 
+                 IF ( ws_scheme_sca )  THEN
+                     CALL advec_s_ws( i, j, e, 'e', flux_s_e, diss_s_e, &
+                                      flux_l_e, diss_l_e , i_omp_start, tn )
+                 ELSE
+                     CALL advec_s_pw( i, j, e )
+                 ENDIF
+             ELSE
+                CALL advec_s_up( i, j, e )
+             ENDIF
+             IF ( .NOT. humidity )  THEN
+                IF ( ocean )  THEN
+                   CALL diffusion_e( i, j, prho, prho_reference )
+                ELSE
+                   CALL diffusion_e( i, j, pt, pt_reference )
+                ENDIF
+             ELSE
+                CALL diffusion_e( i, j, vpt, pt_reference )
+             ENDIF
+             CALL production_e( i, j )
+
+!
+!--          Additional sink term for flows through plant canopies
+             IF ( plant_canopy )  CALL pcm_tendency( i, j, 6 ) 
+
+             CALL user_actions( i, j, 'e-tendency' )
+
+!
+!--          Prognostic equation for TKE.
+!--          Eliminate negative TKE values, which can occur due to numerical
+!--          reasons in the course of the integration. In such cases the old
+!--          TKE value is reduced by 90%.
+             DO  k = nzb_s_inner(j,i)+1, nzt
+                e_p(k,j,i) = e(k,j,i) + dt_3d * ( tsc(2) * tend(k,j,i) +       &
+                                                  tsc(3) * te_m(k,j,i) )
+                IF ( e_p(k,j,i) < 0.0_wp )  e_p(k,j,i) = 0.1_wp * e(k,j,i)
+             ENDDO
+
+!
+!--          Calculate tendencies for the next Runge-Kutta step
+             IF ( timestep_scheme(1:5) == 'runge' )  THEN
+                IF ( intermediate_timestep_count == 1 )  THEN
+                   DO  k = nzb_s_inner(j,i)+1, nzt
+                      te_m(k,j,i) = tend(k,j,i)
+                   ENDDO
+                ELSEIF ( intermediate_timestep_count < &
+                         intermediate_timestep_count_max )  THEN
+                   DO  k = nzb_s_inner(j,i)+1, nzt
+                      te_m(k,j,i) = -9.5625_wp * tend(k,j,i) + &
+                                     5.3125_wp * te_m(k,j,i)
+                   ENDDO
+                ENDIF
+             ENDIF
+
+          ENDIF   ! TKE equation
+
+       ENDDO
+    ENDDO
+!$OMP END PARALLEL
+
+    CALL cpu_log( log_point(32), 'all progn.equations', 'stop' )
+
+
+ END SUBROUTINE prognostic_equations_cache
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Version for vector machines
+!------------------------------------------------------------------------------!
+ 
+ SUBROUTINE prognostic_equations_vector
+
+
+    IMPLICIT NONE
+
+    INTEGER(iwp) ::  i    !<
+    INTEGER(iwp) ::  j    !<
+    INTEGER(iwp) ::  k    !<
+
+    REAL(wp)     ::  sbt  !<
+
+
+!
+!-- If required, calculate cloud microphysical impacts
+    IF ( cloud_physics  .AND.  .NOT. microphysics_sat_adjust  .AND.            &
+         ( intermediate_timestep_count == 1  .OR.                              &
+           call_microphysics_at_all_substeps )                                 &
+       )  THEN
+       CALL cpu_log( log_point(51), 'microphysics', 'start' )
+       CALL microphysics_control
+       CALL cpu_log( log_point(51), 'microphysics', 'stop' )
+    ENDIF
+
+!
+!-- u-velocity component
+    CALL cpu_log( log_point(5), 'u-equation', 'start' )
+
+    tend = 0.0_wp
+    IF ( timestep_scheme(1:5) == 'runge' )  THEN
+       IF ( ws_scheme_mom )  THEN
+          CALL advec_u_ws
+       ELSE
+          CALL advec_u_pw
+       ENDIF
+    ELSE
+       CALL advec_u_up
+    ENDIF
+    CALL diffusion_u
+    CALL coriolis( 1 )
+    IF ( sloping_surface  .AND.  .NOT. neutral )  THEN
+       CALL buoyancy( pt, 1 )
+    ENDIF
+
+!
+!-- Drag by plant canopy
+    IF ( plant_canopy )  CALL pcm_tendency( 1 )
+
+!
+!-- External pressure gradient
+    IF ( dp_external )  THEN
+       DO  i = nxlu, nxr
+          DO  j = nys, nyn
+             DO  k = dp_level_ind_b+1, nzt
+                tend(k,j,i) = tend(k,j,i) - dpdxy(1) * dp_smooth_factor(k)
+             ENDDO
+          ENDDO
+       ENDDO
+    ENDIF
+
+!
+!-- Nudging
+    IF ( nudging )  CALL nudge( simulated_time, 'u' )
+
+    CALL user_actions( 'u-tendency' )
+
+!
+!-- Prognostic equation for u-velocity component
+    DO  i = nxlu, nxr
+       DO  j = nys, nyn
+          DO  k = nzb_u_inner(j,i)+1, nzt
+             u_p(k,j,i) = u(k,j,i) + dt_3d * ( tsc(2) * tend(k,j,i) +          &
+                                               tsc(3) * tu_m(k,j,i) )          &
+                                   - tsc(5) * rdf(k) * ( u(k,j,i) - u_init(k) )
+          ENDDO
+       ENDDO
+    ENDDO
+
+!
+!-- Calculate tendencies for the next Runge-Kutta step
+    IF ( timestep_scheme(1:5) == 'runge' )  THEN
+       IF ( intermediate_timestep_count == 1 )  THEN
+          DO  i = nxlu, nxr
+             DO  j = nys, nyn
+                DO  k = nzb_u_inner(j,i)+1, nzt
+                   tu_m(k,j,i) = tend(k,j,i)
+                ENDDO
+             ENDDO
+          ENDDO
+       ELSEIF ( intermediate_timestep_count < &
+                intermediate_timestep_count_max )  THEN
+          DO  i = nxlu, nxr
+             DO  j = nys, nyn
+                DO  k = nzb_u_inner(j,i)+1, nzt
+                   tu_m(k,j,i) = -9.5625_wp * tend(k,j,i) + 5.3125_wp * tu_m(k,j,i)
+                ENDDO
+             ENDDO
+          ENDDO
+       ENDIF
+    ENDIF
+
+    CALL cpu_log( log_point(5), 'u-equation', 'stop' )
+
+!
+!-- v-velocity component
+    CALL cpu_log( log_point(6), 'v-equation', 'start' )
+
+    tend = 0.0_wp
+    IF ( timestep_scheme(1:5) == 'runge' )  THEN
+       IF ( ws_scheme_mom )  THEN
+          CALL advec_v_ws
+       ELSE 
+          CALL advec_v_pw
+       END IF
+    ELSE
+       CALL advec_v_up
+    ENDIF
+    CALL diffusion_v
+    CALL coriolis( 2 )
+
+!
+!-- Drag by plant canopy
+    IF ( plant_canopy )  CALL pcm_tendency( 2 )
+
+!
+!-- External pressure gradient
+    IF ( dp_external )  THEN
+       DO  i = nxl, nxr
+          DO  j = nysv, nyn
+             DO  k = dp_level_ind_b+1, nzt
+                tend(k,j,i) = tend(k,j,i) - dpdxy(2) * dp_smooth_factor(k)
+             ENDDO
+          ENDDO
+       ENDDO
+    ENDIF
+
+!
+!-- Nudging
+    IF ( nudging )  CALL nudge( simulated_time, 'v' )
+
+    CALL user_actions( 'v-tendency' )
+
+!
+!-- Prognostic equation for v-velocity component
+    DO  i = nxl, nxr
+       DO  j = nysv, nyn
+          DO  k = nzb_v_inner(j,i)+1, nzt
+             v_p(k,j,i) = v(k,j,i) + dt_3d * ( tsc(2) * tend(k,j,i) +          &
+                                               tsc(3) * tv_m(k,j,i) )          &
+                                   - tsc(5) * rdf(k) * ( v(k,j,i) - v_init(k) )
+          ENDDO
+       ENDDO
+    ENDDO
+
+!
+!-- Calculate tendencies for the next Runge-Kutta step
+    IF ( timestep_scheme(1:5) == 'runge' )  THEN
+       IF ( intermediate_timestep_count == 1 )  THEN
+          DO  i = nxl, nxr
+             DO  j = nysv, nyn
+                DO  k = nzb_v_inner(j,i)+1, nzt
+                   tv_m(k,j,i) = tend(k,j,i)
+                ENDDO
+             ENDDO
+          ENDDO
+       ELSEIF ( intermediate_timestep_count < &
+                intermediate_timestep_count_max )  THEN
+          DO  i = nxl, nxr
+             DO  j = nysv, nyn
+                DO  k = nzb_v_inner(j,i)+1, nzt
+                   tv_m(k,j,i) = -9.5625_wp * tend(k,j,i) + 5.3125_wp * tv_m(k,j,i)
+                ENDDO
+             ENDDO
+          ENDDO
+       ENDIF
+    ENDIF
+
+    CALL cpu_log( log_point(6), 'v-equation', 'stop' )
+
+!
+!-- w-velocity component
+    CALL cpu_log( log_point(7), 'w-equation', 'start' )
+
+    tend = 0.0_wp
+    IF ( timestep_scheme(1:5) == 'runge' )  THEN
+       IF ( ws_scheme_mom )  THEN
+          CALL advec_w_ws
+       ELSE
+          CALL advec_w_pw
+       ENDIF
+    ELSE
+       CALL advec_w_up
+    ENDIF
+    CALL diffusion_w
+    CALL coriolis( 3 )
+
+    IF ( .NOT. neutral )  THEN
+       IF ( ocean )  THEN
+          CALL buoyancy( rho, 3 )
+       ELSE
+          IF ( .NOT. humidity )  THEN
+             CALL buoyancy( pt, 3 )
+          ELSE
+             CALL buoyancy( vpt, 3 )
+          ENDIF
+       ENDIF
+    ENDIF
+
+!
+!-- Drag by plant canopy
+    IF ( plant_canopy )  CALL pcm_tendency( 3 )
+
+    CALL user_actions( 'w-tendency' )
+
+!
+!-- Prognostic equation for w-velocity component
+    DO  i = nxl, nxr
+       DO  j = nys, nyn
+          DO  k = nzb_w_inner(j,i)+1, nzt-1
+             w_p(k,j,i) = w(k,j,i) + dt_3d * ( tsc(2) * tend(k,j,i) +          &
+                                               tsc(3) * tw_m(k,j,i) )          &
+                                   - tsc(5) * rdf(k) * w(k,j,i)
+          ENDDO
+       ENDDO
+    ENDDO
+
+!
+!-- Calculate tendencies for the next Runge-Kutta step
+    IF ( timestep_scheme(1:5) == 'runge' )  THEN
+       IF ( intermediate_timestep_count == 1 )  THEN
+          DO  i = nxl, nxr
+             DO  j = nys, nyn
+                DO  k = nzb_w_inner(j,i)+1, nzt-1
+                   tw_m(k,j,i) = tend(k,j,i)
+                ENDDO
+             ENDDO
+          ENDDO
+       ELSEIF ( intermediate_timestep_count < &
+                intermediate_timestep_count_max )  THEN
+          DO  i = nxl, nxr
+             DO  j = nys, nyn
+                DO  k = nzb_w_inner(j,i)+1, nzt-1
+                   tw_m(k,j,i) = -9.5625_wp * tend(k,j,i) + 5.3125_wp * tw_m(k,j,i)
+                ENDDO
+             ENDDO
+          ENDDO
+       ENDIF
+    ENDIF
+
+    CALL cpu_log( log_point(7), 'w-equation', 'stop' )
+
+
+!
+!-- If required, compute prognostic equation for potential temperature
+    IF ( .NOT. neutral )  THEN
+
+       CALL cpu_log( log_point(13), 'pt-equation', 'start' )
+
+!
+!--    pt-tendency terms with communication
+       sbt = tsc(2)
+       IF ( scalar_advec == 'bc-scheme' )  THEN
+
+          IF ( timestep_scheme(1:5) /= 'runge' )  THEN
+!
+!--          Bott-Chlond scheme always uses Euler time step. Thus:
+             sbt = 1.0_wp
+          ENDIF
+          tend = 0.0_wp
+          CALL advec_s_bc( pt, 'pt' )
+
+       ENDIF
+
+!
+!--    pt-tendency terms with no communication
+       IF ( scalar_advec /= 'bc-scheme' )  THEN
+          tend = 0.0_wp
+          IF ( timestep_scheme(1:5) == 'runge' )  THEN
+             IF ( ws_scheme_sca )  THEN
+                CALL advec_s_ws( pt, 'pt' )
+             ELSE
+                CALL advec_s_pw( pt )
+             ENDIF
+          ELSE
+             CALL advec_s_up( pt )
+          ENDIF
+       ENDIF
+
+       CALL diffusion_s( pt, shf, tswst, wall_heatflux )
+
+!
+!--    If required compute heating/cooling due to long wave radiation processes
+       IF ( cloud_top_radiation )  THEN
+          CALL calc_radiation
+       ENDIF
+
+!
+!--    Consideration of heat sources within the plant canopy
+       IF ( plant_canopy .AND. ( cthf /= 0.0_wp ) ) THEN
+          CALL pcm_tendency( 4 )
+       ENDIF
+
+!
+!--    Large scale advection
+       IF ( large_scale_forcing )  THEN
+          CALL ls_advec( simulated_time, 'pt' )
+       ENDIF
+
+!
+!--    Nudging
+       IF ( nudging )  CALL nudge( simulated_time, 'pt' ) 
+
+!
+!--    If required compute influence of large-scale subsidence/ascent
+       IF ( large_scale_subsidence  .AND.                                      &
+            .NOT. use_subsidence_tendencies )  THEN
+          CALL subsidence( tend, pt, pt_init, 2 )
+       ENDIF
+
+!
+!--    If required, add tendency due to radiative heating/cooling
+       IF ( radiation .AND. radiation_scheme == 'rrtmg' .AND.                  &
+            simulated_time > skip_time_do_radiation )  THEN
+            CALL radiation_tendency ( tend )
+       ENDIF
+
+       CALL user_actions( 'pt-tendency' )
+
+!
+!--    Prognostic equation for potential temperature
+       DO  i = nxl, nxr
+          DO  j = nys, nyn
+             DO  k = nzb_s_inner(j,i)+1, nzt
+                pt_p(k,j,i) = pt(k,j,i) + dt_3d * ( sbt * tend(k,j,i) +        &
+                                                    tsc(3) * tpt_m(k,j,i) )    &
+                                        - tsc(5) * ( pt(k,j,i) - pt_init(k) ) *&
+                                          ( rdf_sc(k) + ptdf_x(i) + ptdf_y(j) )
+             ENDDO
+          ENDDO
+       ENDDO
+
+!
+!--    Calculate tendencies for the next Runge-Kutta step
+       IF ( timestep_scheme(1:5) == 'runge' )  THEN
+          IF ( intermediate_timestep_count == 1 )  THEN
+             DO  i = nxl, nxr
+                DO  j = nys, nyn
+                   DO  k = nzb_s_inner(j,i)+1, nzt
+                      tpt_m(k,j,i) = tend(k,j,i)
+                   ENDDO
+                ENDDO
+             ENDDO
+          ELSEIF ( intermediate_timestep_count < &
+                   intermediate_timestep_count_max )  THEN
+             DO  i = nxl, nxr
+                DO  j = nys, nyn
+                   DO  k = nzb_s_inner(j,i)+1, nzt
+                      tpt_m(k,j,i) = -9.5625_wp * tend(k,j,i) + &
+                                      5.3125_wp * tpt_m(k,j,i)
+                   ENDDO
+                ENDDO
+             ENDDO
+          ENDIF
+       ENDIF
+
+       CALL cpu_log( log_point(13), 'pt-equation', 'stop' )
+
+    ENDIF
+
+!
+!-- If required, compute prognostic equation for salinity
+    IF ( ocean )  THEN
+
+       CALL cpu_log( log_point(37), 'sa-equation', 'start' )
+
+!
+!--    sa-tendency terms with communication
+       sbt = tsc(2)
+       IF ( scalar_advec == 'bc-scheme' )  THEN
+
+          IF ( timestep_scheme(1:5) /= 'runge' )  THEN
+!
+!--          Bott-Chlond scheme always uses Euler time step. Thus:
+             sbt = 1.0_wp
+          ENDIF
+          tend = 0.0_wp
+          CALL advec_s_bc( sa, 'sa' )
+
+       ENDIF
+
+!
+!--    sa-tendency terms with no communication
+       IF ( scalar_advec /= 'bc-scheme' )  THEN
+          tend = 0.0_wp
+          IF ( timestep_scheme(1:5) == 'runge' )  THEN
+             IF ( ws_scheme_sca )  THEN
+                 CALL advec_s_ws( sa, 'sa' )
+             ELSE
+                 CALL advec_s_pw( sa )
+             ENDIF
+          ELSE
+             CALL advec_s_up( sa )
+          ENDIF
+       ENDIF
+
+       CALL diffusion_s( sa, saswsb, saswst, wall_salinityflux )
+       
+       CALL user_actions( 'sa-tendency' )
+
+!
+!--    Prognostic equation for salinity
+       DO  i = nxl, nxr
+          DO  j = nys, nyn
+             DO  k = nzb_s_inner(j,i)+1, nzt
+                sa_p(k,j,i) = sa(k,j,i) + dt_3d * ( sbt * tend(k,j,i) +        &
+                                                    tsc(3) * tsa_m(k,j,i) )    &
+                                        - tsc(5) * rdf_sc(k) *                 &
+                                          ( sa(k,j,i) - sa_init(k) )
+                IF ( sa_p(k,j,i) < 0.0_wp )  sa_p(k,j,i) = 0.1_wp * sa(k,j,i)
+             ENDDO
+          ENDDO
+       ENDDO
+
+!
+!--    Calculate tendencies for the next Runge-Kutta step
+       IF ( timestep_scheme(1:5) == 'runge' )  THEN
+          IF ( intermediate_timestep_count == 1 )  THEN
+             DO  i = nxl, nxr
+                DO  j = nys, nyn
+                   DO  k = nzb_s_inner(j,i)+1, nzt
+                      tsa_m(k,j,i) = tend(k,j,i)
+                   ENDDO
+                ENDDO
+             ENDDO
+          ELSEIF ( intermediate_timestep_count < &
+                   intermediate_timestep_count_max )  THEN
+             DO  i = nxl, nxr
+                DO  j = nys, nyn
+                   DO  k = nzb_s_inner(j,i)+1, nzt
+                      tsa_m(k,j,i) = -9.5625_wp * tend(k,j,i) + &
+                                      5.3125_wp * tsa_m(k,j,i)
+                   ENDDO
+                ENDDO
+             ENDDO
+          ENDIF
+       ENDIF
+
+       CALL cpu_log( log_point(37), 'sa-equation', 'stop' )
+
+!
+!--    Calculate density by the equation of state for seawater
+       CALL cpu_log( log_point(38), 'eqns-seawater', 'start' )
+       CALL eqn_state_seawater
+       CALL cpu_log( log_point(38), 'eqns-seawater', 'stop' )
+
+    ENDIF
+
+!
+!-- If required, compute prognostic equation for total water content / scalar
+    IF ( humidity  .OR.  passive_scalar )  THEN
+
+       CALL cpu_log( log_point(29), 'q/s-equation', 'start' )
+
+!
+!--    Scalar/q-tendency terms with communication
+       sbt = tsc(2)
+       IF ( scalar_advec == 'bc-scheme' )  THEN
+
+          IF ( timestep_scheme(1:5) /= 'runge' )  THEN
+!
+!--          Bott-Chlond scheme always uses Euler time step. Thus:
+             sbt = 1.0_wp
+          ENDIF
+          tend = 0.0_wp
+          CALL advec_s_bc( q, 'q' )
+
+       ENDIF
+
+!
+!--    Scalar/q-tendency terms with no communication
+       IF ( scalar_advec /= 'bc-scheme' )  THEN
+          tend = 0.0_wp
+          IF ( timestep_scheme(1:5) == 'runge' )  THEN
+             IF ( ws_scheme_sca )  THEN
+                CALL advec_s_ws( q, 'q' )
+             ELSE
+                CALL advec_s_pw( q )
+             ENDIF
+          ELSE
+             CALL advec_s_up( q )
+          ENDIF
+       ENDIF
+
+       CALL diffusion_s( q, qsws, qswst, wall_qflux )
+       
+!
+!--    Sink or source of scalar concentration due to canopy elements
+       IF ( plant_canopy ) CALL pcm_tendency( 5 )
+
+!
+!--    Large scale advection
+       IF ( large_scale_forcing )  THEN
+          CALL ls_advec( simulated_time, 'q' )
+       ENDIF
+
+!
+!--    Nudging
+       IF ( nudging )  CALL nudge( simulated_time, 'q' ) 
+
+!
+!--    If required compute influence of large-scale subsidence/ascent
+       IF ( large_scale_subsidence  .AND.                                      &
+            .NOT. use_subsidence_tendencies )  THEN
+         CALL subsidence( tend, q, q_init, 3 )
+       ENDIF
+
+       CALL user_actions( 'q-tendency' )
+
+!
+!--    Prognostic equation for total water content / scalar
+       DO  i = nxl, nxr
+          DO  j = nys, nyn
+             DO  k = nzb_s_inner(j,i)+1, nzt
+                q_p(k,j,i) = q(k,j,i) + dt_3d * ( sbt * tend(k,j,i) +          &
+                                                  tsc(3) * tq_m(k,j,i) )       &
+                                      - tsc(5) * rdf_sc(k) *                   &
+                                        ( q(k,j,i) - q_init(k) )
+                IF ( q_p(k,j,i) < 0.0_wp )  q_p(k,j,i) = 0.1_wp * q(k,j,i)
+             ENDDO
+          ENDDO
+       ENDDO
+
+!
+!--    Calculate tendencies for the next Runge-Kutta step
+       IF ( timestep_scheme(1:5) == 'runge' )  THEN
+          IF ( intermediate_timestep_count == 1 )  THEN
+             DO  i = nxl, nxr
+                DO  j = nys, nyn
+                   DO  k = nzb_s_inner(j,i)+1, nzt
+                      tq_m(k,j,i) = tend(k,j,i)
+                   ENDDO
+                ENDDO
+             ENDDO
+          ELSEIF ( intermediate_timestep_count < &
+                   intermediate_timestep_count_max )  THEN
+             DO  i = nxl, nxr
+                DO  j = nys, nyn
+                   DO  k = nzb_s_inner(j,i)+1, nzt
+                      tq_m(k,j,i) = -9.5625_wp * tend(k,j,i) + 5.3125_wp * tq_m(k,j,i)
+                   ENDDO
+                ENDDO
+             ENDDO
+          ENDIF
+       ENDIF
+
+       CALL cpu_log( log_point(29), 'q/s-equation', 'stop' )
+
+!
+!--    If required, calculate prognostic equations for rain water content 
+!--    and rain drop concentration
+       IF ( cloud_physics  .AND.  microphysics_seifert )  THEN
+
+          CALL cpu_log( log_point(52), 'qr-equation', 'start' )
+
+!
+!--       Calculate prognostic equation for rain water content
+          sbt = tsc(2)
+          IF ( scalar_advec == 'bc-scheme' )  THEN
+
+             IF ( timestep_scheme(1:5) /= 'runge' )  THEN
+!
+!--             Bott-Chlond scheme always uses Euler time step. Thus:
+                sbt = 1.0_wp
+             ENDIF
+             tend = 0.0_wp
+             CALL advec_s_bc( qr, 'qr' )
+
+          ENDIF
+
+!
+!--       qr-tendency terms with no communication
+          IF ( scalar_advec /= 'bc-scheme' )  THEN
+             tend = 0.0_wp
+             IF ( timestep_scheme(1:5) == 'runge' )  THEN
+                IF ( ws_scheme_sca )  THEN
+                   CALL advec_s_ws( qr, 'qr' )
+                ELSE
+                   CALL advec_s_pw( qr )
+                ENDIF
+             ELSE
+                CALL advec_s_up( qr )
+             ENDIF
+          ENDIF
+
+          CALL diffusion_s( qr, qrsws, qrswst, wall_qrflux )
+
+          CALL user_actions( 'qr-tendency' )
+
+!
+!--       Prognostic equation for rain water content
+          DO  i = nxl, nxr
+             DO  j = nys, nyn
+                DO  k = nzb_s_inner(j,i)+1, nzt
+                   qr_p(k,j,i) = qr(k,j,i) + dt_3d * ( sbt * tend(k,j,i) +     &
+                                                     tsc(3) * tqr_m(k,j,i) )   &
+                                           - tsc(5) * rdf_sc(k) * qr(k,j,i)
+                   IF ( qr_p(k,j,i) < 0.0_wp )  qr_p(k,j,i) = 0.0_wp
+                ENDDO
+             ENDDO
+          ENDDO
+
+!
+!--       Calculate tendencies for the next Runge-Kutta step
+          IF ( timestep_scheme(1:5) == 'runge' )  THEN
+             IF ( intermediate_timestep_count == 1 )  THEN
+                DO  i = nxl, nxr
+                   DO  j = nys, nyn
+                      DO  k = nzb_s_inner(j,i)+1, nzt
+                         tqr_m(k,j,i) = tend(k,j,i)
+                      ENDDO
+                   ENDDO
+                ENDDO
+             ELSEIF ( intermediate_timestep_count < &
+                      intermediate_timestep_count_max )  THEN
+                DO  i = nxl, nxr
+                   DO  j = nys, nyn
+                      DO  k = nzb_s_inner(j,i)+1, nzt
+                         tqr_m(k,j,i) = -9.5625_wp * tend(k,j,i) + 5.3125_wp * &
+                                                                   tqr_m(k,j,i)
+                      ENDDO
+                   ENDDO
+                ENDDO
+             ENDIF
+          ENDIF
+
+          CALL cpu_log( log_point(52), 'qr-equation', 'stop' )
+          CALL cpu_log( log_point(53), 'nr-equation', 'start' )
+
+!
+!--       Calculate prognostic equation for rain drop concentration
+          sbt = tsc(2)
+          IF ( scalar_advec == 'bc-scheme' )  THEN
+
+             IF ( timestep_scheme(1:5) /= 'runge' )  THEN
+!
+!--             Bott-Chlond scheme always uses Euler time step. Thus:
+                sbt = 1.0_wp
+             ENDIF
+             tend = 0.0_wp
+             CALL advec_s_bc( nr, 'nr' )
+
+          ENDIF
+
+!
+!--       nr-tendency terms with no communication
+          IF ( scalar_advec /= 'bc-scheme' )  THEN
+             tend = 0.0_wp
+             IF ( timestep_scheme(1:5) == 'runge' )  THEN
+                IF ( ws_scheme_sca )  THEN
+                   CALL advec_s_ws( nr, 'nr' )
+                ELSE
+                   CALL advec_s_pw( nr )
+                ENDIF
+             ELSE
+                CALL advec_s_up( nr )
+             ENDIF
+          ENDIF
+
+          CALL diffusion_s( nr, nrsws, nrswst, wall_nrflux )
+
+!
+!--       Prognostic equation for rain drop concentration
+          DO  i = nxl, nxr
+             DO  j = nys, nyn
+                DO  k = nzb_s_inner(j,i)+1, nzt
+                   nr_p(k,j,i) = nr(k,j,i) + dt_3d * ( sbt * tend(k,j,i) +     &
+                                                     tsc(3) * tnr_m(k,j,i) )   &
+                                           - tsc(5) * rdf_sc(k) * nr(k,j,i)
+                   IF ( nr_p(k,j,i) < 0.0_wp )  nr_p(k,j,i) = 0.0_wp
+                ENDDO
+             ENDDO
+          ENDDO
+
+!
+!--       Calculate tendencies for the next Runge-Kutta step
+          IF ( timestep_scheme(1:5) == 'runge' )  THEN
+             IF ( intermediate_timestep_count == 1 )  THEN
+                DO  i = nxl, nxr
+                   DO  j = nys, nyn
+                      DO  k = nzb_s_inner(j,i)+1, nzt
+                         tnr_m(k,j,i) = tend(k,j,i)
+                      ENDDO
+                   ENDDO
+                ENDDO
+             ELSEIF ( intermediate_timestep_count < &
+                      intermediate_timestep_count_max )  THEN
+                DO  i = nxl, nxr
+                   DO  j = nys, nyn
+                      DO  k = nzb_s_inner(j,i)+1, nzt
+                         tnr_m(k,j,i) = -9.5625_wp * tend(k,j,i) + 5.3125_wp * &
+                                                                   tnr_m(k,j,i)
+                      ENDDO
+                   ENDDO
+                ENDDO
+             ENDIF
+          ENDIF
+
+          CALL cpu_log( log_point(53), 'nr-equation', 'stop' )
+
+       ENDIF
+
+    ENDIF
+
+!
+!-- If required, compute prognostic equation for turbulent kinetic 
+!-- energy (TKE)
+    IF ( .NOT. constant_diffusion )  THEN
+
+       CALL cpu_log( log_point(16), 'tke-equation', 'start' )
+
+       sbt = tsc(2)
+       IF ( .NOT. use_upstream_for_tke )  THEN
+          IF ( scalar_advec == 'bc-scheme' )  THEN
+
+             IF ( timestep_scheme(1:5) /= 'runge' )  THEN
+!
+!--             Bott-Chlond scheme always uses Euler time step. Thus:
+                sbt = 1.0_wp
+             ENDIF
+             tend = 0.0_wp
+             CALL advec_s_bc( e, 'e' )
+
+          ENDIF
+       ENDIF
+
+!
+!--    TKE-tendency terms with no communication
+       IF ( scalar_advec /= 'bc-scheme'  .OR.  use_upstream_for_tke )  THEN
+          IF ( use_upstream_for_tke )  THEN
+             tend = 0.0_wp
+             CALL advec_s_up( e )
+          ELSE
+             tend = 0.0_wp
+             IF ( timestep_scheme(1:5) == 'runge' )  THEN
+                IF ( ws_scheme_sca )  THEN
+                   CALL advec_s_ws( e, 'e' )
+                ELSE 
+                   CALL advec_s_pw( e )
+                ENDIF
+             ELSE
+                CALL advec_s_up( e )
+             ENDIF
+          ENDIF
+       ENDIF
+
+       IF ( .NOT. humidity )  THEN
+          IF ( ocean )  THEN
+             CALL diffusion_e( prho, prho_reference )
+          ELSE
+             CALL diffusion_e( pt, pt_reference )
+          ENDIF
+       ELSE
+          CALL diffusion_e( vpt, pt_reference )
+       ENDIF
+
+       CALL production_e
+
+!
+!--    Additional sink term for flows through plant canopies
+       IF ( plant_canopy )  CALL pcm_tendency( 6 )
+       CALL user_actions( 'e-tendency' )
+
+!
+!--    Prognostic equation for TKE.
+!--    Eliminate negative TKE values, which can occur due to numerical
+!--    reasons in the course of the integration. In such cases the old TKE
+!--    value is reduced by 90%.
+       DO  i = nxl, nxr
+          DO  j = nys, nyn
+             DO  k = nzb_s_inner(j,i)+1, nzt
+                e_p(k,j,i) = e(k,j,i) + dt_3d * ( sbt * tend(k,j,i) +          &
+                                                  tsc(3) * te_m(k,j,i) )
+                IF ( e_p(k,j,i) < 0.0_wp )  e_p(k,j,i) = 0.1_wp * e(k,j,i)
+             ENDDO
+          ENDDO
+       ENDDO
+
+!
+!--    Calculate tendencies for the next Runge-Kutta step
+       IF ( timestep_scheme(1:5) == 'runge' )  THEN
+          IF ( intermediate_timestep_count == 1 )  THEN
+             DO  i = nxl, nxr
+                DO  j = nys, nyn
+                   DO  k = nzb_s_inner(j,i)+1, nzt
+                      te_m(k,j,i) = tend(k,j,i)
+                   ENDDO
+                ENDDO
+             ENDDO
+          ELSEIF ( intermediate_timestep_count < &
+                   intermediate_timestep_count_max )  THEN
+             DO  i = nxl, nxr
+                DO  j = nys, nyn
+                   DO  k = nzb_s_inner(j,i)+1, nzt
+                      te_m(k,j,i) = -9.5625_wp * tend(k,j,i) + 5.3125_wp * te_m(k,j,i)
+                   ENDDO
+                ENDDO
+             ENDDO
+          ENDIF
+       ENDIF
+
+       CALL cpu_log( log_point(16), 'tke-equation', 'stop' )
+
+    ENDIF
+
+ END SUBROUTINE prognostic_equations_vector
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Version for accelerator boards
+!------------------------------------------------------------------------------!
+ 
+ SUBROUTINE prognostic_equations_acc
+
+
+    IMPLICIT NONE
+
+    INTEGER(iwp) ::  i           !<
+    INTEGER(iwp) ::  j           !<
+    INTEGER(iwp) ::  k           !<
+    INTEGER(iwp) ::  runge_step  !<
+
+    REAL(wp)     ::  sbt         !<
+
+!
+!-- Set switch for intermediate Runge-Kutta step
+    runge_step = 0
+    IF ( timestep_scheme(1:5) == 'runge' )  THEN
+       IF ( intermediate_timestep_count == 1 )  THEN
+          runge_step = 1
+       ELSEIF ( intermediate_timestep_count < &
+                intermediate_timestep_count_max )  THEN
+          runge_step = 2
+       ENDIF
+    ENDIF
+
+!
+!-- If required, calculate cloud microphysical impacts (two-moment scheme)
+    IF ( cloud_physics  .AND.  .NOT. microphysics_sat_adjust  .AND.            &
+         ( intermediate_timestep_count == 1  .OR.                              &
+           call_microphysics_at_all_substeps )                                 &
+       )  THEN
+       CALL cpu_log( log_point(51), 'microphysics', 'start' )
+       CALL microphysics_control
+       CALL cpu_log( log_point(51), 'microphysics', 'stop' )
+    ENDIF
+
+!
+!-- u-velocity component
+!++ Statistics still not completely ported to accelerators
+    !$acc update device( hom, ref_state )
+    CALL cpu_log( log_point(5), 'u-equation', 'start' )
+
+    IF ( timestep_scheme(1:5) == 'runge' )  THEN
+       IF ( ws_scheme_mom )  THEN
+          CALL advec_u_ws_acc
+       ELSE
+          tend = 0.0_wp   ! to be removed later??
+          CALL advec_u_pw
+       ENDIF
+    ELSE
+       CALL advec_u_up
+    ENDIF
+    CALL diffusion_u_acc
+    CALL coriolis_acc( 1 )
+    IF ( sloping_surface  .AND.  .NOT. neutral )  THEN
+       CALL buoyancy( pt, 1 )
+    ENDIF
+
+!
+!-- Drag by plant canopy
+    IF ( plant_canopy )  CALL pcm_tendency( 1 )
+
+!
+!-- External pressure gradient
+    IF ( dp_external )  THEN
+       DO  i = i_left, i_right
+          DO  j = j_south, j_north
+             DO  k = dp_level_ind_b+1, nzt
+                tend(k,j,i) = tend(k,j,i) - dpdxy(1) * dp_smooth_factor(k)
+             ENDDO
+          ENDDO
+       ENDDO
+    ENDIF
+
+!
+!-- Nudging
+    IF ( nudging )  CALL nudge( simulated_time, 'u' )
+
+    CALL user_actions( 'u-tendency' )
+
+!
+!-- Prognostic equation for u-velocity component
+    !$acc kernels present( nzb_u_inner, rdf, tend, tu_m, u, u_init, u_p )
+    !$acc loop independent
+    DO  i = i_left, i_right
+       !$acc loop independent
+       DO  j = j_south, j_north
+          !$acc loop independent
+          DO  k = 1, nzt
+             IF ( k > nzb_u_inner(j,i) )  THEN
+                u_p(k,j,i) = u(k,j,i) + dt_3d * ( tsc(2) * tend(k,j,i) +       &
+                                                  tsc(3) * tu_m(k,j,i) )       &
+                                      - tsc(5) * rdf(k) * ( u(k,j,i) - u_init(k) )
+!
+!--             Tendencies for the next Runge-Kutta step
+                IF ( runge_step == 1 )  THEN
+                   tu_m(k,j,i) = tend(k,j,i)
+                ELSEIF ( runge_step == 2 )  THEN
+                   tu_m(k,j,i) = -9.5625_wp * tend(k,j,i) + 5.3125_wp * tu_m(k,j,i)
+                ENDIF
+             ENDIF
+          ENDDO
+       ENDDO
+    ENDDO
+    !$acc end kernels
+
+    CALL cpu_log( log_point(5), 'u-equation', 'stop' )
+
+!
+!-- v-velocity component
+    CALL cpu_log( log_point(6), 'v-equation', 'start' )
+
+    IF ( timestep_scheme(1:5) == 'runge' )  THEN
+       IF ( ws_scheme_mom )  THEN
+          CALL advec_v_ws_acc
+       ELSE
+          tend = 0.0_wp    ! to be removed later??
+          CALL advec_v_pw
+       END IF
+    ELSE
+       CALL advec_v_up
+    ENDIF
+    CALL diffusion_v_acc
+    CALL coriolis_acc( 2 )
+
+!
+!-- Drag by plant canopy
+    IF ( plant_canopy )  CALL pcm_tendency( 2 )
+
+!
+!-- External pressure gradient
+    IF ( dp_external )  THEN
+       DO  i = i_left, i_right
+          DO  j = j_south, j_north
+             DO  k = dp_level_ind_b+1, nzt
+                tend(k,j,i) = tend(k,j,i) - dpdxy(2) * dp_smooth_factor(k)
+             ENDDO
+          ENDDO
+       ENDDO
+    ENDIF
+
+!
+!-- Nudging
+    IF ( nudging )  CALL nudge( simulated_time, 'v' )
+
+    CALL user_actions( 'v-tendency' )
+
+!
+!-- Prognostic equation for v-velocity component
+    !$acc kernels present( nzb_v_inner, rdf, tend, tv_m, v, v_init, v_p )
+    !$acc loop independent
+    DO  i = i_left, i_right
+       !$acc loop independent
+       DO  j = j_south, j_north
+          !$acc loop independent
+          DO  k = 1, nzt
+             IF ( k > nzb_v_inner(j,i) )  THEN
+                v_p(k,j,i) = v(k,j,i) + dt_3d * ( tsc(2) * tend(k,j,i) +       &
+                                                  tsc(3) * tv_m(k,j,i) )       &
+                                      - tsc(5) * rdf(k) * ( v(k,j,i) - v_init(k) )
+!
+!--             Tendencies for the next Runge-Kutta step
+                IF ( runge_step == 1 )  THEN
+                   tv_m(k,j,i) = tend(k,j,i)
+                ELSEIF ( runge_step == 2 )  THEN
+                   tv_m(k,j,i) = -9.5625_wp * tend(k,j,i) + 5.3125_wp * tv_m(k,j,i)
+                ENDIF
+             ENDIF
+          ENDDO
+       ENDDO
+    ENDDO
+    !$acc end kernels
+
+    CALL cpu_log( log_point(6), 'v-equation', 'stop' )
+
+!
+!-- w-velocity component
+    CALL cpu_log( log_point(7), 'w-equation', 'start' )
+
+    IF ( timestep_scheme(1:5) == 'runge' )  THEN
+       IF ( ws_scheme_mom )  THEN
+          CALL advec_w_ws_acc
+       ELSE
+          tend = 0.0_wp    ! to be removed later??
+          CALL advec_w_pw
+       ENDIF
+    ELSE
+       CALL advec_w_up
+    ENDIF
+    CALL diffusion_w_acc
+    CALL coriolis_acc( 3 )
+
+    IF ( .NOT. neutral )  THEN
+       IF ( ocean )  THEN
+          CALL buoyancy( rho, 3 )
+       ELSE
+          IF ( .NOT. humidity )  THEN
+             CALL buoyancy_acc( pt, 3 )
+          ELSE
+             CALL buoyancy( vpt, 3 )
+          ENDIF
+       ENDIF
+    ENDIF
+
+!
+!-- Drag by plant canopy
+    IF ( plant_canopy )  CALL pcm_tendency( 3 )
+
+    CALL user_actions( 'w-tendency' )
+
+!
+!-- Prognostic equation for w-velocity component
+    !$acc kernels present( nzb_w_inner, rdf, tend, tw_m, w, w_p )
+    !$acc loop independent
+    DO  i = i_left, i_right
+       !$acc loop independent
+       DO  j = j_south, j_north
+          !$acc loop independent
+          DO  k = 1, nzt-1
+             IF ( k > nzb_w_inner(j,i) )  THEN
+                w_p(k,j,i) = w(k,j,i) + dt_3d * ( tsc(2) * tend(k,j,i) +       &
+                                                  tsc(3) * tw_m(k,j,i) )       &
+                                      - tsc(5) * rdf(k) * w(k,j,i)
+   !
+   !--          Tendencies for the next Runge-Kutta step
+                IF ( runge_step == 1 )  THEN
+                   tw_m(k,j,i) = tend(k,j,i)
+                ELSEIF ( runge_step == 2 )  THEN
+                   tw_m(k,j,i) = -9.5625_wp * tend(k,j,i) + 5.3125_wp * tw_m(k,j,i)
+                ENDIF
+             ENDIF
+          ENDDO
+       ENDDO
+    ENDDO
+    !$acc end kernels
+
+    CALL cpu_log( log_point(7), 'w-equation', 'stop' )
+
+
+!
+!-- If required, compute prognostic equation for potential temperature
+    IF ( .NOT. neutral )  THEN
+
+       CALL cpu_log( log_point(13), 'pt-equation', 'start' )
+
+!
+!--    pt-tendency terms with communication
+       sbt = tsc(2)
+       IF ( scalar_advec == 'bc-scheme' )  THEN
+
+          IF ( timestep_scheme(1:5) /= 'runge' )  THEN
+!
+!--          Bott-Chlond scheme always uses Euler time step. Thus:
+             sbt = 1.0_wp
+          ENDIF
+          tend = 0.0_wp
+          CALL advec_s_bc( pt, 'pt' )
+
+       ENDIF
+
+!
+!--    pt-tendency terms with no communication
+       IF ( scalar_advec /= 'bc-scheme' )  THEN
+          tend = 0.0_wp
+          IF ( timestep_scheme(1:5) == 'runge' )  THEN
+             IF ( ws_scheme_sca )  THEN
+                CALL advec_s_ws_acc( pt, 'pt' )
+             ELSE
+                tend = 0.0_wp    ! to be removed later??
+                CALL advec_s_pw( pt )
+             ENDIF
+          ELSE
+             CALL advec_s_up( pt )
+          ENDIF
+       ENDIF
+
+       CALL diffusion_s_acc( pt, shf, tswst, wall_heatflux )
+
+!
+!--    If required compute heating/cooling due to long wave radiation processes
+       IF ( cloud_top_radiation )  THEN
+          CALL calc_radiation
+       ENDIF
+
+!
+!--    Consideration of heat sources within the plant canopy
+       IF ( plant_canopy .AND. ( cthf /= 0.0_wp ) ) THEN
+          CALL pcm_tendency( 4 )
+       ENDIF
+
+!
+!--    Large scale advection
+       IF ( large_scale_forcing )  THEN
+          CALL ls_advec( simulated_time, 'pt' )
+       ENDIF
+
+!
+!--    Nudging
+       IF ( nudging )  CALL nudge( simulated_time, 'pt' ) 
+
+!
+!--    If required compute influence of large-scale subsidence/ascent
+       IF ( large_scale_subsidence  .AND.                                      &
+            .NOT. use_subsidence_tendencies )  THEN
+          CALL subsidence( tend, pt, pt_init, 2 )
+       ENDIF
+
+       IF ( radiation .AND. radiation_scheme == 'rrtmg' .AND.                  &
+            simulated_time > skip_time_do_radiation )  THEN
+            CALL radiation_tendency ( tend )
+       ENDIF
+
+       CALL user_actions( 'pt-tendency' )
+
+!
+!--    Prognostic equation for potential temperature
+       !$acc kernels present( nzb_s_inner, rdf_sc, ptdf_x, ptdf_y, pt_init ) &
+       !$acc         present( tend, tpt_m, pt, pt_p )
+       !$acc loop independent
+       DO  i = i_left, i_right
+          !$acc loop independent
+          DO  j = j_south, j_north
+             !$acc loop independent
+             DO  k = 1, nzt
+                IF ( k > nzb_s_inner(j,i) )  THEN
+                   pt_p(k,j,i) = pt(k,j,i) + dt_3d * ( sbt * tend(k,j,i) +        &
+                                                       tsc(3) * tpt_m(k,j,i) )    &
+                                           - tsc(5) * ( pt(k,j,i) - pt_init(k) ) *&
+                                             ( rdf_sc(k) + ptdf_x(i) + ptdf_y(j) )
+!
+!--                Tendencies for the next Runge-Kutta step
+                   IF ( runge_step == 1 )  THEN
+                      tpt_m(k,j,i) = tend(k,j,i)
+                   ELSEIF ( runge_step == 2 )  THEN
+                      tpt_m(k,j,i) = -9.5625_wp * tend(k,j,i) + 5.3125_wp * tpt_m(k,j,i)
+                   ENDIF
+                ENDIF
+             ENDDO
+          ENDDO
+       ENDDO
+       !$acc end kernels
+
+       CALL cpu_log( log_point(13), 'pt-equation', 'stop' )
+
+    ENDIF
+
+!
+!-- If required, compute prognostic equation for salinity
+    IF ( ocean )  THEN
+
+       CALL cpu_log( log_point(37), 'sa-equation', 'start' )
+
+!
+!--    sa-tendency terms with communication
+       sbt = tsc(2)
+       IF ( scalar_advec == 'bc-scheme' )  THEN
+
+          IF ( timestep_scheme(1:5) /= 'runge' )  THEN
+!
+!--          Bott-Chlond scheme always uses Euler time step. Thus:
+             sbt = 1.0_wp
+          ENDIF
+          tend = 0.0_wp
+          CALL advec_s_bc( sa, 'sa' )
+
+       ENDIF
+
+!
+!--    sa-tendency terms with no communication
+       IF ( scalar_advec /= 'bc-scheme' )  THEN
+          tend = 0.0_wp
+          IF ( timestep_scheme(1:5) == 'runge' )  THEN
+             IF ( ws_scheme_sca )  THEN
+                 CALL advec_s_ws( sa, 'sa' )
+             ELSE
+                 CALL advec_s_pw( sa )
+             ENDIF
+          ELSE
+             CALL advec_s_up( sa )
+          ENDIF
+       ENDIF
+
+       CALL diffusion_s( sa, saswsb, saswst, wall_salinityflux )
+
+       CALL user_actions( 'sa-tendency' )
+
+!
+!--    Prognostic equation for salinity
+       DO  i = i_left, i_right
+          DO  j = j_south, j_north
+             DO  k = nzb_s_inner(j,i)+1, nzt
+                sa_p(k,j,i) = sa(k,j,i) + dt_3d * ( sbt * tend(k,j,i) +        &
+                                                    tsc(3) * tsa_m(k,j,i) )    &
+                                        - tsc(5) * rdf_sc(k) *                 &
+                                          ( sa(k,j,i) - sa_init(k) )
+                IF ( sa_p(k,j,i) < 0.0_wp )  sa_p(k,j,i) = 0.1_wp * sa(k,j,i)
+!
+!--             Tendencies for the next Runge-Kutta step
+                IF ( runge_step == 1 )  THEN
+                   tsa_m(k,j,i) = tend(k,j,i)
+                ELSEIF ( runge_step == 2 )  THEN
+                   tsa_m(k,j,i) = -9.5625_wp * tend(k,j,i) + 5.3125_wp * tsa_m(k,j,i)
+                ENDIF
+             ENDDO
+          ENDDO
+       ENDDO
+
+       CALL cpu_log( log_point(37), 'sa-equation', 'stop' )
+
+!
+!--    Calculate density by the equation of state for seawater
+       CALL cpu_log( log_point(38), 'eqns-seawater', 'start' )
+       CALL eqn_state_seawater
+       CALL cpu_log( log_point(38), 'eqns-seawater', 'stop' )
+
+    ENDIF
+
+!
+!-- If required, compute prognostic equation for total water content / scalar
+    IF ( humidity  .OR.  passive_scalar )  THEN
+
+       CALL cpu_log( log_point(29), 'q/s-equation', 'start' )
+
+!
+!--    Scalar/q-tendency terms with communication
+       sbt = tsc(2)
+       IF ( scalar_advec == 'bc-scheme' )  THEN
+
+          IF ( timestep_scheme(1:5) /= 'runge' )  THEN
+!
+!--          Bott-Chlond scheme always uses Euler time step. Thus:
+             sbt = 1.0_wp
+          ENDIF
+          tend = 0.0_wp
+          CALL advec_s_bc( q, 'q' )
+
+       ENDIF
+
+!
+!--    Scalar/q-tendency terms with no communication
+       IF ( scalar_advec /= 'bc-scheme' )  THEN
+          tend = 0.0_wp
+          IF ( timestep_scheme(1:5) == 'runge' )  THEN
+             IF ( ws_scheme_sca )  THEN
+                CALL advec_s_ws( q, 'q' )
+             ELSE
+                CALL advec_s_pw( q )
+             ENDIF
+          ELSE
+             CALL advec_s_up( q )
+          ENDIF
+       ENDIF
+
+       CALL diffusion_s( q, qsws, qswst, wall_qflux )
+
+!
+!--    Sink or source of scalar concentration due to canopy elements
+       IF ( plant_canopy ) CALL pcm_tendency( 5 )
+
+!
+!--    Large scale advection
+       IF ( large_scale_forcing )  THEN
+          CALL ls_advec( simulated_time, 'q' )
+       ENDIF
+
+!
+!--    Nudging
+       IF ( nudging )  CALL nudge( simulated_time, 'q' ) 
+
+!
+!--    If required compute influence of large-scale subsidence/ascent
+       IF ( large_scale_subsidence  .AND.                                      &
+            .NOT. use_subsidence_tendencies )  THEN
+         CALL subsidence( tend, q, q_init, 3 )
+       ENDIF
+
+       CALL user_actions( 'q-tendency' )
+
+!
+!--    Prognostic equation for total water content / scalar
+       DO  i = i_left, i_right
+          DO  j = j_south, j_north
+             DO  k = nzb_s_inner(j,i)+1, nzt
+                q_p(k,j,i) = q(k,j,i) + dt_3d * ( sbt * tend(k,j,i) +          &
+                                                  tsc(3) * tq_m(k,j,i) )       &
+                                      - tsc(5) * rdf_sc(k) *                   &
+                                        ( q(k,j,i) - q_init(k) )
+                IF ( q_p(k,j,i) < 0.0_wp )  q_p(k,j,i) = 0.1_wp * q(k,j,i)
+!
+!--             Tendencies for the next Runge-Kutta step
+                IF ( runge_step == 1 )  THEN
+                   tq_m(k,j,i) = tend(k,j,i)
+                ELSEIF ( runge_step == 2 )  THEN
+                   tq_m(k,j,i) = -9.5625_wp * tend(k,j,i) + 5.3125_wp * tq_m(k,j,i)
+                ENDIF
+             ENDDO
+          ENDDO
+       ENDDO
+
+       CALL cpu_log( log_point(29), 'q/s-equation', 'stop' )
+
+!
+!--    If required, calculate prognostic equations for rain water content 
+!--    and rain drop concentration
+       IF ( cloud_physics  .AND.  microphysics_seifert )  THEN
+
+          CALL cpu_log( log_point(52), 'qr-equation', 'start' )
+!
+!--       qr-tendency terms with communication
+          sbt = tsc(2)
+          IF ( scalar_advec == 'bc-scheme' )  THEN
+
+             IF ( timestep_scheme(1:5) /= 'runge' )  THEN
+!
+!--             Bott-Chlond scheme always uses Euler time step. Thus:
+                sbt = 1.0_wp
+             ENDIF
+             tend = 0.0_wp
+             CALL advec_s_bc( qr, 'qr' )
+
+          ENDIF
+
+!
+!--       qr-tendency terms with no communication
+          IF ( scalar_advec /= 'bc-scheme' )  THEN
+             tend = 0.0_wp
+             IF ( timestep_scheme(1:5) == 'runge' )  THEN
+                IF ( ws_scheme_sca )  THEN
+                   CALL advec_s_ws( qr, 'qr' )
+                ELSE
+                   CALL advec_s_pw( qr )
+                ENDIF
+             ELSE
+                CALL advec_s_up( qr )
+             ENDIF
+          ENDIF
+
+          CALL diffusion_s( qr, qrsws, qrswst, wall_qrflux )
+
+!
+!--       Prognostic equation for rain water content
+          DO  i = i_left, i_right
+             DO  j = j_south, j_north
+                DO  k = nzb_s_inner(j,i)+1, nzt
+                   qr_p(k,j,i) = qr(k,j,i) + dt_3d * ( sbt * tend(k,j,i) +     &
+                                                       tsc(3) * tqr_m(k,j,i) ) &
+                                           - tsc(5) * rdf_sc(k) * qr(k,j,i)
+                   IF ( qr_p(k,j,i) < 0.0_wp )  qr_p(k,j,i) = 0.0_wp
+!
+!--                Tendencies for the next Runge-Kutta step
+                   IF ( runge_step == 1 )  THEN
+                      tqr_m(k,j,i) = tend(k,j,i)
+                   ELSEIF ( runge_step == 2 )  THEN
+                      tqr_m(k,j,i) = -9.5625_wp * tend(k,j,i) + 5.3125_wp *    &
+                                                                tqr_m(k,j,i)
+                   ENDIF
+                ENDDO
+             ENDDO
+          ENDDO
+
+          CALL cpu_log( log_point(52), 'qr-equation', 'stop' )
+          CALL cpu_log( log_point(53), 'nr-equation', 'start' )
+
+!
+!--       nr-tendency terms with communication
+          sbt = tsc(2)
+          IF ( scalar_advec == 'bc-scheme' )  THEN
+
+             IF ( timestep_scheme(1:5) /= 'runge' )  THEN
+!
+!--             Bott-Chlond scheme always uses Euler time step. Thus:
+                sbt = 1.0_wp
+             ENDIF
+             tend = 0.0_wp
+             CALL advec_s_bc( nr, 'nr' )
+
+          ENDIF
+
+!
+!--       nr-tendency terms with no communication
+          IF ( scalar_advec /= 'bc-scheme' )  THEN
+             tend = 0.0_wp
+             IF ( timestep_scheme(1:5) == 'runge' )  THEN
+                IF ( ws_scheme_sca )  THEN
+                   CALL advec_s_ws( nr, 'nr' )
+                ELSE
+                   CALL advec_s_pw( nr )
+                ENDIF
+             ELSE
+                CALL advec_s_up( nr )
+             ENDIF
+          ENDIF
+
+          CALL diffusion_s( nr, nrsws, nrswst, wall_nrflux )
+
+!
+!--       Prognostic equation for rain drop concentration
+          DO  i = i_left, i_right
+             DO  j = j_south, j_north
+                DO  k = nzb_s_inner(j,i)+1, nzt
+                   nr_p(k,j,i) = nr(k,j,i) + dt_3d * ( sbt * tend(k,j,i) +     &
+                                                       tsc(3) * tnr_m(k,j,i) ) &
+                                           - tsc(5) * rdf_sc(k) * nr(k,j,i)
+                   IF ( nr_p(k,j,i) < 0.0_wp )  nr_p(k,j,i) = 0.0_wp
+!
+!--                Tendencies for the next Runge-Kutta step
+                   IF ( runge_step == 1 )  THEN
+                      tnr_m(k,j,i) = tend(k,j,i)
+                   ELSEIF ( runge_step == 2 )  THEN
+                      tnr_m(k,j,i) = -9.5625_wp * tend(k,j,i) + 5.3125_wp *    &
+                                                                tnr_m(k,j,i)
+                   ENDIF
+                ENDDO
+             ENDDO
+          ENDDO
+
+          CALL cpu_log( log_point(53), 'nr-equation', 'stop' )
+
+       ENDIF
+
+    ENDIF
+
+!
+!-- If required, compute prognostic equation for turbulent kinetic
+!-- energy (TKE)
+    IF ( .NOT. constant_diffusion )  THEN
+
+       CALL cpu_log( log_point(16), 'tke-equation', 'start' )
+
+       sbt = tsc(2)
+       IF ( .NOT. use_upstream_for_tke )  THEN
+          IF ( scalar_advec == 'bc-scheme' )  THEN
+
+             IF ( timestep_scheme(1:5) /= 'runge' )  THEN
+!
+!--             Bott-Chlond scheme always uses Euler time step. Thus:
+                sbt = 1.0_wp
+             ENDIF
+             tend = 0.0_wp
+             CALL advec_s_bc( e, 'e' )
+
+          ENDIF
+       ENDIF
+
+!
+!--    TKE-tendency terms with no communication
+       IF ( scalar_advec /= 'bc-scheme'  .OR.  use_upstream_for_tke )  THEN
+          IF ( use_upstream_for_tke )  THEN
+             tend = 0.0_wp
+             CALL advec_s_up( e )
+          ELSE
+             IF ( timestep_scheme(1:5) == 'runge' )  THEN
+                IF ( ws_scheme_sca )  THEN
+                   CALL advec_s_ws_acc( e, 'e' )
+                ELSE
+                   tend = 0.0_wp    ! to be removed later??
+                   CALL advec_s_pw( e )
+                ENDIF
+             ELSE
+                tend = 0.0_wp    ! to be removed later??
+                CALL advec_s_up( e )
+             ENDIF
+          ENDIF
+       ENDIF
+
+       IF ( .NOT. humidity )  THEN
+          IF ( ocean )  THEN
+             CALL diffusion_e( prho, prho_reference )
+          ELSE
+             CALL diffusion_e_acc( pt, pt_reference )
+          ENDIF
+       ELSE
+          CALL diffusion_e( vpt, pt_reference )
+       ENDIF
+
+       CALL production_e_acc
+
+!
+!--    Additional sink term for flows through plant canopies
+       IF ( plant_canopy )  CALL pcm_tendency( 6 )
+       CALL user_actions( 'e-tendency' )
+
+!
+!--    Prognostic equation for TKE.
+!--    Eliminate negative TKE values, which can occur due to numerical
+!--    reasons in the course of the integration. In such cases the old TKE
+!--    value is reduced by 90%.
+       !$acc kernels present( e, e_p, nzb_s_inner, tend, te_m )
+       !$acc loop independent
+       DO  i = i_left, i_right
+          !$acc loop independent
+          DO  j = j_south, j_north
+             !$acc loop independent
+             DO  k = 1, nzt
+                IF ( k > nzb_s_inner(j,i) )  THEN
+                   e_p(k,j,i) = e(k,j,i) + dt_3d * ( sbt * tend(k,j,i) +          &
+                                                     tsc(3) * te_m(k,j,i) )
+                   IF ( e_p(k,j,i) < 0.0_wp )  e_p(k,j,i) = 0.1_wp * e(k,j,i)
+!
+!--                Tendencies for the next Runge-Kutta step
+                   IF ( runge_step == 1 )  THEN
+                      te_m(k,j,i) = tend(k,j,i)
+                   ELSEIF ( runge_step == 2 )  THEN
+                      te_m(k,j,i) = -9.5625_wp * tend(k,j,i) + 5.3125_wp * te_m(k,j,i)
+                   ENDIF
+                ENDIF
+             ENDDO
+          ENDDO
+       ENDDO
+       !$acc end kernels
+
+       CALL cpu_log( log_point(16), 'tke-equation', 'stop' )
+
+    ENDIF
+
+ END SUBROUTINE prognostic_equations_acc
+
+
+ END MODULE prognostic_equations_mod
Index: lm/trunk/SOURCE/progress_bar.f90
===================================================================
--- /palm/trunk/SOURCE/progress_bar.f90	(revision 1849)
+++ 	(revision )
@@ -1,211 +1,0 @@
-!> @file progress_bar.f90
-!--------------------------------------------------------------------------------!
-! This file is part of PALM.
-!
-! PALM is free software: you can redistribute it and/or modify it under the terms
-! of the GNU General Public License as published by the Free Software Foundation,
-! either version 3 of the License, or (at your option) any later version.
-!
-! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
-! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
-! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along with
-! PALM. If not, see <http://www.gnu.org/licenses/>.
-!
-! Copyright 1997-2016 Leibniz Universitaet Hannover
-!--------------------------------------------------------------------------------!
-!
-! Current revisions:
-! -----------------
-! 
-!
-! Former revisions:
-! -----------------
-! $Id$
-!
-! 1808 2016-04-05 19:44:00Z raasch
-! routine local_flush replaced by FORTRAN statement
-!
-! 1682 2015-10-07 23:56:08Z knoop
-! Code annotations made doxygen readable 
-! 
-! 1468 2014-09-24 14:06:57Z maronga
-! Added support for progress file PROGRESS which is used in case of batch jobs
-!
-! Description:
-! ------------
-!> This routine prints either a progress bar on the standard output in case of
-!> interactive runs, or it prints the progress in a separate file called
-!> PROGRESS.
-!------------------------------------------------------------------------------!
- MODULE progress_bar
- 
-
-    USE control_parameters,                                                    &
-        ONLY : end_time, run_identifier, simulated_time,                       &
-               simulated_time_at_begin, time_restart
-
-    USE, INTRINSIC ::  ISO_FORTRAN_ENV,                                        &
-        ONLY :  OUTPUT_UNIT
-
-    USE kinds
-
-    IMPLICIT NONE
-
-    PRIVATE
-    PUBLIC   batch_job, finish_progress_bar, output_progress_bar
-
-    CHARACTER(LEN=60) ::  bar      !< progress bar, initially filled with "_"
-    CHARACTER(LEN=60) ::  crosses  !< filled with "X"
-
-    INTEGER(iwp) ::  ilength !< length of progress bar filled with "X"
-
-    LOGICAL ::  batch_job = .FALSE.   !< switch to determine the run mode
-
-    REAL(wp) ::  time_to_be_simulated !< in sec
-
-    LOGICAL ::  initialized = .FALSE. !< switch to determine if bar is initialized
-
-    SAVE
-
- CONTAINS
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Initialize the progress bar/file
-!------------------------------------------------------------------------------!
- 
-    SUBROUTINE init_progress_bar
-
-       IMPLICIT NONE
-
-!
-!--    Calculate the time to be simulated in this job
-!--    (in case of automatic restarts the calculated time will probably be
-!--    larger than the time which will actually be simulated)
-       IF ( time_restart /= 9999999.9_wp  .AND.  time_restart < end_time  .AND.&
-            time_restart > simulated_time_at_begin )  THEN
-          time_to_be_simulated = time_restart - simulated_time_at_begin
-       ELSE
-          time_to_be_simulated = end_time     - simulated_time_at_begin
-       ENDIF
-
-       IF ( batch_job )  THEN
-
-          CALL check_open ( 117 )
-          WRITE ( 117, FMT='(A20,/)' ) run_identifier
-
-       ELSE
-          bar = '____________________________________________________________'
-          crosses = 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX'
-!
-!--       Line feed on stdout to seperate the progress bar from previous messages
-          WRITE ( OUTPUT_UNIT, '(1X)' )
-#if defined( __intel_compiler )
-!
-!--       The Intel compiler does not allow to immediately flush the output buffer
-!--       in case that option ADVANCE='NO' is used in the write statement.
-!--       A workaround is to set a special carriage control feature and use "+" as
-!--       first output character, but this non-standard and only available with the
-!--       Intel compiler
-          OPEN ( OUTPUT_UNIT, CARRIAGECONTROL='FORTRAN' )
-#endif
-
-       ENDIF
-
-       initialized = .TRUE.
-
-    END SUBROUTINE init_progress_bar
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Print progress data to standard output (interactive) or to file (batch jobs)
-!------------------------------------------------------------------------------!
- 
-    SUBROUTINE output_progress_bar
-
-       IMPLICIT NONE
-
-       REAL(wp) ::  remaining_time_in_percent  !< remaining time to be simulated
-                                               !< in the job
-       REAL(wp) ::  remaining_time_in_percent_total !< total remaining time of
-                                                    !< the job chain
-
-       IF ( .NOT. initialized )  CALL init_progress_bar
-
-
-       remaining_time_in_percent =                                             &
-          ( simulated_time - simulated_time_at_begin ) / time_to_be_simulated
-
-       remaining_time_in_percent_total = ( simulated_time / end_time )
-
-!
-!--    In batch mode, use a file (PROGRESS), otherwise use progress bar
-       IF ( batch_job )  THEN
-
-          BACKSPACE ( 117 )
-          WRITE ( 117, FMT='(F5.2,1X,F5.2)' ) remaining_time_in_percent,       &
-                                              remaining_time_in_percent_total
-          FLUSH( 117 )
-
-       ELSE
-
-!
-!--       Calculate length of progress bar
-          ilength = remaining_time_in_percent * 60.0_wp
-          ilength = MIN( ilength, 60 )
-
-          bar(1:ilength) = crosses(1:ilength)
-
-#if defined( __intel_compiler )
-          WRITE ( OUTPUT_UNIT, '(A,6X,''['',A,''] '',F5.1,'' left'')' )        &
-                  '+', bar,                                                    &
-                   MAX( 0.0_wp, ( 1.0_wp - remaining_time_in_percent ) *       &
-                                  100.0_wp )
-#else
-          WRITE ( OUTPUT_UNIT, '(A,6X,''['',A,''] '',F5.1,'' left'')',         &
-                  ADVANCE='NO' )  CHAR( 13 ), bar,                             &
-                   MAX( 0.0_wp, ( 1.0_wp - remaining_time_in_percent ) *       &
-                                  100.0_wp )
-#endif
-          FLUSH( OUTPUT_UNIT )
-
-       ENDIF
-
-    END SUBROUTINE output_progress_bar
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Finalization of the progress bar/file
-!------------------------------------------------------------------------------!
- 
-    SUBROUTINE finish_progress_bar
-
-       IMPLICIT NONE
-
-       IF ( batch_job )  THEN
-
-          CALL close_file ( 117 )
-
-       ELSE
-       
-#if defined( __intel_compiler )
-!
-!--       Reset to the default carriage control
-          OPEN ( OUTPUT_UNIT, CARRIAGECONTROL='LIST' )
-#endif
-!
-!--       Line feed when simulation has finished
-          WRITE ( OUTPUT_UNIT, '(1X)' )
-
-       ENDIF
-
-    END SUBROUTINE finish_progress_bar
-
-
- END MODULE progress_bar
Index: /palm/trunk/SOURCE/progress_bar_mod.f90
===================================================================
--- /palm/trunk/SOURCE/progress_bar_mod.f90	(revision 1850)
+++ /palm/trunk/SOURCE/progress_bar_mod.f90	(revision 1850)
@@ -0,0 +1,212 @@
+!> @file progress_bar_mod.f90
+!--------------------------------------------------------------------------------!
+! This file is part of PALM.
+!
+! PALM is free software: you can redistribute it and/or modify it under the terms
+! of the GNU General Public License as published by the Free Software Foundation,
+! either version 3 of the License, or (at your option) any later version.
+!
+! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
+! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
+! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along with
+! PALM. If not, see <http://www.gnu.org/licenses/>.
+!
+! Copyright 1997-2016 Leibniz Universitaet Hannover
+!--------------------------------------------------------------------------------!
+!
+! Current revisions:
+! -----------------
+! Module renamed
+! 
+!
+! Former revisions:
+! -----------------
+! $Id$
+!
+! 1808 2016-04-05 19:44:00Z raasch
+! routine local_flush replaced by FORTRAN statement
+!
+! 1682 2015-10-07 23:56:08Z knoop
+! Code annotations made doxygen readable 
+! 
+! 1468 2014-09-24 14:06:57Z maronga
+! Added support for progress file PROGRESS which is used in case of batch jobs
+!
+! Description:
+! ------------
+!> This routine prints either a progress bar on the standard output in case of
+!> interactive runs, or it prints the progress in a separate file called
+!> PROGRESS.
+!------------------------------------------------------------------------------!
+ MODULE progress_bar
+ 
+
+    USE control_parameters,                                                    &
+        ONLY : end_time, run_identifier, simulated_time,                       &
+               simulated_time_at_begin, time_restart
+
+    USE, INTRINSIC ::  ISO_FORTRAN_ENV,                                        &
+        ONLY :  OUTPUT_UNIT
+
+    USE kinds
+
+    IMPLICIT NONE
+
+    PRIVATE
+    PUBLIC   batch_job, finish_progress_bar, output_progress_bar
+
+    CHARACTER(LEN=60) ::  bar      !< progress bar, initially filled with "_"
+    CHARACTER(LEN=60) ::  crosses  !< filled with "X"
+
+    INTEGER(iwp) ::  ilength !< length of progress bar filled with "X"
+
+    LOGICAL ::  batch_job = .FALSE.   !< switch to determine the run mode
+
+    REAL(wp) ::  time_to_be_simulated !< in sec
+
+    LOGICAL ::  initialized = .FALSE. !< switch to determine if bar is initialized
+
+    SAVE
+
+ CONTAINS
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Initialize the progress bar/file
+!------------------------------------------------------------------------------!
+ 
+    SUBROUTINE init_progress_bar
+
+       IMPLICIT NONE
+
+!
+!--    Calculate the time to be simulated in this job
+!--    (in case of automatic restarts the calculated time will probably be
+!--    larger than the time which will actually be simulated)
+       IF ( time_restart /= 9999999.9_wp  .AND.  time_restart < end_time  .AND.&
+            time_restart > simulated_time_at_begin )  THEN
+          time_to_be_simulated = time_restart - simulated_time_at_begin
+       ELSE
+          time_to_be_simulated = end_time     - simulated_time_at_begin
+       ENDIF
+
+       IF ( batch_job )  THEN
+
+          CALL check_open ( 117 )
+          WRITE ( 117, FMT='(A20,/)' ) run_identifier
+
+       ELSE
+          bar = '____________________________________________________________'
+          crosses = 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX'
+!
+!--       Line feed on stdout to seperate the progress bar from previous messages
+          WRITE ( OUTPUT_UNIT, '(1X)' )
+#if defined( __intel_compiler )
+!
+!--       The Intel compiler does not allow to immediately flush the output buffer
+!--       in case that option ADVANCE='NO' is used in the write statement.
+!--       A workaround is to set a special carriage control feature and use "+" as
+!--       first output character, but this non-standard and only available with the
+!--       Intel compiler
+          OPEN ( OUTPUT_UNIT, CARRIAGECONTROL='FORTRAN' )
+#endif
+
+       ENDIF
+
+       initialized = .TRUE.
+
+    END SUBROUTINE init_progress_bar
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Print progress data to standard output (interactive) or to file (batch jobs)
+!------------------------------------------------------------------------------!
+ 
+    SUBROUTINE output_progress_bar
+
+       IMPLICIT NONE
+
+       REAL(wp) ::  remaining_time_in_percent  !< remaining time to be simulated
+                                               !< in the job
+       REAL(wp) ::  remaining_time_in_percent_total !< total remaining time of
+                                                    !< the job chain
+
+       IF ( .NOT. initialized )  CALL init_progress_bar
+
+
+       remaining_time_in_percent =                                             &
+          ( simulated_time - simulated_time_at_begin ) / time_to_be_simulated
+
+       remaining_time_in_percent_total = ( simulated_time / end_time )
+
+!
+!--    In batch mode, use a file (PROGRESS), otherwise use progress bar
+       IF ( batch_job )  THEN
+
+          BACKSPACE ( 117 )
+          WRITE ( 117, FMT='(F5.2,1X,F5.2)' ) remaining_time_in_percent,       &
+                                              remaining_time_in_percent_total
+          FLUSH( 117 )
+
+       ELSE
+
+!
+!--       Calculate length of progress bar
+          ilength = remaining_time_in_percent * 60.0_wp
+          ilength = MIN( ilength, 60 )
+
+          bar(1:ilength) = crosses(1:ilength)
+
+#if defined( __intel_compiler )
+          WRITE ( OUTPUT_UNIT, '(A,6X,''['',A,''] '',F5.1,'' left'')' )        &
+                  '+', bar,                                                    &
+                   MAX( 0.0_wp, ( 1.0_wp - remaining_time_in_percent ) *       &
+                                  100.0_wp )
+#else
+          WRITE ( OUTPUT_UNIT, '(A,6X,''['',A,''] '',F5.1,'' left'')',         &
+                  ADVANCE='NO' )  CHAR( 13 ), bar,                             &
+                   MAX( 0.0_wp, ( 1.0_wp - remaining_time_in_percent ) *       &
+                                  100.0_wp )
+#endif
+          FLUSH( OUTPUT_UNIT )
+
+       ENDIF
+
+    END SUBROUTINE output_progress_bar
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Finalization of the progress bar/file
+!------------------------------------------------------------------------------!
+ 
+    SUBROUTINE finish_progress_bar
+
+       IMPLICIT NONE
+
+       IF ( batch_job )  THEN
+
+          CALL close_file ( 117 )
+
+       ELSE
+       
+#if defined( __intel_compiler )
+!
+!--       Reset to the default carriage control
+          OPEN ( OUTPUT_UNIT, CARRIAGECONTROL='LIST' )
+#endif
+!
+!--       Line feed when simulation has finished
+          WRITE ( OUTPUT_UNIT, '(1X)' )
+
+       ENDIF
+
+    END SUBROUTINE finish_progress_bar
+
+
+ END MODULE progress_bar
Index: lm/trunk/SOURCE/random_function.f90
===================================================================
--- /palm/trunk/SOURCE/random_function.f90	(revision 1849)
+++ 	(revision )
@@ -1,142 +1,0 @@
-!> @file random_function.f90
-!--------------------------------------------------------------------------------!
-! This file is part of PALM.
-!
-! PALM is free software: you can redistribute it and/or modify it under the terms
-! of the GNU General Public License as published by the Free Software Foundation,
-! either version 3 of the License, or (at your option) any later version.
-!
-! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
-! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
-! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along with
-! PALM. If not, see <http://www.gnu.org/licenses/>.
-!
-! Copyright 1997-2016 Leibniz Universitaet Hannover
-!--------------------------------------------------------------------------------!
-!
-! Current revisions:
-! -----------------
-! 
-! 
-! Former revisions:
-! -----------------
-! $Id$
-!
-! 1682 2015-10-07 23:56:08Z knoop
-! Code annotations made doxygen readable 
-! 
-! 1342 2014-03-26 17:04:47Z kanani
-! REAL constants defined as wp-kind
-!
-! 1320 2014-03-20 08:40:49Z raasch
-! ONLY-attribute added to USE-statements,
-! kind-parameters added to all INTEGER and REAL declaration statements,
-! kinds are defined in new module kinds,
-! old module precision_kind is removed,
-! revision history before 2012 removed,
-! comment fields (!:) to be used for variable explanations added to
-! all variable declaration statements
-!
-! 1092 2013-02-02 11:24:22Z raasch
-! unused variables removed
-!
-! 1036 2012-10-22 13:43:42Z raasch
-! code put under GPL (PALM 3.9)
-!
-! RCS Log replace by Id keyword, revision history cleaned up
-!
-! Revision 1.1  1998/02/04 16:09:45  raasch
-! Initial revision
-!
-!
-! Description:
-! ------------
-!> Random number generator, produces numbers equally distributed in interval [0,1]
-!> This routine is taken from the "numerical recipies"
-!------------------------------------------------------------------------------!
- MODULE random_function_mod
- 
-
-    USE kinds
-
-    IMPLICIT NONE
-
-    PRIVATE
-
-    PUBLIC random_function, random_function_ini
-
-    INTEGER(iwp), PUBLIC, SAVE ::  random_iv(32)  !<
-    INTEGER(iwp), PUBLIC, SAVE ::  random_iy      !<
-
-    INTERFACE random_function_ini
-       MODULE PROCEDURE random_function_ini
-    END INTERFACE random_function_ini
-
-    INTERFACE random_function
-       MODULE PROCEDURE random_function
-    END INTERFACE random_function
-
- CONTAINS
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> @todo Missing subroutine description.
-!------------------------------------------------------------------------------!
-    SUBROUTINE random_function_ini
-
-       IMPLICIT NONE
-
-       random_iv = 0
-       random_iy = 0
-
-    END SUBROUTINE random_function_ini
-
-    FUNCTION random_function( idum )
-
-
-       IMPLICIT NONE
-
-       INTEGER(iwp) ::  ia               !<
-       INTEGER(iwp) ::  idum             !<
-       INTEGER(iwp) ::  im               !<
-       INTEGER(iwp) ::  iq               !<
-       INTEGER(iwp) ::  ir               !<
-       INTEGER(iwp) ::  ndiv             !<
-       INTEGER(iwp) ::  ntab             !<
-
-       INTEGER(iwp) ::  j                !<
-       INTEGER(iwp) ::  k                !<
-
-       REAL(wp)     ::  am               !<
-       REAL(wp)     ::  eps              !<
-       REAL(wp)     ::  random_function  !<
-       REAL(wp)     ::  rnmx             !<
-
-       PARAMETER ( ia=16807, im=2147483647, am=1.0_wp/im, iq=127773, ir=2836, &
-                   ntab=32, ndiv=1+(im-1)/ntab, eps=1.2e-7_wp, rnmx=1.0_wp-eps )
-
-       IF ( idum .le. 0  .or.  random_iy .eq. 0 )  THEN
-          idum = max (-idum,1)
-          DO  j = ntab+8,1,-1
-             k    = idum / iq
-             idum = ia * ( idum - k * iq ) - ir * k
-             IF ( idum .lt. 0 )  idum = idum + im
-             IF ( j .le. ntab )  random_iv(j) = idum
-          ENDDO
-          random_iy = random_iv(1)
-       ENDIF
-
-       k    = idum / iq
-       idum = ia * ( idum - k * iq ) - ir * k
-       IF ( idum .lt. 0 )  idum = idum + im
-       j            = 1 + random_iy / ndiv
-       random_iy    = random_iv(j)
-       random_iv(j) = idum
-       random_function  = min ( am * random_iy , rnmx )
-
-    END FUNCTION random_function
-
- END MODULE random_function_mod
Index: /palm/trunk/SOURCE/random_function_mod.f90
===================================================================
--- /palm/trunk/SOURCE/random_function_mod.f90	(revision 1850)
+++ /palm/trunk/SOURCE/random_function_mod.f90	(revision 1850)
@@ -0,0 +1,143 @@
+!> @file random_function_mod.f90
+!--------------------------------------------------------------------------------!
+! This file is part of PALM.
+!
+! PALM is free software: you can redistribute it and/or modify it under the terms
+! of the GNU General Public License as published by the Free Software Foundation,
+! either version 3 of the License, or (at your option) any later version.
+!
+! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
+! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
+! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along with
+! PALM. If not, see <http://www.gnu.org/licenses/>.
+!
+! Copyright 1997-2016 Leibniz Universitaet Hannover
+!--------------------------------------------------------------------------------!
+!
+! Current revisions:
+! -----------------
+! Module renamed
+! 
+! 
+! Former revisions:
+! -----------------
+! $Id$
+!
+! 1682 2015-10-07 23:56:08Z knoop
+! Code annotations made doxygen readable 
+! 
+! 1342 2014-03-26 17:04:47Z kanani
+! REAL constants defined as wp-kind
+!
+! 1320 2014-03-20 08:40:49Z raasch
+! ONLY-attribute added to USE-statements,
+! kind-parameters added to all INTEGER and REAL declaration statements,
+! kinds are defined in new module kinds,
+! old module precision_kind is removed,
+! revision history before 2012 removed,
+! comment fields (!:) to be used for variable explanations added to
+! all variable declaration statements
+!
+! 1092 2013-02-02 11:24:22Z raasch
+! unused variables removed
+!
+! 1036 2012-10-22 13:43:42Z raasch
+! code put under GPL (PALM 3.9)
+!
+! RCS Log replace by Id keyword, revision history cleaned up
+!
+! Revision 1.1  1998/02/04 16:09:45  raasch
+! Initial revision
+!
+!
+! Description:
+! ------------
+!> Random number generator, produces numbers equally distributed in interval [0,1]
+!> This routine is taken from the "numerical recipies"
+!------------------------------------------------------------------------------!
+ MODULE random_function_mod
+ 
+
+    USE kinds
+
+    IMPLICIT NONE
+
+    PRIVATE
+
+    PUBLIC random_function, random_function_ini
+
+    INTEGER(iwp), PUBLIC, SAVE ::  random_iv(32)  !<
+    INTEGER(iwp), PUBLIC, SAVE ::  random_iy      !<
+
+    INTERFACE random_function_ini
+       MODULE PROCEDURE random_function_ini
+    END INTERFACE random_function_ini
+
+    INTERFACE random_function
+       MODULE PROCEDURE random_function
+    END INTERFACE random_function
+
+ CONTAINS
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> @todo Missing subroutine description.
+!------------------------------------------------------------------------------!
+    SUBROUTINE random_function_ini
+
+       IMPLICIT NONE
+
+       random_iv = 0
+       random_iy = 0
+
+    END SUBROUTINE random_function_ini
+
+    FUNCTION random_function( idum )
+
+
+       IMPLICIT NONE
+
+       INTEGER(iwp) ::  ia               !<
+       INTEGER(iwp) ::  idum             !<
+       INTEGER(iwp) ::  im               !<
+       INTEGER(iwp) ::  iq               !<
+       INTEGER(iwp) ::  ir               !<
+       INTEGER(iwp) ::  ndiv             !<
+       INTEGER(iwp) ::  ntab             !<
+
+       INTEGER(iwp) ::  j                !<
+       INTEGER(iwp) ::  k                !<
+
+       REAL(wp)     ::  am               !<
+       REAL(wp)     ::  eps              !<
+       REAL(wp)     ::  random_function  !<
+       REAL(wp)     ::  rnmx             !<
+
+       PARAMETER ( ia=16807, im=2147483647, am=1.0_wp/im, iq=127773, ir=2836, &
+                   ntab=32, ndiv=1+(im-1)/ntab, eps=1.2e-7_wp, rnmx=1.0_wp-eps )
+
+       IF ( idum .le. 0  .or.  random_iy .eq. 0 )  THEN
+          idum = max (-idum,1)
+          DO  j = ntab+8,1,-1
+             k    = idum / iq
+             idum = ia * ( idum - k * iq ) - ir * k
+             IF ( idum .lt. 0 )  idum = idum + im
+             IF ( j .le. ntab )  random_iv(j) = idum
+          ENDDO
+          random_iy = random_iv(1)
+       ENDIF
+
+       k    = idum / iq
+       idum = ia * ( idum - k * iq ) - ir * k
+       IF ( idum .lt. 0 )  idum = idum + im
+       j            = 1 + random_iy / ndiv
+       random_iy    = random_iv(j)
+       random_iv(j) = idum
+       random_function  = min ( am * random_iy , rnmx )
+
+    END FUNCTION random_function
+
+ END MODULE random_function_mod
Index: lm/trunk/SOURCE/random_generator_parallel.f90
===================================================================
--- /palm/trunk/SOURCE/random_generator_parallel.f90	(revision 1849)
+++ 	(revision )
@@ -1,472 +1,0 @@
-!> @file random_generator_parallel.f90
-!------------------------------------------------------------------------------!
-! This file is part of PALM.
-!
-! PALM is free software: you can redistribute it and/or modify it under the terms
-! of the GNU General Public License as published by the Free Software Foundation,
-! either version 3 of the License, or (at your option) any later version.
-!
-! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
-! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
-! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along with
-! PALM. If not, see <http://www.gnu.org/licenses/>.
-!
-! Copyright 1997-2016 Leibniz Universitaet Hannover
-!------------------------------------------------------------------------------!
-!
-! Current revisions:
-! -----------------
-! 
-! 
-! Former revisions:
-! -----------------
-! $Id$
-!
-! 1682 2015-10-07 23:56:08Z knoop
-! Code annotations made doxygen readable 
-! 
-! 1400 2014-05-09 14:03:54Z knoop
-! Initial revision
-! 
-!
-! Description:
-! ------------
-!> This module contains and supports the random number generating routine ran_parallel.
-!> ran_parallel returns a uniform random deviate between 0.0 and 1.0 
-!> (exclusive of the end point values).
-!> Additionally it provides the generator with five integer for use as initial state space.
-!> The first tree integers (iran, jran, kran) are maintained as non negative values, 
-!> while the last two (mran, nran) have 32-bit nonzero values. 
-!> Also provided by this module is support for initializing or reinitializing 
-!> the state space to a desired standard sequence number, hashing the initial 
-!> values to random values, and allocating and deallocating the internal workspace
-!> Random number generator, produces numbers equally distributed in interval
-!>
-!> This routine is taken from the "numerical recipies vol. 2"
-!------------------------------------------------------------------------------!
-MODULE random_generator_parallel
- 
-
-   USE kinds
-   
-   IMPLICIT NONE
-   
-   PRIVATE
-   PUBLIC random_number_parallel, random_seed_parallel, random_dummy,          &
-          id_random_array, seq_random_array
-   
-   INTEGER(isp), SAVE :: lenran=0             !< 
-   INTEGER(isp), SAVE :: seq=0                !< 
-   INTEGER(isp), SAVE :: iran0                !< 
-   INTEGER(isp), SAVE :: jran0                !< 
-   INTEGER(isp), SAVE :: kran0                !< 
-   INTEGER(isp), SAVE :: mran0                !< 
-   INTEGER(isp), SAVE :: nran0                !< 
-   INTEGER(isp), SAVE :: rans                 !< 
-   
-   INTEGER(isp), DIMENSION(:, :), POINTER, SAVE :: ranseeds   !< 
-   
-   INTEGER(isp), DIMENSION(:), POINTER, SAVE :: iran   !< 
-   INTEGER(isp), DIMENSION(:), POINTER, SAVE :: jran   !< 
-   INTEGER(isp), DIMENSION(:), POINTER, SAVE :: kran   !< 
-   INTEGER(isp), DIMENSION(:), POINTER, SAVE :: mran   !< 
-   INTEGER(isp), DIMENSION(:), POINTER, SAVE :: nran   !< 
-   INTEGER(isp), DIMENSION(:), POINTER, SAVE :: ranv   !< 
-   
-   
-    
-   INTEGER(isp), DIMENSION(:,:), ALLOCATABLE   ::  id_random_array    !< 
-   INTEGER(isp), DIMENSION(:,:,:), ALLOCATABLE ::  seq_random_array   !< 
-   
-   REAL(wp), SAVE :: amm   !< 
-   
-   REAL(wp) :: random_dummy=0.0   !< 
-   
-   INTERFACE random_number_parallel
-      MODULE PROCEDURE ran0_s
-   END INTERFACE
-   
-   INTERFACE random_seed_parallel
-      MODULE PROCEDURE random_seed_parallel
-   END INTERFACE
-   
-   INTERFACE ran_hash
-      MODULE PROCEDURE ran_hash_v
-   END INTERFACE
-   
-   INTERFACE reallocate
-      MODULE PROCEDURE reallocate_iv,reallocate_im
-   END INTERFACE
-   
-   INTERFACE arth
-      MODULE PROCEDURE arth_i
-   END INTERFACE
-
- CONTAINS
- 
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Lagged Fibonacci generator combined with a Marsaglia shiftsequence. 
-!> Returns as harvest a uniform random deviate between 0.0 and 1.0 (exclusive of the end point values). 
-!> This generator has the same calling and initialization conventions as Fortran 90's random_number routine. 
-!> Use random_seed_parallel to initialize or reinitialize to a particular sequence. 
-!> The period of this generator is about 2.0 x 10^28, and it fully vectorizes.
-!> Validity of the integer model assumed by this generator is tested at initialization.
-!------------------------------------------------------------------------------!
-   SUBROUTINE ran0_s(harvest)
-
-      USE kinds
-      
-      IMPLICIT NONE
-      
-      REAL(wp), INTENT(OUT) :: harvest   !< 
-      
-      IF  (lenran < 1) CALL ran_init(1)  !- Initialization routine in ran_state.
-      
-      !- Update Fibonacci generator, which has period p^2 + p + 1, p = 2^31 - 69.
-      rans = iran0 - kran0   
-      
-      IF  (rans < 0) rans = rans + 2147483579_isp
-      
-      iran0 = jran0
-      jran0 = kran0
-      kran0 = rans
-      
-      nran0 = ieor( nran0, ishft (nran0, 13) ) !- Update Marsaglia shift sequence with period 2^32 - 1.
-      nran0 = ieor( nran0, ishft (nran0, -17) )
-      nran0 = ieor( nran0, ishft (nran0, 5) )
-      
-      rans  = ieor( nran0, rans )   !- Combine the generators.
-      
-      harvest = amm * merge( rans, not(rans), rans < 0 ) !- Make the result positive definite (note that amm is negative).
-      
-   END SUBROUTINE ran0_s
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Initialize or reinitialize the random generator state space to vectors of size length. 
-!> The saved variable seq is hashed (via calls to the module routine ran_hash) 
-!> to create unique starting seeds, different for each vector component.
-!------------------------------------------------------------------------------!
-   SUBROUTINE ran_init( length )
-   
-      USE kinds
-      
-      IMPLICIT NONE
-      
-      INTEGER(isp), INTENT(IN) ::  length   !< 
-   
-      INTEGER(isp), PARAMETER:: hg=huge(1_isp)   !< 
-      INTEGER(isp), PARAMETER:: hgm=-hg          !< 
-      INTEGER(isp), PARAMETER:: hgng=hgm-1       !< 
-      
-      INTEGER(isp) ::  new   !< 
-      INTEGER(isp) ::  j     !< 
-      INTEGER(isp) ::  hgt   !< 
-      
-      IF ( length < lenran ) RETURN !- Simply return if enough space is already allocated.
-      
-      hgt = hg
-      
-      !- The following lines check that kind value isp is in fact a 32-bit integer 
-      !- with the usual properties that we expect it to have (under negation and wrap-around addition).
-      !- If all of these tests are satisfied, then the routines that use this module are portable, 
-      !- even though they go beyond Fortran 90's integer model.
-      
-      IF  ( hg /= 2147483647 ) CALL ran_error('ran_init: arith assump 1 fails')
-      IF  ( hgng >= 0 )        CALL ran_error('ran_init: arith assump 2 fails')
-      IF  ( hgt+1 /= hgng )    CALL ran_error('ran_init: arith assump 3 fails')
-      IF  ( not(hg) >= 0 )     CALL ran_error('ran_init: arith assump 4 fails')
-      IF  ( not(hgng) < 0 )    CALL ran_error('ran_init: arith assump 5 fails')
-      IF  ( hg+hgng >= 0 )     CALL ran_error('ran_init: arith assump 6 fails')
-      IF  ( not(-1_isp) < 0 )  CALL ran_error('ran_init: arith assump 7 fails')
-      IF  ( not(0_isp) >= 0 )  CALL ran_error('ran_init: arith assump 8 fails')
-      IF  ( not(1_isp) >= 0 )  CALL ran_error('ran_init: arith assump 9 fails')
-      
-      IF  ( lenran > 0) THEN                          !- Reallocate space, or ...
-      
-         ranseeds => reallocate( ranseeds, length, 5)
-         ranv => reallocate( ranv, length-1)
-         new = lenran+1
-         
-      ELSE                                            !- allocate space.
-      
-         ALLOCATE(ranseeds(length,5))
-         ALLOCATE(ranv(length-1))
-         new = 1   !- Index of first location not yet initialized.
-         amm = nearest(1.0_wp,-1.0_wp)/hgng
-         !- Use of nearest is to ensure that returned random deviates are strictly lessthan 1.0.
-         IF  (amm*hgng >= 1.0 .or. amm*hgng <= 0.0)                            &
-            CALL ran_error('ran_init: arith assump 10 fails')
-            
-      END IF 
-      
-      !- Set starting values, unique by seq and vector component.
-      ranseeds(new:,1) = seq
-      ranseeds(new:,2:5)=spread(arth(new,1,size(ranseeds(new:,1))),2,4)
-      
-      DO j=1,4   !- Hash them.
-         CALL ran_hash(ranseeds(new:,j), ranseeds(new:,j+1))
-      END DO
-      
-      WHERE (ranseeds (new: ,1:3) < 0)                                         & 
-         ranseeds(new: ,1:3)=not(ranseeds(new: ,1:3))  !- Enforce nonnegativity.
-         
-      WHERE (ranseeds(new: ,4:5) == 0) ranseeds(new: ,4:5)=1 !- Enforce nonzero.
-      
-      IF  (new == 1) THEN !- Set scalar seeds.
-      
-         iran0 = ranseeds(1,1)
-         jran0 = ranseeds(1,2)
-         kran0 = ranseeds(1,3)
-         mran0 = ranseeds(1,4)
-         nran0 = ranseeds(1,5)
-         rans  = nran0
-         
-      END IF 
-      
-      IF  (length > 1) THEN   !- Point to vector seeds.
-      
-         iran => ranseeds(2:,1)
-         jran => ranseeds(2:,2)
-         kran => ranseeds(2:,3)
-         mran => ranseeds(2:,4)
-         nran => ranseeds(2:,5)
-         ranv = nran
-         
-      END IF 
-      
-      lenran = length
-      
-   END SUBROUTINE ran_init
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> User interface to release the workspace used by the random number routines.
-!------------------------------------------------------------------------------!
-   SUBROUTINE ran_deallocate
-   
-      IF  ( lenran > 0 ) THEN
-      
-         DEALLOCATE(ranseeds, ranv)
-         NULLIFY(ranseeds, ranv, iran, jran, kran, mran, nran)
-         lenran = 0
-         
-      END IF 
-      
-   END SUBROUTINE ran_deallocate
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> User interface for seeding the random number routines. 
-!> Syntax is exactly like Fortran 90's random_seed routine, 
-!> with one additional argument keyword: random_sequence, set to any integer 
-!> value, causes an immediate new initialization, seeded by that integer.
-!------------------------------------------------------------------------------!
-   SUBROUTINE random_seed_parallel( random_sequence, state_size, put, get )
-   
-      IMPLICIT NONE
-      
-      INTEGER(isp), OPTIONAL, INTENT(IN)  ::  random_sequence   !< 
-      INTEGER(isp), OPTIONAL, INTENT(OUT) ::  state_size        !< 
-      
-      INTEGER(isp), DIMENSION(:), OPTIONAL, INTENT(IN)  ::  put   !< 
-      INTEGER(isp), DIMENSION(:), OPTIONAL, INTENT(OUT) ::  get   !< 
-      
-      IF  ( present(state_size) ) THEN
-      
-         state_size = 5 * lenran
-         
-      ELSE IF  ( present(put) ) THEN
-      
-         IF  ( lenran == 0 ) RETURN
-         
-         ranseeds = reshape( put,shape(ranseeds) )
-         
-         WHERE (ranseeds(:,1:3) < 0) ranseeds(: ,1:3) = not(ranseeds(: ,1:3))
-         !- Enforce nonnegativity and nonzero conditions on any user-supplied seeds.
-         
-         WHERE (ranseeds(:,4:5) == 0) ranseeds(:,4:5) = 1
-         
-         iran0 = ranseeds(1,1)
-         jran0 = ranseeds(1,2)
-         kran0 = ranseeds(1,3)
-         mran0 = ranseeds(1,4)
-         nran0 = ranseeds(1,5)
-         
-      ELSE IF  ( present(get) ) THEN
-      
-         IF  (lenran == 0) RETURN
-         
-         ranseeds(1,1:5) = (/ iran0,jran0,kran0,mran0,nran0 /)
-         get = reshape( ranseeds, shape(get) )
-         
-      ELSE IF  ( present(random_sequence) ) THEN
-      
-         CALL ran_deallocate
-         seq = random_sequence
-         
-      END IF 
-      
-   END SUBROUTINE random_seed_parallel
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> DES-like hashing of two 32-bit integers, using shifts, 
-!> xor's, and adds to make the internal nonlinear function.
-!------------------------------------------------------------------------------!
-   SUBROUTINE ran_hash_v( il, ir )
-   
-      IMPLICIT NONE
-      
-      INTEGER(isp), DIMENSION(:), INTENT(INOUT) ::  il   !< 
-      INTEGER(isp), DIMENSION(:), INTENT(INOUT) ::  ir   !< 
-      
-      INTEGER(isp), DIMENSION(size(il)) ::  is   !< 
-      
-      INTEGER(isp) :: j   !< 
-      
-      DO j=1,4
-      
-         is = ir
-         ir = ieor( ir, ishft(ir,5) ) + 1422217823
-         ir = ieor( ir, ishft(ir,-16) ) + 1842055030
-         ir = ieor( ir, ishft(ir,9) ) + 80567781
-         ir = ieor( il, ir )
-         il = is
-      END DO
-      
-   END SUBROUTINE ran_hash_v
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> User interface to process error-messages 
-!> produced by the random_number_parallel module
-!------------------------------------------------------------------------------!
-   SUBROUTINE ran_error(string)
-   
-      CHARACTER(LEN=*), INTENT(IN) ::  string   !< 
-      
-      write (*,*) 'Error in module random_number_parallel: ',string
-      
-      STOP 'Program terminated by ran_error'
-      
-   END SUBROUTINE ran_error
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Reallocates the generators state space "ranseeds" to vectors of size length. 
-!------------------------------------------------------------------------------!
-   FUNCTION reallocate_iv( p, n )
-   
-      INTEGER(isp), DIMENSION(:), POINTER ::  p               !< 
-      INTEGER(isp), DIMENSION(:), POINTER ::  reallocate_iv   !< 
-      
-      INTEGER(isp), INTENT(IN) ::  n   !< 
-      
-      INTEGER(isp) ::  nold   !< 
-      INTEGER(isp) ::  ierr   !< 
-      
-      ALLOCATE(reallocate_iv(n),stat=ierr)
-      
-      IF (ierr /= 0) CALL                                                      &
-         ran_error('reallocate_iv: problem in attempt to allocate memory')
-         
-      IF (.not. associated(p)) RETURN
-      
-      nold = size(p)
-      
-      reallocate_iv(1:min(nold,n)) = p(1:min(nold,n))
-      
-      DEALLOCATE(p)
-      
-   END FUNCTION reallocate_iv
-   
-   FUNCTION reallocate_im( p, n, m )
-   
-      INTEGER(isp), DIMENSION(:,:), POINTER ::  p               !< 
-      INTEGER(isp), DIMENSION(:,:), POINTER ::  reallocate_im   !< 
-      
-      INTEGER(isp), INTENT(IN) ::  m   !< 
-      INTEGER(isp), INTENT(IN) ::  n   !< 
-      
-      INTEGER(isp) ::  mold   !< 
-      INTEGER(isp) ::  nold   !< 
-      INTEGER(isp) ::  ierr   !< 
-      
-      ALLOCATE(reallocate_im(n,m),stat=ierr)
-      
-      IF (ierr /= 0) CALL                                                      &
-         ran_error('reallocate_im: problem in attempt to allocate memory')
-         
-      IF (.not. associated(p)) RETURN
-      
-      nold = size(p,1)
-      mold = size(p,2)
-      
-      reallocate_im(1:min(nold,n),1:min(mold,m)) =                             &
-         p(1:min(nold,n),1:min(mold,m))
-         
-      DEALLOCATE(p)
-      
-   END FUNCTION reallocate_im
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Reallocates the generators state space "ranseeds" to vectors of size length. 
-!------------------------------------------------------------------------------!
-   FUNCTION arth_i(first,increment,n)
-   
-      INTEGER(isp), INTENT(IN) ::  first       !< 
-      INTEGER(isp), INTENT(IN) ::  increment   !< 
-      INTEGER(isp), INTENT(IN) ::  n           !< 
-      
-      INTEGER(isp), DIMENSION(n) ::  arth_i    !< 
-      
-      INTEGER(isp) ::  k      !< 
-      INTEGER(isp) ::  k2     !< 
-      INTEGER(isp) ::  temp   !< 
-      
-      INTEGER(isp), PARAMETER ::  npar_arth=16   !< 
-      INTEGER(isp), PARAMETER ::  npar2_arth=8   !< 
-      
-      IF (n > 0) arth_i(1) = first
-      
-      IF (n <= npar_arth) THEN
-      
-         DO k=2,n
-            arth_i(k) = arth_i(k-1)+increment
-         END DO
-         
-      ELSE
-      
-         DO k=2,npar2_arth
-            arth_i(k) = arth_i(k-1) + increment
-         END DO
-         
-         temp = increment * npar2_arth
-         k = npar2_arth
-         
-         DO
-            IF (k >= n) EXIT
-            k2 = k + k
-            arth_i(k+1:min(k2,n)) = temp + arth_i(1:min(k,n-k))
-            temp = temp + temp
-            k = k2
-         END DO
-         
-      END IF
-      
-   END FUNCTION arth_i
-
-END MODULE random_generator_parallel
Index: /palm/trunk/SOURCE/random_generator_parallel_mod.f90
===================================================================
--- /palm/trunk/SOURCE/random_generator_parallel_mod.f90	(revision 1850)
+++ /palm/trunk/SOURCE/random_generator_parallel_mod.f90	(revision 1850)
@@ -0,0 +1,473 @@
+!> @file random_generator_parallel_mod.f90
+!------------------------------------------------------------------------------!
+! This file is part of PALM.
+!
+! PALM is free software: you can redistribute it and/or modify it under the terms
+! of the GNU General Public License as published by the Free Software Foundation,
+! either version 3 of the License, or (at your option) any later version.
+!
+! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
+! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
+! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along with
+! PALM. If not, see <http://www.gnu.org/licenses/>.
+!
+! Copyright 1997-2016 Leibniz Universitaet Hannover
+!------------------------------------------------------------------------------!
+!
+! Current revisions:
+! -----------------
+! Module renamed
+! 
+! 
+! Former revisions:
+! -----------------
+! $Id$
+!
+! 1682 2015-10-07 23:56:08Z knoop
+! Code annotations made doxygen readable 
+! 
+! 1400 2014-05-09 14:03:54Z knoop
+! Initial revision
+! 
+!
+! Description:
+! ------------
+!> This module contains and supports the random number generating routine ran_parallel.
+!> ran_parallel returns a uniform random deviate between 0.0 and 1.0 
+!> (exclusive of the end point values).
+!> Additionally it provides the generator with five integer for use as initial state space.
+!> The first tree integers (iran, jran, kran) are maintained as non negative values, 
+!> while the last two (mran, nran) have 32-bit nonzero values. 
+!> Also provided by this module is support for initializing or reinitializing 
+!> the state space to a desired standard sequence number, hashing the initial 
+!> values to random values, and allocating and deallocating the internal workspace
+!> Random number generator, produces numbers equally distributed in interval
+!>
+!> This routine is taken from the "numerical recipies vol. 2"
+!------------------------------------------------------------------------------!
+MODULE random_generator_parallel
+ 
+
+   USE kinds
+   
+   IMPLICIT NONE
+   
+   PRIVATE
+   PUBLIC random_number_parallel, random_seed_parallel, random_dummy,          &
+          id_random_array, seq_random_array
+   
+   INTEGER(isp), SAVE :: lenran=0             !< 
+   INTEGER(isp), SAVE :: seq=0                !< 
+   INTEGER(isp), SAVE :: iran0                !< 
+   INTEGER(isp), SAVE :: jran0                !< 
+   INTEGER(isp), SAVE :: kran0                !< 
+   INTEGER(isp), SAVE :: mran0                !< 
+   INTEGER(isp), SAVE :: nran0                !< 
+   INTEGER(isp), SAVE :: rans                 !< 
+   
+   INTEGER(isp), DIMENSION(:, :), POINTER, SAVE :: ranseeds   !< 
+   
+   INTEGER(isp), DIMENSION(:), POINTER, SAVE :: iran   !< 
+   INTEGER(isp), DIMENSION(:), POINTER, SAVE :: jran   !< 
+   INTEGER(isp), DIMENSION(:), POINTER, SAVE :: kran   !< 
+   INTEGER(isp), DIMENSION(:), POINTER, SAVE :: mran   !< 
+   INTEGER(isp), DIMENSION(:), POINTER, SAVE :: nran   !< 
+   INTEGER(isp), DIMENSION(:), POINTER, SAVE :: ranv   !< 
+   
+   
+    
+   INTEGER(isp), DIMENSION(:,:), ALLOCATABLE   ::  id_random_array    !< 
+   INTEGER(isp), DIMENSION(:,:,:), ALLOCATABLE ::  seq_random_array   !< 
+   
+   REAL(wp), SAVE :: amm   !< 
+   
+   REAL(wp) :: random_dummy=0.0   !< 
+   
+   INTERFACE random_number_parallel
+      MODULE PROCEDURE ran0_s
+   END INTERFACE
+   
+   INTERFACE random_seed_parallel
+      MODULE PROCEDURE random_seed_parallel
+   END INTERFACE
+   
+   INTERFACE ran_hash
+      MODULE PROCEDURE ran_hash_v
+   END INTERFACE
+   
+   INTERFACE reallocate
+      MODULE PROCEDURE reallocate_iv,reallocate_im
+   END INTERFACE
+   
+   INTERFACE arth
+      MODULE PROCEDURE arth_i
+   END INTERFACE
+
+ CONTAINS
+ 
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Lagged Fibonacci generator combined with a Marsaglia shiftsequence. 
+!> Returns as harvest a uniform random deviate between 0.0 and 1.0 (exclusive of the end point values). 
+!> This generator has the same calling and initialization conventions as Fortran 90's random_number routine. 
+!> Use random_seed_parallel to initialize or reinitialize to a particular sequence. 
+!> The period of this generator is about 2.0 x 10^28, and it fully vectorizes.
+!> Validity of the integer model assumed by this generator is tested at initialization.
+!------------------------------------------------------------------------------!
+   SUBROUTINE ran0_s(harvest)
+
+      USE kinds
+      
+      IMPLICIT NONE
+      
+      REAL(wp), INTENT(OUT) :: harvest   !< 
+      
+      IF  (lenran < 1) CALL ran_init(1)  !- Initialization routine in ran_state.
+      
+      !- Update Fibonacci generator, which has period p^2 + p + 1, p = 2^31 - 69.
+      rans = iran0 - kran0   
+      
+      IF  (rans < 0) rans = rans + 2147483579_isp
+      
+      iran0 = jran0
+      jran0 = kran0
+      kran0 = rans
+      
+      nran0 = ieor( nran0, ishft (nran0, 13) ) !- Update Marsaglia shift sequence with period 2^32 - 1.
+      nran0 = ieor( nran0, ishft (nran0, -17) )
+      nran0 = ieor( nran0, ishft (nran0, 5) )
+      
+      rans  = ieor( nran0, rans )   !- Combine the generators.
+      
+      harvest = amm * merge( rans, not(rans), rans < 0 ) !- Make the result positive definite (note that amm is negative).
+      
+   END SUBROUTINE ran0_s
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Initialize or reinitialize the random generator state space to vectors of size length. 
+!> The saved variable seq is hashed (via calls to the module routine ran_hash) 
+!> to create unique starting seeds, different for each vector component.
+!------------------------------------------------------------------------------!
+   SUBROUTINE ran_init( length )
+   
+      USE kinds
+      
+      IMPLICIT NONE
+      
+      INTEGER(isp), INTENT(IN) ::  length   !< 
+   
+      INTEGER(isp), PARAMETER:: hg=huge(1_isp)   !< 
+      INTEGER(isp), PARAMETER:: hgm=-hg          !< 
+      INTEGER(isp), PARAMETER:: hgng=hgm-1       !< 
+      
+      INTEGER(isp) ::  new   !< 
+      INTEGER(isp) ::  j     !< 
+      INTEGER(isp) ::  hgt   !< 
+      
+      IF ( length < lenran ) RETURN !- Simply return if enough space is already allocated.
+      
+      hgt = hg
+      
+      !- The following lines check that kind value isp is in fact a 32-bit integer 
+      !- with the usual properties that we expect it to have (under negation and wrap-around addition).
+      !- If all of these tests are satisfied, then the routines that use this module are portable, 
+      !- even though they go beyond Fortran 90's integer model.
+      
+      IF  ( hg /= 2147483647 ) CALL ran_error('ran_init: arith assump 1 fails')
+      IF  ( hgng >= 0 )        CALL ran_error('ran_init: arith assump 2 fails')
+      IF  ( hgt+1 /= hgng )    CALL ran_error('ran_init: arith assump 3 fails')
+      IF  ( not(hg) >= 0 )     CALL ran_error('ran_init: arith assump 4 fails')
+      IF  ( not(hgng) < 0 )    CALL ran_error('ran_init: arith assump 5 fails')
+      IF  ( hg+hgng >= 0 )     CALL ran_error('ran_init: arith assump 6 fails')
+      IF  ( not(-1_isp) < 0 )  CALL ran_error('ran_init: arith assump 7 fails')
+      IF  ( not(0_isp) >= 0 )  CALL ran_error('ran_init: arith assump 8 fails')
+      IF  ( not(1_isp) >= 0 )  CALL ran_error('ran_init: arith assump 9 fails')
+      
+      IF  ( lenran > 0) THEN                          !- Reallocate space, or ...
+      
+         ranseeds => reallocate( ranseeds, length, 5)
+         ranv => reallocate( ranv, length-1)
+         new = lenran+1
+         
+      ELSE                                            !- allocate space.
+      
+         ALLOCATE(ranseeds(length,5))
+         ALLOCATE(ranv(length-1))
+         new = 1   !- Index of first location not yet initialized.
+         amm = nearest(1.0_wp,-1.0_wp)/hgng
+         !- Use of nearest is to ensure that returned random deviates are strictly lessthan 1.0.
+         IF  (amm*hgng >= 1.0 .or. amm*hgng <= 0.0)                            &
+            CALL ran_error('ran_init: arith assump 10 fails')
+            
+      END IF 
+      
+      !- Set starting values, unique by seq and vector component.
+      ranseeds(new:,1) = seq
+      ranseeds(new:,2:5)=spread(arth(new,1,size(ranseeds(new:,1))),2,4)
+      
+      DO j=1,4   !- Hash them.
+         CALL ran_hash(ranseeds(new:,j), ranseeds(new:,j+1))
+      END DO
+      
+      WHERE (ranseeds (new: ,1:3) < 0)                                         & 
+         ranseeds(new: ,1:3)=not(ranseeds(new: ,1:3))  !- Enforce nonnegativity.
+         
+      WHERE (ranseeds(new: ,4:5) == 0) ranseeds(new: ,4:5)=1 !- Enforce nonzero.
+      
+      IF  (new == 1) THEN !- Set scalar seeds.
+      
+         iran0 = ranseeds(1,1)
+         jran0 = ranseeds(1,2)
+         kran0 = ranseeds(1,3)
+         mran0 = ranseeds(1,4)
+         nran0 = ranseeds(1,5)
+         rans  = nran0
+         
+      END IF 
+      
+      IF  (length > 1) THEN   !- Point to vector seeds.
+      
+         iran => ranseeds(2:,1)
+         jran => ranseeds(2:,2)
+         kran => ranseeds(2:,3)
+         mran => ranseeds(2:,4)
+         nran => ranseeds(2:,5)
+         ranv = nran
+         
+      END IF 
+      
+      lenran = length
+      
+   END SUBROUTINE ran_init
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> User interface to release the workspace used by the random number routines.
+!------------------------------------------------------------------------------!
+   SUBROUTINE ran_deallocate
+   
+      IF  ( lenran > 0 ) THEN
+      
+         DEALLOCATE(ranseeds, ranv)
+         NULLIFY(ranseeds, ranv, iran, jran, kran, mran, nran)
+         lenran = 0
+         
+      END IF 
+      
+   END SUBROUTINE ran_deallocate
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> User interface for seeding the random number routines. 
+!> Syntax is exactly like Fortran 90's random_seed routine, 
+!> with one additional argument keyword: random_sequence, set to any integer 
+!> value, causes an immediate new initialization, seeded by that integer.
+!------------------------------------------------------------------------------!
+   SUBROUTINE random_seed_parallel( random_sequence, state_size, put, get )
+   
+      IMPLICIT NONE
+      
+      INTEGER(isp), OPTIONAL, INTENT(IN)  ::  random_sequence   !< 
+      INTEGER(isp), OPTIONAL, INTENT(OUT) ::  state_size        !< 
+      
+      INTEGER(isp), DIMENSION(:), OPTIONAL, INTENT(IN)  ::  put   !< 
+      INTEGER(isp), DIMENSION(:), OPTIONAL, INTENT(OUT) ::  get   !< 
+      
+      IF  ( present(state_size) ) THEN
+      
+         state_size = 5 * lenran
+         
+      ELSE IF  ( present(put) ) THEN
+      
+         IF  ( lenran == 0 ) RETURN
+         
+         ranseeds = reshape( put,shape(ranseeds) )
+         
+         WHERE (ranseeds(:,1:3) < 0) ranseeds(: ,1:3) = not(ranseeds(: ,1:3))
+         !- Enforce nonnegativity and nonzero conditions on any user-supplied seeds.
+         
+         WHERE (ranseeds(:,4:5) == 0) ranseeds(:,4:5) = 1
+         
+         iran0 = ranseeds(1,1)
+         jran0 = ranseeds(1,2)
+         kran0 = ranseeds(1,3)
+         mran0 = ranseeds(1,4)
+         nran0 = ranseeds(1,5)
+         
+      ELSE IF  ( present(get) ) THEN
+      
+         IF  (lenran == 0) RETURN
+         
+         ranseeds(1,1:5) = (/ iran0,jran0,kran0,mran0,nran0 /)
+         get = reshape( ranseeds, shape(get) )
+         
+      ELSE IF  ( present(random_sequence) ) THEN
+      
+         CALL ran_deallocate
+         seq = random_sequence
+         
+      END IF 
+      
+   END SUBROUTINE random_seed_parallel
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> DES-like hashing of two 32-bit integers, using shifts, 
+!> xor's, and adds to make the internal nonlinear function.
+!------------------------------------------------------------------------------!
+   SUBROUTINE ran_hash_v( il, ir )
+   
+      IMPLICIT NONE
+      
+      INTEGER(isp), DIMENSION(:), INTENT(INOUT) ::  il   !< 
+      INTEGER(isp), DIMENSION(:), INTENT(INOUT) ::  ir   !< 
+      
+      INTEGER(isp), DIMENSION(size(il)) ::  is   !< 
+      
+      INTEGER(isp) :: j   !< 
+      
+      DO j=1,4
+      
+         is = ir
+         ir = ieor( ir, ishft(ir,5) ) + 1422217823
+         ir = ieor( ir, ishft(ir,-16) ) + 1842055030
+         ir = ieor( ir, ishft(ir,9) ) + 80567781
+         ir = ieor( il, ir )
+         il = is
+      END DO
+      
+   END SUBROUTINE ran_hash_v
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> User interface to process error-messages 
+!> produced by the random_number_parallel module
+!------------------------------------------------------------------------------!
+   SUBROUTINE ran_error(string)
+   
+      CHARACTER(LEN=*), INTENT(IN) ::  string   !< 
+      
+      write (*,*) 'Error in module random_number_parallel: ',string
+      
+      STOP 'Program terminated by ran_error'
+      
+   END SUBROUTINE ran_error
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Reallocates the generators state space "ranseeds" to vectors of size length. 
+!------------------------------------------------------------------------------!
+   FUNCTION reallocate_iv( p, n )
+   
+      INTEGER(isp), DIMENSION(:), POINTER ::  p               !< 
+      INTEGER(isp), DIMENSION(:), POINTER ::  reallocate_iv   !< 
+      
+      INTEGER(isp), INTENT(IN) ::  n   !< 
+      
+      INTEGER(isp) ::  nold   !< 
+      INTEGER(isp) ::  ierr   !< 
+      
+      ALLOCATE(reallocate_iv(n),stat=ierr)
+      
+      IF (ierr /= 0) CALL                                                      &
+         ran_error('reallocate_iv: problem in attempt to allocate memory')
+         
+      IF (.not. associated(p)) RETURN
+      
+      nold = size(p)
+      
+      reallocate_iv(1:min(nold,n)) = p(1:min(nold,n))
+      
+      DEALLOCATE(p)
+      
+   END FUNCTION reallocate_iv
+   
+   FUNCTION reallocate_im( p, n, m )
+   
+      INTEGER(isp), DIMENSION(:,:), POINTER ::  p               !< 
+      INTEGER(isp), DIMENSION(:,:), POINTER ::  reallocate_im   !< 
+      
+      INTEGER(isp), INTENT(IN) ::  m   !< 
+      INTEGER(isp), INTENT(IN) ::  n   !< 
+      
+      INTEGER(isp) ::  mold   !< 
+      INTEGER(isp) ::  nold   !< 
+      INTEGER(isp) ::  ierr   !< 
+      
+      ALLOCATE(reallocate_im(n,m),stat=ierr)
+      
+      IF (ierr /= 0) CALL                                                      &
+         ran_error('reallocate_im: problem in attempt to allocate memory')
+         
+      IF (.not. associated(p)) RETURN
+      
+      nold = size(p,1)
+      mold = size(p,2)
+      
+      reallocate_im(1:min(nold,n),1:min(mold,m)) =                             &
+         p(1:min(nold,n),1:min(mold,m))
+         
+      DEALLOCATE(p)
+      
+   END FUNCTION reallocate_im
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Reallocates the generators state space "ranseeds" to vectors of size length. 
+!------------------------------------------------------------------------------!
+   FUNCTION arth_i(first,increment,n)
+   
+      INTEGER(isp), INTENT(IN) ::  first       !< 
+      INTEGER(isp), INTENT(IN) ::  increment   !< 
+      INTEGER(isp), INTENT(IN) ::  n           !< 
+      
+      INTEGER(isp), DIMENSION(n) ::  arth_i    !< 
+      
+      INTEGER(isp) ::  k      !< 
+      INTEGER(isp) ::  k2     !< 
+      INTEGER(isp) ::  temp   !< 
+      
+      INTEGER(isp), PARAMETER ::  npar_arth=16   !< 
+      INTEGER(isp), PARAMETER ::  npar2_arth=8   !< 
+      
+      IF (n > 0) arth_i(1) = first
+      
+      IF (n <= npar_arth) THEN
+      
+         DO k=2,n
+            arth_i(k) = arth_i(k-1)+increment
+         END DO
+         
+      ELSE
+      
+         DO k=2,npar2_arth
+            arth_i(k) = arth_i(k-1) + increment
+         END DO
+         
+         temp = increment * npar2_arth
+         k = npar2_arth
+         
+         DO
+            IF (k >= n) EXIT
+            k2 = k + k
+            arth_i(k+1:min(k2,n)) = temp + arth_i(1:min(k,n-k))
+            temp = temp + temp
+            k = k2
+         END DO
+         
+      END IF
+      
+   END FUNCTION arth_i
+
+END MODULE random_generator_parallel
Index: lm/trunk/SOURCE/singleton.f90
===================================================================
--- /palm/trunk/SOURCE/singleton.f90	(revision 1849)
+++ 	(revision )
@@ -1,1187 +1,0 @@
-!> @file singleton.f90
-!-----------------------------------------------------------------------------
-! Current revisions:
-! -----------------
-! 
-! 
-! Former revisions:
-! -----------------
-! $Id$
-!
-! 1682 2015-10-07 23:56:08Z knoop
-! Code annotations made doxygen readable
-!
-! 1320 2014-03-20 08:40:49Z raasch
-! kind-parameters added to all INTEGER and REAL declaration statements,
-! kinds are defined in new module kinds,
-! revision history before 2012 removed,
-!
-! Revision 1.1  2002/05/02 18:56:59  raasch
-! Initial revision
-!
-!
-! Description:
-! ------------
-!> Multivariate Fast Fourier Transform
-!>
-!> Fortran 90 Implementation of Singleton's mixed-radix algorithm,
-!> RC Singleton, Stanford Research Institute, Sept. 1968.
-!>
-!> Adapted from fftn.c, translated from Fortran 66 to C by Mark Olesen and
-!> John Beale.
-!>
-!> Fourier transforms can be computed either in place, using assumed size
-!> arguments, or by generic function, using assumed shape arguments.
-!>
-!>
-!> Public:
-!>
-!>   fftkind                              kind parameter of complex arguments
-!>                                        and function results.
-!>
-!>   fft(array, dim, inv, stat)           generic transform function
-!>    COMPLEX(fftkind), DIMENSION(:,...,:), INTENT(IN)           :: array
-!>    INTEGER,          DIMENSION(:),       INTENT(IN),  OPTIONAL:: dim
-!>    LOGICAL,                              INTENT(IN),  OPTIONAL:: inv
-!>    INTEGER,                              INTENT(OUT), OPTIONAL:: stat
-!>
-!>   fftn(array, shape, dim, inv, stat)   in place transform subroutine
-!>    COMPLEX(fftkind), DIMENSION(*), INTENT(INOUT)        :: array
-!>    INTEGER,          DIMENSION(:), INTENT(IN)           :: shape
-!>    INTEGER,          DIMENSION(:), INTENT(IN),  OPTIONAL:: dim
-!>    LOGICAL,                        INTENT(IN),  OPTIONAL:: inv
-!>    INTEGER,                        INTENT(OUT), OPTIONAL:: stat
-!>
-!>
-!> Formal Parameters:
-!>
-!>   array    The complex array to be transformed. array can be of arbitrary
-!>            rank (i.e. up to seven).
-!>
-!>   shape    With subroutine fftn, the shape of the array to be transformed
-!>            has to be passed separately, since fftradix - the internal trans-
-!>            formation routine - will treat array always as one dimensional.
-!>            The product of elements in shape must be the number of
-!>            elements in array.
-!>            Although passing array with assumed shape would have been nicer,
-!>            I prefered assumed size in order to prevent the compiler from
-!>            using a copy-in-copy-out mechanism. That would generally be
-!>            necessary with fftn passing array to fftradix and with fftn
-!>            being prepared for accepting non consecutive array sections.
-!>            Using assumed size, it's up to the user to pass an array argu-
-!>            ment, that can be addressed as continous one dimensional array
-!>            without copying. Otherwise, transformation will not really be
-!>            performed in place.
-!>            On the other hand, since the rank of array and the size of
-!>            shape needn't match, fftn is appropriate for handling more than
-!>            seven dimensions.
-!>            As far as function fft is concerned all this doesn't matter,
-!>            because the argument will be copied anyway. Thus no extra
-!>            shape argument is needed for fft.
-!>
-!> Optional Parameters:
-!>
-!>   dim      One dimensional integer array, containing the dimensions to be
-!>            transformed. Default is (/1,...,N/) with N being the rank of
-!>            array, i.e. complete transform. dim can restrict transformation
-!>            to a subset of available dimensions. Its size must not exceed the
-!>            rank of array or the size of shape respectivly.
-!>
-!>   inv      If .true., inverse transformation will be performed. Default is
-!>            .false., i.e. forward transformation.
-!>
-!>   stat     If present, a system dependent nonzero status value will be
-!>            returned in stat, if allocation of temporary storage failed.
-!>
-!>
-!> Scaling:
-!>
-!>   Transformation results will always be scaled by the square root of the
-!>   product of sizes of each dimension in dim. (See examples below)
-!>
-!>
-!> Examples:
-!>
-!>   Let A be a L*M*N three dimensional complex array. Then
-!>
-!>     result = fft(A)
-!>
-!>   will produce a three dimensional transform, scaled by sqrt(L*M*N), while
-!>
-!>     call fftn(A, SHAPE(A))
-!>
-!>   will do the same in place.
-!>
-!>     result = fft(A, dim=(/1,3/))
-!>
-!>   will transform with respect to the first and the third dimension, scaled
-!>   by sqrt(L*N).
-!>
-!>     result = fft(fft(A), inv=.true.)
-!>
-!>   should (approximately) reproduce A.
-!>   With B having the same shape as A
-!>
-!>     result = fft(fft(A) * CONJG(fft(B)), inv=.true.)
-!>
-!>   will correlate A and B.
-!>
-!>
-!> Remarks:
-!>
-!>   Following changes have been introduced with respect to fftn.c:
-!>   - complex arguments and results are of type complex, rather than
-!>     real an imaginary part separately.
-!>   - increment parameter (magnitude of isign) has been dropped,
-!>     inc is always one, direction of transform is given by inv.     
-!>   - maxf and maxp have been dropped. The amount of temporary storage
-!>     needed is determined by the fftradix routine. Both fftn and fft
-!>     can handle any size of array. (Maybe they take a lot of time and
-!>     memory, but they will do it)
-!>
-!>   Redesigning fftradix in a way, that it handles assumed shape arrays
-!>   would have been desirable. However, I found it rather hard to do this
-!>   in an efficient way. Problems were:
-!>   - to prevent stride multiplications when indexing arrays. At least our
-!>     compiler was not clever enough to discover that in fact additions
-!>     would do the job as well. On the other hand, I haven't been clever
-!>     enough to find an implementation using array operations.
-!>   - fftradix is rather large and different versions would be necessaray
-!>     for each possible rank of array.
-!>   Consequently, in place transformation still needs the argument stored
-!>   in a consecutive bunch of memory and can't be performed on array
-!>   sections like A(100:199:-3, 50:1020). Calling fftn with such sections
-!>   will most probably imply copy-in-copy-out. However, the function fft
-!>   works with everything it gets and should be convenient to use.
-!>
-!> Michael Steffens, 09.12.96, <Michael.Steffens@mbox.muk.uni-hannover.de>
-!> Restructured fftradix for better optimization. M. Steffens, 4 June 1997
-!-----------------------------------------------------------------------------
- MODULE singleton
- 
-
-    USE kinds
-
-    IMPLICIT NONE
-
-    PRIVATE
-    PUBLIC:: fft, fftn
-
-    REAL(wp), PARAMETER:: sin60 = 0.86602540378443865_wp
-    REAL(wp), PARAMETER:: cos72 = 0.30901699437494742_wp
-    REAL(wp), PARAMETER:: sin72 = 0.95105651629515357_wp
-    REAL(wp), PARAMETER:: pi    = 3.14159265358979323_wp
-
-    INTERFACE fft
-       MODULE PROCEDURE fft1d
-       MODULE PROCEDURE fft2d
-       MODULE PROCEDURE fft3d
-       MODULE PROCEDURE fft4d
-       MODULE PROCEDURE fft5d
-       MODULE PROCEDURE fft6d
-       MODULE PROCEDURE fft7d
-    END INTERFACE
-
-
- CONTAINS
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> @todo Missing function description.
-!------------------------------------------------------------------------------!
- FUNCTION fft1d(array, dim, inv, stat) RESULT(ft)
-!
-!-- Formal parameters
-    COMPLEX(wp),  DIMENSION(:), INTENT(IN)           :: array
-    INTEGER(iwp), DIMENSION(:), INTENT(IN),  OPTIONAL:: dim
-    INTEGER(iwp),               INTENT(OUT), OPTIONAL:: stat
-    LOGICAL,                    INTENT(IN),  OPTIONAL:: inv
-!
-!-- Function result
-    COMPLEX(wp), DIMENSION(SIZE(array, 1)):: ft
-
-    INTEGER(iwp)::  ishape(1)
-
-!
-!-- Intrinsics used
-    INTRINSIC SIZE, SHAPE
-
-    ft = array
-    ishape = SHAPE( array )
-    CALL fftn(ft, ishape, inv = inv,  stat = stat)
-
- END FUNCTION fft1d
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> @todo Missing function description.
-!------------------------------------------------------------------------------!
- FUNCTION fft2d(array, dim, inv, stat) RESULT(ft)
-!
-!-- Formal parameters
-    COMPLEX(wp),  DIMENSION(:,:), INTENT(IN)           :: array
-    INTEGER(iwp), DIMENSION(:),   INTENT(IN),  OPTIONAL:: dim
-    INTEGER(iwp),                 INTENT(OUT), OPTIONAL:: stat
-    LOGICAL,                      INTENT(IN),  OPTIONAL:: inv
-!
-!-- Function result
-    COMPLEX(wp), DIMENSION(SIZE(array, 1), SIZE(array, 2)):: ft
-
-    INTEGER(iwp) ::  ishape(2)
-!
-!-- Intrinsics used
-    INTRINSIC SIZE, SHAPE
-
-    ft = array
-    ishape = SHAPE( array )
-    CALL fftn(ft, ishape, dim, inv, stat)
-
- END FUNCTION fft2d
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> @todo Missing function description.
-!------------------------------------------------------------------------------!
- FUNCTION fft3d(array, dim, inv, stat) RESULT(ft)
-!
-!-- Formal parameters
-    COMPLEX(wp),  DIMENSION(:,:,:), INTENT(IN)           :: array
-    INTEGER(iwp), DIMENSION(:),     INTENT(IN),  OPTIONAL:: dim
-    INTEGER(iwp),                   INTENT(OUT), OPTIONAL:: stat
-    LOGICAL,                        INTENT(IN),  OPTIONAL:: inv
-!
-!-- Function result
-    COMPLEX(wp), &
-         DIMENSION(SIZE(array, 1), SIZE(array, 2), SIZE(array, 3)):: ft
-
-    INTEGER(iwp) ::  ishape(3)
-
-!
-!-- Intrinsics used
-    INTRINSIC SIZE, SHAPE
-
-    ft = array
-    ishape = SHAPE( array)
-    CALL fftn(ft, ishape, dim, inv, stat)
-
- END FUNCTION fft3d
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> @todo Missing function description.
-!------------------------------------------------------------------------------!
- FUNCTION fft4d(array, dim, inv, stat) RESULT(ft)
-!
-!-- Formal parameters
-    COMPLEX(wp),  DIMENSION(:,:,:,:), INTENT(IN)           :: array
-    INTEGER(iwp), DIMENSION(:),       INTENT(IN),  OPTIONAL:: dim
-    INTEGER(iwp),                     INTENT(OUT), OPTIONAL:: stat
-    LOGICAL,                          INTENT(IN),  OPTIONAL:: inv
-!
-!-- Function result
-    COMPLEX(wp), DIMENSION( &
-         SIZE(array, 1), SIZE(array, 2), SIZE(array, 3), SIZE(array, 4)):: ft
-
-    INTEGER(iwp) ::  ishape(4)
-!
-!-- Intrinsics used
-    INTRINSIC SIZE, SHAPE
-
-    ft = array
-    ishape = SHAPE( array )
-    CALL fftn(ft, ishape, dim, inv, stat)
-
- END FUNCTION fft4d
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> @todo Missing function description.
-!------------------------------------------------------------------------------!
- FUNCTION fft5d(array, dim, inv, stat) RESULT(ft)
-!
-!-- Formal parameters
-    COMPLEX(wp),  DIMENSION(:,:,:,:,:), INTENT(IN)           :: array
-    INTEGER(iwp), DIMENSION(:),         INTENT(IN),  OPTIONAL:: dim
-    INTEGER(iwp),                       INTENT(OUT), OPTIONAL:: stat
-    LOGICAL,                            INTENT(IN),  OPTIONAL:: inv
-!
-!-- Function result
-    COMPLEX(wp), DIMENSION( &
-         SIZE(array, 1), SIZE(array, 2), SIZE(array, 3), SIZE(array, 4), &
-         SIZE(array, 5)):: ft
-
-    INTEGER(iwp) ::  ishape(5)
-
-!
-!-- Intrinsics used
-    INTRINSIC SIZE, SHAPE
-
-    ft = array
-    ishape = SHAPE( array )
-    CALL fftn(ft, ishape, dim, inv, stat)
-
- END FUNCTION fft5d
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> @todo Missing function description.
-!------------------------------------------------------------------------------!
- FUNCTION fft6d(array, dim, inv, stat) RESULT(ft)
-!
-!-- Formal parameters
-    COMPLEX(wp),  DIMENSION(:,:,:,:,:,:), INTENT(IN)           :: array
-    INTEGER(iwp), DIMENSION(:),           INTENT(IN),  OPTIONAL:: dim
-    INTEGER(iwp),                         INTENT(OUT), OPTIONAL:: stat
-    LOGICAL,                              INTENT(IN),  OPTIONAL:: inv
-!
-!-- Function result
-    COMPLEX(wp), DIMENSION( &
-         SIZE(array, 1), SIZE(array, 2), SIZE(array, 3), SIZE(array, 4), &
-         SIZE(array, 5), SIZE(array, 6)):: ft
-
-    INTEGER(iwp) ::  ishape(6)
-
-!
-!-- Intrinsics used
-    INTRINSIC SIZE, SHAPE
-
-    ft = array
-    ishape = SHAPE( array )
-    CALL fftn(ft, ishape, dim, inv, stat)
-
- END FUNCTION fft6d
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> @todo Missing function description.
-!------------------------------------------------------------------------------!
- FUNCTION fft7d(array, dim, inv, stat) RESULT(ft)
-!
-!-- Formal parameters
-    COMPLEX(wp), DIMENSION(:,:,:,:,:,:,:), INTENT(IN)           :: array
-    INTEGER(iwp),          DIMENSION(:),   INTENT(IN),  OPTIONAL:: dim
-    INTEGER(iwp),                          INTENT(OUT), OPTIONAL:: stat
-    LOGICAL,                               INTENT(IN),  OPTIONAL:: inv
-!
-!-- Function result
-    COMPLEX(wp), DIMENSION( &
-         SIZE(array, 1), SIZE(array, 2), SIZE(array, 3), SIZE(array, 4), &
-         SIZE(array, 5), SIZE(array, 6), SIZE(array, 7)):: ft
-
-    INTEGER(iwp) ::  ishape(7)
-
-!
-!-- Intrinsics used
-    INTRINSIC SIZE, SHAPE
-
-    ft = array
-    ishape = SHAPE( array )
-    CALL fftn(ft, ishape, dim, inv, stat)
-
- END FUNCTION fft7d
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> @todo Missing subroutine description.
-!------------------------------------------------------------------------------!
- SUBROUTINE fftn(array, shape, dim, inv, stat)
-!
-!-- Formal parameters
-    COMPLEX(wp),  DIMENSION(*), INTENT(INOUT)        :: array
-    INTEGER(iwp), DIMENSION(:), INTENT(IN)           :: shape
-    INTEGER(iwp), DIMENSION(:), INTENT(IN),  OPTIONAL:: dim
-    INTEGER(iwp),               INTENT(OUT), OPTIONAL:: stat
-    LOGICAL,                    INTENT(IN),  OPTIONAL:: inv
-!
-!-- Local arrays
-    INTEGER(iwp), DIMENSION(SIZE(shape)):: d
-!
-!-- Local scalars
-    LOGICAL      :: inverse
-    INTEGER(iwp) :: i, ndim, ntotal
-    REAL(wp):: scale
-!
-!-- Intrinsics used
-    INTRINSIC PRESENT, MIN, PRODUCT, SIZE, SQRT
-
-!
-!-- Optional parameter settings
-    IF (PRESENT(inv)) THEN
-       inverse = inv
-    ELSE
-       inverse = .FALSE.
-    END IF
-    IF (PRESENT(dim)) THEN
-       ndim = MIN(SIZE(dim), SIZE(d))
-       d(1:ndim) = DIM(1:ndim)
-    ELSE
-       ndim = SIZE(d)
-       d = (/(i, i = 1, SIZE(d))/)
-    END IF
-
-    ntotal = PRODUCT(shape)
-    scale = SQRT(1.0_wp / PRODUCT(shape(d(1:ndim))))
-    DO i = 1, ntotal
-       array(i) = CMPLX(REAL(array(i)) * scale, AIMAG(array(i)) * scale, &
-            KIND=wp)
-    END DO
-
-    DO i = 1, ndim
-       CALL fftradix(array, ntotal, shape(d(i)), PRODUCT(shape(1:d(i))), &
-            inverse, stat)
-       IF (PRESENT(stat)) THEN
-          IF (stat /=0) RETURN
-       END IF
-    END DO
-
- END SUBROUTINE fftn
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> @todo Missing subroutine description.
-!------------------------------------------------------------------------------!
- SUBROUTINE fftradix(array, ntotal, npass, nspan, inv, stat)
-!
-!-- Formal parameters
-    COMPLEX(wp),  DIMENSION(*), INTENT(INOUT)        :: array
-    INTEGER(iwp),               INTENT(IN)           :: ntotal, npass, nspan
-    INTEGER(iwp),               INTENT(OUT), OPTIONAL:: stat
-    LOGICAL,                    INTENT(IN)           :: inv
-!
-!-- Local arrays
-    COMPLEX(wp),  DIMENSION(:), ALLOCATABLE  :: ctmp
-    INTEGER(iwp), DIMENSION(BIT_SIZE(0))     :: factor
-    INTEGER(iwp), DIMENSION(:), ALLOCATABLE  :: perm
-    REAL(wp),     DIMENSION(:), ALLOCATABLE  :: sine, cosine
-!
-!-- Local scalars
-    INTEGER(iwp)         :: maxfactor, nfactor, nsquare, nperm
-!
-!-- Intrinsics used
-    INTRINSIC MAXVAL, MOD, PRESENT, ISHFT, BIT_SIZE, SIN, COS, &
-         CMPLX, REAL, AIMAG
-
-    IF (npass <= 1) RETURN
-
-    CALL factorize(npass, factor, nfactor, nsquare)
-
-    maxfactor = MAXVAL(factor(:nfactor))
-    IF (nfactor - ISHFT(nsquare, 1) > 0) THEN
-       nperm = MAX(nfactor + 1, PRODUCT(factor(nsquare+1: nfactor-nsquare)) - 1)
-    ELSE
-       nperm = nfactor + 1
-    END IF
-
-    IF (PRESENT(stat)) THEN
-       ALLOCATE(ctmp(maxfactor), sine(maxfactor), cosine(maxfactor), STAT=stat)
-       IF (stat /= 0) RETURN
-       CALL transform(array, ntotal, npass, nspan, &
-            factor, nfactor, ctmp, sine, cosine, inv)
-       DEALLOCATE(sine, cosine, STAT=stat)
-       IF (stat /= 0) RETURN
-       ALLOCATE(perm(nperm), STAT=stat)
-       IF (stat /= 0) RETURN
-       CALL permute(array, ntotal, npass, nspan, &
-            factor, nfactor, nsquare, maxfactor, &
-            ctmp, perm)
-       DEALLOCATE(perm, ctmp, STAT=stat)
-       IF (stat /= 0) RETURN
-    ELSE
-       ALLOCATE(ctmp(maxfactor), sine(maxfactor), cosine(maxfactor))
-       CALL transform(array, ntotal, npass, nspan, &
-            factor, nfactor, ctmp, sine, cosine, inv)
-       DEALLOCATE(sine, cosine)
-       ALLOCATE(perm(nperm))
-       CALL permute(array, ntotal, npass, nspan, &
-            factor, nfactor, nsquare, maxfactor, &
-            ctmp, perm)
-       DEALLOCATE(perm, ctmp)
-    END IF
-
-
-  CONTAINS
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> @todo Missing subroutine description.
-!------------------------------------------------------------------------------!
-    SUBROUTINE factorize(npass, factor, nfactor, nsquare)
-!
-!--   Formal parameters
-      INTEGER(iwp),               INTENT(IN) :: npass
-      INTEGER(iwp), DIMENSION(*), INTENT(OUT):: factor
-      INTEGER(iwp),               INTENT(OUT):: nfactor, nsquare
-!
-!--   Local scalars
-      INTEGER(iwp):: j, jj, k
-
-      nfactor = 0
-      k = npass
-      DO WHILE (MOD(k, 16) == 0) 
-         nfactor = nfactor + 1
-         factor(nfactor) = 4
-         k = k / 16
-      END DO
-      j = 3
-      jj = 9
-      DO
-         DO WHILE (MOD(k, jj) == 0)
-            nfactor = nfactor + 1
-            factor(nfactor) = j
-            k = k / jj
-         END DO
-         j = j + 2
-         jj = j * j
-         IF (jj > k) EXIT
-      END DO
-      IF (k <= 4) THEN
-         nsquare = nfactor
-         factor(nfactor + 1) = k
-         IF (k /= 1) nfactor = nfactor + 1
-      ELSE 
-         IF (k - ISHFT(k / 4, 2) == 0) THEN
-            nfactor = nfactor + 1
-            factor(nfactor) = 2
-            k = k / 4
-         END IF
-         nsquare = nfactor
-         j = 2
-         DO
-            IF (MOD(k, j) == 0) THEN
-               nfactor = nfactor + 1
-               factor(nfactor) = j
-               k = k / j
-            END IF
-            j = ISHFT((j + 1) / 2, 1) + 1
-            IF (j > k) EXIT
-         END DO
-      END IF
-      IF (nsquare > 0) THEN
-         j = nsquare
-         DO
-            nfactor = nfactor + 1
-            factor(nfactor) = factor(j)
-            j = j - 1
-            IF (j==0) EXIT
-         END DO
-      END IF
-
-    END SUBROUTINE factorize
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> @todo Missing subroutine description.
-!------------------------------------------------------------------------------!
-    SUBROUTINE transform(array, ntotal, npass, nspan, &
-         factor, nfactor, ctmp, sine, cosine, inv) !-- compute fourier transform
-!
-!--   Formal parameters
-      COMPLEX(wp),  DIMENSION(*), INTENT(IN OUT):: array
-      COMPLEX(wp),  DIMENSION(*), INTENT(OUT)   :: ctmp
-      INTEGER(iwp),               INTENT(IN)    :: ntotal, npass, nspan
-      INTEGER(iwp), DIMENSION(*), INTENT(IN)    :: factor
-      INTEGER(iwp),               INTENT(IN)    :: nfactor
-      LOGICAL,                    INTENT(IN)    :: inv
-      REAL(wp),     DIMENSION(*), INTENT(OUT)   :: sine, cosine
-!
-!--   Local scalars
-      INTEGER(iwp):: ii, ispan
-      INTEGER(iwp):: j, jc, jf, jj
-      INTEGER(iwp):: k, kk, kspan, k1, k2, k3, k4
-      INTEGER(iwp):: nn, nt
-      REAL(wp)    :: s60, c72, s72, pi2, radf
-      REAL(wp)    :: c1, s1, c2, s2, c3, s3, cd, sd, ak
-      COMPLEX(wp) :: cc, cj, ck, cjp, cjm, ckp, ckm
-
-      c72 = cos72
-      IF (inv) THEN
-         s72 = sin72
-         s60 = sin60
-         pi2 = pi
-      ELSE
-         s72 = -sin72
-         s60 = -sin60
-         pi2 = -pi
-      END IF
-
-      nt = ntotal
-      nn = nt - 1
-      kspan = nspan
-      jc = nspan / npass
-      radf = pi2 * jc
-      pi2 = pi2 * 2.0_wp !-- use 2 PI from here on
-
-      ii = 0
-      jf = 0
-      DO
-         sd = radf / kspan
-         cd = SIN(sd)
-         cd = 2.0_wp * cd * cd
-         sd = SIN(sd + sd)
-         kk = 1
-         ii = ii + 1
-
-         SELECT CASE (factor(ii))
-         CASE (2)
-!
-!--         Transform for factor of 2 (including rotation factor)
-            kspan = kspan / 2
-            k1 = kspan + 2
-            DO
-               DO
-                  k2 = kk + kspan
-                  ck = array(k2)
-                  array(k2) = array(kk)-ck
-                  array(kk) = array(kk) + ck
-                  kk = k2 + kspan
-                  IF (kk > nn) EXIT
-               END DO
-               kk = kk - nn
-               IF (kk > jc) EXIT
-            END DO
-            IF (kk > kspan) RETURN
-            DO
-               c1 = 1.0_wp - cd
-               s1 = sd
-               DO
-                  DO
-                     DO
-                        k2 = kk + kspan
-                        ck = array(kk) - array(k2)
-                        array(kk) = array(kk) + array(k2)
-                        array(k2) = ck * CMPLX(c1, s1, KIND=wp)
-                        kk = k2 + kspan
-                        IF (kk >= nt) EXIT
-                     END DO
-                     k2 = kk - nt
-                     c1 = -c1
-                     kk = k1 - k2
-                     IF (kk <= k2) EXIT
-                  END DO
-                  ak = c1 - (cd * c1 + sd * s1)
-                  s1 = sd * c1 - cd * s1 + s1
-                  c1 = 2.0_wp - (ak * ak + s1 * s1)
-                  s1 = s1 * c1
-                  c1 = c1 * ak
-                  kk = kk + jc
-                  IF (kk >= k2) EXIT
-               END DO
-               k1 = k1 + 1 + 1
-               kk = (k1 - kspan) / 2 + jc
-               IF (kk > jc + jc) EXIT
-            END DO
-
-         CASE (4) !-- transform for factor of 4
-            ispan = kspan
-            kspan = kspan / 4
-
-            DO
-               c1 = 1.0_wp
-               s1 = 0.0_wp
-               DO
-                  DO
-                     k1 = kk + kspan
-                     k2 = k1 + kspan
-                     k3 = k2 + kspan
-                     ckp = array(kk) + array(k2)
-                     ckm = array(kk) - array(k2)
-                     cjp = array(k1) + array(k3)
-                     cjm = array(k1) - array(k3)
-                     array(kk) = ckp + cjp
-                     cjp = ckp - cjp
-                     IF (inv) THEN
-                        ckp = ckm + CMPLX(-AIMAG(cjm), REAL(cjm), KIND=wp)
-                        ckm = ckm + CMPLX(AIMAG(cjm), -REAL(cjm), KIND=wp)
-                     ELSE
-                        ckp = ckm + CMPLX(AIMAG(cjm), -REAL(cjm), KIND=wp)
-                        ckm = ckm + CMPLX(-AIMAG(cjm), REAL(cjm), KIND=wp)
-                     END IF
-!
-!--                  Avoid useless multiplies
-                     IF (s1 == 0.0_wp) THEN
-                        array(k1) = ckp
-                        array(k2) = cjp
-                        array(k3) = ckm
-                     ELSE
-                        array(k1) = ckp * CMPLX(c1, s1, KIND=wp)
-                        array(k2) = cjp * CMPLX(c2, s2, KIND=wp)
-                        array(k3) = ckm * CMPLX(c3, s3, KIND=wp)
-                     END IF
-                     kk = k3 + kspan
-                     IF (kk > nt) EXIT
-                  END DO
-
-                  c2 = c1 - (cd * c1 + sd * s1)
-                  s1 = sd * c1 - cd * s1 + s1
-                  c1 = 2.0_wp - (c2 * c2 + s1 * s1)
-                  s1 = s1 * c1
-                  c1 = c1 * c2
-!
-!--               Values of c2, c3, s2, s3 that will get used next time
-                  c2 = c1 * c1 - s1 * s1
-                  s2 = 2.0_wp * c1 * s1
-                  c3 = c2 * c1 - s2 * s1
-                  s3 = c2 * s1 + s2 * c1
-                  kk = kk - nt + jc
-                  IF (kk > kspan) EXIT
-               END DO
-               kk = kk - kspan + 1
-               IF (kk > jc) EXIT
-            END DO
-            IF (kspan == jc) RETURN
-
-         CASE default
-!
-!--         Transform for odd factors
-            k = factor(ii)
-            ispan = kspan
-            kspan = kspan / k
-
-            SELECT CASE (k)
-            CASE (3) !-- transform for factor of 3 (optional code)
-               DO
-                  DO
-                     k1 = kk + kspan
-                     k2 = k1 + kspan
-                     ck = array(kk)
-                     cj = array(k1) + array(k2)
-                     array(kk) = ck + cj
-                     ck = ck - CMPLX( &
-                          0.5_wp * REAL (cj), &
-                          0.5_wp * AIMAG(cj), &
-                          KIND=wp)
-                     cj = CMPLX( &
-                          (REAL (array(k1)) - REAL (array(k2))) * s60, &
-                          (AIMAG(array(k1)) - AIMAG(array(k2))) * s60, &
-                          KIND=wp)
-                     array(k1) = ck + CMPLX(-AIMAG(cj), REAL(cj), KIND=wp)
-                     array(k2) = ck + CMPLX(AIMAG(cj), -REAL(cj), KIND=wp)
-                     kk = k2 + kspan
-                     IF (kk >= nn) EXIT
-                  END DO
-                  kk = kk - nn
-                  IF (kk > kspan) EXIT
-               END DO
-
-            CASE (5) !-- transform for factor of 5 (optional code)
-               c2 = c72 * c72 - s72 * s72
-               s2 = 2.0_wp * c72 * s72
-               DO
-                  DO
-                     k1 = kk + kspan
-                     k2 = k1 + kspan
-                     k3 = k2 + kspan
-                     k4 = k3 + kspan
-                     ckp = array(k1) + array(k4)
-                     ckm = array(k1) - array(k4)
-                     cjp = array(k2) + array(k3)
-                     cjm = array(k2) - array(k3)
-                     cc = array(kk)
-                     array(kk) = cc + ckp + cjp
-                     ck = CMPLX(REAL(ckp) * c72, AIMAG(ckp) * c72, &
-                          KIND=wp) + &
-                          CMPLX(REAL(cjp) * c2,  AIMAG(cjp) * c2,  &
-                          KIND=wp) + cc
-                     cj = CMPLX(REAL(ckm) * s72, AIMAG(ckm) * s72, &
-                          KIND=wp) + &
-                          CMPLX(REAL(cjm) * s2,  AIMAG(cjm) * s2,  &
-                          KIND=wp)
-                     array(k1) = ck + CMPLX(-AIMAG(cj), REAL(cj), KIND=wp)
-                     array(k4) = ck + CMPLX(AIMAG(cj), -REAL(cj), KIND=wp)
-                     ck = CMPLX(REAL(ckp) * c2,  AIMAG(ckp) * c2,  &
-                          KIND=wp) + &
-                          CMPLX(REAL(cjp) * c72, AIMAG(cjp) * c72, &
-                          KIND=wp) + cc
-                     cj = CMPLX(REAL(ckm) * s2,  AIMAG(ckm) * s2,  &
-                          KIND=wp) - &
-                          CMPLX(REAL(cjm) * s72, AIMAG(cjm) * s72, &
-                          KIND=wp)
-                     array(k2) = ck + CMPLX(-AIMAG(cj), REAL(cj), KIND=wp)
-                     array(k3) = ck + CMPLX(AIMAG(cj), -REAL(cj), KIND=wp)
-                     kk = k4 + kspan
-                     IF (kk >= nn) EXIT
-                  END DO
-                  kk = kk - nn
-                  IF (kk > kspan) EXIT
-               END DO
-
-            CASE default
-               IF (k /= jf) THEN
-                  jf = k
-                  s1 = pi2 / k
-                  c1 = COS(s1)
-                  s1 = SIN(s1)
-                  cosine (jf) = 1.0_wp
-                  sine (jf) = 0.0_wp
-                  j = 1
-                  DO
-                     cosine (j) = cosine (k) * c1 + sine (k) * s1
-                     sine (j) = cosine (k) * s1 - sine (k) * c1
-                     k = k-1
-                     cosine (k) = cosine (j)
-                     sine (k) = -sine (j)
-                     j = j + 1
-                     IF (j >= k) EXIT
-                  END DO
-               END IF
-               DO
-                  DO
-                     k1 = kk
-                     k2 = kk + ispan
-                     cc = array(kk)
-                     ck = cc
-                     j = 1
-                     k1 = k1 + kspan
-                     DO
-                        k2 = k2 - kspan
-                        j = j + 1
-                        ctmp(j) = array(k1) + array(k2)
-                        ck = ck + ctmp(j)
-                        j = j + 1
-                        ctmp(j) = array(k1) - array(k2)
-                        k1 = k1 + kspan
-                        IF (k1 >= k2) EXIT
-                     END DO
-                     array(kk) = ck
-                     k1 = kk
-                     k2 = kk + ispan
-                     j = 1
-                     DO
-                        k1 = k1 + kspan
-                        k2 = k2 - kspan
-                        jj = j
-                        ck = cc
-                        cj = (0.0_wp, 0.0_wp)
-                        k = 1
-                        DO
-                           k = k + 1
-                           ck = ck + CMPLX( &
-                                REAL (ctmp(k)) * cosine(jj), &
-                                AIMAG(ctmp(k)) * cosine(jj), KIND=wp)
-                           k = k + 1
-                           cj = cj + CMPLX( &
-                                REAL (ctmp(k)) * sine(jj), &
-                                AIMAG(ctmp(k)) * sine(jj), KIND=wp)
-                           jj = jj + j
-                           IF (jj > jf) jj = jj - jf
-                           IF (k >= jf) EXIT
-                        END DO
-                        k = jf - j
-                        array(k1) = ck + CMPLX(-AIMAG(cj), REAL(cj), &
-                             KIND=wp)
-                        array(k2) = ck + CMPLX(AIMAG(cj), -REAL(cj), &
-                             KIND=wp)
-                        j = j + 1
-                        IF (j >= k) EXIT
-                     END DO
-                     kk = kk + ispan
-                     IF (kk > nn) EXIT
-                  END DO
-                  kk = kk - nn
-                  IF (kk > kspan) EXIT
-               END DO
-
-            END SELECT
-!
-!--         Multiply by rotation factor (except for factors of 2 and 4)
-            IF (ii == nfactor) RETURN
-            kk = jc + 1
-            DO
-               c2 = 1.0_wp - cd
-               s1 = sd
-               DO
-                  c1 = c2
-                  s2 = s1
-                  kk = kk + kspan
-                  DO
-                     DO
-                        array(kk) = CMPLX(c2, s2, KIND=wp) * array(kk)
-                        kk = kk + ispan
-                        IF (kk > nt) EXIT
-                     END DO
-                     ak = s1 * s2
-                     s2 = s1 * c2 + c1 * s2
-                     c2 = c1 * c2 - ak
-                     kk = kk - nt + kspan
-                     IF (kk > ispan) EXIT
-                  END DO
-                  c2 = c1 - (cd * c1 + sd * s1)
-                  s1 = s1 + sd * c1 - cd * s1
-                  c1 = 2.0_wp - (c2 * c2 + s1 * s1)
-                  s1 = s1 * c1
-                  c2 = c2 * c1
-                  kk = kk - ispan + jc
-                  IF (kk > kspan) EXIT
-               END DO
-               kk = kk - kspan + jc + 1
-               IF (kk > jc + jc) EXIT
-            END DO
-
-         END SELECT
-      END DO
-    END SUBROUTINE transform
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> @todo Missing subroutine description.
-!------------------------------------------------------------------------------!
-    SUBROUTINE permute(array, ntotal, npass, nspan, &
-         factor, nfactor, nsquare, maxfactor, &
-         ctmp, perm)
-!
-!--   Formal parameters
-      COMPLEX(wp),  DIMENSION(*), INTENT(IN OUT):: array
-      COMPLEX(wp),  DIMENSION(*), INTENT(OUT)   :: ctmp
-      INTEGER(iwp),               INTENT(IN)    :: ntotal, npass, nspan
-      INTEGER(iwp), DIMENSION(*), INTENT(IN OUT):: factor
-      INTEGER(iwp),               INTENT(IN)    :: nfactor, nsquare
-      INTEGER(iwp),               INTENT(IN)    :: maxfactor
-      INTEGER(iwp), DIMENSION(*), INTENT(OUT)   :: perm
-!
-!--   Local scalars
-      COMPLEX(wp) :: ck
-      INTEGER(iwp):: ii, ispan
-      INTEGER(iwp):: j, jc, jj
-      INTEGER(iwp):: k, kk, kspan, kt, k1, k2, k3
-      INTEGER(iwp):: nn, nt
-!
-!--   Permute the results to normal order---done in two stages
-!--   Permutation for square factors of n
-
-      nt = ntotal
-      nn = nt - 1
-      kt = nsquare
-      kspan = nspan
-      jc = nspan / npass
-
-      perm (1) = nspan
-      IF (kt > 0) THEN
-         k = kt + kt + 1
-         IF (nfactor < k) k = k - 1
-         j = 1
-         perm (k + 1) = jc
-         DO
-            perm (j + 1) = perm (j) / factor(j)
-            perm (k) = perm (k + 1) * factor(j)
-            j = j + 1
-            k = k - 1
-            IF (j >= k) EXIT
-         END DO
-         k3 = perm (k + 1)
-         kspan = perm (2)
-         kk = jc + 1
-         k2 = kspan + 1
-         j = 1
-
-         IF (npass /= ntotal) THEN
-            permute_multi: DO
-               DO
-                  DO
-                     k = kk + jc
-                     DO
-!
-!--                     Swap array(kk) <> array(k2)
-                        ck = array(kk)
-                        array(kk) = array(k2)
-                        array(k2) = ck
-                        kk = kk + 1
-                        k2 = k2 + 1
-                        IF (kk >= k) EXIT
-                     END DO
-                     kk = kk + nspan - jc
-                     k2 = k2 + nspan - jc
-                     IF (kk >= nt) EXIT
-                  END DO
-                  kk = kk - nt + jc
-                  k2 = k2 - nt + kspan
-                  IF (k2 >= nspan) EXIT
-               END DO
-               DO
-                  DO
-                     k2 = k2 - perm (j)
-                     j = j + 1
-                     k2 = perm (j + 1) + k2
-                     IF (k2 <= perm (j)) EXIT
-                  END DO
-                  j = 1
-                  DO
-                     IF (kk < k2) CYCLE permute_multi
-                     kk = kk + jc
-                     k2 = k2 + kspan
-                     IF (k2 >= nspan) EXIT
-                  END DO
-                  IF (kk >= nspan) EXIT
-               END DO
-               EXIT
-            END DO permute_multi
-         ELSE
-            permute_single: DO
-               DO
-!
-!--               Swap array(kk) <> array(k2)
-                  ck = array(kk)
-                  array(kk) = array(k2)
-                  array(k2) = ck
-                  kk = kk + 1
-                  k2 = k2 + kspan
-                  IF (k2 >= nspan) EXIT
-               END DO
-               DO
-                  DO
-                     k2 = k2 - perm (j)
-                     j = j + 1
-                     k2 = perm (j + 1) + k2
-                     IF (k2 <= perm (j)) EXIT
-                  END DO
-                  j = 1
-                  DO
-                     IF (kk < k2) CYCLE permute_single
-                     kk = kk + 1
-                     k2 = k2 + kspan
-                     IF (k2 >= nspan) EXIT
-                  END DO
-                  IF (kk >= nspan) EXIT
-               END DO
-               EXIT
-            END DO permute_single
-         END IF
-         jc = k3
-      END IF
-
-      IF (ISHFT(kt, 1) + 1 >= nfactor) RETURN
-
-      ispan = perm (kt + 1)
-!
-!--   Permutation for square-free factors of n
-      j = nfactor - kt
-      factor(j + 1) = 1
-      DO
-         factor(j) = factor(j) * factor(j+1)
-         j = j - 1
-         IF (j == kt) EXIT
-      END DO
-      kt = kt + 1
-      nn = factor(kt) - 1
-      j = 0
-      jj = 0
-      DO
-         k = kt + 1
-         k2 = factor(kt)
-         kk = factor(k)
-         j = j + 1
-         IF (j > nn) EXIT !-- exit infinite loop
-         jj = jj + kk
-         DO WHILE (jj >= k2)
-            jj = jj - k2
-            k2 = kk
-            k = k + 1
-            kk = factor(k)
-            jj = jj + kk
-         END DO
-         perm (j) = jj
-      END DO
-!
-!--   Determine the permutation cycles of length greater than 1
-      j = 0
-      DO
-         DO
-            j = j + 1
-            kk = perm(j)
-            IF (kk >= 0) EXIT
-         END DO
-         IF (kk /= j) THEN
-            DO
-               k = kk
-               kk = perm (k)
-               perm (k) = -kk
-               IF (kk == j) EXIT
-            END DO
-            k3 = kk
-         ELSE
-            perm (j) = -j
-            IF (j == nn) EXIT !-- exit infinite loop
-         END IF
-      END DO
-!
-!--   Reorder a and b, following the permutation cycles
-      DO
-         j = k3 + 1
-         nt = nt - ispan
-         ii = nt - 1 + 1
-         IF (nt < 0) EXIT !-- exit infinite loop
-         DO
-            DO
-               j = j-1
-               IF (perm(j) >= 0) EXIT
-            END DO
-            jj = jc
-            DO
-               kspan = jj
-               IF (jj > maxfactor) kspan = maxfactor
-               jj = jj - kspan
-               k = perm(j)
-               kk = jc * k + ii + jj
-               k1 = kk + kspan
-               k2 = 0
-               DO
-                  k2 = k2 + 1
-                  ctmp(k2) = array(k1)
-                  k1 = k1 - 1
-                  IF (k1 == kk) EXIT
-               END DO
-               DO
-                  k1 = kk + kspan
-                  k2 = k1 - jc * (k + perm(k))
-                  k = -perm(k)
-                  DO
-                     array(k1) = array(k2)
-                     k1 = k1 - 1
-                     k2 = k2 - 1
-                     IF (k1 == kk) EXIT
-                  END DO
-                  kk = k2
-                  IF (k == j) EXIT
-               END DO
-               k1 = kk + kspan
-               k2 = 0
-               DO
-                  k2 = k2 + 1
-                  array(k1) = ctmp(k2)
-                  k1 = k1 - 1
-                  IF (k1 == kk) EXIT
-               END DO
-               IF (jj == 0) EXIT
-            END DO
-            IF (j == 1) EXIT
-         END DO
-      END DO
-
-    END SUBROUTINE permute
-
- END SUBROUTINE fftradix
-
- END MODULE singleton
Index: /palm/trunk/SOURCE/singleton_mod.f90
===================================================================
--- /palm/trunk/SOURCE/singleton_mod.f90	(revision 1850)
+++ /palm/trunk/SOURCE/singleton_mod.f90	(revision 1850)
@@ -0,0 +1,1188 @@
+!> @file singleton_mod.f90
+!-----------------------------------------------------------------------------
+! Current revisions:
+! -----------------
+! Module renamed
+! 
+! 
+! Former revisions:
+! -----------------
+! $Id$
+!
+! 1682 2015-10-07 23:56:08Z knoop
+! Code annotations made doxygen readable
+!
+! 1320 2014-03-20 08:40:49Z raasch
+! kind-parameters added to all INTEGER and REAL declaration statements,
+! kinds are defined in new module kinds,
+! revision history before 2012 removed,
+!
+! Revision 1.1  2002/05/02 18:56:59  raasch
+! Initial revision
+!
+!
+! Description:
+! ------------
+!> Multivariate Fast Fourier Transform
+!>
+!> Fortran 90 Implementation of Singleton's mixed-radix algorithm,
+!> RC Singleton, Stanford Research Institute, Sept. 1968.
+!>
+!> Adapted from fftn.c, translated from Fortran 66 to C by Mark Olesen and
+!> John Beale.
+!>
+!> Fourier transforms can be computed either in place, using assumed size
+!> arguments, or by generic function, using assumed shape arguments.
+!>
+!>
+!> Public:
+!>
+!>   fftkind                              kind parameter of complex arguments
+!>                                        and function results.
+!>
+!>   fft(array, dim, inv, stat)           generic transform function
+!>    COMPLEX(fftkind), DIMENSION(:,...,:), INTENT(IN)           :: array
+!>    INTEGER,          DIMENSION(:),       INTENT(IN),  OPTIONAL:: dim
+!>    LOGICAL,                              INTENT(IN),  OPTIONAL:: inv
+!>    INTEGER,                              INTENT(OUT), OPTIONAL:: stat
+!>
+!>   fftn(array, shape, dim, inv, stat)   in place transform subroutine
+!>    COMPLEX(fftkind), DIMENSION(*), INTENT(INOUT)        :: array
+!>    INTEGER,          DIMENSION(:), INTENT(IN)           :: shape
+!>    INTEGER,          DIMENSION(:), INTENT(IN),  OPTIONAL:: dim
+!>    LOGICAL,                        INTENT(IN),  OPTIONAL:: inv
+!>    INTEGER,                        INTENT(OUT), OPTIONAL:: stat
+!>
+!>
+!> Formal Parameters:
+!>
+!>   array    The complex array to be transformed. array can be of arbitrary
+!>            rank (i.e. up to seven).
+!>
+!>   shape    With subroutine fftn, the shape of the array to be transformed
+!>            has to be passed separately, since fftradix - the internal trans-
+!>            formation routine - will treat array always as one dimensional.
+!>            The product of elements in shape must be the number of
+!>            elements in array.
+!>            Although passing array with assumed shape would have been nicer,
+!>            I prefered assumed size in order to prevent the compiler from
+!>            using a copy-in-copy-out mechanism. That would generally be
+!>            necessary with fftn passing array to fftradix and with fftn
+!>            being prepared for accepting non consecutive array sections.
+!>            Using assumed size, it's up to the user to pass an array argu-
+!>            ment, that can be addressed as continous one dimensional array
+!>            without copying. Otherwise, transformation will not really be
+!>            performed in place.
+!>            On the other hand, since the rank of array and the size of
+!>            shape needn't match, fftn is appropriate for handling more than
+!>            seven dimensions.
+!>            As far as function fft is concerned all this doesn't matter,
+!>            because the argument will be copied anyway. Thus no extra
+!>            shape argument is needed for fft.
+!>
+!> Optional Parameters:
+!>
+!>   dim      One dimensional integer array, containing the dimensions to be
+!>            transformed. Default is (/1,...,N/) with N being the rank of
+!>            array, i.e. complete transform. dim can restrict transformation
+!>            to a subset of available dimensions. Its size must not exceed the
+!>            rank of array or the size of shape respectivly.
+!>
+!>   inv      If .true., inverse transformation will be performed. Default is
+!>            .false., i.e. forward transformation.
+!>
+!>   stat     If present, a system dependent nonzero status value will be
+!>            returned in stat, if allocation of temporary storage failed.
+!>
+!>
+!> Scaling:
+!>
+!>   Transformation results will always be scaled by the square root of the
+!>   product of sizes of each dimension in dim. (See examples below)
+!>
+!>
+!> Examples:
+!>
+!>   Let A be a L*M*N three dimensional complex array. Then
+!>
+!>     result = fft(A)
+!>
+!>   will produce a three dimensional transform, scaled by sqrt(L*M*N), while
+!>
+!>     call fftn(A, SHAPE(A))
+!>
+!>   will do the same in place.
+!>
+!>     result = fft(A, dim=(/1,3/))
+!>
+!>   will transform with respect to the first and the third dimension, scaled
+!>   by sqrt(L*N).
+!>
+!>     result = fft(fft(A), inv=.true.)
+!>
+!>   should (approximately) reproduce A.
+!>   With B having the same shape as A
+!>
+!>     result = fft(fft(A) * CONJG(fft(B)), inv=.true.)
+!>
+!>   will correlate A and B.
+!>
+!>
+!> Remarks:
+!>
+!>   Following changes have been introduced with respect to fftn.c:
+!>   - complex arguments and results are of type complex, rather than
+!>     real an imaginary part separately.
+!>   - increment parameter (magnitude of isign) has been dropped,
+!>     inc is always one, direction of transform is given by inv.     
+!>   - maxf and maxp have been dropped. The amount of temporary storage
+!>     needed is determined by the fftradix routine. Both fftn and fft
+!>     can handle any size of array. (Maybe they take a lot of time and
+!>     memory, but they will do it)
+!>
+!>   Redesigning fftradix in a way, that it handles assumed shape arrays
+!>   would have been desirable. However, I found it rather hard to do this
+!>   in an efficient way. Problems were:
+!>   - to prevent stride multiplications when indexing arrays. At least our
+!>     compiler was not clever enough to discover that in fact additions
+!>     would do the job as well. On the other hand, I haven't been clever
+!>     enough to find an implementation using array operations.
+!>   - fftradix is rather large and different versions would be necessaray
+!>     for each possible rank of array.
+!>   Consequently, in place transformation still needs the argument stored
+!>   in a consecutive bunch of memory and can't be performed on array
+!>   sections like A(100:199:-3, 50:1020). Calling fftn with such sections
+!>   will most probably imply copy-in-copy-out. However, the function fft
+!>   works with everything it gets and should be convenient to use.
+!>
+!> Michael Steffens, 09.12.96, <Michael.Steffens@mbox.muk.uni-hannover.de>
+!> Restructured fftradix for better optimization. M. Steffens, 4 June 1997
+!-----------------------------------------------------------------------------
+ MODULE singleton
+ 
+
+    USE kinds
+
+    IMPLICIT NONE
+
+    PRIVATE
+    PUBLIC:: fft, fftn
+
+    REAL(wp), PARAMETER:: sin60 = 0.86602540378443865_wp
+    REAL(wp), PARAMETER:: cos72 = 0.30901699437494742_wp
+    REAL(wp), PARAMETER:: sin72 = 0.95105651629515357_wp
+    REAL(wp), PARAMETER:: pi    = 3.14159265358979323_wp
+
+    INTERFACE fft
+       MODULE PROCEDURE fft1d
+       MODULE PROCEDURE fft2d
+       MODULE PROCEDURE fft3d
+       MODULE PROCEDURE fft4d
+       MODULE PROCEDURE fft5d
+       MODULE PROCEDURE fft6d
+       MODULE PROCEDURE fft7d
+    END INTERFACE
+
+
+ CONTAINS
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> @todo Missing function description.
+!------------------------------------------------------------------------------!
+ FUNCTION fft1d(array, dim, inv, stat) RESULT(ft)
+!
+!-- Formal parameters
+    COMPLEX(wp),  DIMENSION(:), INTENT(IN)           :: array
+    INTEGER(iwp), DIMENSION(:), INTENT(IN),  OPTIONAL:: dim
+    INTEGER(iwp),               INTENT(OUT), OPTIONAL:: stat
+    LOGICAL,                    INTENT(IN),  OPTIONAL:: inv
+!
+!-- Function result
+    COMPLEX(wp), DIMENSION(SIZE(array, 1)):: ft
+
+    INTEGER(iwp)::  ishape(1)
+
+!
+!-- Intrinsics used
+    INTRINSIC SIZE, SHAPE
+
+    ft = array
+    ishape = SHAPE( array )
+    CALL fftn(ft, ishape, inv = inv,  stat = stat)
+
+ END FUNCTION fft1d
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> @todo Missing function description.
+!------------------------------------------------------------------------------!
+ FUNCTION fft2d(array, dim, inv, stat) RESULT(ft)
+!
+!-- Formal parameters
+    COMPLEX(wp),  DIMENSION(:,:), INTENT(IN)           :: array
+    INTEGER(iwp), DIMENSION(:),   INTENT(IN),  OPTIONAL:: dim
+    INTEGER(iwp),                 INTENT(OUT), OPTIONAL:: stat
+    LOGICAL,                      INTENT(IN),  OPTIONAL:: inv
+!
+!-- Function result
+    COMPLEX(wp), DIMENSION(SIZE(array, 1), SIZE(array, 2)):: ft
+
+    INTEGER(iwp) ::  ishape(2)
+!
+!-- Intrinsics used
+    INTRINSIC SIZE, SHAPE
+
+    ft = array
+    ishape = SHAPE( array )
+    CALL fftn(ft, ishape, dim, inv, stat)
+
+ END FUNCTION fft2d
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> @todo Missing function description.
+!------------------------------------------------------------------------------!
+ FUNCTION fft3d(array, dim, inv, stat) RESULT(ft)
+!
+!-- Formal parameters
+    COMPLEX(wp),  DIMENSION(:,:,:), INTENT(IN)           :: array
+    INTEGER(iwp), DIMENSION(:),     INTENT(IN),  OPTIONAL:: dim
+    INTEGER(iwp),                   INTENT(OUT), OPTIONAL:: stat
+    LOGICAL,                        INTENT(IN),  OPTIONAL:: inv
+!
+!-- Function result
+    COMPLEX(wp), &
+         DIMENSION(SIZE(array, 1), SIZE(array, 2), SIZE(array, 3)):: ft
+
+    INTEGER(iwp) ::  ishape(3)
+
+!
+!-- Intrinsics used
+    INTRINSIC SIZE, SHAPE
+
+    ft = array
+    ishape = SHAPE( array)
+    CALL fftn(ft, ishape, dim, inv, stat)
+
+ END FUNCTION fft3d
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> @todo Missing function description.
+!------------------------------------------------------------------------------!
+ FUNCTION fft4d(array, dim, inv, stat) RESULT(ft)
+!
+!-- Formal parameters
+    COMPLEX(wp),  DIMENSION(:,:,:,:), INTENT(IN)           :: array
+    INTEGER(iwp), DIMENSION(:),       INTENT(IN),  OPTIONAL:: dim
+    INTEGER(iwp),                     INTENT(OUT), OPTIONAL:: stat
+    LOGICAL,                          INTENT(IN),  OPTIONAL:: inv
+!
+!-- Function result
+    COMPLEX(wp), DIMENSION( &
+         SIZE(array, 1), SIZE(array, 2), SIZE(array, 3), SIZE(array, 4)):: ft
+
+    INTEGER(iwp) ::  ishape(4)
+!
+!-- Intrinsics used
+    INTRINSIC SIZE, SHAPE
+
+    ft = array
+    ishape = SHAPE( array )
+    CALL fftn(ft, ishape, dim, inv, stat)
+
+ END FUNCTION fft4d
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> @todo Missing function description.
+!------------------------------------------------------------------------------!
+ FUNCTION fft5d(array, dim, inv, stat) RESULT(ft)
+!
+!-- Formal parameters
+    COMPLEX(wp),  DIMENSION(:,:,:,:,:), INTENT(IN)           :: array
+    INTEGER(iwp), DIMENSION(:),         INTENT(IN),  OPTIONAL:: dim
+    INTEGER(iwp),                       INTENT(OUT), OPTIONAL:: stat
+    LOGICAL,                            INTENT(IN),  OPTIONAL:: inv
+!
+!-- Function result
+    COMPLEX(wp), DIMENSION( &
+         SIZE(array, 1), SIZE(array, 2), SIZE(array, 3), SIZE(array, 4), &
+         SIZE(array, 5)):: ft
+
+    INTEGER(iwp) ::  ishape(5)
+
+!
+!-- Intrinsics used
+    INTRINSIC SIZE, SHAPE
+
+    ft = array
+    ishape = SHAPE( array )
+    CALL fftn(ft, ishape, dim, inv, stat)
+
+ END FUNCTION fft5d
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> @todo Missing function description.
+!------------------------------------------------------------------------------!
+ FUNCTION fft6d(array, dim, inv, stat) RESULT(ft)
+!
+!-- Formal parameters
+    COMPLEX(wp),  DIMENSION(:,:,:,:,:,:), INTENT(IN)           :: array
+    INTEGER(iwp), DIMENSION(:),           INTENT(IN),  OPTIONAL:: dim
+    INTEGER(iwp),                         INTENT(OUT), OPTIONAL:: stat
+    LOGICAL,                              INTENT(IN),  OPTIONAL:: inv
+!
+!-- Function result
+    COMPLEX(wp), DIMENSION( &
+         SIZE(array, 1), SIZE(array, 2), SIZE(array, 3), SIZE(array, 4), &
+         SIZE(array, 5), SIZE(array, 6)):: ft
+
+    INTEGER(iwp) ::  ishape(6)
+
+!
+!-- Intrinsics used
+    INTRINSIC SIZE, SHAPE
+
+    ft = array
+    ishape = SHAPE( array )
+    CALL fftn(ft, ishape, dim, inv, stat)
+
+ END FUNCTION fft6d
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> @todo Missing function description.
+!------------------------------------------------------------------------------!
+ FUNCTION fft7d(array, dim, inv, stat) RESULT(ft)
+!
+!-- Formal parameters
+    COMPLEX(wp), DIMENSION(:,:,:,:,:,:,:), INTENT(IN)           :: array
+    INTEGER(iwp),          DIMENSION(:),   INTENT(IN),  OPTIONAL:: dim
+    INTEGER(iwp),                          INTENT(OUT), OPTIONAL:: stat
+    LOGICAL,                               INTENT(IN),  OPTIONAL:: inv
+!
+!-- Function result
+    COMPLEX(wp), DIMENSION( &
+         SIZE(array, 1), SIZE(array, 2), SIZE(array, 3), SIZE(array, 4), &
+         SIZE(array, 5), SIZE(array, 6), SIZE(array, 7)):: ft
+
+    INTEGER(iwp) ::  ishape(7)
+
+!
+!-- Intrinsics used
+    INTRINSIC SIZE, SHAPE
+
+    ft = array
+    ishape = SHAPE( array )
+    CALL fftn(ft, ishape, dim, inv, stat)
+
+ END FUNCTION fft7d
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> @todo Missing subroutine description.
+!------------------------------------------------------------------------------!
+ SUBROUTINE fftn(array, shape, dim, inv, stat)
+!
+!-- Formal parameters
+    COMPLEX(wp),  DIMENSION(*), INTENT(INOUT)        :: array
+    INTEGER(iwp), DIMENSION(:), INTENT(IN)           :: shape
+    INTEGER(iwp), DIMENSION(:), INTENT(IN),  OPTIONAL:: dim
+    INTEGER(iwp),               INTENT(OUT), OPTIONAL:: stat
+    LOGICAL,                    INTENT(IN),  OPTIONAL:: inv
+!
+!-- Local arrays
+    INTEGER(iwp), DIMENSION(SIZE(shape)):: d
+!
+!-- Local scalars
+    LOGICAL      :: inverse
+    INTEGER(iwp) :: i, ndim, ntotal
+    REAL(wp):: scale
+!
+!-- Intrinsics used
+    INTRINSIC PRESENT, MIN, PRODUCT, SIZE, SQRT
+
+!
+!-- Optional parameter settings
+    IF (PRESENT(inv)) THEN
+       inverse = inv
+    ELSE
+       inverse = .FALSE.
+    END IF
+    IF (PRESENT(dim)) THEN
+       ndim = MIN(SIZE(dim), SIZE(d))
+       d(1:ndim) = DIM(1:ndim)
+    ELSE
+       ndim = SIZE(d)
+       d = (/(i, i = 1, SIZE(d))/)
+    END IF
+
+    ntotal = PRODUCT(shape)
+    scale = SQRT(1.0_wp / PRODUCT(shape(d(1:ndim))))
+    DO i = 1, ntotal
+       array(i) = CMPLX(REAL(array(i)) * scale, AIMAG(array(i)) * scale, &
+            KIND=wp)
+    END DO
+
+    DO i = 1, ndim
+       CALL fftradix(array, ntotal, shape(d(i)), PRODUCT(shape(1:d(i))), &
+            inverse, stat)
+       IF (PRESENT(stat)) THEN
+          IF (stat /=0) RETURN
+       END IF
+    END DO
+
+ END SUBROUTINE fftn
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> @todo Missing subroutine description.
+!------------------------------------------------------------------------------!
+ SUBROUTINE fftradix(array, ntotal, npass, nspan, inv, stat)
+!
+!-- Formal parameters
+    COMPLEX(wp),  DIMENSION(*), INTENT(INOUT)        :: array
+    INTEGER(iwp),               INTENT(IN)           :: ntotal, npass, nspan
+    INTEGER(iwp),               INTENT(OUT), OPTIONAL:: stat
+    LOGICAL,                    INTENT(IN)           :: inv
+!
+!-- Local arrays
+    COMPLEX(wp),  DIMENSION(:), ALLOCATABLE  :: ctmp
+    INTEGER(iwp), DIMENSION(BIT_SIZE(0))     :: factor
+    INTEGER(iwp), DIMENSION(:), ALLOCATABLE  :: perm
+    REAL(wp),     DIMENSION(:), ALLOCATABLE  :: sine, cosine
+!
+!-- Local scalars
+    INTEGER(iwp)         :: maxfactor, nfactor, nsquare, nperm
+!
+!-- Intrinsics used
+    INTRINSIC MAXVAL, MOD, PRESENT, ISHFT, BIT_SIZE, SIN, COS, &
+         CMPLX, REAL, AIMAG
+
+    IF (npass <= 1) RETURN
+
+    CALL factorize(npass, factor, nfactor, nsquare)
+
+    maxfactor = MAXVAL(factor(:nfactor))
+    IF (nfactor - ISHFT(nsquare, 1) > 0) THEN
+       nperm = MAX(nfactor + 1, PRODUCT(factor(nsquare+1: nfactor-nsquare)) - 1)
+    ELSE
+       nperm = nfactor + 1
+    END IF
+
+    IF (PRESENT(stat)) THEN
+       ALLOCATE(ctmp(maxfactor), sine(maxfactor), cosine(maxfactor), STAT=stat)
+       IF (stat /= 0) RETURN
+       CALL transform(array, ntotal, npass, nspan, &
+            factor, nfactor, ctmp, sine, cosine, inv)
+       DEALLOCATE(sine, cosine, STAT=stat)
+       IF (stat /= 0) RETURN
+       ALLOCATE(perm(nperm), STAT=stat)
+       IF (stat /= 0) RETURN
+       CALL permute(array, ntotal, npass, nspan, &
+            factor, nfactor, nsquare, maxfactor, &
+            ctmp, perm)
+       DEALLOCATE(perm, ctmp, STAT=stat)
+       IF (stat /= 0) RETURN
+    ELSE
+       ALLOCATE(ctmp(maxfactor), sine(maxfactor), cosine(maxfactor))
+       CALL transform(array, ntotal, npass, nspan, &
+            factor, nfactor, ctmp, sine, cosine, inv)
+       DEALLOCATE(sine, cosine)
+       ALLOCATE(perm(nperm))
+       CALL permute(array, ntotal, npass, nspan, &
+            factor, nfactor, nsquare, maxfactor, &
+            ctmp, perm)
+       DEALLOCATE(perm, ctmp)
+    END IF
+
+
+  CONTAINS
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> @todo Missing subroutine description.
+!------------------------------------------------------------------------------!
+    SUBROUTINE factorize(npass, factor, nfactor, nsquare)
+!
+!--   Formal parameters
+      INTEGER(iwp),               INTENT(IN) :: npass
+      INTEGER(iwp), DIMENSION(*), INTENT(OUT):: factor
+      INTEGER(iwp),               INTENT(OUT):: nfactor, nsquare
+!
+!--   Local scalars
+      INTEGER(iwp):: j, jj, k
+
+      nfactor = 0
+      k = npass
+      DO WHILE (MOD(k, 16) == 0) 
+         nfactor = nfactor + 1
+         factor(nfactor) = 4
+         k = k / 16
+      END DO
+      j = 3
+      jj = 9
+      DO
+         DO WHILE (MOD(k, jj) == 0)
+            nfactor = nfactor + 1
+            factor(nfactor) = j
+            k = k / jj
+         END DO
+         j = j + 2
+         jj = j * j
+         IF (jj > k) EXIT
+      END DO
+      IF (k <= 4) THEN
+         nsquare = nfactor
+         factor(nfactor + 1) = k
+         IF (k /= 1) nfactor = nfactor + 1
+      ELSE 
+         IF (k - ISHFT(k / 4, 2) == 0) THEN
+            nfactor = nfactor + 1
+            factor(nfactor) = 2
+            k = k / 4
+         END IF
+         nsquare = nfactor
+         j = 2
+         DO
+            IF (MOD(k, j) == 0) THEN
+               nfactor = nfactor + 1
+               factor(nfactor) = j
+               k = k / j
+            END IF
+            j = ISHFT((j + 1) / 2, 1) + 1
+            IF (j > k) EXIT
+         END DO
+      END IF
+      IF (nsquare > 0) THEN
+         j = nsquare
+         DO
+            nfactor = nfactor + 1
+            factor(nfactor) = factor(j)
+            j = j - 1
+            IF (j==0) EXIT
+         END DO
+      END IF
+
+    END SUBROUTINE factorize
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> @todo Missing subroutine description.
+!------------------------------------------------------------------------------!
+    SUBROUTINE transform(array, ntotal, npass, nspan, &
+         factor, nfactor, ctmp, sine, cosine, inv) !-- compute fourier transform
+!
+!--   Formal parameters
+      COMPLEX(wp),  DIMENSION(*), INTENT(IN OUT):: array
+      COMPLEX(wp),  DIMENSION(*), INTENT(OUT)   :: ctmp
+      INTEGER(iwp),               INTENT(IN)    :: ntotal, npass, nspan
+      INTEGER(iwp), DIMENSION(*), INTENT(IN)    :: factor
+      INTEGER(iwp),               INTENT(IN)    :: nfactor
+      LOGICAL,                    INTENT(IN)    :: inv
+      REAL(wp),     DIMENSION(*), INTENT(OUT)   :: sine, cosine
+!
+!--   Local scalars
+      INTEGER(iwp):: ii, ispan
+      INTEGER(iwp):: j, jc, jf, jj
+      INTEGER(iwp):: k, kk, kspan, k1, k2, k3, k4
+      INTEGER(iwp):: nn, nt
+      REAL(wp)    :: s60, c72, s72, pi2, radf
+      REAL(wp)    :: c1, s1, c2, s2, c3, s3, cd, sd, ak
+      COMPLEX(wp) :: cc, cj, ck, cjp, cjm, ckp, ckm
+
+      c72 = cos72
+      IF (inv) THEN
+         s72 = sin72
+         s60 = sin60
+         pi2 = pi
+      ELSE
+         s72 = -sin72
+         s60 = -sin60
+         pi2 = -pi
+      END IF
+
+      nt = ntotal
+      nn = nt - 1
+      kspan = nspan
+      jc = nspan / npass
+      radf = pi2 * jc
+      pi2 = pi2 * 2.0_wp !-- use 2 PI from here on
+
+      ii = 0
+      jf = 0
+      DO
+         sd = radf / kspan
+         cd = SIN(sd)
+         cd = 2.0_wp * cd * cd
+         sd = SIN(sd + sd)
+         kk = 1
+         ii = ii + 1
+
+         SELECT CASE (factor(ii))
+         CASE (2)
+!
+!--         Transform for factor of 2 (including rotation factor)
+            kspan = kspan / 2
+            k1 = kspan + 2
+            DO
+               DO
+                  k2 = kk + kspan
+                  ck = array(k2)
+                  array(k2) = array(kk)-ck
+                  array(kk) = array(kk) + ck
+                  kk = k2 + kspan
+                  IF (kk > nn) EXIT
+               END DO
+               kk = kk - nn
+               IF (kk > jc) EXIT
+            END DO
+            IF (kk > kspan) RETURN
+            DO
+               c1 = 1.0_wp - cd
+               s1 = sd
+               DO
+                  DO
+                     DO
+                        k2 = kk + kspan
+                        ck = array(kk) - array(k2)
+                        array(kk) = array(kk) + array(k2)
+                        array(k2) = ck * CMPLX(c1, s1, KIND=wp)
+                        kk = k2 + kspan
+                        IF (kk >= nt) EXIT
+                     END DO
+                     k2 = kk - nt
+                     c1 = -c1
+                     kk = k1 - k2
+                     IF (kk <= k2) EXIT
+                  END DO
+                  ak = c1 - (cd * c1 + sd * s1)
+                  s1 = sd * c1 - cd * s1 + s1
+                  c1 = 2.0_wp - (ak * ak + s1 * s1)
+                  s1 = s1 * c1
+                  c1 = c1 * ak
+                  kk = kk + jc
+                  IF (kk >= k2) EXIT
+               END DO
+               k1 = k1 + 1 + 1
+               kk = (k1 - kspan) / 2 + jc
+               IF (kk > jc + jc) EXIT
+            END DO
+
+         CASE (4) !-- transform for factor of 4
+            ispan = kspan
+            kspan = kspan / 4
+
+            DO
+               c1 = 1.0_wp
+               s1 = 0.0_wp
+               DO
+                  DO
+                     k1 = kk + kspan
+                     k2 = k1 + kspan
+                     k3 = k2 + kspan
+                     ckp = array(kk) + array(k2)
+                     ckm = array(kk) - array(k2)
+                     cjp = array(k1) + array(k3)
+                     cjm = array(k1) - array(k3)
+                     array(kk) = ckp + cjp
+                     cjp = ckp - cjp
+                     IF (inv) THEN
+                        ckp = ckm + CMPLX(-AIMAG(cjm), REAL(cjm), KIND=wp)
+                        ckm = ckm + CMPLX(AIMAG(cjm), -REAL(cjm), KIND=wp)
+                     ELSE
+                        ckp = ckm + CMPLX(AIMAG(cjm), -REAL(cjm), KIND=wp)
+                        ckm = ckm + CMPLX(-AIMAG(cjm), REAL(cjm), KIND=wp)
+                     END IF
+!
+!--                  Avoid useless multiplies
+                     IF (s1 == 0.0_wp) THEN
+                        array(k1) = ckp
+                        array(k2) = cjp
+                        array(k3) = ckm
+                     ELSE
+                        array(k1) = ckp * CMPLX(c1, s1, KIND=wp)
+                        array(k2) = cjp * CMPLX(c2, s2, KIND=wp)
+                        array(k3) = ckm * CMPLX(c3, s3, KIND=wp)
+                     END IF
+                     kk = k3 + kspan
+                     IF (kk > nt) EXIT
+                  END DO
+
+                  c2 = c1 - (cd * c1 + sd * s1)
+                  s1 = sd * c1 - cd * s1 + s1
+                  c1 = 2.0_wp - (c2 * c2 + s1 * s1)
+                  s1 = s1 * c1
+                  c1 = c1 * c2
+!
+!--               Values of c2, c3, s2, s3 that will get used next time
+                  c2 = c1 * c1 - s1 * s1
+                  s2 = 2.0_wp * c1 * s1
+                  c3 = c2 * c1 - s2 * s1
+                  s3 = c2 * s1 + s2 * c1
+                  kk = kk - nt + jc
+                  IF (kk > kspan) EXIT
+               END DO
+               kk = kk - kspan + 1
+               IF (kk > jc) EXIT
+            END DO
+            IF (kspan == jc) RETURN
+
+         CASE default
+!
+!--         Transform for odd factors
+            k = factor(ii)
+            ispan = kspan
+            kspan = kspan / k
+
+            SELECT CASE (k)
+            CASE (3) !-- transform for factor of 3 (optional code)
+               DO
+                  DO
+                     k1 = kk + kspan
+                     k2 = k1 + kspan
+                     ck = array(kk)
+                     cj = array(k1) + array(k2)
+                     array(kk) = ck + cj
+                     ck = ck - CMPLX( &
+                          0.5_wp * REAL (cj), &
+                          0.5_wp * AIMAG(cj), &
+                          KIND=wp)
+                     cj = CMPLX( &
+                          (REAL (array(k1)) - REAL (array(k2))) * s60, &
+                          (AIMAG(array(k1)) - AIMAG(array(k2))) * s60, &
+                          KIND=wp)
+                     array(k1) = ck + CMPLX(-AIMAG(cj), REAL(cj), KIND=wp)
+                     array(k2) = ck + CMPLX(AIMAG(cj), -REAL(cj), KIND=wp)
+                     kk = k2 + kspan
+                     IF (kk >= nn) EXIT
+                  END DO
+                  kk = kk - nn
+                  IF (kk > kspan) EXIT
+               END DO
+
+            CASE (5) !-- transform for factor of 5 (optional code)
+               c2 = c72 * c72 - s72 * s72
+               s2 = 2.0_wp * c72 * s72
+               DO
+                  DO
+                     k1 = kk + kspan
+                     k2 = k1 + kspan
+                     k3 = k2 + kspan
+                     k4 = k3 + kspan
+                     ckp = array(k1) + array(k4)
+                     ckm = array(k1) - array(k4)
+                     cjp = array(k2) + array(k3)
+                     cjm = array(k2) - array(k3)
+                     cc = array(kk)
+                     array(kk) = cc + ckp + cjp
+                     ck = CMPLX(REAL(ckp) * c72, AIMAG(ckp) * c72, &
+                          KIND=wp) + &
+                          CMPLX(REAL(cjp) * c2,  AIMAG(cjp) * c2,  &
+                          KIND=wp) + cc
+                     cj = CMPLX(REAL(ckm) * s72, AIMAG(ckm) * s72, &
+                          KIND=wp) + &
+                          CMPLX(REAL(cjm) * s2,  AIMAG(cjm) * s2,  &
+                          KIND=wp)
+                     array(k1) = ck + CMPLX(-AIMAG(cj), REAL(cj), KIND=wp)
+                     array(k4) = ck + CMPLX(AIMAG(cj), -REAL(cj), KIND=wp)
+                     ck = CMPLX(REAL(ckp) * c2,  AIMAG(ckp) * c2,  &
+                          KIND=wp) + &
+                          CMPLX(REAL(cjp) * c72, AIMAG(cjp) * c72, &
+                          KIND=wp) + cc
+                     cj = CMPLX(REAL(ckm) * s2,  AIMAG(ckm) * s2,  &
+                          KIND=wp) - &
+                          CMPLX(REAL(cjm) * s72, AIMAG(cjm) * s72, &
+                          KIND=wp)
+                     array(k2) = ck + CMPLX(-AIMAG(cj), REAL(cj), KIND=wp)
+                     array(k3) = ck + CMPLX(AIMAG(cj), -REAL(cj), KIND=wp)
+                     kk = k4 + kspan
+                     IF (kk >= nn) EXIT
+                  END DO
+                  kk = kk - nn
+                  IF (kk > kspan) EXIT
+               END DO
+
+            CASE default
+               IF (k /= jf) THEN
+                  jf = k
+                  s1 = pi2 / k
+                  c1 = COS(s1)
+                  s1 = SIN(s1)
+                  cosine (jf) = 1.0_wp
+                  sine (jf) = 0.0_wp
+                  j = 1
+                  DO
+                     cosine (j) = cosine (k) * c1 + sine (k) * s1
+                     sine (j) = cosine (k) * s1 - sine (k) * c1
+                     k = k-1
+                     cosine (k) = cosine (j)
+                     sine (k) = -sine (j)
+                     j = j + 1
+                     IF (j >= k) EXIT
+                  END DO
+               END IF
+               DO
+                  DO
+                     k1 = kk
+                     k2 = kk + ispan
+                     cc = array(kk)
+                     ck = cc
+                     j = 1
+                     k1 = k1 + kspan
+                     DO
+                        k2 = k2 - kspan
+                        j = j + 1
+                        ctmp(j) = array(k1) + array(k2)
+                        ck = ck + ctmp(j)
+                        j = j + 1
+                        ctmp(j) = array(k1) - array(k2)
+                        k1 = k1 + kspan
+                        IF (k1 >= k2) EXIT
+                     END DO
+                     array(kk) = ck
+                     k1 = kk
+                     k2 = kk + ispan
+                     j = 1
+                     DO
+                        k1 = k1 + kspan
+                        k2 = k2 - kspan
+                        jj = j
+                        ck = cc
+                        cj = (0.0_wp, 0.0_wp)
+                        k = 1
+                        DO
+                           k = k + 1
+                           ck = ck + CMPLX( &
+                                REAL (ctmp(k)) * cosine(jj), &
+                                AIMAG(ctmp(k)) * cosine(jj), KIND=wp)
+                           k = k + 1
+                           cj = cj + CMPLX( &
+                                REAL (ctmp(k)) * sine(jj), &
+                                AIMAG(ctmp(k)) * sine(jj), KIND=wp)
+                           jj = jj + j
+                           IF (jj > jf) jj = jj - jf
+                           IF (k >= jf) EXIT
+                        END DO
+                        k = jf - j
+                        array(k1) = ck + CMPLX(-AIMAG(cj), REAL(cj), &
+                             KIND=wp)
+                        array(k2) = ck + CMPLX(AIMAG(cj), -REAL(cj), &
+                             KIND=wp)
+                        j = j + 1
+                        IF (j >= k) EXIT
+                     END DO
+                     kk = kk + ispan
+                     IF (kk > nn) EXIT
+                  END DO
+                  kk = kk - nn
+                  IF (kk > kspan) EXIT
+               END DO
+
+            END SELECT
+!
+!--         Multiply by rotation factor (except for factors of 2 and 4)
+            IF (ii == nfactor) RETURN
+            kk = jc + 1
+            DO
+               c2 = 1.0_wp - cd
+               s1 = sd
+               DO
+                  c1 = c2
+                  s2 = s1
+                  kk = kk + kspan
+                  DO
+                     DO
+                        array(kk) = CMPLX(c2, s2, KIND=wp) * array(kk)
+                        kk = kk + ispan
+                        IF (kk > nt) EXIT
+                     END DO
+                     ak = s1 * s2
+                     s2 = s1 * c2 + c1 * s2
+                     c2 = c1 * c2 - ak
+                     kk = kk - nt + kspan
+                     IF (kk > ispan) EXIT
+                  END DO
+                  c2 = c1 - (cd * c1 + sd * s1)
+                  s1 = s1 + sd * c1 - cd * s1
+                  c1 = 2.0_wp - (c2 * c2 + s1 * s1)
+                  s1 = s1 * c1
+                  c2 = c2 * c1
+                  kk = kk - ispan + jc
+                  IF (kk > kspan) EXIT
+               END DO
+               kk = kk - kspan + jc + 1
+               IF (kk > jc + jc) EXIT
+            END DO
+
+         END SELECT
+      END DO
+    END SUBROUTINE transform
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> @todo Missing subroutine description.
+!------------------------------------------------------------------------------!
+    SUBROUTINE permute(array, ntotal, npass, nspan, &
+         factor, nfactor, nsquare, maxfactor, &
+         ctmp, perm)
+!
+!--   Formal parameters
+      COMPLEX(wp),  DIMENSION(*), INTENT(IN OUT):: array
+      COMPLEX(wp),  DIMENSION(*), INTENT(OUT)   :: ctmp
+      INTEGER(iwp),               INTENT(IN)    :: ntotal, npass, nspan
+      INTEGER(iwp), DIMENSION(*), INTENT(IN OUT):: factor
+      INTEGER(iwp),               INTENT(IN)    :: nfactor, nsquare
+      INTEGER(iwp),               INTENT(IN)    :: maxfactor
+      INTEGER(iwp), DIMENSION(*), INTENT(OUT)   :: perm
+!
+!--   Local scalars
+      COMPLEX(wp) :: ck
+      INTEGER(iwp):: ii, ispan
+      INTEGER(iwp):: j, jc, jj
+      INTEGER(iwp):: k, kk, kspan, kt, k1, k2, k3
+      INTEGER(iwp):: nn, nt
+!
+!--   Permute the results to normal order---done in two stages
+!--   Permutation for square factors of n
+
+      nt = ntotal
+      nn = nt - 1
+      kt = nsquare
+      kspan = nspan
+      jc = nspan / npass
+
+      perm (1) = nspan
+      IF (kt > 0) THEN
+         k = kt + kt + 1
+         IF (nfactor < k) k = k - 1
+         j = 1
+         perm (k + 1) = jc
+         DO
+            perm (j + 1) = perm (j) / factor(j)
+            perm (k) = perm (k + 1) * factor(j)
+            j = j + 1
+            k = k - 1
+            IF (j >= k) EXIT
+         END DO
+         k3 = perm (k + 1)
+         kspan = perm (2)
+         kk = jc + 1
+         k2 = kspan + 1
+         j = 1
+
+         IF (npass /= ntotal) THEN
+            permute_multi: DO
+               DO
+                  DO
+                     k = kk + jc
+                     DO
+!
+!--                     Swap array(kk) <> array(k2)
+                        ck = array(kk)
+                        array(kk) = array(k2)
+                        array(k2) = ck
+                        kk = kk + 1
+                        k2 = k2 + 1
+                        IF (kk >= k) EXIT
+                     END DO
+                     kk = kk + nspan - jc
+                     k2 = k2 + nspan - jc
+                     IF (kk >= nt) EXIT
+                  END DO
+                  kk = kk - nt + jc
+                  k2 = k2 - nt + kspan
+                  IF (k2 >= nspan) EXIT
+               END DO
+               DO
+                  DO
+                     k2 = k2 - perm (j)
+                     j = j + 1
+                     k2 = perm (j + 1) + k2
+                     IF (k2 <= perm (j)) EXIT
+                  END DO
+                  j = 1
+                  DO
+                     IF (kk < k2) CYCLE permute_multi
+                     kk = kk + jc
+                     k2 = k2 + kspan
+                     IF (k2 >= nspan) EXIT
+                  END DO
+                  IF (kk >= nspan) EXIT
+               END DO
+               EXIT
+            END DO permute_multi
+         ELSE
+            permute_single: DO
+               DO
+!
+!--               Swap array(kk) <> array(k2)
+                  ck = array(kk)
+                  array(kk) = array(k2)
+                  array(k2) = ck
+                  kk = kk + 1
+                  k2 = k2 + kspan
+                  IF (k2 >= nspan) EXIT
+               END DO
+               DO
+                  DO
+                     k2 = k2 - perm (j)
+                     j = j + 1
+                     k2 = perm (j + 1) + k2
+                     IF (k2 <= perm (j)) EXIT
+                  END DO
+                  j = 1
+                  DO
+                     IF (kk < k2) CYCLE permute_single
+                     kk = kk + 1
+                     k2 = k2 + kspan
+                     IF (k2 >= nspan) EXIT
+                  END DO
+                  IF (kk >= nspan) EXIT
+               END DO
+               EXIT
+            END DO permute_single
+         END IF
+         jc = k3
+      END IF
+
+      IF (ISHFT(kt, 1) + 1 >= nfactor) RETURN
+
+      ispan = perm (kt + 1)
+!
+!--   Permutation for square-free factors of n
+      j = nfactor - kt
+      factor(j + 1) = 1
+      DO
+         factor(j) = factor(j) * factor(j+1)
+         j = j - 1
+         IF (j == kt) EXIT
+      END DO
+      kt = kt + 1
+      nn = factor(kt) - 1
+      j = 0
+      jj = 0
+      DO
+         k = kt + 1
+         k2 = factor(kt)
+         kk = factor(k)
+         j = j + 1
+         IF (j > nn) EXIT !-- exit infinite loop
+         jj = jj + kk
+         DO WHILE (jj >= k2)
+            jj = jj - k2
+            k2 = kk
+            k = k + 1
+            kk = factor(k)
+            jj = jj + kk
+         END DO
+         perm (j) = jj
+      END DO
+!
+!--   Determine the permutation cycles of length greater than 1
+      j = 0
+      DO
+         DO
+            j = j + 1
+            kk = perm(j)
+            IF (kk >= 0) EXIT
+         END DO
+         IF (kk /= j) THEN
+            DO
+               k = kk
+               kk = perm (k)
+               perm (k) = -kk
+               IF (kk == j) EXIT
+            END DO
+            k3 = kk
+         ELSE
+            perm (j) = -j
+            IF (j == nn) EXIT !-- exit infinite loop
+         END IF
+      END DO
+!
+!--   Reorder a and b, following the permutation cycles
+      DO
+         j = k3 + 1
+         nt = nt - ispan
+         ii = nt - 1 + 1
+         IF (nt < 0) EXIT !-- exit infinite loop
+         DO
+            DO
+               j = j-1
+               IF (perm(j) >= 0) EXIT
+            END DO
+            jj = jc
+            DO
+               kspan = jj
+               IF (jj > maxfactor) kspan = maxfactor
+               jj = jj - kspan
+               k = perm(j)
+               kk = jc * k + ii + jj
+               k1 = kk + kspan
+               k2 = 0
+               DO
+                  k2 = k2 + 1
+                  ctmp(k2) = array(k1)
+                  k1 = k1 - 1
+                  IF (k1 == kk) EXIT
+               END DO
+               DO
+                  k1 = kk + kspan
+                  k2 = k1 - jc * (k + perm(k))
+                  k = -perm(k)
+                  DO
+                     array(k1) = array(k2)
+                     k1 = k1 - 1
+                     k2 = k2 - 1
+                     IF (k1 == kk) EXIT
+                  END DO
+                  kk = k2
+                  IF (k == j) EXIT
+               END DO
+               k1 = kk + kspan
+               k2 = 0
+               DO
+                  k2 = k2 + 1
+                  array(k1) = ctmp(k2)
+                  k1 = k1 - 1
+                  IF (k1 == kk) EXIT
+               END DO
+               IF (jj == 0) EXIT
+            END DO
+            IF (j == 1) EXIT
+         END DO
+      END DO
+
+    END SUBROUTINE permute
+
+ END SUBROUTINE fftradix
+
+ END MODULE singleton
Index: lm/trunk/SOURCE/subsidence.f90
===================================================================
--- /palm/trunk/SOURCE/subsidence.f90	(revision 1849)
+++ 	(revision )
@@ -1,381 +1,0 @@
-!> @file subsidence.f90
-!--------------------------------------------------------------------------------!
-! This file is part of PALM.
-!
-! PALM is free software: you can redistribute it and/or modify it under the terms
-! of the GNU General Public License as published by the Free Software Foundation,
-! either version 3 of the License, or (at your option) any later version.
-!
-! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
-! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
-! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along with
-! PALM. If not, see <http://www.gnu.org/licenses/>.
-!
-! Copyright 1997-2016 Leibniz Universitaet Hannover
-!--------------------------------------------------------------------------------!
-!
-! Current revisions:
-! -----------------
-! 
-! 
-! Former revisions:
-! -----------------
-! $Id$
-!
-! 1729 2015-11-20 11:01:48Z gronemeier
-! Bugfix: shifting of initial profiles only once each time step
-! 
-! 1682 2015-10-07 23:56:08Z knoop
-! Code annotations made doxygen readable 
-!
-! 1489 2014-10-30 08:09:12Z raasch
-! bugfix: sums_ls_l can only be used if large_scale_forcing is switched on
-!
-! 1382 2014-04-30 12:15:41Z boeske
-! Changed the weighting factor that is used in the summation of subsidence 
-! tendencies for profile data output from weight_pres to weight_substep
-! added Neumann boundary conditions for profile data output of subsidence terms
-! at nzt+1
-! 
-! 1380 2014-04-28 12:40:45Z heinze
-! Shifting only necessary in case of scalar Rayleigh damping
-! 
-! 1365 2014-04-22 15:03:56Z boeske
-! Summation of subsidence tendencies for data output added 
-! +ls_index, sums_ls_l, tmp_tend
-! 
-! 1353 2014-04-08 15:21:23Z heinze
-! REAL constants provided with KIND-attribute
-! 
-! 1320 2014-03-20 08:40:49Z raasch
-! ONLY-attribute added to USE-statements,
-! kind-parameters added to all INTEGER and REAL declaration statements,
-! kinds are defined in new module kinds,
-! old module precision_kind is removed,
-! revision history before 2012 removed,
-! comment fields (!:) to be used for variable explanations added to
-! all variable declaration statements 
-!
-! 1036 2012-10-22 13:43:42Z raasch
-! code put under GPL (PALM 3.9)
-!
-! Revision 3.7 2009-12-11 14:15:58Z heinze
-! Initial revision 
-!
-! Description:
-! ------------
-!> Impact of large-scale subsidence or ascent as tendency term for use 
-!> in the prognostic equation of potential temperature. This enables the 
-!> construction of a constant boundary layer height z_i with time.
-!-----------------------------------------------------------------------------!
- MODULE subsidence_mod
- 
-
-
-    IMPLICIT NONE
-
-    PRIVATE
-    PUBLIC  init_w_subsidence, subsidence
-
-    INTERFACE init_w_subsidence
-       MODULE PROCEDURE init_w_subsidence
-    END INTERFACE init_w_subsidence
-
-    INTERFACE subsidence
-       MODULE PROCEDURE subsidence
-       MODULE PROCEDURE subsidence_ij
-    END INTERFACE subsidence
-
- CONTAINS
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> @todo Missing subroutine description.
-!------------------------------------------------------------------------------!
-    SUBROUTINE init_w_subsidence 
-
-       USE arrays_3d,                                                          &
-           ONLY:  dzu, w_subs, zu
-
-       USE control_parameters,                                                 &
-           ONLY:  message_string, ocean, subs_vertical_gradient,               &
-                  subs_vertical_gradient_level, subs_vertical_gradient_level_i
-
-       USE indices,                                                            &
-           ONLY:  nzb, nzt
-
-       USE kinds
-
-       IMPLICIT NONE
-
-       INTEGER(iwp) ::  i !< 
-       INTEGER(iwp) ::  k !< 
-
-       REAL(wp)     ::  gradient   !< 
-       REAL(wp)     ::  ws_surface !< 
-
-       IF ( .NOT. ALLOCATED( w_subs ))  THEN
-          ALLOCATE( w_subs(nzb:nzt+1) )
-          w_subs = 0.0_wp
-       ENDIF 
-
-       IF ( ocean )  THEN
-          message_string = 'Applying large scale vertical motion is not ' // &
-                           'allowed for ocean runs'
-          CALL message( 'init_w_subsidence', 'PA0324', 2, 2, 0, 6, 0 )
-       ENDIF
-
-!
-!--   Compute the profile of the subsidence/ascent velocity 
-!--   using the given gradients
-      i = 1
-      gradient = 0.0_wp
-      ws_surface = 0.0_wp
-      
-
-      subs_vertical_gradient_level_i(1) = 0
-      DO  k = 1, nzt+1
-         IF ( i < 11 )  THEN
-            IF ( subs_vertical_gradient_level(i) < zu(k)  .AND. &
-                 subs_vertical_gradient_level(i) >= 0.0_wp )  THEN
-               gradient = subs_vertical_gradient(i) / 100.0_wp
-               subs_vertical_gradient_level_i(i) = k - 1
-               i = i + 1
-            ENDIF
-         ENDIF
-         IF ( gradient /= 0.0_wp )  THEN
-            IF ( k /= 1 )  THEN
-               w_subs(k) = w_subs(k-1) + dzu(k) * gradient
-            ELSE
-               w_subs(k) = ws_surface   + 0.5_wp * dzu(k) * gradient
-            ENDIF
-         ELSE
-            w_subs(k) = w_subs(k-1)
-         ENDIF
-      ENDDO
-
-!
-!--   In case of no given gradients for the subsidence/ascent velocity,
-!--   choose zero gradient
-      IF ( subs_vertical_gradient_level(1) == -9999999.9_wp )  THEN
-         subs_vertical_gradient_level(1) = 0.0_wp
-      ENDIF
-
-    END SUBROUTINE init_w_subsidence
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> @todo Missing subroutine description.
-!------------------------------------------------------------------------------!
-    SUBROUTINE subsidence( tendency, var, var_init, ls_index ) 
-
-       USE arrays_3d,                                                          &
-           ONLY:  ddzu, w_subs
-
-       USE control_parameters,                                                 &
-           ONLY:  dt_3d, intermediate_timestep_count, large_scale_forcing,     &
-                  scalar_rayleigh_damping
-
-       USE indices,                                                            &
-           ONLY:  nxl, nxlg, nxr, nxrg, nyn, nyng, nys, nysg, nzb, nzb_s_inner,&
-                  nzt
-
-       USE kinds
-
-       USE statistics,                                                         &
-           ONLY:  sums_ls_l, weight_substep
-
-       IMPLICIT NONE
- 
-       INTEGER(iwp) ::  i !< 
-       INTEGER(iwp) ::  j !< 
-       INTEGER(iwp) ::  k !< 
-       INTEGER(iwp) ::  ls_index !<
-
-       REAL(wp)     ::  tmp_tend !<
-       REAL(wp)     ::  tmp_grad !< 
-    
-       REAL(wp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ::  var      !< 
-       REAL(wp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ::  tendency !< 
-       REAL(wp), DIMENSION(nzb:nzt+1) ::  var_init                     !< 
-       REAL(wp), DIMENSION(nzb:nzt+1) ::  var_mod                      !< 
-
-       var_mod = var_init
-
-!
-!--    Influence of w_subsidence on the current tendency term
-       DO  i = nxl, nxr
-          DO  j = nys, nyn
-
-             DO  k = nzb_s_inner(j,i)+1, nzt 
-                IF ( w_subs(k) < 0.0_wp )  THEN    ! large-scale subsidence
-                   tmp_tend = - w_subs(k) *                                    &
-                              ( var(k+1,j,i) - var(k,j,i) ) * ddzu(k+1)
-                ELSE                               ! large-scale ascent
-                   tmp_tend = - w_subs(k) *                                    &
-                              ( var(k,j,i) - var(k-1,j,i) ) * ddzu(k)
-                ENDIF
-
-                tendency(k,j,i) = tendency(k,j,i) + tmp_tend
-
-                IF ( large_scale_forcing )  THEN
-                   sums_ls_l(k,ls_index) = sums_ls_l(k,ls_index) + tmp_tend    &
-                                   * weight_substep(intermediate_timestep_count)
-                ENDIF
-             ENDDO
-
-             sums_ls_l(nzt+1,ls_index) = sums_ls_l(nzt,ls_index)
-
-          ENDDO
-       ENDDO
-
-!
-!--    Shifting of the initial profile is especially necessary with Rayleigh 
-!--    damping switched on
-       IF ( scalar_rayleigh_damping .AND.                                      &
-            intermediate_timestep_count == 1 )  THEN
-          DO  k = nzb, nzt
-             IF ( w_subs(k) < 0.0_wp )  THEN      ! large-scale subsidence
-                var_mod(k) = var_init(k) - dt_3d * w_subs(k) *  &
-                                  ( var_init(k+1) - var_init(k) ) * ddzu(k+1)
-             ENDIF
-          ENDDO
-!
-!--      At the upper boundary, the initial profile is shifted with aid of 
-!--      the gradient tmp_grad. (This is ok if the gradients are linear.)
-         IF ( w_subs(nzt) < 0.0_wp )  THEN
-            tmp_grad = ( var_init(nzt+1) - var_init(nzt) ) * ddzu(nzt+1)
-            var_mod(nzt+1) = var_init(nzt+1) -  &
-                                 dt_3d * w_subs(nzt+1) * tmp_grad
-         ENDIF
-       
-
-         DO  k = nzt+1, nzb+1, -1
-            IF ( w_subs(k) >= 0.0_wp )  THEN  ! large-scale ascent
-               var_mod(k) = var_init(k) - dt_3d * w_subs(k) *  &
-                                  ( var_init(k) - var_init(k-1) ) * ddzu(k) 
-            ENDIF
-         ENDDO
-!
-!--      At the lower boundary shifting is not necessary because the 
-!--      subsidence velocity w_subs(nzb) vanishes.
-         IF ( w_subs(nzb+1) >= 0.0_wp )  THEN
-            var_mod(nzb) = var_init(nzb)
-         ENDIF
-
-         var_init = var_mod
-      ENDIF
-
-
- END SUBROUTINE subsidence
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> @todo Missing subroutine description.
-!------------------------------------------------------------------------------!
- SUBROUTINE subsidence_ij( i, j, tendency, var, var_init, ls_index ) 
-
-       USE arrays_3d,                                                          &
-           ONLY:  ddzu, w_subs
-
-       USE control_parameters,                                                 &
-           ONLY:  dt_3d, intermediate_timestep_count, large_scale_forcing,     &
-                  scalar_rayleigh_damping
-
-       USE indices,                                                            &
-           ONLY:  nxl, nxlg, nxrg, nyng, nys, nysg, nzb_s_inner, nzb, nzt
-
-       USE kinds
-
-       USE statistics,                                                         &
-           ONLY:  sums_ls_l, weight_substep
-
-       IMPLICIT NONE
- 
-       INTEGER(iwp) ::  i !< 
-       INTEGER(iwp) ::  j !< 
-       INTEGER(iwp) ::  k !< 
-       INTEGER(iwp) ::  ls_index !<
-
-       REAL(wp)     ::  tmp_tend !<
-       REAL(wp)     ::  tmp_grad !< 
-    
-       REAL(wp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ::  var      !< 
-       REAL(wp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ::  tendency !< 
-       REAL(wp), DIMENSION(nzb:nzt+1) ::  var_init                     !< 
-       REAL(wp), DIMENSION(nzb:nzt+1) ::  var_mod                      !< 
-
-       var_mod = var_init
-
-!
-!--    Influence of w_subsidence on the current tendency term
-       DO  k = nzb_s_inner(j,i)+1, nzt 
-          IF ( w_subs(k) < 0.0_wp )  THEN      ! large-scale subsidence
-             tmp_tend = - w_subs(k) * ( var(k+1,j,i) - var(k,j,i) ) * ddzu(k+1)
-          ELSE                                 ! large-scale ascent
-             tmp_tend = - w_subs(k) * ( var(k,j,i) - var(k-1,j,i) ) * ddzu(k)
-          ENDIF
-
-          tendency(k,j,i) = tendency(k,j,i) + tmp_tend
-
-          IF ( large_scale_forcing )  THEN
-             sums_ls_l(k,ls_index) = sums_ls_l(k,ls_index) + tmp_tend          &
-                                   * weight_substep(intermediate_timestep_count)
-          ENDIF
-       ENDDO
-
-       IF ( large_scale_forcing )  THEN
-          sums_ls_l(nzt+1,ls_index) = sums_ls_l(nzt,ls_index)
-       ENDIF
-
-!
-!--    Shifting of the initial profile is especially necessary with Rayleigh 
-!--    damping switched on
-       IF ( scalar_rayleigh_damping .AND.                                      &
-            intermediate_timestep_count == 1 )  THEN
-          IF ( i == nxl .AND. j == nys )  THEN ! shifting only once per PE 
-
-             DO  k = nzb, nzt
-                IF ( w_subs(k) < 0.0_wp )  THEN      ! large-scale subsidence
-                   var_mod(k) = var_init(k) - dt_3d * w_subs(k) *  &
-                                     ( var_init(k+1) - var_init(k) ) * ddzu(k+1)
-                ENDIF
-             ENDDO
-!
-!--          At the upper boundary, the initial profile is shifted with aid of 
-!--          the gradient tmp_grad. (This is ok if the gradients are linear.)
-             IF ( w_subs(nzt) < 0.0_wp )  THEN
-                tmp_grad = ( var_init(nzt+1) - var_init(nzt) ) * ddzu(nzt+1)
-                var_mod(nzt+1) = var_init(nzt+1) -  &
-                                     dt_3d * w_subs(nzt+1) * tmp_grad
-             ENDIF
-       
-
-             DO  k = nzt+1, nzb+1, -1
-                IF ( w_subs(k) >= 0.0_wp )  THEN  ! large-scale ascent
-                   var_mod(k) = var_init(k) - dt_3d * w_subs(k) *  &
-                                      ( var_init(k) - var_init(k-1) ) * ddzu(k)
-                ENDIF
-             ENDDO
-!
-!--          At the lower boundary shifting is not necessary because the 
-!--          subsidence velocity w_subs(nzb) vanishes.
-             IF ( w_subs(nzb+1) >= 0.0_wp )  THEN
-                var_mod(nzb) = var_init(nzb)
-             ENDIF
-
-             var_init = var_mod 
-
-          ENDIF
-       ENDIF
-
- END SUBROUTINE subsidence_ij
-
-
- END MODULE subsidence_mod
Index: /palm/trunk/SOURCE/subsidence_mod.f90
===================================================================
--- /palm/trunk/SOURCE/subsidence_mod.f90	(revision 1850)
+++ /palm/trunk/SOURCE/subsidence_mod.f90	(revision 1850)
@@ -0,0 +1,382 @@
+!> @file subsidence_mod.f90
+!--------------------------------------------------------------------------------!
+! This file is part of PALM.
+!
+! PALM is free software: you can redistribute it and/or modify it under the terms
+! of the GNU General Public License as published by the Free Software Foundation,
+! either version 3 of the License, or (at your option) any later version.
+!
+! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
+! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
+! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along with
+! PALM. If not, see <http://www.gnu.org/licenses/>.
+!
+! Copyright 1997-2016 Leibniz Universitaet Hannover
+!--------------------------------------------------------------------------------!
+!
+! Current revisions:
+! -----------------
+! Module renamed
+! 
+! 
+! Former revisions:
+! -----------------
+! $Id$
+!
+! 1729 2015-11-20 11:01:48Z gronemeier
+! Bugfix: shifting of initial profiles only once each time step
+! 
+! 1682 2015-10-07 23:56:08Z knoop
+! Code annotations made doxygen readable 
+!
+! 1489 2014-10-30 08:09:12Z raasch
+! bugfix: sums_ls_l can only be used if large_scale_forcing is switched on
+!
+! 1382 2014-04-30 12:15:41Z boeske
+! Changed the weighting factor that is used in the summation of subsidence 
+! tendencies for profile data output from weight_pres to weight_substep
+! added Neumann boundary conditions for profile data output of subsidence terms
+! at nzt+1
+! 
+! 1380 2014-04-28 12:40:45Z heinze
+! Shifting only necessary in case of scalar Rayleigh damping
+! 
+! 1365 2014-04-22 15:03:56Z boeske
+! Summation of subsidence tendencies for data output added 
+! +ls_index, sums_ls_l, tmp_tend
+! 
+! 1353 2014-04-08 15:21:23Z heinze
+! REAL constants provided with KIND-attribute
+! 
+! 1320 2014-03-20 08:40:49Z raasch
+! ONLY-attribute added to USE-statements,
+! kind-parameters added to all INTEGER and REAL declaration statements,
+! kinds are defined in new module kinds,
+! old module precision_kind is removed,
+! revision history before 2012 removed,
+! comment fields (!:) to be used for variable explanations added to
+! all variable declaration statements 
+!
+! 1036 2012-10-22 13:43:42Z raasch
+! code put under GPL (PALM 3.9)
+!
+! Revision 3.7 2009-12-11 14:15:58Z heinze
+! Initial revision 
+!
+! Description:
+! ------------
+!> Impact of large-scale subsidence or ascent as tendency term for use 
+!> in the prognostic equation of potential temperature. This enables the 
+!> construction of a constant boundary layer height z_i with time.
+!-----------------------------------------------------------------------------!
+ MODULE subsidence_mod
+ 
+
+
+    IMPLICIT NONE
+
+    PRIVATE
+    PUBLIC  init_w_subsidence, subsidence
+
+    INTERFACE init_w_subsidence
+       MODULE PROCEDURE init_w_subsidence
+    END INTERFACE init_w_subsidence
+
+    INTERFACE subsidence
+       MODULE PROCEDURE subsidence
+       MODULE PROCEDURE subsidence_ij
+    END INTERFACE subsidence
+
+ CONTAINS
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> @todo Missing subroutine description.
+!------------------------------------------------------------------------------!
+    SUBROUTINE init_w_subsidence 
+
+       USE arrays_3d,                                                          &
+           ONLY:  dzu, w_subs, zu
+
+       USE control_parameters,                                                 &
+           ONLY:  message_string, ocean, subs_vertical_gradient,               &
+                  subs_vertical_gradient_level, subs_vertical_gradient_level_i
+
+       USE indices,                                                            &
+           ONLY:  nzb, nzt
+
+       USE kinds
+
+       IMPLICIT NONE
+
+       INTEGER(iwp) ::  i !< 
+       INTEGER(iwp) ::  k !< 
+
+       REAL(wp)     ::  gradient   !< 
+       REAL(wp)     ::  ws_surface !< 
+
+       IF ( .NOT. ALLOCATED( w_subs ))  THEN
+          ALLOCATE( w_subs(nzb:nzt+1) )
+          w_subs = 0.0_wp
+       ENDIF 
+
+       IF ( ocean )  THEN
+          message_string = 'Applying large scale vertical motion is not ' // &
+                           'allowed for ocean runs'
+          CALL message( 'init_w_subsidence', 'PA0324', 2, 2, 0, 6, 0 )
+       ENDIF
+
+!
+!--   Compute the profile of the subsidence/ascent velocity 
+!--   using the given gradients
+      i = 1
+      gradient = 0.0_wp
+      ws_surface = 0.0_wp
+      
+
+      subs_vertical_gradient_level_i(1) = 0
+      DO  k = 1, nzt+1
+         IF ( i < 11 )  THEN
+            IF ( subs_vertical_gradient_level(i) < zu(k)  .AND. &
+                 subs_vertical_gradient_level(i) >= 0.0_wp )  THEN
+               gradient = subs_vertical_gradient(i) / 100.0_wp
+               subs_vertical_gradient_level_i(i) = k - 1
+               i = i + 1
+            ENDIF
+         ENDIF
+         IF ( gradient /= 0.0_wp )  THEN
+            IF ( k /= 1 )  THEN
+               w_subs(k) = w_subs(k-1) + dzu(k) * gradient
+            ELSE
+               w_subs(k) = ws_surface   + 0.5_wp * dzu(k) * gradient
+            ENDIF
+         ELSE
+            w_subs(k) = w_subs(k-1)
+         ENDIF
+      ENDDO
+
+!
+!--   In case of no given gradients for the subsidence/ascent velocity,
+!--   choose zero gradient
+      IF ( subs_vertical_gradient_level(1) == -9999999.9_wp )  THEN
+         subs_vertical_gradient_level(1) = 0.0_wp
+      ENDIF
+
+    END SUBROUTINE init_w_subsidence
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> @todo Missing subroutine description.
+!------------------------------------------------------------------------------!
+    SUBROUTINE subsidence( tendency, var, var_init, ls_index ) 
+
+       USE arrays_3d,                                                          &
+           ONLY:  ddzu, w_subs
+
+       USE control_parameters,                                                 &
+           ONLY:  dt_3d, intermediate_timestep_count, large_scale_forcing,     &
+                  scalar_rayleigh_damping
+
+       USE indices,                                                            &
+           ONLY:  nxl, nxlg, nxr, nxrg, nyn, nyng, nys, nysg, nzb, nzb_s_inner,&
+                  nzt
+
+       USE kinds
+
+       USE statistics,                                                         &
+           ONLY:  sums_ls_l, weight_substep
+
+       IMPLICIT NONE
+ 
+       INTEGER(iwp) ::  i !< 
+       INTEGER(iwp) ::  j !< 
+       INTEGER(iwp) ::  k !< 
+       INTEGER(iwp) ::  ls_index !<
+
+       REAL(wp)     ::  tmp_tend !<
+       REAL(wp)     ::  tmp_grad !< 
+    
+       REAL(wp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ::  var      !< 
+       REAL(wp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ::  tendency !< 
+       REAL(wp), DIMENSION(nzb:nzt+1) ::  var_init                     !< 
+       REAL(wp), DIMENSION(nzb:nzt+1) ::  var_mod                      !< 
+
+       var_mod = var_init
+
+!
+!--    Influence of w_subsidence on the current tendency term
+       DO  i = nxl, nxr
+          DO  j = nys, nyn
+
+             DO  k = nzb_s_inner(j,i)+1, nzt 
+                IF ( w_subs(k) < 0.0_wp )  THEN    ! large-scale subsidence
+                   tmp_tend = - w_subs(k) *                                    &
+                              ( var(k+1,j,i) - var(k,j,i) ) * ddzu(k+1)
+                ELSE                               ! large-scale ascent
+                   tmp_tend = - w_subs(k) *                                    &
+                              ( var(k,j,i) - var(k-1,j,i) ) * ddzu(k)
+                ENDIF
+
+                tendency(k,j,i) = tendency(k,j,i) + tmp_tend
+
+                IF ( large_scale_forcing )  THEN
+                   sums_ls_l(k,ls_index) = sums_ls_l(k,ls_index) + tmp_tend    &
+                                   * weight_substep(intermediate_timestep_count)
+                ENDIF
+             ENDDO
+
+             sums_ls_l(nzt+1,ls_index) = sums_ls_l(nzt,ls_index)
+
+          ENDDO
+       ENDDO
+
+!
+!--    Shifting of the initial profile is especially necessary with Rayleigh 
+!--    damping switched on
+       IF ( scalar_rayleigh_damping .AND.                                      &
+            intermediate_timestep_count == 1 )  THEN
+          DO  k = nzb, nzt
+             IF ( w_subs(k) < 0.0_wp )  THEN      ! large-scale subsidence
+                var_mod(k) = var_init(k) - dt_3d * w_subs(k) *  &
+                                  ( var_init(k+1) - var_init(k) ) * ddzu(k+1)
+             ENDIF
+          ENDDO
+!
+!--      At the upper boundary, the initial profile is shifted with aid of 
+!--      the gradient tmp_grad. (This is ok if the gradients are linear.)
+         IF ( w_subs(nzt) < 0.0_wp )  THEN
+            tmp_grad = ( var_init(nzt+1) - var_init(nzt) ) * ddzu(nzt+1)
+            var_mod(nzt+1) = var_init(nzt+1) -  &
+                                 dt_3d * w_subs(nzt+1) * tmp_grad
+         ENDIF
+       
+
+         DO  k = nzt+1, nzb+1, -1
+            IF ( w_subs(k) >= 0.0_wp )  THEN  ! large-scale ascent
+               var_mod(k) = var_init(k) - dt_3d * w_subs(k) *  &
+                                  ( var_init(k) - var_init(k-1) ) * ddzu(k) 
+            ENDIF
+         ENDDO
+!
+!--      At the lower boundary shifting is not necessary because the 
+!--      subsidence velocity w_subs(nzb) vanishes.
+         IF ( w_subs(nzb+1) >= 0.0_wp )  THEN
+            var_mod(nzb) = var_init(nzb)
+         ENDIF
+
+         var_init = var_mod
+      ENDIF
+
+
+ END SUBROUTINE subsidence
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> @todo Missing subroutine description.
+!------------------------------------------------------------------------------!
+ SUBROUTINE subsidence_ij( i, j, tendency, var, var_init, ls_index ) 
+
+       USE arrays_3d,                                                          &
+           ONLY:  ddzu, w_subs
+
+       USE control_parameters,                                                 &
+           ONLY:  dt_3d, intermediate_timestep_count, large_scale_forcing,     &
+                  scalar_rayleigh_damping
+
+       USE indices,                                                            &
+           ONLY:  nxl, nxlg, nxrg, nyng, nys, nysg, nzb_s_inner, nzb, nzt
+
+       USE kinds
+
+       USE statistics,                                                         &
+           ONLY:  sums_ls_l, weight_substep
+
+       IMPLICIT NONE
+ 
+       INTEGER(iwp) ::  i !< 
+       INTEGER(iwp) ::  j !< 
+       INTEGER(iwp) ::  k !< 
+       INTEGER(iwp) ::  ls_index !<
+
+       REAL(wp)     ::  tmp_tend !<
+       REAL(wp)     ::  tmp_grad !< 
+    
+       REAL(wp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ::  var      !< 
+       REAL(wp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ::  tendency !< 
+       REAL(wp), DIMENSION(nzb:nzt+1) ::  var_init                     !< 
+       REAL(wp), DIMENSION(nzb:nzt+1) ::  var_mod                      !< 
+
+       var_mod = var_init
+
+!
+!--    Influence of w_subsidence on the current tendency term
+       DO  k = nzb_s_inner(j,i)+1, nzt 
+          IF ( w_subs(k) < 0.0_wp )  THEN      ! large-scale subsidence
+             tmp_tend = - w_subs(k) * ( var(k+1,j,i) - var(k,j,i) ) * ddzu(k+1)
+          ELSE                                 ! large-scale ascent
+             tmp_tend = - w_subs(k) * ( var(k,j,i) - var(k-1,j,i) ) * ddzu(k)
+          ENDIF
+
+          tendency(k,j,i) = tendency(k,j,i) + tmp_tend
+
+          IF ( large_scale_forcing )  THEN
+             sums_ls_l(k,ls_index) = sums_ls_l(k,ls_index) + tmp_tend          &
+                                   * weight_substep(intermediate_timestep_count)
+          ENDIF
+       ENDDO
+
+       IF ( large_scale_forcing )  THEN
+          sums_ls_l(nzt+1,ls_index) = sums_ls_l(nzt,ls_index)
+       ENDIF
+
+!
+!--    Shifting of the initial profile is especially necessary with Rayleigh 
+!--    damping switched on
+       IF ( scalar_rayleigh_damping .AND.                                      &
+            intermediate_timestep_count == 1 )  THEN
+          IF ( i == nxl .AND. j == nys )  THEN ! shifting only once per PE 
+
+             DO  k = nzb, nzt
+                IF ( w_subs(k) < 0.0_wp )  THEN      ! large-scale subsidence
+                   var_mod(k) = var_init(k) - dt_3d * w_subs(k) *  &
+                                     ( var_init(k+1) - var_init(k) ) * ddzu(k+1)
+                ENDIF
+             ENDDO
+!
+!--          At the upper boundary, the initial profile is shifted with aid of 
+!--          the gradient tmp_grad. (This is ok if the gradients are linear.)
+             IF ( w_subs(nzt) < 0.0_wp )  THEN
+                tmp_grad = ( var_init(nzt+1) - var_init(nzt) ) * ddzu(nzt+1)
+                var_mod(nzt+1) = var_init(nzt+1) -  &
+                                     dt_3d * w_subs(nzt+1) * tmp_grad
+             ENDIF
+       
+
+             DO  k = nzt+1, nzb+1, -1
+                IF ( w_subs(k) >= 0.0_wp )  THEN  ! large-scale ascent
+                   var_mod(k) = var_init(k) - dt_3d * w_subs(k) *  &
+                                      ( var_init(k) - var_init(k-1) ) * ddzu(k)
+                ENDIF
+             ENDDO
+!
+!--          At the lower boundary shifting is not necessary because the 
+!--          subsidence velocity w_subs(nzb) vanishes.
+             IF ( w_subs(nzb+1) >= 0.0_wp )  THEN
+                var_mod(nzb) = var_init(nzb)
+             ENDIF
+
+             var_init = var_mod 
+
+          ENDIF
+       ENDIF
+
+ END SUBROUTINE subsidence_ij
+
+
+ END MODULE subsidence_mod
Index: lm/trunk/SOURCE/surface_layer_fluxes.f90
===================================================================
--- /palm/trunk/SOURCE/surface_layer_fluxes.f90	(revision 1849)
+++ 	(revision )
@@ -1,1149 +1,0 @@
-!> @file surface_layer_fluxes.f90
-!--------------------------------------------------------------------------------!
-! This file is part of PALM.
-!
-! PALM is free software: you can redistribute it and/or modify it under the terms
-! of the GNU General Public License as published by the Free Software Foundation,
-! either version 3 of the License, or (at your option) any later version.
-!
-! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
-! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
-! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along with
-! PALM. If not, see <http://www.gnu.org/licenses/>.
-!
-! Copyright 1997-2016 Leibniz Universitaet Hannover
-!
-!--------------------------------------------------------------------------------!
-! Current revisions:
-! ------------------
-!
-! 
-! Former revisions:
-! -----------------
-! $Id$
-!
-! 1822 2016-04-07 07:49:42Z hoffmann
-! icloud_scheme replaced by microphysics_*
-!
-! 1788 2016-03-10 11:01:04Z maronga
-! Added parameter z0q which replaces z0h in the similarity functions for
-! humidity.
-! Syntax layout improved.
-! 
-! 1757 2016-02-22 15:49:32Z maronga
-! Minor fixes.
-!
-! 1749 2016-02-09 12:19:56Z raasch
-! further OpenACC adjustments
-!
-! 1747 2016-02-08 12:25:53Z raasch
-! adjustments for OpenACC usage
-!
-! 1709 2015-11-04 14:47:01Z maronga
-! Bugfix: division by zero could occur when calculating rib at low wind speeds
-! Bugfix: calculation of uv_total for neutral = .T., initial value for ol for
-! neutral = .T.
-! 
-! 1705 2015-11-02 14:28:56Z maronga
-! Typo removed
-!
-! 1697 2015-10-28 17:14:10Z raasch
-! FORTRAN and OpenMP errors removed
-!
-! 1696 2015-10-27 10:03:34Z maronga
-! Modularized and completely re-written version of prandtl_fluxes.f90. In the
-! course of the re-writing two additional methods have been implemented. See
-! updated description.
-!
-! 1551 2015-03-03 14:18:16Z maronga
-! Removed land surface model part. The surface fluxes are now always calculated
-! within prandtl_fluxes, based on the given surface temperature/humidity (which 
-! is either provided by the land surface model, by large scale forcing data, or
-! directly prescribed by the user.
-! 
-! 1496 2014-12-02 17:25:50Z maronga
-! Adapted for land surface model
-! 
-! 1494 2014-11-21 17:14:03Z maronga
-! Bugfixes: qs is now calculated before calculation of Rif. calculation of
-! buoyancy flux in Rif corrected (added missing humidity term), allow use of 
-! topography for coupled runs (not tested)
-! 
-! 1361 2014-04-16 15:17:48Z hoffmann
-! Bugfix: calculation of turbulent fluxes of rain water content (qrsws) and rain 
-! drop concentration (nrsws) added
-! 
-! 1340 2014-03-25 19:45:13Z kanani
-! REAL constants defined as wp-kind
-!
-! 1320 2014-03-20 08:40:49Z raasch
-! ONLY-attribute added to USE-statements,
-! kind-parameters added to all INTEGER and REAL declaration statements,
-! kinds are defined in new module kinds,
-! old module precision_kind is removed,
-! revision history before 2012 removed,
-! comment fields (!:) to be used for variable explanations added to
-! all variable declaration statements
-!
-! 1276 2014-01-15 13:40:41Z heinze
-! Use LSF_DATA also in case of Dirichlet bottom boundary condition for scalars
-!
-! 1257 2013-11-08 15:18:40Z raasch
-! openACC "kernels do" replaced by "kernels loop", "loop independent" added
-!
-! 1036 2012-10-22 13:43:42Z raasch
-! code put under GPL (PALM 3.9)
-!
-! 1015 2012-09-27 09:23:24Z raasch
-! OpenACC statements added
-!
-! 978 2012-08-09 08:28:32Z fricke
-! roughness length for scalar quantities z0h added
-!
-! Revision 1.1  1998/01/23 10:06:06  raasch
-! Initial revision
-!
-!
-! Description:
-! ------------
-!> Diagnostic computation of vertical fluxes in the constant flux layer from the
-!> values of the variables at grid point k=1. Three different methods are
-!> available:
-!> 1) the "old" version (most_method = 'circular') which is fast, but inaccurate
-!> 2) a Newton iteration method (most_method = 'newton'), which is accurate, but
-!>    slower
-!> 3) a method using a lookup table which is fast and accurate. Note, however,
-!>    that this method cannot be used in case of roughness heterogeneity
-!>
-!> @todo (re)move large_scale_forcing actions
-!> @todo check/optimize OpenMP and OpenACC directives
-!------------------------------------------------------------------------------!
- MODULE surface_layer_fluxes_mod
-
-    USE arrays_3d,                                                             &
-        ONLY:  e, kh, nr, nrs, nrsws, ol, pt, q, ql, qr, qrs, qrsws, qs, qsws, &
-               shf, ts, u, us, usws, v, vpt, vsws, zu, zw, z0, z0h, z0q
-
-    USE cloud_parameters,                                                      &
-        ONLY:  l_d_cp, pt_d_t
-
-    USE constants,                                                             &
-        ONLY:  pi
-
-    USE cpulog
-
-    USE control_parameters,                                                    &
-        ONLY:  cloud_physics, constant_heatflux, constant_waterflux,           &
-               coupling_mode, g, humidity, ibc_e_b, ibc_pt_b,                  &
-               initializing_actions, kappa, intermediate_timestep_count,       &
-               intermediate_timestep_count_max, large_scale_forcing, lsf_surf, &
-               message_string, microphysics_seifert, most_method, neutral,     &
-               passive_scalar, pt_surface, q_surface, run_coupled,             &
-               surface_pressure, simulated_time, terminate_run, zeta_max,      &
-               zeta_min 
-
-    USE indices,                                                               &
-        ONLY:  nxl, nxlg, nxr, nxrg, nys, nysg, nyn, nyng, nzb_s_inner,        &
-               nzb_u_inner, nzb_v_inner
-
-    USE kinds
-
-    USE pegrid
-
-    USE land_surface_model_mod,                                                &
-        ONLY:  land_surface, skip_time_do_lsm
-
-    IMPLICIT NONE
-
-    INTEGER(iwp) ::  i            !< loop index x direction
-    INTEGER(iwp) ::  j            !< loop index y direction
-    INTEGER(iwp) ::  k            !< loop index z direction
-
-    INTEGER(iwp), PARAMETER     :: num_steps = 15000  !< number of steps in the lookup table
-
-    LOGICAL      ::  coupled_run  !< Flag for coupled atmosphere-ocean runs
-
-    REAL(wp), DIMENSION(:,:), ALLOCATABLE :: pt1,      & !< Potential temperature at first grid level (required for cloud_physics = .T.)
-                                             qv1,      & !< Specific humidity at first grid level (required for cloud_physics = .T.)
-                                             uv_total    !< Total velocity at first grid level
-
-    REAL(wp), DIMENSION(0:num_steps-1) :: rib_tab,  & !< Lookup table bulk Richardson number
-                                          ol_tab      !< Lookup table values of L
-
-    REAL(wp)     ::  e_s,               & !< Saturation water vapor pressure
-                     l_bnd  = 7500,     & !< Lookup table index of the last time step
-                     ol_max = 1.0E6_wp, & !< Maximum Obukhov length
-                     rib_max,           & !< Maximum Richardson number in lookup table
-                     rib_min,           & !< Minimum Richardson number in lookup table
-                     z_mo                 !< Height of the constant flux layer where MOST is assumed
-
-
-    SAVE
-
-    PRIVATE
-
-    PUBLIC init_surface_layer_fluxes, pt1, qv1, surface_layer_fluxes, uv_total
-
-    INTERFACE init_surface_layer_fluxes
-       MODULE PROCEDURE init_surface_layer_fluxes
-    END INTERFACE init_surface_layer_fluxes
-
-    INTERFACE surface_layer_fluxes
-       MODULE PROCEDURE surface_layer_fluxes
-    END INTERFACE surface_layer_fluxes
-
-
- CONTAINS
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Main routine to compute the surface fluxes
-!------------------------------------------------------------------------------!
-    SUBROUTINE surface_layer_fluxes
-
-       IMPLICIT NONE
-
-!
-!--    In case cloud physics is used, it is required to derive potential
-!--    temperature and specific humidity at first grid level from the fields pt 
-!--    and q
-       IF ( cloud_physics )  THEN
-          CALL calc_pt_q
-       ENDIF
-
-!
-!--    First, calculate the new Obukhov length, then new friction velocity,
-!--    followed by the new scaling parameters (th*, q*, etc.), and the new
-!--    surface fluxes if required. The old routine ("circular") requires a 
-!--    different order of calls as the scaling parameters from the previous time
-!--    steps are used to calculate the Obukhov length
-
-!
-!--    Depending on setting of most_method use the "old" routine
-       IF ( most_method == 'circular' )  THEN
-
-          CALL calc_scaling_parameters
-
-          CALL calc_uv_total
-
-          IF ( .NOT. neutral )  THEN
-             CALL calc_ol
-          ENDIF
-
-          CALL calc_us
-
-          CALL calc_surface_fluxes
-
-!
-!--    Use either Newton iteration or a lookup table for the bulk Richardson
-!--    number to calculate the Obukhov length 
-       ELSEIF ( most_method == 'newton'  .OR.  most_method == 'lookup' )  THEN
-
-          CALL calc_uv_total
-
-          IF ( .NOT. neutral )  THEN
-             CALL calc_ol
-          ENDIF
-
-          CALL calc_us
-
-          CALL calc_scaling_parameters
-
-          CALL calc_surface_fluxes
-
-       ENDIF
-
-    END SUBROUTINE surface_layer_fluxes
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Initializing actions for the surface layer routine. Basically, this involves
-!> the preparation of a lookup table for the the bulk Richardson number vs 
-!> Obukhov length L when using the lookup table method.
-!------------------------------------------------------------------------------!
-    SUBROUTINE init_surface_layer_fluxes
-
-       IMPLICIT NONE
-
-       INTEGER(iwp) :: l,          & !< Index for loop to create lookup table
-                       num_steps_n   !< Number of non-stretched zeta steps
-
-       LOGICAL :: terminate_run_l = .FALSE.    !< Flag to terminate run (global)
-
-       REAL(wp), PARAMETER ::  zeta_stretch = -10.0_wp !< Start of stretching in the free convection limit
-                               
-       REAL(wp), DIMENSION(:), ALLOCATABLE :: zeta_tmp
-
-
-       REAL(wp) :: zeta_step,            & !< Increment of zeta
-                   regr      = 1.01_wp,  & !< Stretching factor of zeta_step in the free convection limit
-                   regr_old  = 1.0E9_wp, & !< Stretching factor of last iteration step
-                   z0h_min   = 0.0_wp,   & !< Minimum value of z0h to create table
-                   z0_min    = 0.0_wp      !< Minimum value of z0 to create table
-!
-!--    When cloud physics is used, arrays for storing potential temperature and
-!--    specific humidity at first grid level are required
-       IF ( cloud_physics )  THEN
-          ALLOCATE ( pt1(nysg:nyng,nxlg:nxrg) )
-          ALLOCATE ( qv1(nysg:nyng,nxlg:nxrg) )
-       ENDIF
-
-!
-!--    Allocate field for storing the horizontal velocity
-       ALLOCATE ( uv_total(nysg:nyng,nxlg:nxrg) )
-
-
-!
-!--    In case of runs with neutral statification, set Obukhov length to a
-!--    large value
-       IF ( neutral ) ol = 1.0E10_wp
-
-       IF ( most_method == 'lookup' )  THEN
-
-!
-!--       Check for roughness heterogeneity. In that case terminate run and
-!--       inform user
-          IF ( MINVAL( z0h ) /= MAXVAL( z0h )  .OR.                            &
-               MINVAL( z0  ) /= MAXVAL( z0  ) )  THEN
-             terminate_run_l = .TRUE.
-          ENDIF
-
-#if defined( __parallel )
-!
-!--       Make a logical OR for all processes. Force termiation of model if result
-!--       is TRUE
-          IF ( collective_wait )  CALL MPI_BARRIER( comm2d, ierr )
-          CALL MPI_ALLREDUCE( terminate_run_l, terminate_run, 1, MPI_LOGICAL,  &
-                              MPI_LOR, comm2d, ierr )
-#else
-          terminate_run = terminate_run_l
-#endif
-
-          IF ( terminate_run )  THEN
-             message_string = 'most_method = "lookup" cannot be used in ' //   &
-                              'combination with a prescribed roughness '  //   &
-                              'heterogeneity'
-             CALL message( 'surface_layer_fluxes', 'PA0417', 1, 2, 0, 6, 0 )
-          ENDIF
-
-          ALLOCATE(  zeta_tmp(0:num_steps-1) )
-
-!
-!--       Use the lowest possible value for z_mo
-          k    = MINVAL(nzb_s_inner)
-          z_mo = zu(k+1) - zw(k)
-
-!
-!--       Calculate z/L range from zeta_stretch to zeta_max using 90% of the
-!--       available steps (num_steps). The calculation is done with negative
-!--       values of zeta in order to simplify the stretching in the free
-!--       convection limit for the remaining 10% of steps.
-          zeta_tmp(0) = - zeta_max
-          num_steps_n = ( num_steps * 9 / 10 ) - 1
-          zeta_step   = (zeta_max - zeta_stretch) / REAL(num_steps_n)
-
-          DO l = 1, num_steps_n
-             zeta_tmp(l) = zeta_tmp(l-1) + zeta_step
-          ENDDO
-
-!
-!--       Calculate stretching factor for the free convection range
-          DO  WHILE ( ABS( (regr-regr_old) / regr_old ) > 1.0E-10_wp )
-             regr_old = regr
-             regr = ( 1.0_wp - ( -zeta_min / zeta_step ) * ( 1.0_wp - regr )   &
-                    )**( 10.0_wp / REAL(num_steps) )
-          ENDDO
-
-!
-!--       Calculate z/L range from zeta_min to zeta_stretch
-          DO l = num_steps_n+1, num_steps-1
-             zeta_tmp(l) = zeta_tmp(l-1) + zeta_step
-             zeta_step = zeta_step * regr
-          ENDDO
-
-!
-!--       Save roughness lengths to temporary variables
-          z0h_min = z0h(nys,nxl)
-          z0_min  = z0(nys,nxl)
-          
-!
-!--       Calculate lookup table for the Richardson number versus Obukhov length
-!--       The Richardson number (rib) is defined depending on the choice of 
-!--       boundary conditions for temperature
-          IF ( ibc_pt_b == 1 )  THEN
-             DO l = 0, num_steps-1
-                ol_tab(l)  = - z_mo / zeta_tmp(num_steps-1-l)
-                rib_tab(l) = z_mo / ol_tab(l)  / ( LOG( z_mo / z0_min )        &
-                                                - psi_m( z_mo / ol_tab(l) )    &
-                                                + psi_m( z0_min / ol_tab(l) )  &
-                                                  )**3
-             ENDDO  
-          ELSE
-             DO l = 0, num_steps-1
-                ol_tab(l)  = - z_mo / zeta_tmp(num_steps-1-l)
-                rib_tab(l) = z_mo / ol_tab(l)  * ( LOG( z_mo / z0h_min )       &
-                                              - psi_h( z_mo / ol_tab(l) )      &
-                                              + psi_h( z0h_min / ol_tab(l) )   &
-                                            )                                  &
-                                          / ( LOG( z_mo / z0_min )             &
-                                              - psi_m( z_mo / ol_tab(l) )      &
-                                              + psi_m( z0_min / ol_tab(l) )    &
-                                            )**2
-             ENDDO
-          ENDIF
-
-!
-!--       Determine minimum values of rib in the lookup table. Set upper limit 
-!--       to critical Richardson number (0.25)
-          rib_min  = MINVAL(rib_tab)
-          rib_max  = 0.25 !MAXVAL(rib_tab)
-
-          DEALLOCATE( zeta_tmp )
-       ENDIF
-
-    END SUBROUTINE init_surface_layer_fluxes
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Compute the absolute value of the horizontal velocity (relative to the
-!> surface). This is required by all methods
-!------------------------------------------------------------------------------!
-    SUBROUTINE calc_uv_total
-
-       IMPLICIT NONE
-
-
-       !$OMP PARALLEL DO PRIVATE( k )
-       !$acc kernels loop present( nzb_s_inner, u, uv_total, v ) private( j, k )
-       DO  i = nxl, nxr
-          DO  j = nys, nyn
-
-             k   = nzb_s_inner(j,i)
-             uv_total(j,i) = SQRT( ( 0.5_wp * ( u(k+1,j,i) + u(k+1,j,i+1)      &
-                                         - u(k,j,i)   - u(k,j,i+1) ) )**2 +    &
-                              ( 0.5_wp * ( v(k+1,j,i) + v(k+1,j+1,i)           &
-                                         - v(k,j,i)   - v(k,j+1,i) ) )**2 )
-
-!
-!--          For too small values of the local wind, MOST does not work. A
-!--          threshold value is thus set if required
-!            uv_total(j,i) = MAX(0.01_wp,uv_total(j,i))
-
-          ENDDO
-       ENDDO
-
-!
-!--    Values of uv_total need to be exchanged at the ghost boundaries
-       !$acc update host( uv_total )
-       CALL exchange_horiz_2d( uv_total )
-       !$acc update device( uv_total )
-
-    END SUBROUTINE calc_uv_total
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Calculate the Obukhov length (L) and Richardson flux number (z/L)
-!------------------------------------------------------------------------------!
-    SUBROUTINE calc_ol
-
-       IMPLICIT NONE
-
-       INTEGER(iwp) :: iter,  & !< Newton iteration step
-                       l        !< look index
-
-       REAL(wp), DIMENSION(nysg:nyng,nxlg:nxrg) :: rib !< Bulk Richardson number
-
-       REAL(wp)     :: f,      & !< Function for Newton iteration: f = Ri - [...]/[...]^2 = 0
-                       f_d_ol, & !< Derivative of f
-                       ol_l,   & !< Lower bound of L for Newton iteration
-                       ol_m,   & !< Previous value of L for Newton iteration
-                       ol_old, & !< Previous time step value of L
-                       ol_u      !< Upper bound of L for Newton iteration
-
-       IF ( TRIM( most_method ) /= 'circular' )  THEN
-      
-          !$acc data present( nzb_s_inner, pt, q, qsws, rib, shf, uv_total, vpt, zu, zw )
-
-          !$OMP PARALLEL DO PRIVATE( k, z_mo )
-          !$acc kernels loop private( j, k, z_mo )
-          DO  i = nxl, nxr
-             DO  j = nys, nyn
-
-                k   = nzb_s_inner(j,i)
-                z_mo = zu(k+1) - zw(k)
-
-!
-!--             Evaluate bulk Richardson number (calculation depends on
-!--             definition based on setting of boundary conditions
-                IF ( ibc_pt_b /= 1 )  THEN
-                   IF ( humidity )  THEN
-                      rib(j,i) = g * z_mo * ( vpt(k+1,j,i) - vpt(k,j,i) )      &
-                           / ( uv_total(j,i)**2 * vpt(k+1,j,i) + 1.0E-20_wp )
-                   ELSE
-                      rib(j,i) = g * z_mo * ( pt(k+1,j,i) - pt(k,j,i) )        &
-                           / ( uv_total(j,i)**2 * pt(k+1,j,i)  + 1.0E-20_wp )
-                   ENDIF      
-                ELSE
-!
-!--                When using Neumann boundary conditions, the buoyancy flux
-!--                is required but cannot be calculated at the surface, as pt
-!--                and q are not known at the surface. Hence the values at 
-!--                first grid level are used to estimate the buoyancy flux
-                   IF ( humidity )  THEN
-                      rib(j,i) = - g * z_mo * ( ( 1.0_wp + 0.61_wp             &
-                                 * q(k+1,j,i) ) * shf(j,i) + 0.61_wp           &
-                                 * pt(k+1,j,i) * qsws(j,i) )   &
-                                 / ( uv_total(j,i)**3 * vpt(k+1,j,i) * kappa**2&
-                                 + 1.0E-20_wp)
-                   ELSE
-                      rib(j,i) = - g * z_mo * shf(j,i)                         &
-                           / ( uv_total(j,i)**3 * pt(k+1,j,i) * kappa**2       &
-                           + 1.0E-20_wp )
-                   ENDIF
-                ENDIF  
-     
-             ENDDO
-          ENDDO 
-          !$acc end data
-
-       ENDIF
-
-!
-!--    Calculate the Obukhov length either using a Newton iteration
-!--    method, via a lookup table, or using the old circular way
-       IF ( TRIM( most_method ) == 'newton' )  THEN
-
-          !$OMP PARALLEL DO PRIVATE( k, z_mo )
-          !# WARNING: does not work on GPU so far because of DO-loop with
-          !#          undetermined iterations
-          !!!!!!$acc kernels loop
-          DO  i = nxl, nxr
-             DO  j = nys, nyn
-
-                k   = nzb_s_inner(j,i)
-                z_mo = zu(k+1) - zw(k)
-
-!
-!--             Store current value in case the Newton iteration fails
-                ol_old = ol(j,i)
-
-!
-!--             Ensure that the bulk Richardson number and the Obukhov 
-!--             lengtH have the same sign
-                IF ( rib(j,i) * ol(j,i) < 0.0_wp  .OR.                         &
-                     ABS( ol(j,i) ) == ol_max )  THEN
-                   IF ( rib(j,i) > 0.0_wp ) ol(j,i) =  0.01_wp
-                   IF ( rib(j,i) < 0.0_wp ) ol(j,i) = -0.01_wp
-                ENDIF
-!
-!--             Iteration to find Obukhov length
-                iter = 0
-                DO
-                   iter = iter + 1
-!
-!--                In case of divergence, use the value of the previous time step
-                   IF ( iter > 1000 )  THEN
-                      ol(j,i) = ol_old
-                      EXIT
-                   ENDIF
-
-                   ol_m = ol(j,i)
-                   ol_l = ol_m - 0.001_wp * ol_m
-                   ol_u = ol_m + 0.001_wp * ol_m
-
-
-                   IF ( ibc_pt_b /= 1 )  THEN
-!
-!--                   Calculate f = Ri - [...]/[...]^2 = 0
-                      f = rib(j,i) - ( z_mo / ol_m ) * ( LOG( z_mo / z0h(j,i) )&
-                                                    - psi_h( z_mo / ol_m )     &
-                                                    + psi_h( z0h(j,i) / ol_m ) &
-                                                   )                           &
-                                                 / ( LOG( z_mo / z0(j,i) )     &
-                                                    - psi_m( z_mo / ol_m )     &
-                                                    + psi_m( z0(j,i) / ol_m )  &
-                                                    )**2
-
-!
-!--                    Calculate df/dL
-                       f_d_ol = ( - ( z_mo / ol_u ) * ( LOG( z_mo / z0h(j,i) ) &
-                                                   - psi_h( z_mo / ol_u )      &
-                                                   + psi_h( z0h(j,i) / ol_u )  &
-                                                 )                             &
-                                               / ( LOG( z_mo / z0(j,i) )       &
-                                                   - psi_m( z_mo / ol_u )      &
-                                                   + psi_m( z0(j,i) / ol_u )   &
-                                                 )**2                          &
-                              + ( z_mo / ol_l ) * ( LOG( z_mo / z0h(j,i) )     &
-                                                   - psi_h( z_mo / ol_l )      &
-                                                   + psi_h( z0h(j,i) / ol_l )  &
-                                                 )                             &
-                                               / ( LOG( z_mo / z0(j,i) )       &
-                                                   - psi_m( z_mo / ol_l )      &
-                                                   + psi_m( z0(j,i) / ol_l )   &
-                                                 )**2                          &
-                                ) / ( ol_u - ol_l )
-                   ELSE
-!
-!--                   Calculate f = Ri - 1 /[...]^3 = 0
-                      f = rib(j,i) - ( z_mo / ol_m ) / ( LOG( z_mo / z0(j,i) )&
-                                                    - psi_m( z_mo / ol_m )    &
-                                                    + psi_m( z0(j,i) / ol_m ) &
-                                                       )**3
-
-!
-!--                   Calculate df/dL
-                      f_d_ol = ( - ( z_mo / ol_u ) / ( LOG( z_mo / z0(j,i) )  &
-                                                   - psi_m( z_mo / ol_u )     &
-                                                   + psi_m( z0(j,i) / ol_u )  &
-                                                 )**3                         &
-                              + ( z_mo / ol_l ) / ( LOG( z_mo / z0(j,i) )     &
-                                                   - psi_m( z_mo / ol_l )     &
-                                                   + psi_m( z0(j,i) / ol_l )  &
-                                                 )**3                         &
-                                     ) / ( ol_u - ol_l )
-                   ENDIF
-!
-!--                Calculate new L
-                   ol(j,i) = ol_m - f / f_d_ol
-
-!
-!--                Ensure that the bulk Richardson number and the Obukhov 
-!--                length have the same sign and ensure convergence.
-                   IF ( ol(j,i) * ol_m < 0.0_wp )  ol(j,i) = ol_m * 0.5_wp
-
-!
-!--                If unrealistic value occurs, set L to the maximum
-!--                value that is allowed
-                   IF ( ABS( ol(j,i) ) > ol_max )  THEN
-                      ol(j,i) = ol_max
-                      EXIT
-                   ENDIF
-!
-!--                Check for convergence
-                   IF ( ABS( ( ol(j,i) - ol_m ) / ol(j,i) ) < 1.0E-4_wp )  THEN
-                      EXIT
-                   ELSE
-                      CYCLE
-                   ENDIF
-
-                ENDDO
-                       
-             ENDDO
-          ENDDO
-
-       ELSEIF ( TRIM( most_method ) == 'lookup' )  THEN
-
-          !$OMP PARALLEL DO PRIVATE( k, z_mo )
-          !# WARNING: does not work on GPU so far because of DO  WHILE construct
-          !!!!!!$acc kernels loop
-          DO  i = nxl, nxr
-             DO  j = nys, nyn
-
-!
-!--             If the bulk Richardson number is outside the range of the lookup
-!--             table, set it to the exceeding threshold value
-                IF ( rib(j,i) < rib_min )  rib(j,i) = rib_min
-                IF ( rib(j,i) > rib_max )  rib(j,i) = rib_max
-
-!
-!--             Find the correct index bounds for linear interpolation. As the
-!--             Richardson number will not differ very much from time step to
-!--             time step , use the index from the last step and search in the 
-!--             correct direction
-                l = l_bnd
-                IF ( rib_tab(l) - rib(j,i) > 0.0_wp )  THEN
-                   DO  WHILE ( rib_tab(l-1) - rib(j,i) > 0.0_wp  .AND.  l > 0 )
-                      l = l-1
-                   ENDDO
-                ELSE
-                   DO  WHILE ( rib_tab(l) - rib(j,i) < 0.0_wp                  &
-                              .AND.  l < num_steps-1 )
-                      l = l+1
-                   ENDDO
-                ENDIF
-                l_bnd = l
-
-!
-!--             Linear interpolation to find the correct value of z/L
-                ol(j,i) = ( ol_tab(l-1) + ( ol_tab(l) - ol_tab(l-1) )          &
-                            / (  rib_tab(l) - rib_tab(l-1) )                   &
-                            * ( rib(j,i) - rib_tab(l-1) ) )
-
-             ENDDO
-          ENDDO
-
-       ELSEIF ( TRIM( most_method ) == 'circular' )  THEN
-
-          !$OMP PARALLEL DO PRIVATE( k, z_mo )
-          !$acc kernels loop present( nzb_s_inner, ol, pt, pt1, q, ql, qs, qv1, ts, us, vpt, zu, zw ) private( j, k, z_mo )
-          DO  i = nxl, nxr
-             DO  j = nys, nyn
-
-                k   = nzb_s_inner(j,i)
-                z_mo = zu(k+1) - zw(k)
-
-                IF ( .NOT. humidity )  THEN
-                   ol(j,i) =  ( pt(k+1,j,i) *  us(j,i)**2 ) / ( kappa * g      &
-                              * ts(j,i) + 1E-30_wp )
-                ELSEIF ( cloud_physics )  THEN
-
-                   ol(j,i) =  ( vpt(k+1,j,i) * us(j,i)**2 ) / ( kappa * g      &
-                              * ( ts(j,i) + 0.61_wp * pt1(j,i) * qs(j,i)       &
-                              + 0.61_wp * qv1(j,i) * ts(j,i) - ts(j,i)         &
-                              * ql(k+1,j,i) ) + 1E-30_wp )
-                ELSE
-                   ol(j,i) =  ( vpt(k+1,j,i) *  us(j,i)**2 ) / ( kappa * g     &
-                              * ( ts(j,i) + 0.61_wp * pt(k+1,j,i) * qs(j,i)    &
-                                  + 0.61_wp * q(k+1,j,i) * ts(j,i) ) + 1E-30_wp )
-                ENDIF
-!
-!--             Limit the value range of the Obukhov length.
-!--             This is necessary for very small velocities (u,v --> 0), because
-!--             the absolute value of ol can then become very small, which in
-!--             consequence would result in very large shear stresses and very
-!--             small momentum fluxes (both are generally unrealistic).
-                IF ( ( z_mo / ol(j,i) ) < zeta_min )  ol(j,i) = z_mo / zeta_min
-                IF ( ( z_mo / ol(j,i) ) > zeta_max )  ol(j,i) = z_mo / zeta_max
-
-             ENDDO
-          ENDDO
-
-       ENDIF
-
-!
-!--    Values of ol at ghost point locations are needed for the evaluation
-!--    of usws and vsws.
-       !$acc update host( ol )
-       CALL exchange_horiz_2d( ol )
-       !$acc update device( ol )
-
-    END SUBROUTINE calc_ol
-
-!
-!-- Calculate friction velocity u*
-    SUBROUTINE calc_us
-
-       IMPLICIT NONE
-
-       !$OMP PARALLEL DO PRIVATE( k, z_mo )
-       !$acc kernels loop present( nzb_s_inner, ol, us, uv_total, zu, zw, z0 ) private( j, k, z_mo )
-       DO  i = nxlg, nxrg
-          DO  j = nysg, nyng
-
-             k   = nzb_s_inner(j,i)+1
-             z_mo = zu(k+1) - zw(k)
-
-!
-!--          Compute u* at the scalars' grid points
-             us(j,i) = kappa * uv_total(j,i) / ( LOG( z_mo / z0(j,i) )         &
-                                          - psi_m( z_mo / ol(j,i) )            &
-                                          + psi_m( z0(j,i) / ol(j,i) ) )
-          ENDDO
-       ENDDO
-
-    END SUBROUTINE calc_us
-
-!
-!-- Calculate potential temperature and specific humidity at first grid level
-    SUBROUTINE calc_pt_q
-
-       IMPLICIT NONE
-
-       !$acc kernels loop present( nzb_s_inner, pt, pt1, pt_d_t, q, ql, qv1 ) private( j, k )
-       DO  i = nxlg, nxrg
-          DO  j = nysg, nyng
-             k   = nzb_s_inner(j,i)+1
-             pt1(j,i) = pt(k,j,i) + l_d_cp * pt_d_t(k) * ql(k,j,i)
-             qv1(j,i) = q(k,j,i) - ql(k,j,i)
-          ENDDO
-       ENDDO
-
-    END SUBROUTINE calc_pt_q
-
-!
-!-- Calculate the other MOST scaling parameters theta*, q*, (qr*, nr*)
-    SUBROUTINE calc_scaling_parameters
-
-       IMPLICIT NONE
-
-!
-!--    Data information for accelerators
-       !$acc data present( e, nrsws, nzb_u_inner, nzb_v_inner, nzb_s_inner, pt )  &
-       !$acc      present( q, qs, qsws, qrsws, shf, ts, u, us, usws, v )     &
-       !$acc      present( vpt, vsws, zu, zw, z0, z0h )
-! 
-!--    Compute theta*
-       IF ( constant_heatflux )  THEN
-
-!
-!--       For a given heat flux in the surface layer:
-          !$OMP PARALLEL DO
-          !$acc kernels loop private( j )
-          DO  i = nxlg, nxrg
-             DO  j = nysg, nyng
-                ts(j,i) = -shf(j,i) / ( us(j,i) + 1E-30_wp )
-!
-!--             ts must be limited, because otherwise overflow may occur in case
-!--             of us=0 when computing ol further below
-                IF ( ts(j,i) < -1.05E5_wp )  ts(j,i) = -1.0E5_wp
-                IF ( ts(j,i) >   1.0E5_wp )  ts(j,i) =  1.0E5_wp
-             ENDDO
-          ENDDO
-
-       ELSE
-!
-!--       For a given surface temperature:
-          IF ( large_scale_forcing  .AND.  lsf_surf )  THEN
-             !$OMP PARALLEL DO
-             !$acc kernels loop private( j, k )
-             DO  i = nxlg, nxrg
-                DO  j = nysg, nyng
-                   k = nzb_s_inner(j,i)
-                   pt(k,j,i) = pt_surface
-                ENDDO
-             ENDDO
-          ENDIF
-
-          !$OMP PARALLEL DO PRIVATE( k, z_mo )
-          !$acc kernels loop present( nzb_s_inner, ol, pt, pt1, ts, zu, zw, z0h ) private( j, k, z_mo )
-          DO  i = nxlg, nxrg
-             DO  j = nysg, nyng
-
-                k   = nzb_s_inner(j,i)
-                z_mo = zu(k+1) - zw(k)
-
-                IF ( cloud_physics )  THEN
-                   ts(j,i) = kappa * ( pt1(j,i) - pt(k,j,i) )                  &
-                                     / ( LOG( z_mo / z0h(j,i) )                &
-                                         - psi_h( z_mo / ol(j,i) )             &
-                                         + psi_h( z0h(j,i) / ol(j,i) ) )
-                ELSE
-                   ts(j,i) = kappa * ( pt(k+1,j,i) - pt(k,j,i) )               &
-                                     / ( LOG( z_mo / z0h(j,i) )                &
-                                         - psi_h( z_mo / ol(j,i) )             &
-                                         + psi_h( z0h(j,i) / ol(j,i) ) )
-                ENDIF
-
-             ENDDO
-          ENDDO
-       ENDIF
-
-!
-!--    If required compute q*
-       IF ( humidity  .OR.  passive_scalar )  THEN
-          IF ( constant_waterflux )  THEN
-!
-!--          For a given water flux in the surface layer
-             !$OMP PARALLEL DO
-             !$acc kernels loop private( j )
-             DO  i = nxlg, nxrg
-                DO  j = nysg, nyng
-                   qs(j,i) = -qsws(j,i) / ( us(j,i) + 1E-30_wp )
-                ENDDO
-             ENDDO
-
-          ELSE
-             coupled_run = ( coupling_mode == 'atmosphere_to_ocean'  .AND.     &
-                             run_coupled )
-
-             IF ( large_scale_forcing  .AND.  lsf_surf )  THEN
-                !$OMP PARALLEL DO
-                !$acc kernels loop private( j, k )
-                DO  i = nxlg, nxrg
-                   DO  j = nysg, nyng
-                      k = nzb_s_inner(j,i)
-                      q(k,j,i) = q_surface
-                   ENDDO
-                ENDDO
-             ENDIF
-
-             !$OMP PARALLEL DO PRIVATE( e_s, k, z_mo )
-             !$acc kernels loop independent present( nzb_s_inner, ol, pt, q, qs, qv1, zu, zw, z0q ) private( e_s, j, k, z_mo )
-             DO  i = nxlg, nxrg
-                !$acc loop independent
-                DO  j = nysg, nyng
-
-                   k   = nzb_s_inner(j,i)
-                   z_mo = zu(k+1) - zw(k)
-
-!
-!--                Assume saturation for atmosphere coupled to ocean (but not
-!--                in case of precursor runs)
-                   IF ( coupled_run )  THEN
-                      e_s = 6.1_wp * &
-                              EXP( 0.07_wp * ( MIN(pt(k,j,i),pt(k+1,j,i))      &
-                                               - 273.15_wp ) )
-                      q(k,j,i) = 0.622_wp * e_s / ( surface_pressure - e_s )
-                   ENDIF
-
-                   IF ( cloud_physics )  THEN
-                      qs(j,i) = kappa * ( qv1(j,i) - q(k,j,i) )                &
-                                        / ( LOG( z_mo / z0q(j,i) )             &
-                                            - psi_h( z_mo / ol(j,i) )          &
-                                            + psi_h( z0q(j,i) / ol(j,i) ) )
-
-                   ELSE
-                      qs(j,i) = kappa * ( q(k+1,j,i) - q(k,j,i) )              &
-                                        / ( LOG( z_mo / z0q(j,i) )             &
-                                            - psi_h( z_mo / ol(j,i) )          &
-                                            + psi_h( z0q(j,i) / ol(j,i) ) )
-                   ENDIF
-
-                ENDDO
-             ENDDO
-          ENDIF
-       ENDIF
-
-
-!
-!--    If required compute qr* and nr*
-       IF ( cloud_physics  .AND.  microphysics_seifert )   &
-       THEN
-
-          !$OMP PARALLEL DO PRIVATE( k, z_mo )
-          !$acc kernels loop independent present( nr, nrs, nzb_s_inner, ol, qr, qrs, zu, zw, z0q ) private( j, k, z_mo )
-          DO  i = nxlg, nxrg
-             !$acc loop independent
-             DO  j = nysg, nyng
-
-                k   = nzb_s_inner(j,i)
-                z_mo = zu(k+1) - zw(k)
-
-                qrs(j,i) = kappa * ( qr(k+1,j,i) - qr(k,j,i) )              &
-                                 / ( LOG( z_mo / z0q(j,i) )                 &
-                                     - psi_h( z_mo / ol(j,i) )              &
-                                     + psi_h( z0q(j,i) / ol(j,i) ) )
-
-                nrs(j,i) = kappa * ( nr(k+1,j,i) - nr(k,j,i) )              &
-                                 / ( LOG( z_mo / z0q(j,i) )                 &
-                                     - psi_h( z_mo / ol(j,i) )              &
-                                     + psi_h( z0q(j,i) / ol(j,i) ) )
-             ENDDO
-          ENDDO
-
-       ENDIF
-       !$acc end data
-
-    END SUBROUTINE calc_scaling_parameters
-
-
-
-!
-!-- Calculate surface fluxes usws, vsws, shf, qsws, (qrsws, nrsws)
-    SUBROUTINE calc_surface_fluxes
-
-       IMPLICIT NONE
-
-       REAL(wp) :: ol_mid !< Grid-interpolated L
-
-!
-!--    Compute u'w' for the total model domain.
-!--    First compute the corresponding component of u* and square it.
-       !$OMP PARALLEL DO PRIVATE( k, ol_mid, z_mo )
-       !$acc kernels loop present( nzb_u_inner, ol, u, us, usws, zu, zw, z0 ) private( j, k, z_mo )
-       DO  i = nxl, nxr
-          DO  j = nys, nyn
-
-             k   = nzb_u_inner(j,i)
-             z_mo = zu(k+1) - zw(k)
-!
-!--          Compute bulk Obukhov length for this point
-             ol_mid = 0.5_wp * ( ol(j,i-1) + ol(j,i) )
-
-             IF ( ol_mid == 0.0_wp )  THEN
-                ol_mid = MIN(ol(j,i-1), ol(j,i))
-             ENDIF
-
-             usws(j,i) = kappa * ( u(k+1,j,i) - u(k,j,i) )                     &
-                                 / ( LOG( z_mo / z0(j,i) )                     &
-                                     - psi_m( z_mo / ol_mid )                  &
-                                     + psi_m( z0(j,i) / ol_mid ) )
-
-             usws(j,i) = -usws(j,i) * 0.5_wp * ( us(j,i-1) + us(j,i) )
-          ENDDO
-       ENDDO
-
-!
-!--    Compute v'w' for the total model domain.
-!--    First compute the corresponding component of u* and square it.
-       !$OMP PARALLEL DO PRIVATE( k, ol_mid, z_mo )
-       !$acc kernels loop present( nzb_v_inner, ol, v, us, vsws, zu, zw, z0 ) private( j, k, ol_mid, z_mo )
-       DO  i = nxl, nxr
-          DO  j = nys, nyn
-
-             k   = nzb_v_inner(j,i)
-             z_mo = zu(k+1) - zw(k)
-!
-!--          Compute bulk Obukhov length for this point
-             ol_mid = 0.5_wp * ( ol(j-1,i) + ol(j,i) )
-
-             IF ( ol_mid == 0.0_wp )  THEN
-                ol_mid = MIN(ol(j-1,i), ol(j-1,i))
-             ENDIF
-
-             vsws(j,i) = kappa * ( v(k+1,j,i) - v(k,j,i) )                     &
-                                 / ( LOG( z_mo / z0(j,i) )                     &
-                                     - psi_m( z_mo / ol_mid )                  &
-                                     + psi_m( z0(j,i) / ol_mid ) )
-
-             vsws(j,i) = -vsws(j,i) * 0.5_wp * ( us(j,i-1) + us(j,i) )
-
-          ENDDO
-       ENDDO
-
-!
-!--    Exchange the boundaries for the momentum fluxes (is this still required?)
-       !$acc update host( usws, vsws )
-       CALL exchange_horiz_2d( usws )
-       CALL exchange_horiz_2d( vsws )
-       !$acc update device( usws, vsws )
-
-!
-!--    Compute the vertical kinematic heat flux
-       IF (  .NOT.  constant_heatflux .AND.  ( simulated_time <=               &
-            skip_time_do_lsm  .OR.  .NOT.  land_surface ) )  THEN
-          !$OMP PARALLEL DO
-          !$acc kernels loop independent present( shf, ts, us )
-          DO  i = nxlg, nxrg
-             !$acc loop independent
-             DO  j = nysg, nyng
-                shf(j,i) = -ts(j,i) * us(j,i)
-             ENDDO
-          ENDDO
-
-       ENDIF
-
-!
-!-- Compute the vertical water/scalar flux
-       IF (  .NOT.  constant_waterflux  .AND.  ( humidity  .OR.                &
-             passive_scalar )  .AND.  ( simulated_time <= skip_time_do_lsm     &
-            .OR.  .NOT.  land_surface ) )  THEN
-          !$OMP PARALLEL DO
-          !$acc kernels loop independent present( qs, qsws, us )
-          DO  i = nxlg, nxrg
-             !$acc loop independent
-             DO  j = nysg, nyng
-                qsws(j,i) = -qs(j,i) * us(j,i)
-             ENDDO
-          ENDDO
-
-       ENDIF
-
-!
-!--    Compute (turbulent) fluxes of rain water content and rain drop conc.
-       IF ( cloud_physics  .AND.  microphysics_seifert )  THEN
-          !$OMP PARALLEL DO
-          !$acc kernels loop independent present( nrs, nrsws, qrs, qrsws, us )
-          DO  i = nxlg, nxrg
-             !$acc loop independent
-             DO  j = nysg, nyng
-                qrsws(j,i) = -qrs(j,i) * us(j,i)
-                nrsws(j,i) = -nrs(j,i) * us(j,i)
-             ENDDO
-          ENDDO
-       ENDIF
-
-!
-!--    Bottom boundary condition for the TKE
-       IF ( ibc_e_b == 2 )  THEN
-          !$OMP PARALLEL DO
-          !$acc kernels loop independent present( e, nzb_s_inner, us )
-          DO  i = nxlg, nxrg
-             !$acc loop independent
-             DO  j = nysg, nyng
-                k = nzb_s_inner(j,i)
-                e(k+1,j,i) = ( us(j,i) / 0.1_wp )**2
-!
-!--             As a test: cm = 0.4
-!               e(k+1,j,i) = ( us(j,i) / 0.4_wp )**2
-                e(k,j,i)   = e(k+1,j,i)
-             ENDDO
-          ENDDO
-       ENDIF
-
-    END SUBROUTINE calc_surface_fluxes
-
-
-!
-!-- Integrated stability function for momentum
-    FUNCTION psi_m( zeta ) 
-       
-       USE kinds
-
-       IMPLICIT NONE 
-
-       REAL(wp)            :: psi_m !< Integrated similarity function result
-       REAL(wp)            :: zeta  !< Stability parameter z/L
-       REAL(wp)            :: x     !< dummy variable
-
-       REAL(wp), PARAMETER :: a = 1.0_wp            !< constant
-       REAL(wp), PARAMETER :: b = 0.66666666666_wp  !< constant
-       REAL(wp), PARAMETER :: c = 5.0_wp            !< constant
-       REAL(wp), PARAMETER :: d = 0.35_wp           !< constant
-       REAL(wp), PARAMETER :: c_d_d = c / d         !< constant
-       REAL(wp), PARAMETER :: bc_d_d = b * c / d    !< constant
-
-
-       IF ( zeta < 0.0_wp )  THEN
-          x = SQRT( SQRT( 1.0_wp  - 16.0_wp * zeta ) )
-          psi_m = pi * 0.5_wp - 2.0_wp * ATAN( x ) + LOG( ( 1.0_wp + x )**2    &
-                  * ( 1.0_wp + x**2 ) * 0.125_wp )
-       ELSE
-
-          psi_m = - b * ( zeta - c_d_d ) * EXP( -d * zeta ) - a * zeta         &
-                   - bc_d_d
-!
-!--       Old version for stable conditions (only valid for z/L < 0.5)
-!--       psi_m = - 5.0_wp * zeta
-
-       ENDIF
-
-    END FUNCTION psi_m
-
-
-!
-!-- Integrated stability function for heat and moisture
-    FUNCTION psi_h( zeta ) 
-       
-       USE kinds
-
-       IMPLICIT NONE 
-
-       REAL(wp)            :: psi_h !< Integrated similarity function result
-       REAL(wp)            :: zeta  !< Stability parameter z/L
-       REAL(wp)            :: x     !< dummy variable
-
-       REAL(wp), PARAMETER :: a = 1.0_wp            !< constant
-       REAL(wp), PARAMETER :: b = 0.66666666666_wp  !< constant
-       REAL(wp), PARAMETER :: c = 5.0_wp            !< constant
-       REAL(wp), PARAMETER :: d = 0.35_wp           !< constant
-       REAL(wp), PARAMETER :: c_d_d = c / d         !< constant
-       REAL(wp), PARAMETER :: bc_d_d = b * c / d    !< constant
-
-
-       IF ( zeta < 0.0_wp )  THEN
-          x = SQRT( 1.0_wp  - 16.0_wp * zeta )
-          psi_h = 2.0_wp * LOG( (1.0_wp + x ) / 2.0_wp )
-       ELSE
-          psi_h = - b * ( zeta - c_d_d ) * EXP( -d * zeta ) - (1.0_wp          &
-                  + 0.66666666666_wp * a * zeta )**1.5_wp - bc_d_d             &
-                  + 1.0_wp
-!
-!--       Old version for stable conditions (only valid for z/L < 0.5)
-!--       psi_h = - 5.0_wp * zeta
-       ENDIF
-
-    END FUNCTION psi_h
-
- END MODULE surface_layer_fluxes_mod
Index: /palm/trunk/SOURCE/surface_layer_fluxes_mod.f90
===================================================================
--- /palm/trunk/SOURCE/surface_layer_fluxes_mod.f90	(revision 1850)
+++ /palm/trunk/SOURCE/surface_layer_fluxes_mod.f90	(revision 1850)
@@ -0,0 +1,1150 @@
+!> @file surface_layer_fluxes_mod.f90
+!--------------------------------------------------------------------------------!
+! This file is part of PALM.
+!
+! PALM is free software: you can redistribute it and/or modify it under the terms
+! of the GNU General Public License as published by the Free Software Foundation,
+! either version 3 of the License, or (at your option) any later version.
+!
+! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
+! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
+! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along with
+! PALM. If not, see <http://www.gnu.org/licenses/>.
+!
+! Copyright 1997-2016 Leibniz Universitaet Hannover
+!
+!--------------------------------------------------------------------------------!
+! Current revisions:
+! ------------------
+! Module renamed
+!
+! 
+! Former revisions:
+! -----------------
+! $Id$
+!
+! 1822 2016-04-07 07:49:42Z hoffmann
+! icloud_scheme replaced by microphysics_*
+!
+! 1788 2016-03-10 11:01:04Z maronga
+! Added parameter z0q which replaces z0h in the similarity functions for
+! humidity.
+! Syntax layout improved.
+! 
+! 1757 2016-02-22 15:49:32Z maronga
+! Minor fixes.
+!
+! 1749 2016-02-09 12:19:56Z raasch
+! further OpenACC adjustments
+!
+! 1747 2016-02-08 12:25:53Z raasch
+! adjustments for OpenACC usage
+!
+! 1709 2015-11-04 14:47:01Z maronga
+! Bugfix: division by zero could occur when calculating rib at low wind speeds
+! Bugfix: calculation of uv_total for neutral = .T., initial value for ol for
+! neutral = .T.
+! 
+! 1705 2015-11-02 14:28:56Z maronga
+! Typo removed
+!
+! 1697 2015-10-28 17:14:10Z raasch
+! FORTRAN and OpenMP errors removed
+!
+! 1696 2015-10-27 10:03:34Z maronga
+! Modularized and completely re-written version of prandtl_fluxes.f90. In the
+! course of the re-writing two additional methods have been implemented. See
+! updated description.
+!
+! 1551 2015-03-03 14:18:16Z maronga
+! Removed land surface model part. The surface fluxes are now always calculated
+! within prandtl_fluxes, based on the given surface temperature/humidity (which 
+! is either provided by the land surface model, by large scale forcing data, or
+! directly prescribed by the user.
+! 
+! 1496 2014-12-02 17:25:50Z maronga
+! Adapted for land surface model
+! 
+! 1494 2014-11-21 17:14:03Z maronga
+! Bugfixes: qs is now calculated before calculation of Rif. calculation of
+! buoyancy flux in Rif corrected (added missing humidity term), allow use of 
+! topography for coupled runs (not tested)
+! 
+! 1361 2014-04-16 15:17:48Z hoffmann
+! Bugfix: calculation of turbulent fluxes of rain water content (qrsws) and rain 
+! drop concentration (nrsws) added
+! 
+! 1340 2014-03-25 19:45:13Z kanani
+! REAL constants defined as wp-kind
+!
+! 1320 2014-03-20 08:40:49Z raasch
+! ONLY-attribute added to USE-statements,
+! kind-parameters added to all INTEGER and REAL declaration statements,
+! kinds are defined in new module kinds,
+! old module precision_kind is removed,
+! revision history before 2012 removed,
+! comment fields (!:) to be used for variable explanations added to
+! all variable declaration statements
+!
+! 1276 2014-01-15 13:40:41Z heinze
+! Use LSF_DATA also in case of Dirichlet bottom boundary condition for scalars
+!
+! 1257 2013-11-08 15:18:40Z raasch
+! openACC "kernels do" replaced by "kernels loop", "loop independent" added
+!
+! 1036 2012-10-22 13:43:42Z raasch
+! code put under GPL (PALM 3.9)
+!
+! 1015 2012-09-27 09:23:24Z raasch
+! OpenACC statements added
+!
+! 978 2012-08-09 08:28:32Z fricke
+! roughness length for scalar quantities z0h added
+!
+! Revision 1.1  1998/01/23 10:06:06  raasch
+! Initial revision
+!
+!
+! Description:
+! ------------
+!> Diagnostic computation of vertical fluxes in the constant flux layer from the
+!> values of the variables at grid point k=1. Three different methods are
+!> available:
+!> 1) the "old" version (most_method = 'circular') which is fast, but inaccurate
+!> 2) a Newton iteration method (most_method = 'newton'), which is accurate, but
+!>    slower
+!> 3) a method using a lookup table which is fast and accurate. Note, however,
+!>    that this method cannot be used in case of roughness heterogeneity
+!>
+!> @todo (re)move large_scale_forcing actions
+!> @todo check/optimize OpenMP and OpenACC directives
+!------------------------------------------------------------------------------!
+ MODULE surface_layer_fluxes_mod
+
+    USE arrays_3d,                                                             &
+        ONLY:  e, kh, nr, nrs, nrsws, ol, pt, q, ql, qr, qrs, qrsws, qs, qsws, &
+               shf, ts, u, us, usws, v, vpt, vsws, zu, zw, z0, z0h, z0q
+
+    USE cloud_parameters,                                                      &
+        ONLY:  l_d_cp, pt_d_t
+
+    USE constants,                                                             &
+        ONLY:  pi
+
+    USE cpulog
+
+    USE control_parameters,                                                    &
+        ONLY:  cloud_physics, constant_heatflux, constant_waterflux,           &
+               coupling_mode, g, humidity, ibc_e_b, ibc_pt_b,                  &
+               initializing_actions, kappa, intermediate_timestep_count,       &
+               intermediate_timestep_count_max, large_scale_forcing, lsf_surf, &
+               message_string, microphysics_seifert, most_method, neutral,     &
+               passive_scalar, pt_surface, q_surface, run_coupled,             &
+               surface_pressure, simulated_time, terminate_run, zeta_max,      &
+               zeta_min 
+
+    USE indices,                                                               &
+        ONLY:  nxl, nxlg, nxr, nxrg, nys, nysg, nyn, nyng, nzb_s_inner,        &
+               nzb_u_inner, nzb_v_inner
+
+    USE kinds
+
+    USE pegrid
+
+    USE land_surface_model_mod,                                                &
+        ONLY:  land_surface, skip_time_do_lsm
+
+    IMPLICIT NONE
+
+    INTEGER(iwp) ::  i            !< loop index x direction
+    INTEGER(iwp) ::  j            !< loop index y direction
+    INTEGER(iwp) ::  k            !< loop index z direction
+
+    INTEGER(iwp), PARAMETER     :: num_steps = 15000  !< number of steps in the lookup table
+
+    LOGICAL      ::  coupled_run  !< Flag for coupled atmosphere-ocean runs
+
+    REAL(wp), DIMENSION(:,:), ALLOCATABLE :: pt1,      & !< Potential temperature at first grid level (required for cloud_physics = .T.)
+                                             qv1,      & !< Specific humidity at first grid level (required for cloud_physics = .T.)
+                                             uv_total    !< Total velocity at first grid level
+
+    REAL(wp), DIMENSION(0:num_steps-1) :: rib_tab,  & !< Lookup table bulk Richardson number
+                                          ol_tab      !< Lookup table values of L
+
+    REAL(wp)     ::  e_s,               & !< Saturation water vapor pressure
+                     l_bnd  = 7500,     & !< Lookup table index of the last time step
+                     ol_max = 1.0E6_wp, & !< Maximum Obukhov length
+                     rib_max,           & !< Maximum Richardson number in lookup table
+                     rib_min,           & !< Minimum Richardson number in lookup table
+                     z_mo                 !< Height of the constant flux layer where MOST is assumed
+
+
+    SAVE
+
+    PRIVATE
+
+    PUBLIC init_surface_layer_fluxes, pt1, qv1, surface_layer_fluxes, uv_total
+
+    INTERFACE init_surface_layer_fluxes
+       MODULE PROCEDURE init_surface_layer_fluxes
+    END INTERFACE init_surface_layer_fluxes
+
+    INTERFACE surface_layer_fluxes
+       MODULE PROCEDURE surface_layer_fluxes
+    END INTERFACE surface_layer_fluxes
+
+
+ CONTAINS
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Main routine to compute the surface fluxes
+!------------------------------------------------------------------------------!
+    SUBROUTINE surface_layer_fluxes
+
+       IMPLICIT NONE
+
+!
+!--    In case cloud physics is used, it is required to derive potential
+!--    temperature and specific humidity at first grid level from the fields pt 
+!--    and q
+       IF ( cloud_physics )  THEN
+          CALL calc_pt_q
+       ENDIF
+
+!
+!--    First, calculate the new Obukhov length, then new friction velocity,
+!--    followed by the new scaling parameters (th*, q*, etc.), and the new
+!--    surface fluxes if required. The old routine ("circular") requires a 
+!--    different order of calls as the scaling parameters from the previous time
+!--    steps are used to calculate the Obukhov length
+
+!
+!--    Depending on setting of most_method use the "old" routine
+       IF ( most_method == 'circular' )  THEN
+
+          CALL calc_scaling_parameters
+
+          CALL calc_uv_total
+
+          IF ( .NOT. neutral )  THEN
+             CALL calc_ol
+          ENDIF
+
+          CALL calc_us
+
+          CALL calc_surface_fluxes
+
+!
+!--    Use either Newton iteration or a lookup table for the bulk Richardson
+!--    number to calculate the Obukhov length 
+       ELSEIF ( most_method == 'newton'  .OR.  most_method == 'lookup' )  THEN
+
+          CALL calc_uv_total
+
+          IF ( .NOT. neutral )  THEN
+             CALL calc_ol
+          ENDIF
+
+          CALL calc_us
+
+          CALL calc_scaling_parameters
+
+          CALL calc_surface_fluxes
+
+       ENDIF
+
+    END SUBROUTINE surface_layer_fluxes
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Initializing actions for the surface layer routine. Basically, this involves
+!> the preparation of a lookup table for the the bulk Richardson number vs 
+!> Obukhov length L when using the lookup table method.
+!------------------------------------------------------------------------------!
+    SUBROUTINE init_surface_layer_fluxes
+
+       IMPLICIT NONE
+
+       INTEGER(iwp) :: l,          & !< Index for loop to create lookup table
+                       num_steps_n   !< Number of non-stretched zeta steps
+
+       LOGICAL :: terminate_run_l = .FALSE.    !< Flag to terminate run (global)
+
+       REAL(wp), PARAMETER ::  zeta_stretch = -10.0_wp !< Start of stretching in the free convection limit
+                               
+       REAL(wp), DIMENSION(:), ALLOCATABLE :: zeta_tmp
+
+
+       REAL(wp) :: zeta_step,            & !< Increment of zeta
+                   regr      = 1.01_wp,  & !< Stretching factor of zeta_step in the free convection limit
+                   regr_old  = 1.0E9_wp, & !< Stretching factor of last iteration step
+                   z0h_min   = 0.0_wp,   & !< Minimum value of z0h to create table
+                   z0_min    = 0.0_wp      !< Minimum value of z0 to create table
+!
+!--    When cloud physics is used, arrays for storing potential temperature and
+!--    specific humidity at first grid level are required
+       IF ( cloud_physics )  THEN
+          ALLOCATE ( pt1(nysg:nyng,nxlg:nxrg) )
+          ALLOCATE ( qv1(nysg:nyng,nxlg:nxrg) )
+       ENDIF
+
+!
+!--    Allocate field for storing the horizontal velocity
+       ALLOCATE ( uv_total(nysg:nyng,nxlg:nxrg) )
+
+
+!
+!--    In case of runs with neutral statification, set Obukhov length to a
+!--    large value
+       IF ( neutral ) ol = 1.0E10_wp
+
+       IF ( most_method == 'lookup' )  THEN
+
+!
+!--       Check for roughness heterogeneity. In that case terminate run and
+!--       inform user
+          IF ( MINVAL( z0h ) /= MAXVAL( z0h )  .OR.                            &
+               MINVAL( z0  ) /= MAXVAL( z0  ) )  THEN
+             terminate_run_l = .TRUE.
+          ENDIF
+
+#if defined( __parallel )
+!
+!--       Make a logical OR for all processes. Force termiation of model if result
+!--       is TRUE
+          IF ( collective_wait )  CALL MPI_BARRIER( comm2d, ierr )
+          CALL MPI_ALLREDUCE( terminate_run_l, terminate_run, 1, MPI_LOGICAL,  &
+                              MPI_LOR, comm2d, ierr )
+#else
+          terminate_run = terminate_run_l
+#endif
+
+          IF ( terminate_run )  THEN
+             message_string = 'most_method = "lookup" cannot be used in ' //   &
+                              'combination with a prescribed roughness '  //   &
+                              'heterogeneity'
+             CALL message( 'surface_layer_fluxes', 'PA0417', 1, 2, 0, 6, 0 )
+          ENDIF
+
+          ALLOCATE(  zeta_tmp(0:num_steps-1) )
+
+!
+!--       Use the lowest possible value for z_mo
+          k    = MINVAL(nzb_s_inner)
+          z_mo = zu(k+1) - zw(k)
+
+!
+!--       Calculate z/L range from zeta_stretch to zeta_max using 90% of the
+!--       available steps (num_steps). The calculation is done with negative
+!--       values of zeta in order to simplify the stretching in the free
+!--       convection limit for the remaining 10% of steps.
+          zeta_tmp(0) = - zeta_max
+          num_steps_n = ( num_steps * 9 / 10 ) - 1
+          zeta_step   = (zeta_max - zeta_stretch) / REAL(num_steps_n)
+
+          DO l = 1, num_steps_n
+             zeta_tmp(l) = zeta_tmp(l-1) + zeta_step
+          ENDDO
+
+!
+!--       Calculate stretching factor for the free convection range
+          DO  WHILE ( ABS( (regr-regr_old) / regr_old ) > 1.0E-10_wp )
+             regr_old = regr
+             regr = ( 1.0_wp - ( -zeta_min / zeta_step ) * ( 1.0_wp - regr )   &
+                    )**( 10.0_wp / REAL(num_steps) )
+          ENDDO
+
+!
+!--       Calculate z/L range from zeta_min to zeta_stretch
+          DO l = num_steps_n+1, num_steps-1
+             zeta_tmp(l) = zeta_tmp(l-1) + zeta_step
+             zeta_step = zeta_step * regr
+          ENDDO
+
+!
+!--       Save roughness lengths to temporary variables
+          z0h_min = z0h(nys,nxl)
+          z0_min  = z0(nys,nxl)
+          
+!
+!--       Calculate lookup table for the Richardson number versus Obukhov length
+!--       The Richardson number (rib) is defined depending on the choice of 
+!--       boundary conditions for temperature
+          IF ( ibc_pt_b == 1 )  THEN
+             DO l = 0, num_steps-1
+                ol_tab(l)  = - z_mo / zeta_tmp(num_steps-1-l)
+                rib_tab(l) = z_mo / ol_tab(l)  / ( LOG( z_mo / z0_min )        &
+                                                - psi_m( z_mo / ol_tab(l) )    &
+                                                + psi_m( z0_min / ol_tab(l) )  &
+                                                  )**3
+             ENDDO  
+          ELSE
+             DO l = 0, num_steps-1
+                ol_tab(l)  = - z_mo / zeta_tmp(num_steps-1-l)
+                rib_tab(l) = z_mo / ol_tab(l)  * ( LOG( z_mo / z0h_min )       &
+                                              - psi_h( z_mo / ol_tab(l) )      &
+                                              + psi_h( z0h_min / ol_tab(l) )   &
+                                            )                                  &
+                                          / ( LOG( z_mo / z0_min )             &
+                                              - psi_m( z_mo / ol_tab(l) )      &
+                                              + psi_m( z0_min / ol_tab(l) )    &
+                                            )**2
+             ENDDO
+          ENDIF
+
+!
+!--       Determine minimum values of rib in the lookup table. Set upper limit 
+!--       to critical Richardson number (0.25)
+          rib_min  = MINVAL(rib_tab)
+          rib_max  = 0.25 !MAXVAL(rib_tab)
+
+          DEALLOCATE( zeta_tmp )
+       ENDIF
+
+    END SUBROUTINE init_surface_layer_fluxes
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Compute the absolute value of the horizontal velocity (relative to the
+!> surface). This is required by all methods
+!------------------------------------------------------------------------------!
+    SUBROUTINE calc_uv_total
+
+       IMPLICIT NONE
+
+
+       !$OMP PARALLEL DO PRIVATE( k )
+       !$acc kernels loop present( nzb_s_inner, u, uv_total, v ) private( j, k )
+       DO  i = nxl, nxr
+          DO  j = nys, nyn
+
+             k   = nzb_s_inner(j,i)
+             uv_total(j,i) = SQRT( ( 0.5_wp * ( u(k+1,j,i) + u(k+1,j,i+1)      &
+                                         - u(k,j,i)   - u(k,j,i+1) ) )**2 +    &
+                              ( 0.5_wp * ( v(k+1,j,i) + v(k+1,j+1,i)           &
+                                         - v(k,j,i)   - v(k,j+1,i) ) )**2 )
+
+!
+!--          For too small values of the local wind, MOST does not work. A
+!--          threshold value is thus set if required
+!            uv_total(j,i) = MAX(0.01_wp,uv_total(j,i))
+
+          ENDDO
+       ENDDO
+
+!
+!--    Values of uv_total need to be exchanged at the ghost boundaries
+       !$acc update host( uv_total )
+       CALL exchange_horiz_2d( uv_total )
+       !$acc update device( uv_total )
+
+    END SUBROUTINE calc_uv_total
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Calculate the Obukhov length (L) and Richardson flux number (z/L)
+!------------------------------------------------------------------------------!
+    SUBROUTINE calc_ol
+
+       IMPLICIT NONE
+
+       INTEGER(iwp) :: iter,  & !< Newton iteration step
+                       l        !< look index
+
+       REAL(wp), DIMENSION(nysg:nyng,nxlg:nxrg) :: rib !< Bulk Richardson number
+
+       REAL(wp)     :: f,      & !< Function for Newton iteration: f = Ri - [...]/[...]^2 = 0
+                       f_d_ol, & !< Derivative of f
+                       ol_l,   & !< Lower bound of L for Newton iteration
+                       ol_m,   & !< Previous value of L for Newton iteration
+                       ol_old, & !< Previous time step value of L
+                       ol_u      !< Upper bound of L for Newton iteration
+
+       IF ( TRIM( most_method ) /= 'circular' )  THEN
+      
+          !$acc data present( nzb_s_inner, pt, q, qsws, rib, shf, uv_total, vpt, zu, zw )
+
+          !$OMP PARALLEL DO PRIVATE( k, z_mo )
+          !$acc kernels loop private( j, k, z_mo )
+          DO  i = nxl, nxr
+             DO  j = nys, nyn
+
+                k   = nzb_s_inner(j,i)
+                z_mo = zu(k+1) - zw(k)
+
+!
+!--             Evaluate bulk Richardson number (calculation depends on
+!--             definition based on setting of boundary conditions
+                IF ( ibc_pt_b /= 1 )  THEN
+                   IF ( humidity )  THEN
+                      rib(j,i) = g * z_mo * ( vpt(k+1,j,i) - vpt(k,j,i) )      &
+                           / ( uv_total(j,i)**2 * vpt(k+1,j,i) + 1.0E-20_wp )
+                   ELSE
+                      rib(j,i) = g * z_mo * ( pt(k+1,j,i) - pt(k,j,i) )        &
+                           / ( uv_total(j,i)**2 * pt(k+1,j,i)  + 1.0E-20_wp )
+                   ENDIF      
+                ELSE
+!
+!--                When using Neumann boundary conditions, the buoyancy flux
+!--                is required but cannot be calculated at the surface, as pt
+!--                and q are not known at the surface. Hence the values at 
+!--                first grid level are used to estimate the buoyancy flux
+                   IF ( humidity )  THEN
+                      rib(j,i) = - g * z_mo * ( ( 1.0_wp + 0.61_wp             &
+                                 * q(k+1,j,i) ) * shf(j,i) + 0.61_wp           &
+                                 * pt(k+1,j,i) * qsws(j,i) )   &
+                                 / ( uv_total(j,i)**3 * vpt(k+1,j,i) * kappa**2&
+                                 + 1.0E-20_wp)
+                   ELSE
+                      rib(j,i) = - g * z_mo * shf(j,i)                         &
+                           / ( uv_total(j,i)**3 * pt(k+1,j,i) * kappa**2       &
+                           + 1.0E-20_wp )
+                   ENDIF
+                ENDIF  
+     
+             ENDDO
+          ENDDO 
+          !$acc end data
+
+       ENDIF
+
+!
+!--    Calculate the Obukhov length either using a Newton iteration
+!--    method, via a lookup table, or using the old circular way
+       IF ( TRIM( most_method ) == 'newton' )  THEN
+
+          !$OMP PARALLEL DO PRIVATE( k, z_mo )
+          !# WARNING: does not work on GPU so far because of DO-loop with
+          !#          undetermined iterations
+          !!!!!!$acc kernels loop
+          DO  i = nxl, nxr
+             DO  j = nys, nyn
+
+                k   = nzb_s_inner(j,i)
+                z_mo = zu(k+1) - zw(k)
+
+!
+!--             Store current value in case the Newton iteration fails
+                ol_old = ol(j,i)
+
+!
+!--             Ensure that the bulk Richardson number and the Obukhov 
+!--             lengtH have the same sign
+                IF ( rib(j,i) * ol(j,i) < 0.0_wp  .OR.                         &
+                     ABS( ol(j,i) ) == ol_max )  THEN
+                   IF ( rib(j,i) > 0.0_wp ) ol(j,i) =  0.01_wp
+                   IF ( rib(j,i) < 0.0_wp ) ol(j,i) = -0.01_wp
+                ENDIF
+!
+!--             Iteration to find Obukhov length
+                iter = 0
+                DO
+                   iter = iter + 1
+!
+!--                In case of divergence, use the value of the previous time step
+                   IF ( iter > 1000 )  THEN
+                      ol(j,i) = ol_old
+                      EXIT
+                   ENDIF
+
+                   ol_m = ol(j,i)
+                   ol_l = ol_m - 0.001_wp * ol_m
+                   ol_u = ol_m + 0.001_wp * ol_m
+
+
+                   IF ( ibc_pt_b /= 1 )  THEN
+!
+!--                   Calculate f = Ri - [...]/[...]^2 = 0
+                      f = rib(j,i) - ( z_mo / ol_m ) * ( LOG( z_mo / z0h(j,i) )&
+                                                    - psi_h( z_mo / ol_m )     &
+                                                    + psi_h( z0h(j,i) / ol_m ) &
+                                                   )                           &
+                                                 / ( LOG( z_mo / z0(j,i) )     &
+                                                    - psi_m( z_mo / ol_m )     &
+                                                    + psi_m( z0(j,i) / ol_m )  &
+                                                    )**2
+
+!
+!--                    Calculate df/dL
+                       f_d_ol = ( - ( z_mo / ol_u ) * ( LOG( z_mo / z0h(j,i) ) &
+                                                   - psi_h( z_mo / ol_u )      &
+                                                   + psi_h( z0h(j,i) / ol_u )  &
+                                                 )                             &
+                                               / ( LOG( z_mo / z0(j,i) )       &
+                                                   - psi_m( z_mo / ol_u )      &
+                                                   + psi_m( z0(j,i) / ol_u )   &
+                                                 )**2                          &
+                              + ( z_mo / ol_l ) * ( LOG( z_mo / z0h(j,i) )     &
+                                                   - psi_h( z_mo / ol_l )      &
+                                                   + psi_h( z0h(j,i) / ol_l )  &
+                                                 )                             &
+                                               / ( LOG( z_mo / z0(j,i) )       &
+                                                   - psi_m( z_mo / ol_l )      &
+                                                   + psi_m( z0(j,i) / ol_l )   &
+                                                 )**2                          &
+                                ) / ( ol_u - ol_l )
+                   ELSE
+!
+!--                   Calculate f = Ri - 1 /[...]^3 = 0
+                      f = rib(j,i) - ( z_mo / ol_m ) / ( LOG( z_mo / z0(j,i) )&
+                                                    - psi_m( z_mo / ol_m )    &
+                                                    + psi_m( z0(j,i) / ol_m ) &
+                                                       )**3
+
+!
+!--                   Calculate df/dL
+                      f_d_ol = ( - ( z_mo / ol_u ) / ( LOG( z_mo / z0(j,i) )  &
+                                                   - psi_m( z_mo / ol_u )     &
+                                                   + psi_m( z0(j,i) / ol_u )  &
+                                                 )**3                         &
+                              + ( z_mo / ol_l ) / ( LOG( z_mo / z0(j,i) )     &
+                                                   - psi_m( z_mo / ol_l )     &
+                                                   + psi_m( z0(j,i) / ol_l )  &
+                                                 )**3                         &
+                                     ) / ( ol_u - ol_l )
+                   ENDIF
+!
+!--                Calculate new L
+                   ol(j,i) = ol_m - f / f_d_ol
+
+!
+!--                Ensure that the bulk Richardson number and the Obukhov 
+!--                length have the same sign and ensure convergence.
+                   IF ( ol(j,i) * ol_m < 0.0_wp )  ol(j,i) = ol_m * 0.5_wp
+
+!
+!--                If unrealistic value occurs, set L to the maximum
+!--                value that is allowed
+                   IF ( ABS( ol(j,i) ) > ol_max )  THEN
+                      ol(j,i) = ol_max
+                      EXIT
+                   ENDIF
+!
+!--                Check for convergence
+                   IF ( ABS( ( ol(j,i) - ol_m ) / ol(j,i) ) < 1.0E-4_wp )  THEN
+                      EXIT
+                   ELSE
+                      CYCLE
+                   ENDIF
+
+                ENDDO
+                       
+             ENDDO
+          ENDDO
+
+       ELSEIF ( TRIM( most_method ) == 'lookup' )  THEN
+
+          !$OMP PARALLEL DO PRIVATE( k, z_mo )
+          !# WARNING: does not work on GPU so far because of DO  WHILE construct
+          !!!!!!$acc kernels loop
+          DO  i = nxl, nxr
+             DO  j = nys, nyn
+
+!
+!--             If the bulk Richardson number is outside the range of the lookup
+!--             table, set it to the exceeding threshold value
+                IF ( rib(j,i) < rib_min )  rib(j,i) = rib_min
+                IF ( rib(j,i) > rib_max )  rib(j,i) = rib_max
+
+!
+!--             Find the correct index bounds for linear interpolation. As the
+!--             Richardson number will not differ very much from time step to
+!--             time step , use the index from the last step and search in the 
+!--             correct direction
+                l = l_bnd
+                IF ( rib_tab(l) - rib(j,i) > 0.0_wp )  THEN
+                   DO  WHILE ( rib_tab(l-1) - rib(j,i) > 0.0_wp  .AND.  l > 0 )
+                      l = l-1
+                   ENDDO
+                ELSE
+                   DO  WHILE ( rib_tab(l) - rib(j,i) < 0.0_wp                  &
+                              .AND.  l < num_steps-1 )
+                      l = l+1
+                   ENDDO
+                ENDIF
+                l_bnd = l
+
+!
+!--             Linear interpolation to find the correct value of z/L
+                ol(j,i) = ( ol_tab(l-1) + ( ol_tab(l) - ol_tab(l-1) )          &
+                            / (  rib_tab(l) - rib_tab(l-1) )                   &
+                            * ( rib(j,i) - rib_tab(l-1) ) )
+
+             ENDDO
+          ENDDO
+
+       ELSEIF ( TRIM( most_method ) == 'circular' )  THEN
+
+          !$OMP PARALLEL DO PRIVATE( k, z_mo )
+          !$acc kernels loop present( nzb_s_inner, ol, pt, pt1, q, ql, qs, qv1, ts, us, vpt, zu, zw ) private( j, k, z_mo )
+          DO  i = nxl, nxr
+             DO  j = nys, nyn
+
+                k   = nzb_s_inner(j,i)
+                z_mo = zu(k+1) - zw(k)
+
+                IF ( .NOT. humidity )  THEN
+                   ol(j,i) =  ( pt(k+1,j,i) *  us(j,i)**2 ) / ( kappa * g      &
+                              * ts(j,i) + 1E-30_wp )
+                ELSEIF ( cloud_physics )  THEN
+
+                   ol(j,i) =  ( vpt(k+1,j,i) * us(j,i)**2 ) / ( kappa * g      &
+                              * ( ts(j,i) + 0.61_wp * pt1(j,i) * qs(j,i)       &
+                              + 0.61_wp * qv1(j,i) * ts(j,i) - ts(j,i)         &
+                              * ql(k+1,j,i) ) + 1E-30_wp )
+                ELSE
+                   ol(j,i) =  ( vpt(k+1,j,i) *  us(j,i)**2 ) / ( kappa * g     &
+                              * ( ts(j,i) + 0.61_wp * pt(k+1,j,i) * qs(j,i)    &
+                                  + 0.61_wp * q(k+1,j,i) * ts(j,i) ) + 1E-30_wp )
+                ENDIF
+!
+!--             Limit the value range of the Obukhov length.
+!--             This is necessary for very small velocities (u,v --> 0), because
+!--             the absolute value of ol can then become very small, which in
+!--             consequence would result in very large shear stresses and very
+!--             small momentum fluxes (both are generally unrealistic).
+                IF ( ( z_mo / ol(j,i) ) < zeta_min )  ol(j,i) = z_mo / zeta_min
+                IF ( ( z_mo / ol(j,i) ) > zeta_max )  ol(j,i) = z_mo / zeta_max
+
+             ENDDO
+          ENDDO
+
+       ENDIF
+
+!
+!--    Values of ol at ghost point locations are needed for the evaluation
+!--    of usws and vsws.
+       !$acc update host( ol )
+       CALL exchange_horiz_2d( ol )
+       !$acc update device( ol )
+
+    END SUBROUTINE calc_ol
+
+!
+!-- Calculate friction velocity u*
+    SUBROUTINE calc_us
+
+       IMPLICIT NONE
+
+       !$OMP PARALLEL DO PRIVATE( k, z_mo )
+       !$acc kernels loop present( nzb_s_inner, ol, us, uv_total, zu, zw, z0 ) private( j, k, z_mo )
+       DO  i = nxlg, nxrg
+          DO  j = nysg, nyng
+
+             k   = nzb_s_inner(j,i)+1
+             z_mo = zu(k+1) - zw(k)
+
+!
+!--          Compute u* at the scalars' grid points
+             us(j,i) = kappa * uv_total(j,i) / ( LOG( z_mo / z0(j,i) )         &
+                                          - psi_m( z_mo / ol(j,i) )            &
+                                          + psi_m( z0(j,i) / ol(j,i) ) )
+          ENDDO
+       ENDDO
+
+    END SUBROUTINE calc_us
+
+!
+!-- Calculate potential temperature and specific humidity at first grid level
+    SUBROUTINE calc_pt_q
+
+       IMPLICIT NONE
+
+       !$acc kernels loop present( nzb_s_inner, pt, pt1, pt_d_t, q, ql, qv1 ) private( j, k )
+       DO  i = nxlg, nxrg
+          DO  j = nysg, nyng
+             k   = nzb_s_inner(j,i)+1
+             pt1(j,i) = pt(k,j,i) + l_d_cp * pt_d_t(k) * ql(k,j,i)
+             qv1(j,i) = q(k,j,i) - ql(k,j,i)
+          ENDDO
+       ENDDO
+
+    END SUBROUTINE calc_pt_q
+
+!
+!-- Calculate the other MOST scaling parameters theta*, q*, (qr*, nr*)
+    SUBROUTINE calc_scaling_parameters
+
+       IMPLICIT NONE
+
+!
+!--    Data information for accelerators
+       !$acc data present( e, nrsws, nzb_u_inner, nzb_v_inner, nzb_s_inner, pt )  &
+       !$acc      present( q, qs, qsws, qrsws, shf, ts, u, us, usws, v )     &
+       !$acc      present( vpt, vsws, zu, zw, z0, z0h )
+! 
+!--    Compute theta*
+       IF ( constant_heatflux )  THEN
+
+!
+!--       For a given heat flux in the surface layer:
+          !$OMP PARALLEL DO
+          !$acc kernels loop private( j )
+          DO  i = nxlg, nxrg
+             DO  j = nysg, nyng
+                ts(j,i) = -shf(j,i) / ( us(j,i) + 1E-30_wp )
+!
+!--             ts must be limited, because otherwise overflow may occur in case
+!--             of us=0 when computing ol further below
+                IF ( ts(j,i) < -1.05E5_wp )  ts(j,i) = -1.0E5_wp
+                IF ( ts(j,i) >   1.0E5_wp )  ts(j,i) =  1.0E5_wp
+             ENDDO
+          ENDDO
+
+       ELSE
+!
+!--       For a given surface temperature:
+          IF ( large_scale_forcing  .AND.  lsf_surf )  THEN
+             !$OMP PARALLEL DO
+             !$acc kernels loop private( j, k )
+             DO  i = nxlg, nxrg
+                DO  j = nysg, nyng
+                   k = nzb_s_inner(j,i)
+                   pt(k,j,i) = pt_surface
+                ENDDO
+             ENDDO
+          ENDIF
+
+          !$OMP PARALLEL DO PRIVATE( k, z_mo )
+          !$acc kernels loop present( nzb_s_inner, ol, pt, pt1, ts, zu, zw, z0h ) private( j, k, z_mo )
+          DO  i = nxlg, nxrg
+             DO  j = nysg, nyng
+
+                k   = nzb_s_inner(j,i)
+                z_mo = zu(k+1) - zw(k)
+
+                IF ( cloud_physics )  THEN
+                   ts(j,i) = kappa * ( pt1(j,i) - pt(k,j,i) )                  &
+                                     / ( LOG( z_mo / z0h(j,i) )                &
+                                         - psi_h( z_mo / ol(j,i) )             &
+                                         + psi_h( z0h(j,i) / ol(j,i) ) )
+                ELSE
+                   ts(j,i) = kappa * ( pt(k+1,j,i) - pt(k,j,i) )               &
+                                     / ( LOG( z_mo / z0h(j,i) )                &
+                                         - psi_h( z_mo / ol(j,i) )             &
+                                         + psi_h( z0h(j,i) / ol(j,i) ) )
+                ENDIF
+
+             ENDDO
+          ENDDO
+       ENDIF
+
+!
+!--    If required compute q*
+       IF ( humidity  .OR.  passive_scalar )  THEN
+          IF ( constant_waterflux )  THEN
+!
+!--          For a given water flux in the surface layer
+             !$OMP PARALLEL DO
+             !$acc kernels loop private( j )
+             DO  i = nxlg, nxrg
+                DO  j = nysg, nyng
+                   qs(j,i) = -qsws(j,i) / ( us(j,i) + 1E-30_wp )
+                ENDDO
+             ENDDO
+
+          ELSE
+             coupled_run = ( coupling_mode == 'atmosphere_to_ocean'  .AND.     &
+                             run_coupled )
+
+             IF ( large_scale_forcing  .AND.  lsf_surf )  THEN
+                !$OMP PARALLEL DO
+                !$acc kernels loop private( j, k )
+                DO  i = nxlg, nxrg
+                   DO  j = nysg, nyng
+                      k = nzb_s_inner(j,i)
+                      q(k,j,i) = q_surface
+                   ENDDO
+                ENDDO
+             ENDIF
+
+             !$OMP PARALLEL DO PRIVATE( e_s, k, z_mo )
+             !$acc kernels loop independent present( nzb_s_inner, ol, pt, q, qs, qv1, zu, zw, z0q ) private( e_s, j, k, z_mo )
+             DO  i = nxlg, nxrg
+                !$acc loop independent
+                DO  j = nysg, nyng
+
+                   k   = nzb_s_inner(j,i)
+                   z_mo = zu(k+1) - zw(k)
+
+!
+!--                Assume saturation for atmosphere coupled to ocean (but not
+!--                in case of precursor runs)
+                   IF ( coupled_run )  THEN
+                      e_s = 6.1_wp * &
+                              EXP( 0.07_wp * ( MIN(pt(k,j,i),pt(k+1,j,i))      &
+                                               - 273.15_wp ) )
+                      q(k,j,i) = 0.622_wp * e_s / ( surface_pressure - e_s )
+                   ENDIF
+
+                   IF ( cloud_physics )  THEN
+                      qs(j,i) = kappa * ( qv1(j,i) - q(k,j,i) )                &
+                                        / ( LOG( z_mo / z0q(j,i) )             &
+                                            - psi_h( z_mo / ol(j,i) )          &
+                                            + psi_h( z0q(j,i) / ol(j,i) ) )
+
+                   ELSE
+                      qs(j,i) = kappa * ( q(k+1,j,i) - q(k,j,i) )              &
+                                        / ( LOG( z_mo / z0q(j,i) )             &
+                                            - psi_h( z_mo / ol(j,i) )          &
+                                            + psi_h( z0q(j,i) / ol(j,i) ) )
+                   ENDIF
+
+                ENDDO
+             ENDDO
+          ENDIF
+       ENDIF
+
+
+!
+!--    If required compute qr* and nr*
+       IF ( cloud_physics  .AND.  microphysics_seifert )   &
+       THEN
+
+          !$OMP PARALLEL DO PRIVATE( k, z_mo )
+          !$acc kernels loop independent present( nr, nrs, nzb_s_inner, ol, qr, qrs, zu, zw, z0q ) private( j, k, z_mo )
+          DO  i = nxlg, nxrg
+             !$acc loop independent
+             DO  j = nysg, nyng
+
+                k   = nzb_s_inner(j,i)
+                z_mo = zu(k+1) - zw(k)
+
+                qrs(j,i) = kappa * ( qr(k+1,j,i) - qr(k,j,i) )              &
+                                 / ( LOG( z_mo / z0q(j,i) )                 &
+                                     - psi_h( z_mo / ol(j,i) )              &
+                                     + psi_h( z0q(j,i) / ol(j,i) ) )
+
+                nrs(j,i) = kappa * ( nr(k+1,j,i) - nr(k,j,i) )              &
+                                 / ( LOG( z_mo / z0q(j,i) )                 &
+                                     - psi_h( z_mo / ol(j,i) )              &
+                                     + psi_h( z0q(j,i) / ol(j,i) ) )
+             ENDDO
+          ENDDO
+
+       ENDIF
+       !$acc end data
+
+    END SUBROUTINE calc_scaling_parameters
+
+
+
+!
+!-- Calculate surface fluxes usws, vsws, shf, qsws, (qrsws, nrsws)
+    SUBROUTINE calc_surface_fluxes
+
+       IMPLICIT NONE
+
+       REAL(wp) :: ol_mid !< Grid-interpolated L
+
+!
+!--    Compute u'w' for the total model domain.
+!--    First compute the corresponding component of u* and square it.
+       !$OMP PARALLEL DO PRIVATE( k, ol_mid, z_mo )
+       !$acc kernels loop present( nzb_u_inner, ol, u, us, usws, zu, zw, z0 ) private( j, k, z_mo )
+       DO  i = nxl, nxr
+          DO  j = nys, nyn
+
+             k   = nzb_u_inner(j,i)
+             z_mo = zu(k+1) - zw(k)
+!
+!--          Compute bulk Obukhov length for this point
+             ol_mid = 0.5_wp * ( ol(j,i-1) + ol(j,i) )
+
+             IF ( ol_mid == 0.0_wp )  THEN
+                ol_mid = MIN(ol(j,i-1), ol(j,i))
+             ENDIF
+
+             usws(j,i) = kappa * ( u(k+1,j,i) - u(k,j,i) )                     &
+                                 / ( LOG( z_mo / z0(j,i) )                     &
+                                     - psi_m( z_mo / ol_mid )                  &
+                                     + psi_m( z0(j,i) / ol_mid ) )
+
+             usws(j,i) = -usws(j,i) * 0.5_wp * ( us(j,i-1) + us(j,i) )
+          ENDDO
+       ENDDO
+
+!
+!--    Compute v'w' for the total model domain.
+!--    First compute the corresponding component of u* and square it.
+       !$OMP PARALLEL DO PRIVATE( k, ol_mid, z_mo )
+       !$acc kernels loop present( nzb_v_inner, ol, v, us, vsws, zu, zw, z0 ) private( j, k, ol_mid, z_mo )
+       DO  i = nxl, nxr
+          DO  j = nys, nyn
+
+             k   = nzb_v_inner(j,i)
+             z_mo = zu(k+1) - zw(k)
+!
+!--          Compute bulk Obukhov length for this point
+             ol_mid = 0.5_wp * ( ol(j-1,i) + ol(j,i) )
+
+             IF ( ol_mid == 0.0_wp )  THEN
+                ol_mid = MIN(ol(j-1,i), ol(j-1,i))
+             ENDIF
+
+             vsws(j,i) = kappa * ( v(k+1,j,i) - v(k,j,i) )                     &
+                                 / ( LOG( z_mo / z0(j,i) )                     &
+                                     - psi_m( z_mo / ol_mid )                  &
+                                     + psi_m( z0(j,i) / ol_mid ) )
+
+             vsws(j,i) = -vsws(j,i) * 0.5_wp * ( us(j,i-1) + us(j,i) )
+
+          ENDDO
+       ENDDO
+
+!
+!--    Exchange the boundaries for the momentum fluxes (is this still required?)
+       !$acc update host( usws, vsws )
+       CALL exchange_horiz_2d( usws )
+       CALL exchange_horiz_2d( vsws )
+       !$acc update device( usws, vsws )
+
+!
+!--    Compute the vertical kinematic heat flux
+       IF (  .NOT.  constant_heatflux .AND.  ( simulated_time <=               &
+            skip_time_do_lsm  .OR.  .NOT.  land_surface ) )  THEN
+          !$OMP PARALLEL DO
+          !$acc kernels loop independent present( shf, ts, us )
+          DO  i = nxlg, nxrg
+             !$acc loop independent
+             DO  j = nysg, nyng
+                shf(j,i) = -ts(j,i) * us(j,i)
+             ENDDO
+          ENDDO
+
+       ENDIF
+
+!
+!-- Compute the vertical water/scalar flux
+       IF (  .NOT.  constant_waterflux  .AND.  ( humidity  .OR.                &
+             passive_scalar )  .AND.  ( simulated_time <= skip_time_do_lsm     &
+            .OR.  .NOT.  land_surface ) )  THEN
+          !$OMP PARALLEL DO
+          !$acc kernels loop independent present( qs, qsws, us )
+          DO  i = nxlg, nxrg
+             !$acc loop independent
+             DO  j = nysg, nyng
+                qsws(j,i) = -qs(j,i) * us(j,i)
+             ENDDO
+          ENDDO
+
+       ENDIF
+
+!
+!--    Compute (turbulent) fluxes of rain water content and rain drop conc.
+       IF ( cloud_physics  .AND.  microphysics_seifert )  THEN
+          !$OMP PARALLEL DO
+          !$acc kernels loop independent present( nrs, nrsws, qrs, qrsws, us )
+          DO  i = nxlg, nxrg
+             !$acc loop independent
+             DO  j = nysg, nyng
+                qrsws(j,i) = -qrs(j,i) * us(j,i)
+                nrsws(j,i) = -nrs(j,i) * us(j,i)
+             ENDDO
+          ENDDO
+       ENDIF
+
+!
+!--    Bottom boundary condition for the TKE
+       IF ( ibc_e_b == 2 )  THEN
+          !$OMP PARALLEL DO
+          !$acc kernels loop independent present( e, nzb_s_inner, us )
+          DO  i = nxlg, nxrg
+             !$acc loop independent
+             DO  j = nysg, nyng
+                k = nzb_s_inner(j,i)
+                e(k+1,j,i) = ( us(j,i) / 0.1_wp )**2
+!
+!--             As a test: cm = 0.4
+!               e(k+1,j,i) = ( us(j,i) / 0.4_wp )**2
+                e(k,j,i)   = e(k+1,j,i)
+             ENDDO
+          ENDDO
+       ENDIF
+
+    END SUBROUTINE calc_surface_fluxes
+
+
+!
+!-- Integrated stability function for momentum
+    FUNCTION psi_m( zeta ) 
+       
+       USE kinds
+
+       IMPLICIT NONE 
+
+       REAL(wp)            :: psi_m !< Integrated similarity function result
+       REAL(wp)            :: zeta  !< Stability parameter z/L
+       REAL(wp)            :: x     !< dummy variable
+
+       REAL(wp), PARAMETER :: a = 1.0_wp            !< constant
+       REAL(wp), PARAMETER :: b = 0.66666666666_wp  !< constant
+       REAL(wp), PARAMETER :: c = 5.0_wp            !< constant
+       REAL(wp), PARAMETER :: d = 0.35_wp           !< constant
+       REAL(wp), PARAMETER :: c_d_d = c / d         !< constant
+       REAL(wp), PARAMETER :: bc_d_d = b * c / d    !< constant
+
+
+       IF ( zeta < 0.0_wp )  THEN
+          x = SQRT( SQRT( 1.0_wp  - 16.0_wp * zeta ) )
+          psi_m = pi * 0.5_wp - 2.0_wp * ATAN( x ) + LOG( ( 1.0_wp + x )**2    &
+                  * ( 1.0_wp + x**2 ) * 0.125_wp )
+       ELSE
+
+          psi_m = - b * ( zeta - c_d_d ) * EXP( -d * zeta ) - a * zeta         &
+                   - bc_d_d
+!
+!--       Old version for stable conditions (only valid for z/L < 0.5)
+!--       psi_m = - 5.0_wp * zeta
+
+       ENDIF
+
+    END FUNCTION psi_m
+
+
+!
+!-- Integrated stability function for heat and moisture
+    FUNCTION psi_h( zeta ) 
+       
+       USE kinds
+
+       IMPLICIT NONE 
+
+       REAL(wp)            :: psi_h !< Integrated similarity function result
+       REAL(wp)            :: zeta  !< Stability parameter z/L
+       REAL(wp)            :: x     !< dummy variable
+
+       REAL(wp), PARAMETER :: a = 1.0_wp            !< constant
+       REAL(wp), PARAMETER :: b = 0.66666666666_wp  !< constant
+       REAL(wp), PARAMETER :: c = 5.0_wp            !< constant
+       REAL(wp), PARAMETER :: d = 0.35_wp           !< constant
+       REAL(wp), PARAMETER :: c_d_d = c / d         !< constant
+       REAL(wp), PARAMETER :: bc_d_d = b * c / d    !< constant
+
+
+       IF ( zeta < 0.0_wp )  THEN
+          x = SQRT( 1.0_wp  - 16.0_wp * zeta )
+          psi_h = 2.0_wp * LOG( (1.0_wp + x ) / 2.0_wp )
+       ELSE
+          psi_h = - b * ( zeta - c_d_d ) * EXP( -d * zeta ) - (1.0_wp          &
+                  + 0.66666666666_wp * a * zeta )**1.5_wp - bc_d_d             &
+                  + 1.0_wp
+!
+!--       Old version for stable conditions (only valid for z/L < 0.5)
+!--       psi_h = - 5.0_wp * zeta
+       ENDIF
+
+    END FUNCTION psi_h
+
+ END MODULE surface_layer_fluxes_mod
Index: lm/trunk/SOURCE/temperton_fft.f90
===================================================================
--- /palm/trunk/SOURCE/temperton_fft.f90	(revision 1849)
+++ 	(revision )
@@ -1,2181 +1,0 @@
-!> @file temperton_fft.f90
-!------------------------------------------------------------------------------!
-!
-! Current revisions:
-! -----------------
-! 
-! 
-! Former revisions:
-! -----------------
-! $Id$
-!
-! 1682 2015-10-07 23:56:08Z knoop
-! Code annotations made doxygen readable 
-! 
-! 1342 2014-03-26 17:04:47Z kanani
-! REAL constants defined as wp-kind
-!
-! 1322 2014-03-20 16:38:49Z raasch
-! REAL constants defined as wp-kind
-!
-! 1320 2014-03-20 08:40:49Z raasch
-! ONLY-attribute added to USE-statements,
-! kind-parameters added to all INTEGER and REAL declaration statements,
-! kinds are defined in new module kinds,
-! old module precision_kind is removed,
-! revision history before 2012 removed,
-! comment fields (!:) to be used for variable explanations added to
-! all variable declaration statements 
-!
-! Revision 1.1  2003/03/12 16:41:59  raasch
-! Initial revision
-!
-!
-! Description:
-! ------------
-!> Fast Fourier transformation developed by Clive Temperton, ECMWF.
-!------------------------------------------------------------------------------!
- MODULE temperton_fft
-
-    USE kinds
-
-    IMPLICIT NONE
-
-    PRIVATE
-
-    PUBLIC set99, fft991cy
-
-
-    INTEGER(iwp)          ::  nfax(10)   !< array used by *fft991*.
-    REAL(wp), ALLOCATABLE ::  trig(:)    !< array used by *fft991*.
-
-!
-!-- nfft: maximum length of calls to *fft.
-#if defined( __nec )
-    INTEGER(iwp), PARAMETER ::  nfft = 256  !< 
-#else
-    INTEGER(iwp), PARAMETER ::  nfft =  32  !< 
-#endif
-
-    INTEGER(iwp), PARAMETER ::  nout =   6  !< standard output stream
-
-CONTAINS
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Calls fortran-versions of fft's.
-!> 
-!> Method:
-!> 
-!> Subroutine 'fft991cy' - multiple fast real periodic transform
-!> supersedes previous routine 'fft991cy'.
-!> 
-!> Real transform of length n performed by removing redundant
-!> operations from complex transform of length n.
-!> 
-!> a       is the array containing input & output data.
-!> work    is an area of size (n+1)*min(lot,nfft).
-!> trigs   is a previously prepared list of trig function values.
-!> ifax    is a previously prepared list of factors of n.
-!> inc     is the increment within each data 'vector'
-!>         (e.g. inc=1 for consecutively stored data).
-!> jump    is the increment between the start of each data vector.
-!> n       is the length of the data vectors.
-!> lot     is the number of data vectors.
-!> isign = +1 for transform from spectral to gridpoint
-!>       = -1 for transform from gridpoint to spectral.
-!> 
-!> ordering of coefficients:
-!> a(0),b(0),a(1),b(1),a(2),b(2),.,a(n/2),b(n/2)
-!> where b(0)=b(n/2)=0; (n+2) locations required.
-!> 
-!> ordering of data:
-!> x(0),x(1),x(2),.,x(n-1), 0 , 0 ; (n+2) locations required.
-!> 
-!> Vectorization is achieved on cray by doing the transforms
-!> in parallel.
-!> 
-!> n must be composed of factors 2,3 & 5 but does not have to be even.
-!> 
-!> definition of transforms:
-!> 
-!> isign=+1: x(j)=sum(k=0,.,n-1)(c(k)*exp(2*i*j*k*pi/n))
-!> where c(k)=a(k)+i*b(k) and c(n-k)=a(k)-i*b(k)
-!> 
-!> isign=-1: a(k)=(1/n)*sum(j=0,.,n-1)(x(j)*cos(2*j*k*pi/n))
-!> b(k)=-(1/n)*sum(j=0,.,n-1)(x(j)*sin(2*j*k*pi/n))
-!> 
-!> calls fortran-versions of fft's  !!!
-!> dimension a(n),work(n),trigs(n),ifax(1)
-!------------------------------------------------------------------------------!
-  SUBROUTINE fft991cy(a,work,trigs,ifax,inc,jump,n,lot,isign)
-
-    USE kinds
-
-    IMPLICIT NONE
-
-    !  Scalar arguments 
-    INTEGER(iwp) ::  inc   !< 
-    INTEGER(iwp) ::  isign !< 
-    INTEGER(iwp) ::  jump  !< 
-    INTEGER(iwp) ::  lot   !< 
-    INTEGER(iwp) ::  n     !< 
-
-    !  Array arguments 
-    REAL(wp)     ::  a(*)     !< 
-    REAL(wp)     ::  trigs(*) !< 
-    REAL(wp)     ::  work(*)  !< 
-    INTEGER(iwp) ::  ifax(*)  !< 
-
-    !  Local scalars: 
-    INTEGER(iwp) ::  i      !< 
-    INTEGER(iwp) ::  ia     !< 
-    INTEGER(iwp) ::  ibase  !< 
-    INTEGER(iwp) ::  ierr   !< 
-    INTEGER(iwp) ::  ifac   !< 
-    INTEGER(iwp) ::  igo    !< 
-    INTEGER(iwp) ::  ii     !< 
-    INTEGER(iwp) ::  istart !< 
-    INTEGER(iwp) ::  ix     !< 
-    INTEGER(iwp) ::  iz     !< 
-    INTEGER(iwp) ::  j      !< 
-    INTEGER(iwp) ::  jbase  !< 
-    INTEGER(iwp) ::  jj     !< 
-    INTEGER(iwp) ::  k      !< 
-    INTEGER(iwp) ::  la     !< 
-    INTEGER(iwp) ::  nb     !< 
-    INTEGER(iwp) ::  nblox  !< 
-    INTEGER(iwp) ::  nfax   !< 
-    INTEGER(iwp) ::  nvex   !< 
-    INTEGER(iwp) ::  nx     !< 
-
-    !  Intrinsic functions 
-!    INTRINSIC MOD
-
-
-    !  Executable statements 
-
-    IF (ifax(10)/=n) CALL set99(trigs,ifax,n)
-    nfax = ifax(1)
-    nx = n + 1
-    IF (MOD(n,2)==1) nx = n
-    nblox = 1 + (lot-1)/nfft
-    nvex = lot - (nblox-1)*nfft
-    IF (isign==-1) GO TO 50
-
-    ! isign=+1, spectral to gridpoint transform
-
-    istart = 1
-    DO nb = 1, nblox
-       ia = istart
-       i = istart
-!DIR$ IVDEP
-!CDIR NODEP
-!OCL NOVREC
-       DO j = 1, nvex
-          a(i+inc) = 0.5_wp*a(i)
-          i = i + jump
-       END DO
-       IF (MOD(n,2)==1) GO TO 10
-       i = istart + n*inc
-       DO j = 1, nvex
-          a(i) = 0.5_wp*a(i)
-          i = i + jump
-       END DO
-10     CONTINUE
-       ia = istart + inc
-       la = 1
-       igo = + 1
-
-       DO k = 1, nfax
-          ifac = ifax(k+1)
-          ierr = -1
-          IF (igo==-1) GO TO 20
-          CALL rpassm(a(ia),a(ia+la*inc),work(1),work(ifac*la+1),trigs,inc,1, &
-               &          jump,nx,nvex,n,ifac,la,ierr)
-          GO TO 30
-20        CONTINUE
-          CALL rpassm(work(1),work(la+1),a(ia),a(ia+ifac*la*inc),trigs,1,inc,nx, &
-               &          jump,nvex,n,ifac,la,ierr)
-30        CONTINUE
-          IF (ierr/=0) GO TO 100
-          la = ifac*la
-          igo = -igo
-          ia = istart
-       END DO
-
-       ! If necessary, copy results back to a
-
-       IF (MOD(nfax,2)==0) GO TO 40
-       ibase = 1
-       jbase = ia
-       DO jj = 1, nvex
-          i = ibase
-          j = jbase
-          DO ii = 1, n
-             a(j) = work(i)
-             i = i + 1
-             j = j + inc
-          END DO
-          ibase = ibase + nx
-          jbase = jbase + jump
-       END DO
-40     CONTINUE
-
-       ! Fill in zeros at end
-
-       ix = istart + n*inc
-!DIR$ IVDEP
-!CDIR NODEP
-!OCL NOVREC
-       DO j = 1, nvex
-          a(ix) = 0.0_wp
-          a(ix+inc) = 0.0_wp
-          ix = ix + jump
-       END DO
-
-       istart = istart + nvex*jump
-       nvex = nfft
-    END DO
-    RETURN
-
-    ! isign=-1, gridpoint to spectral transform
-
-50  CONTINUE
-    istart = 1
-    DO nb = 1, nblox
-       ia = istart
-       la = n
-       igo = + 1
-
-       DO k = 1, nfax
-          ifac = ifax(nfax+2-k)
-          la = la/ifac
-          ierr = -1
-          IF (igo==-1) GO TO 60
-          CALL qpassm(a(ia),a(ia+ifac*la*inc),work(1),work(la+1),trigs,inc,1, &
-               &          jump,nx,nvex,n,ifac,la,ierr)
-          GO TO 70
-60        CONTINUE
-          CALL qpassm(work(1),work(ifac*la+1),a(ia),a(ia+la*inc),trigs,1,inc,nx, &
-               &          jump,nvex,n,ifac,la,ierr)
-70        CONTINUE
-          IF (ierr/=0) GO TO 100
-          igo = -igo
-          ia = istart + inc
-       END DO
-
-       ! If necessary, copy results back to a
-
-       IF (MOD(nfax,2)==0) GO TO 80
-       ibase = 1
-       jbase = ia
-       DO jj = 1, nvex
-          i = ibase
-          j = jbase
-          DO ii = 1, n
-             a(j) = work(i)
-             i = i + 1
-             j = j + inc
-          END DO
-          ibase = ibase + nx
-          jbase = jbase + jump
-       END DO
-80     CONTINUE
-
-       ! Shift a(0) & fill in zero imag parts
-
-       ix = istart
-!DIR$ IVDEP
-!CDIR NODEP
-!OCL NOVREC
-       DO j = 1, nvex
-          a(ix) = a(ix+inc)
-          a(ix+inc) = 0.0_wp
-          ix = ix + jump
-       END DO
-       IF (MOD(n,2)==1) GO TO 90
-       iz = istart + (n+1)*inc
-       DO j = 1, nvex
-          a(iz) = 0.0_wp
-          iz = iz + jump
-       END DO
-90     CONTINUE
-
-       istart = istart + nvex*jump
-       nvex = nfft
-    END DO
-    RETURN
-
-    ! Error messages
-
-100 CONTINUE
-
-    SELECT CASE (ierr)
-    CASE (:-1)
-       WRITE (nout,'(A,I5,A)') ' Vector length =',nvex,', greater than nfft'
-    CASE (0)
-       WRITE (nout,'(A,I3,A)') ' Factor =',ifac,', not catered for'
-    CASE (1:)
-       WRITE (nout,'(A,I3,A)') ' Factor =',ifac,', only catered for if la*ifac=n'
-    END SELECT
-
-    RETURN
-  END SUBROUTINE fft991cy
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Performs one pass through data as part of 
-!> multiple real fft (fourier analysis) routine.
-!> 
-!> Method:
-!> 
-!> a       is first real input vector
-!>         equivalence b(1) with a(ifac*la*inc1+1)
-!> c       is first real output vector
-!>         equivalence d(1) with c(la*inc2+1)
-!> trigs   is a precalculated list of sines & cosines
-!> inc1    is the addressing increment for a
-!> inc2    is the addressing increment for c
-!> inc3    is the increment between input vectors a
-!> inc4    is the increment between output vectors c
-!> lot     is the number of vectors
-!> n       is the length of the vectors
-!> ifac    is the current factor of n
-!>         la = n/(product of factors used so far)
-!> ierr    is an error indicator:
-!>         0 - pass completed without error
-!>         1 - lot greater than nfft
-!>         2 - ifac not catered for
-!>         3 - ifac only catered for if la=n/ifac
-!------------------------------------------------------------------------------!
-  SUBROUTINE qpassm(a,b,c,d,trigs,inc1,inc2,inc3,inc4,lot,n,ifac,la,ierr)
-
-    USE kinds
-
-    IMPLICIT NONE 
-
-    !  Scalar arguments 
-    INTEGER(iwp) ::  ierr !< 
-    INTEGER(iwp) ::  ifac !< 
-    INTEGER(iwp) ::  inc1 !< 
-    INTEGER(iwp) ::  inc2 !< 
-    INTEGER(iwp) ::  inc3 !< 
-    INTEGER(iwp) ::  inc4 !< 
-    INTEGER(iwp) ::  la   !< 
-    INTEGER(iwp) ::  lot  !< 
-    INTEGER(iwp) ::  n    !< 
-
-    !  Array arguments 
-    ! REAL :: a(n),b(n),c(n),d(n),trigs(n)
-    REAL(wp) ::  a(*)     !< 
-    REAL(wp) ::  b(*)     !< 
-    REAL(wp) ::  c(*)     !< 
-    REAL(wp) ::  d(*)     !< 
-    REAL(wp) ::  trigs(*) !<
- 
-    !  Local scalars: 
-    REAL(wp) ::  a0     !< 
-    REAL(wp) ::  a1     !< 
-    REAL(wp) ::  a10    !< 
-    REAL(wp) ::  a11    !< 
-    REAL(wp) ::  a2     !< 
-    REAL(wp) ::  a20    !< 
-    REAL(wp) ::  a21    !< 
-    REAL(wp) ::  a3     !< 
-    REAL(wp) ::  a4     !< 
-    REAL(wp) ::  a5     !< 
-    REAL(wp) ::  a6     !< 
-    REAL(wp) ::  b0     !< 
-    REAL(wp) ::  b1     !< 
-    REAL(wp) ::  b10    !< 
-    REAL(wp) ::  b11    !< 
-    REAL(wp) ::  b2     !< 
-    REAL(wp) ::  b20    !< 
-    REAL(wp) ::  b21    !< 
-    REAL(wp) ::  b3     !< 
-    REAL(wp) ::  b4     !< 
-    REAL(wp) ::  b5     !< 
-    REAL(wp) ::  b6     !< 
-    REAL(wp) ::  c1     !< 
-    REAL(wp) ::  c2     !< 
-    REAL(wp) ::  c3     !< 
-    REAL(wp) ::  c4     !< 
-    REAL(wp) ::  c5     !< 
-    REAL(wp) ::  qrt5   !< 
-    REAL(wp) ::  s1     !< 
-    REAL(wp) ::  s2     !< 
-    REAL(wp) ::  s3     !< 
-    REAL(wp) ::  s4     !< 
-    REAL(wp) ::  s5     !< 
-    REAL(wp) ::  sin36  !< 
-    REAL(wp) ::  sin45  !< 
-    REAL(wp) ::  sin60  !< 
-    REAL(wp) ::  sin72  !< 
-    REAL(wp) ::  z      !< 
-    REAL(wp) ::  zqrt5  !< 
-    REAL(wp) ::  zsin36 !< 
-    REAL(wp) ::  zsin45 !< 
-    REAL(wp) ::  zsin60 !< 
-    REAL(wp) ::  zsin72 !< 
-
-    INTEGER(iwp) ::  i     !< 
-    INTEGER(iwp) ::  ia    !< 
-    INTEGER(iwp) ::  ib    !< 
-    INTEGER(iwp) ::  ibad  !< 
-    INTEGER(iwp) ::  ibase !< 
-    INTEGER(iwp) ::  ic    !< 
-    INTEGER(iwp) ::  id    !< 
-    INTEGER(iwp) ::  ie    !< 
-    INTEGER(iwp) ::  if    !< 
-    INTEGER(iwp) ::  ig    !< 
-    INTEGER(iwp) ::  igo   !< 
-    INTEGER(iwp) ::  ih    !< 
-    INTEGER(iwp) ::  iink  !< 
-    INTEGER(iwp) ::  ijk   !< 
-    INTEGER(iwp) ::  ijump !< 
-    INTEGER(iwp) ::  j     !< 
-    INTEGER(iwp) ::  ja    !< 
-    INTEGER(iwp) ::  jb    !< 
-    INTEGER(iwp) ::  jbase !< 
-    INTEGER(iwp) ::  jc    !< 
-    INTEGER(iwp) ::  jd    !< 
-    INTEGER(iwp) ::  je    !< 
-    INTEGER(iwp) ::  jf    !< 
-    INTEGER(iwp) ::  jink  !< 
-    INTEGER(iwp) ::  k     !< 
-    INTEGER(iwp) ::  kb    !< 
-    INTEGER(iwp) ::  kc    !< 
-    INTEGER(iwp) ::  kd    !< 
-    INTEGER(iwp) ::  ke    !< 
-    INTEGER(iwp) ::  kf    !< 
-    INTEGER(iwp) ::  kstop !< 
-    INTEGER(iwp) ::  l     !< 
-    INTEGER(iwp) ::  m     !< 
-
-    !  Intrinsic functions 
-!    INTRINSIC REAL, SQRT
-
-    !  Data statements 
-    DATA sin36/0.587785252292473_wp/, sin72/0.951056516295154_wp/, &
-         &      qrt5/0.559016994374947_wp/, sin60/0.866025403784437_wp/
-
-
-    !  Executable statements 
-
-    m = n/ifac
-    iink = la*inc1
-    jink = la*inc2
-    ijump = (ifac-1)*iink
-    kstop = (n-ifac)/(2*ifac)
-
-    ibad = 1
-    IF (lot>nfft) GO TO 180
-    ibase = 0
-    jbase = 0
-    igo = ifac - 1
-    IF (igo==7) igo = 6
-    ibad = 2
-    IF (igo<1 .OR. igo>6) GO TO 180
-    GO TO (10,40,70,100,130,160) igo
-
-    ! Coding for factor 2
-
-10  CONTINUE
-    ia = 1
-    ib = ia + iink
-    ja = 1
-    jb = ja + (2*m-la)*inc2
-
-    IF (la==m) GO TO 30
-
-    DO l = 1, la
-       i = ibase
-       j = jbase
-!DIR$ IVDEP
-!CDIR NODEP
-!OCL NOVREC
-       DO ijk = 1, lot
-          c(ja+j) = a(ia+i) + a(ib+i)
-          c(jb+j) = a(ia+i) - a(ib+i)
-          i = i + inc3
-          j = j + inc4
-       END DO
-       ibase = ibase + inc1
-       jbase = jbase + inc2
-    END DO
-    ja = ja + jink
-    jink = 2*jink
-    jb = jb - jink
-    ibase = ibase + ijump
-    ijump = 2*ijump + iink
-    IF (ja==jb) GO TO 20
-    DO k = la, kstop, la
-       kb = k + k
-       c1 = trigs(kb+1)
-       s1 = trigs(kb+2)
-       jbase = 0
-       DO l = 1, la
-          i = ibase
-          j = jbase
-!DIR$ IVDEP
-!CDIR NODEP
-!OCL NOVREC
-          DO ijk = 1, lot
-             c(ja+j) = a(ia+i) + (c1*a(ib+i)+s1*b(ib+i))
-             c(jb+j) = a(ia+i) - (c1*a(ib+i)+s1*b(ib+i))
-             d(ja+j) = (c1*b(ib+i)-s1*a(ib+i)) + b(ia+i)
-             d(jb+j) = (c1*b(ib+i)-s1*a(ib+i)) - b(ia+i)
-             i = i + inc3
-             j = j + inc4
-          END DO
-          ibase = ibase + inc1
-          jbase = jbase + inc2
-       END DO
-       ibase = ibase + ijump
-       ja = ja + jink
-       jb = jb - jink
-    END DO
-    IF (ja>jb) GO TO 170
-20  CONTINUE
-    jbase = 0
-    DO l = 1, la
-       i = ibase
-       j = jbase
-!DIR$ IVDEP
-!CDIR NODEP
-!OCL NOVREC
-       DO ijk = 1, lot
-          c(ja+j) = a(ia+i)
-          d(ja+j) = -a(ib+i)
-          i = i + inc3
-          j = j + inc4
-       END DO
-       ibase = ibase + inc1
-       jbase = jbase + inc2
-    END DO
-
-    GO TO 170
-30  CONTINUE
-    z = 1.0_wp/REAL(n,KIND=wp)
-    DO l = 1, la
-       i = ibase
-       j = jbase
-!DIR$ IVDEP
-!CDIR NODEP
-!OCL NOVREC
-       DO ijk = 1, lot
-          c(ja+j) = z*(a(ia+i)+a(ib+i))
-          c(jb+j) = z*(a(ia+i)-a(ib+i))
-          i = i + inc3
-          j = j + inc4
-       END DO
-       ibase = ibase + inc1
-       jbase = jbase + inc2
-    END DO
-    GO TO 170
-
-    ! Coding for factor 3
-
-40  CONTINUE
-    ia = 1
-    ib = ia + iink
-    ic = ib + iink
-    ja = 1
-    jb = ja + (2*m-la)*inc2
-    jc = jb
-
-    IF (la==m) GO TO 60
-
-    DO l = 1, la
-       i = ibase
-       j = jbase
-!DIR$ IVDEP
-!CDIR NODEP
-!OCL NOVREC
-       DO ijk = 1, lot
-          c(ja+j) = a(ia+i) + (a(ib+i)+a(ic+i))
-          c(jb+j) = a(ia+i) - 0.5_wp*(a(ib+i)+a(ic+i))
-          d(jb+j) = sin60*(a(ic+i)-a(ib+i))
-          i = i + inc3
-          j = j + inc4
-       END DO
-       ibase = ibase + inc1
-       jbase = jbase + inc2
-    END DO
-    ja = ja + jink
-    jink = 2*jink
-    jb = jb + jink
-    jc = jc - jink
-    ibase = ibase + ijump
-    ijump = 2*ijump + iink
-    IF (ja==jc) GO TO 50
-    DO k = la, kstop, la
-       kb = k + k
-       kc = kb + kb
-       c1 = trigs(kb+1)
-       s1 = trigs(kb+2)
-       c2 = trigs(kc+1)
-       s2 = trigs(kc+2)
-       jbase = 0
-       DO l = 1, la
-          i = ibase
-          j = jbase
-!DIR$ IVDEP
-!CDIR NODEP
-!OCL NOVREC
-          DO ijk = 1, lot
-             a1 = (c1*a(ib+i)+s1*b(ib+i)) + (c2*a(ic+i)+s2*b(ic+i))
-             b1 = (c1*b(ib+i)-s1*a(ib+i)) + (c2*b(ic+i)-s2*a(ic+i))
-             a2 = a(ia+i) - 0.5_wp*a1
-             b2 = b(ia+i) - 0.5_wp*b1
-             a3 = sin60*((c1*a(ib+i)+s1*b(ib+i))-(c2*a(ic+i)+s2*b(ic+i)))
-             b3 = sin60*((c1*b(ib+i)-s1*a(ib+i))-(c2*b(ic+i)-s2*a(ic+i)))
-             c(ja+j) = a(ia+i) + a1
-             d(ja+j) = b(ia+i) + b1
-             c(jb+j) = a2 + b3
-             d(jb+j) = b2 - a3
-             c(jc+j) = a2 - b3
-             d(jc+j) = -(b2+a3)
-             i = i + inc3
-             j = j + inc4
-          END DO
-          ibase = ibase + inc1
-          jbase = jbase + inc2
-       END DO
-       ibase = ibase + ijump
-       ja = ja + jink
-       jb = jb + jink
-       jc = jc - jink
-    END DO
-    IF (ja>jc) GO TO 170
-50  CONTINUE
-    jbase = 0
-    DO l = 1, la
-       i = ibase
-       j = jbase
-!DIR$ IVDEP
-!CDIR NODEP
-!OCL NOVREC
-       DO ijk = 1, lot
-          c(ja+j) = a(ia+i) + 0.5_wp*(a(ib+i)-a(ic+i))
-          d(ja+j) = -sin60*(a(ib+i)+a(ic+i))
-          c(jb+j) = a(ia+i) - (a(ib+i)-a(ic+i))
-          i = i + inc3
-          j = j + inc4
-       END DO
-       ibase = ibase + inc1
-       jbase = jbase + inc2
-    END DO
-
-    GO TO 170
-60  CONTINUE
-    z = 1.0_wp/REAL(n,KIND=wp)
-    zsin60 = z*sin60
-    DO l = 1, la
-       i = ibase
-       j = jbase
-!DIR$ IVDEP
-!CDIR NODEP
-!OCL NOVREC
-       DO ijk = 1, lot
-          c(ja+j) = z*(a(ia+i)+(a(ib+i)+a(ic+i)))
-          c(jb+j) = z*(a(ia+i)-0.5_wp*(a(ib+i)+a(ic+i)))
-          d(jb+j) = zsin60*(a(ic+i)-a(ib+i))
-          i = i + inc3
-          j = j + inc4
-       END DO
-       ibase = ibase + inc1
-       jbase = jbase + inc2
-    END DO
-    GO TO 170
-
-    ! Coding for factor 4
-
-70  CONTINUE
-    ia = 1
-    ib = ia + iink
-    ic = ib + iink
-    id = ic + iink
-    ja = 1
-    jb = ja + (2*m-la)*inc2
-    jc = jb + 2*m*inc2
-    jd = jb
-
-    IF (la==m) GO TO 90
-
-    DO l = 1, la
-       i = ibase
-       j = jbase
-!DIR$ IVDEP
-!CDIR NODEP
-!OCL NOVREC
-       DO ijk = 1, lot
-          c(ja+j) = (a(ia+i)+a(ic+i)) + (a(ib+i)+a(id+i))
-          c(jc+j) = (a(ia+i)+a(ic+i)) - (a(ib+i)+a(id+i))
-          c(jb+j) = a(ia+i) - a(ic+i)
-          d(jb+j) = a(id+i) - a(ib+i)
-          i = i + inc3
-          j = j + inc4
-       END DO
-       ibase = ibase + inc1
-       jbase = jbase + inc2
-    END DO
-    ja = ja + jink
-    jink = 2*jink
-    jb = jb + jink
-    jc = jc - jink
-    jd = jd - jink
-    ibase = ibase + ijump
-    ijump = 2*ijump + iink
-    IF (jb==jc) GO TO 80
-    DO k = la, kstop, la
-       kb = k + k
-       kc = kb + kb
-       kd = kc + kb
-       c1 = trigs(kb+1)
-       s1 = trigs(kb+2)
-       c2 = trigs(kc+1)
-       s2 = trigs(kc+2)
-       c3 = trigs(kd+1)
-       s3 = trigs(kd+2)
-       jbase = 0
-       DO l = 1, la
-          i = ibase
-          j = jbase
-!DIR$ IVDEP
-!CDIR NODEP
-!OCL NOVREC
-          DO ijk = 1, lot
-             a0 = a(ia+i) + (c2*a(ic+i)+s2*b(ic+i))
-             a2 = a(ia+i) - (c2*a(ic+i)+s2*b(ic+i))
-             a1 = (c1*a(ib+i)+s1*b(ib+i)) + (c3*a(id+i)+s3*b(id+i))
-             a3 = (c1*a(ib+i)+s1*b(ib+i)) - (c3*a(id+i)+s3*b(id+i))
-             b0 = b(ia+i) + (c2*b(ic+i)-s2*a(ic+i))
-             b2 = b(ia+i) - (c2*b(ic+i)-s2*a(ic+i))
-             b1 = (c1*b(ib+i)-s1*a(ib+i)) + (c3*b(id+i)-s3*a(id+i))
-             b3 = (c1*b(ib+i)-s1*a(ib+i)) - (c3*b(id+i)-s3*a(id+i))
-             c(ja+j) = a0 + a1
-             c(jc+j) = a0 - a1
-             d(ja+j) = b0 + b1
-             d(jc+j) = b1 - b0
-             c(jb+j) = a2 + b3
-             c(jd+j) = a2 - b3
-             d(jb+j) = b2 - a3
-             d(jd+j) = -(b2+a3)
-             i = i + inc3
-             j = j + inc4
-          END DO
-          ibase = ibase + inc1
-          jbase = jbase + inc2
-       END DO
-       ibase = ibase + ijump
-       ja = ja + jink
-       jb = jb + jink
-       jc = jc - jink
-       jd = jd - jink
-    END DO
-    IF (jb>jc) GO TO 170
-80  CONTINUE
-    sin45 = SQRT(0.5_wp)
-    jbase = 0
-    DO l = 1, la
-       i = ibase
-       j = jbase
-!DIR$ IVDEP
-!CDIR NODEP
-!OCL NOVREC
-       DO ijk = 1, lot
-          c(ja+j) = a(ia+i) + sin45*(a(ib+i)-a(id+i))
-          c(jb+j) = a(ia+i) - sin45*(a(ib+i)-a(id+i))
-          d(ja+j) = -a(ic+i) - sin45*(a(ib+i)+a(id+i))
-          d(jb+j) = a(ic+i) - sin45*(a(ib+i)+a(id+i))
-          i = i + inc3
-          j = j + inc4
-       END DO
-       ibase = ibase + inc1
-       jbase = jbase + inc2
-    END DO
-
-    GO TO 170
-90  CONTINUE
-    z = 1.0_wp/REAL(n,KIND=wp)
-    DO l = 1, la
-       i = ibase
-       j = jbase
-!DIR$ IVDEP
-!CDIR NODEP
-!OCL NOVREC
-       DO ijk = 1, lot
-          c(ja+j) = z*((a(ia+i)+a(ic+i))+(a(ib+i)+a(id+i)))
-          c(jc+j) = z*((a(ia+i)+a(ic+i))-(a(ib+i)+a(id+i)))
-          c(jb+j) = z*(a(ia+i)-a(ic+i))
-          d(jb+j) = z*(a(id+i)-a(ib+i))
-          i = i + inc3
-          j = j + inc4
-       END DO
-       ibase = ibase + inc1
-       jbase = jbase + inc2
-    END DO
-    GO TO 170
-
-    ! Coding for factor 5
-
-100 CONTINUE
-    ia = 1
-    ib = ia + iink
-    ic = ib + iink
-    id = ic + iink
-    ie = id + iink
-    ja = 1
-    jb = ja + (2*m-la)*inc2
-    jc = jb + 2*m*inc2
-    jd = jc
-    je = jb
-
-    IF (la==m) GO TO 120
-
-    DO l = 1, la
-       i = ibase
-       j = jbase
-!DIR$ IVDEP
-!CDIR NODEP
-!OCL NOVREC
-       DO ijk = 1, lot
-          a1 = a(ib+i) + a(ie+i)
-          a3 = a(ib+i) - a(ie+i)
-          a2 = a(ic+i) + a(id+i)
-          a4 = a(ic+i) - a(id+i)
-          a5 = a(ia+i) - 0.25_wp*(a1+a2)
-          a6 = qrt5*(a1-a2)
-          c(ja+j) = a(ia+i) + (a1+a2)
-          c(jb+j) = a5 + a6
-          c(jc+j) = a5 - a6
-          d(jb+j) = -sin72*a3 - sin36*a4
-          d(jc+j) = -sin36*a3 + sin72*a4
-          i = i + inc3
-          j = j + inc4
-       END DO
-       ibase = ibase + inc1
-       jbase = jbase + inc2
-    END DO
-    ja = ja + jink
-    jink = 2*jink
-    jb = jb + jink
-    jc = jc + jink
-    jd = jd - jink
-    je = je - jink
-    ibase = ibase + ijump
-    ijump = 2*ijump + iink
-    IF (jb==jd) GO TO 110
-    DO k = la, kstop, la
-       kb = k + k
-       kc = kb + kb
-       kd = kc + kb
-       ke = kd + kb
-       c1 = trigs(kb+1)
-       s1 = trigs(kb+2)
-       c2 = trigs(kc+1)
-       s2 = trigs(kc+2)
-       c3 = trigs(kd+1)
-       s3 = trigs(kd+2)
-       c4 = trigs(ke+1)
-       s4 = trigs(ke+2)
-       jbase = 0
-       DO l = 1, la
-          i = ibase
-          j = jbase
-!DIR$ IVDEP
-!CDIR NODEP
-!OCL NOVREC
-          DO ijk = 1, lot
-             a1 = (c1*a(ib+i)+s1*b(ib+i)) + (c4*a(ie+i)+s4*b(ie+i))
-             a3 = (c1*a(ib+i)+s1*b(ib+i)) - (c4*a(ie+i)+s4*b(ie+i))
-             a2 = (c2*a(ic+i)+s2*b(ic+i)) + (c3*a(id+i)+s3*b(id+i))
-             a4 = (c2*a(ic+i)+s2*b(ic+i)) - (c3*a(id+i)+s3*b(id+i))
-             b1 = (c1*b(ib+i)-s1*a(ib+i)) + (c4*b(ie+i)-s4*a(ie+i))
-             b3 = (c1*b(ib+i)-s1*a(ib+i)) - (c4*b(ie+i)-s4*a(ie+i))
-             b2 = (c2*b(ic+i)-s2*a(ic+i)) + (c3*b(id+i)-s3*a(id+i))
-             b4 = (c2*b(ic+i)-s2*a(ic+i)) - (c3*b(id+i)-s3*a(id+i))
-             a5 = a(ia+i) - 0.25_wp*(a1+a2)
-             a6 = qrt5*(a1-a2)
-             b5 = b(ia+i) - 0.25_wp*(b1+b2)
-             b6 = qrt5*(b1-b2)
-             a10 = a5 + a6
-             a20 = a5 - a6
-             b10 = b5 + b6
-             b20 = b5 - b6
-             a11 = sin72*b3 + sin36*b4
-             a21 = sin36*b3 - sin72*b4
-             b11 = sin72*a3 + sin36*a4
-             b21 = sin36*a3 - sin72*a4
-             c(ja+j) = a(ia+i) + (a1+a2)
-             c(jb+j) = a10 + a11
-             c(je+j) = a10 - a11
-             c(jc+j) = a20 + a21
-             c(jd+j) = a20 - a21
-             d(ja+j) = b(ia+i) + (b1+b2)
-             d(jb+j) = b10 - b11
-             d(je+j) = -(b10+b11)
-             d(jc+j) = b20 - b21
-             d(jd+j) = -(b20+b21)
-             i = i + inc3
-             j = j + inc4
-          END DO
-          ibase = ibase + inc1
-          jbase = jbase + inc2
-       END DO
-       ibase = ibase + ijump
-       ja = ja + jink
-       jb = jb + jink
-       jc = jc + jink
-       jd = jd - jink
-       je = je - jink
-    END DO
-    IF (jb>jd) GO TO 170
-110 CONTINUE
-    jbase = 0
-    DO l = 1, la
-       i = ibase
-       j = jbase
-!DIR$ IVDEP
-!CDIR NODEP
-!OCL NOVREC
-       DO ijk = 1, lot
-          a1 = a(ib+i) + a(ie+i)
-          a3 = a(ib+i) - a(ie+i)
-          a2 = a(ic+i) + a(id+i)
-          a4 = a(ic+i) - a(id+i)
-          a5 = a(ia+i) + 0.25_wp*(a3-a4)
-          a6 = qrt5*(a3+a4)
-          c(ja+j) = a5 + a6
-          c(jb+j) = a5 - a6
-          c(jc+j) = a(ia+i) - (a3-a4)
-          d(ja+j) = -sin36*a1 - sin72*a2
-          d(jb+j) = -sin72*a1 + sin36*a2
-          i = i + inc3
-          j = j + inc4
-       END DO
-       ibase = ibase + inc1
-       jbase = jbase + inc2
-    END DO
-
-    GO TO 170
-120 CONTINUE
-    z = 1.0_wp/REAL(n,KIND=wp)
-    zqrt5 = z*qrt5
-    zsin36 = z*sin36
-    zsin72 = z*sin72
-    DO l = 1, la
-       i = ibase
-       j = jbase
-!DIR$ IVDEP
-!CDIR NODEP
-!OCL NOVREC
-       DO ijk = 1, lot
-          a1 = a(ib+i) + a(ie+i)
-          a3 = a(ib+i) - a(ie+i)
-          a2 = a(ic+i) + a(id+i)
-          a4 = a(ic+i) - a(id+i)
-          a5 = z*(a(ia+i)-0.25_wp*(a1+a2))
-          a6 = zqrt5*(a1-a2)
-          c(ja+j) = z*(a(ia+i)+(a1+a2))
-          c(jb+j) = a5 + a6
-          c(jc+j) = a5 - a6
-          d(jb+j) = -zsin72*a3 - zsin36*a4
-          d(jc+j) = -zsin36*a3 + zsin72*a4
-          i = i + inc3
-          j = j + inc4
-       END DO
-       ibase = ibase + inc1
-       jbase = jbase + inc2
-    END DO
-    GO TO 170
-
-    ! Coding for factor 6
-
-130 CONTINUE
-    ia = 1
-    ib = ia + iink
-    ic = ib + iink
-    id = ic + iink
-    ie = id + iink
-    if = ie + iink
-    ja = 1
-    jb = ja + (2*m-la)*inc2
-    jc = jb + 2*m*inc2
-    jd = jc + 2*m*inc2
-    je = jc
-    jf = jb
-
-    IF (la==m) GO TO 150
-
-    DO l = 1, la
-       i = ibase
-       j = jbase
-!DIR$ IVDEP
-!CDIR NODEP
-!OCL NOVREC
-       DO ijk = 1, lot
-          a11 = (a(ic+i)+a(if+i)) + (a(ib+i)+a(ie+i))
-          c(ja+j) = (a(ia+i)+a(id+i)) + a11
-          c(jc+j) = (a(ia+i)+a(id+i)-0.5_wp*a11)
-          d(jc+j) = sin60*((a(ic+i)+a(if+i))-(a(ib+i)+a(ie+i)))
-          a11 = (a(ic+i)-a(if+i)) + (a(ie+i)-a(ib+i))
-          c(jb+j) = (a(ia+i)-a(id+i)) - 0.5_wp*a11
-          d(jb+j) = sin60*((a(ie+i)-a(ib+i))-(a(ic+i)-a(if+i)))
-          c(jd+j) = (a(ia+i)-a(id+i)) + a11
-          i = i + inc3
-          j = j + inc4
-       END DO
-       ibase = ibase + inc1
-       jbase = jbase + inc2
-    END DO
-    ja = ja + jink
-    jink = 2*jink
-    jb = jb + jink
-    jc = jc + jink
-    jd = jd - jink
-    je = je - jink
-    jf = jf - jink
-    ibase = ibase + ijump
-    ijump = 2*ijump + iink
-    IF (jc==jd) GO TO 140
-    DO k = la, kstop, la
-       kb = k + k
-       kc = kb + kb
-       kd = kc + kb
-       ke = kd + kb
-       kf = ke + kb
-       c1 = trigs(kb+1)
-       s1 = trigs(kb+2)
-       c2 = trigs(kc+1)
-       s2 = trigs(kc+2)
-       c3 = trigs(kd+1)
-       s3 = trigs(kd+2)
-       c4 = trigs(ke+1)
-       s4 = trigs(ke+2)
-       c5 = trigs(kf+1)
-       s5 = trigs(kf+2)
-       jbase = 0
-       DO l = 1, la
-          i = ibase
-          j = jbase
-!DIR$ IVDEP
-!CDIR NODEP
-!OCL NOVREC
-          DO ijk = 1, lot
-             a1 = c1*a(ib+i) + s1*b(ib+i)
-             b1 = c1*b(ib+i) - s1*a(ib+i)
-             a2 = c2*a(ic+i) + s2*b(ic+i)
-             b2 = c2*b(ic+i) - s2*a(ic+i)
-             a3 = c3*a(id+i) + s3*b(id+i)
-             b3 = c3*b(id+i) - s3*a(id+i)
-             a4 = c4*a(ie+i) + s4*b(ie+i)
-             b4 = c4*b(ie+i) - s4*a(ie+i)
-             a5 = c5*a(if+i) + s5*b(if+i)
-             b5 = c5*b(if+i) - s5*a(if+i)
-             a11 = (a2+a5) + (a1+a4)
-             a20 = (a(ia+i)+a3) - 0.5_wp*a11
-             a21 = sin60*((a2+a5)-(a1+a4))
-             b11 = (b2+b5) + (b1+b4)
-             b20 = (b(ia+i)+b3) - 0.5_wp*b11
-             b21 = sin60*((b2+b5)-(b1+b4))
-             c(ja+j) = (a(ia+i)+a3) + a11
-             d(ja+j) = (b(ia+i)+b3) + b11
-             c(jc+j) = a20 - b21
-             d(jc+j) = a21 + b20
-             c(je+j) = a20 + b21
-             d(je+j) = a21 - b20
-             a11 = (a2-a5) + (a4-a1)
-             a20 = (a(ia+i)-a3) - 0.5_wp*a11
-             a21 = sin60*((a4-a1)-(a2-a5))
-             b11 = (b5-b2) - (b4-b1)
-             b20 = (b3-b(ia+i)) - 0.5_wp*b11
-             b21 = sin60*((b5-b2)+(b4-b1))
-             c(jb+j) = a20 - b21
-             d(jb+j) = a21 - b20
-             c(jd+j) = a11 + (a(ia+i)-a3)
-             d(jd+j) = b11 + (b3-b(ia+i))
-             c(jf+j) = a20 + b21
-             d(jf+j) = a21 + b20
-             i = i + inc3
-             j = j + inc4
-          END DO
-          ibase = ibase + inc1
-          jbase = jbase + inc2
-       END DO
-       ibase = ibase + ijump
-       ja = ja + jink
-       jb = jb + jink
-       jc = jc + jink
-       jd = jd - jink
-       je = je - jink
-       jf = jf - jink
-    END DO
-    IF (jc>jd) GO TO 170
-140 CONTINUE
-    jbase = 0
-    DO l = 1, la
-       i = ibase
-       j = jbase
-!DIR$ IVDEP
-!CDIR NODEP
-!OCL NOVREC
-       DO ijk = 1, lot
-          c(ja+j) = (a(ia+i)+0.5_wp*(a(ic+i)-a(ie+i))) + sin60*(a(ib+i)-a(if+i))
-          d(ja+j) = -(a(id+i)+0.5_wp*(a(ib+i)+a(if+i))) - sin60*(a(ic+i)+a(ie+i))
-          c(jb+j) = a(ia+i) - (a(ic+i)-a(ie+i))
-          d(jb+j) = a(id+i) - (a(ib+i)+a(if+i))
-          c(jc+j) = (a(ia+i)+0.5_wp*(a(ic+i)-a(ie+i))) - sin60*(a(ib+i)-a(if+i))
-          d(jc+j) = -(a(id+i)+0.5_wp*(a(ib+i)+a(if+i))) + sin60*(a(ic+i)+a(ie+i))
-          i = i + inc3
-          j = j + inc4
-       END DO
-       ibase = ibase + inc1
-       jbase = jbase + inc2
-    END DO
-
-    GO TO 170
-150 CONTINUE
-    z = 1.0_wp/REAL(n,KIND=wp)
-    zsin60 = z*sin60
-    DO l = 1, la
-       i = ibase
-       j = jbase
-!DIR$ IVDEP
-!CDIR NODEP
-!OCL NOVREC
-       DO ijk = 1, lot
-          a11 = (a(ic+i)+a(if+i)) + (a(ib+i)+a(ie+i))
-          c(ja+j) = z*((a(ia+i)+a(id+i))+a11)
-          c(jc+j) = z*((a(ia+i)+a(id+i))-0.5_wp*a11)
-          d(jc+j) = zsin60*((a(ic+i)+a(if+i))-(a(ib+i)+a(ie+i)))
-          a11 = (a(ic+i)-a(if+i)) + (a(ie+i)-a(ib+i))
-          c(jb+j) = z*((a(ia+i)-a(id+i))-0.5_wp*a11)
-          d(jb+j) = zsin60*((a(ie+i)-a(ib+i))-(a(ic+i)-a(if+i)))
-          c(jd+j) = z*((a(ia+i)-a(id+i))+a11)
-          i = i + inc3
-          j = j + inc4
-       END DO
-       ibase = ibase + inc1
-       jbase = jbase + inc2
-    END DO
-    GO TO 170
-
-    ! Coding for factor 8
-
-160 CONTINUE
-    ibad = 3
-    IF (la/=m) GO TO 180
-    ia = 1
-    ib = ia + iink
-    ic = ib + iink
-    id = ic + iink
-    ie = id + iink
-    if = ie + iink
-    ig = if + iink
-    ih = ig + iink
-    ja = 1
-    jb = ja + la*inc2
-    jc = jb + 2*m*inc2
-    jd = jc + 2*m*inc2
-    je = jd + 2*m*inc2
-    z = 1.0_wp/REAL(n,KIND=wp)
-    zsin45 = z*SQRT(0.5_wp)
-
-    DO l = 1, la
-       i = ibase
-       j = jbase
-!DIR$ IVDEP
-!CDIR NODEP
-!OCL NOVREC
-       DO ijk = 1, lot
-          c(ja+j) = z*(((a(ia+i)+a(ie+i))+(a(ic+i)+a(ig+i)))+((a(id+i)+ &
-               &          a(ih+i))+(a(ib+i)+a(if+i))))
-          c(je+j) = z*(((a(ia+i)+a(ie+i))+(a(ic+i)+a(ig+i)))-((a(id+i)+ &
-               &          a(ih+i))+(a(ib+i)+a(if+i))))
-          c(jc+j) = z*((a(ia+i)+a(ie+i))-(a(ic+i)+a(ig+i)))
-          d(jc+j) = z*((a(id+i)+a(ih+i))-(a(ib+i)+a(if+i)))
-          c(jb+j) = z*(a(ia+i)-a(ie+i)) + zsin45*((a(ih+i)-a(id+i))-(a(if+ &
-               &          i)-a(ib+i)))
-          c(jd+j) = z*(a(ia+i)-a(ie+i)) - zsin45*((a(ih+i)-a(id+i))-(a(if+ &
-               &          i)-a(ib+i)))
-          d(jb+j) = zsin45*((a(ih+i)-a(id+i))+(a(if+i)-a(ib+i))) + &
-               &          z*(a(ig+i)-a(ic+i))
-          d(jd+j) = zsin45*((a(ih+i)-a(id+i))+(a(if+i)-a(ib+i))) - &
-               &          z*(a(ig+i)-a(ic+i))
-          i = i + inc3
-          j = j + inc4
-       END DO
-       ibase = ibase + inc1
-       jbase = jbase + inc2
-    END DO
-
-    ! Return
-
-170 CONTINUE
-    ibad = 0
-180 CONTINUE
-    ierr = ibad
-    RETURN
-  END SUBROUTINE qpassm
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> @todo Missing subroutine description.
-!------------------------------------------------------------------------------!
-  SUBROUTINE rpassm(a,b,c,d,trigs,inc1,inc2,inc3,inc4,lot,n,ifac,la,ierr)
-    ! Dimension a(n),b(n),c(n),d(n),trigs(n)
-
-    USE kinds
-
-    IMPLICIT NONE
-
-    !  Scalar arguments 
-    INTEGER(iwp) ::  ierr !< 
-    INTEGER(iwp) ::  ifac !< 
-    INTEGER(iwp) ::  inc1 !< 
-    INTEGER(iwp) ::  inc2 !< 
-    INTEGER(iwp) ::  inc3 !< 
-    INTEGER(iwp) ::  inc4 !< 
-    INTEGER(iwp) ::  la   !< 
-    INTEGER(iwp) ::  lot  !< 
-    INTEGER(iwp) ::  n    !< 
-
-    !  Array arguments 
-    REAL(wp) ::  a(*)     !< 
-    REAL(wp) ::  b(*)     !< 
-    REAL(wp) ::  c(*)     !< 
-    REAL(wp) ::  d(*)     !< 
-    REAL(wp) ::  trigs(*) !< 
-
-    !  Local scalars: 
-    REAL(wp) ::  c1     !< 
-    REAL(wp) ::  c2     !< 
-    REAL(wp) ::  c3     !< 
-    REAL(wp) ::  c4     !< 
-    REAL(wp) ::  c5     !< 
-    REAL(wp) ::  qqrt5  !< 
-    REAL(wp) ::  qrt5   !< 
-    REAL(wp) ::  s1     !< 
-    REAL(wp) ::  s2     !< 
-    REAL(wp) ::  s3     !< 
-    REAL(wp) ::  s4     !< 
-    REAL(wp) ::  s5     !< 
-    REAL(wp) ::  sin36  !< 
-    REAL(wp) ::  sin45  !< 
-    REAL(wp) ::  sin60  !< 
-    REAL(wp) ::  sin72  !< 
-    REAL(wp) ::  ssin36 !< 
-    REAL(wp) ::  ssin45 !< 
-    REAL(wp) ::  ssin60 !< 
-    REAL(wp) ::  ssin72 !< 
-
-    INTEGER(iwp) ::  i     !< 
-    INTEGER(iwp) ::  ia    !< 
-    INTEGER(iwp) ::  ib    !< 
-    INTEGER(iwp) ::  ibad  !< 
-    INTEGER(iwp) ::  ibase !< 
-    INTEGER(iwp) ::  ic    !< 
-    INTEGER(iwp) ::  id    !< 
-    INTEGER(iwp) ::  ie    !< 
-    INTEGER(iwp) ::  if    !< 
-    INTEGER(iwp) ::  igo   !< 
-    INTEGER(iwp) ::  iink  !< 
-    INTEGER(iwp) ::  ijk   !< 
-    INTEGER(iwp) ::  j     !< 
-    INTEGER(iwp) ::  ja    !< 
-    INTEGER(iwp) ::  jb    !< 
-    INTEGER(iwp) ::  jbase !< 
-    INTEGER(iwp) ::  jc    !< 
-    INTEGER(iwp) ::  jd    !< 
-    INTEGER(iwp) ::  je    !< 
-    INTEGER(iwp) ::  jf    !< 
-    INTEGER(iwp) ::  jg    !< 
-    INTEGER(iwp) ::  jh    !< 
-    INTEGER(iwp) ::  jink  !< 
-    INTEGER(iwp) ::  jump  !< 
-    INTEGER(iwp) ::  k     !< 
-    INTEGER(iwp) ::  kb    !< 
-    INTEGER(iwp) ::  kc    !< 
-    INTEGER(iwp) ::  kd    !< 
-    INTEGER(iwp) ::  ke    !< 
-    INTEGER(iwp) ::  kf    !< 
-    INTEGER(iwp) ::  kstop !< 
-    INTEGER(iwp) ::  l     !< 
-    INTEGER(iwp) ::  m     !< 
-
-    !  Local arrays: 
-    REAL(wp) ::  a10(nfft) !< 
-    REAL(wp) ::  a11(nfft) !< 
-    REAL(wp) ::  a20(nfft) !< 
-    REAL(wp) ::  a21(nfft) !< 
-    REAL(wp) ::  b10(nfft) !< 
-    REAL(wp) ::  b11(nfft) !< 
-    REAL(wp) ::  b20(nfft) !< 
-    REAL(wp) ::  b21(nfft) !< 
-
-    !  Intrinsic functions 
-!    INTRINSIC SQRT
-
-    !  Data statements 
-    DATA sin36/0.587785252292473_wp/, sin72/0.951056516295154_wp/, &
-         &      qrt5/0.559016994374947_wp/, sin60/0.866025403784437_wp/
-
-
-    !  Executable statements 
-
-    m = n/ifac
-    iink = la*inc1
-    jink = la*inc2
-    jump = (ifac-1)*jink
-    kstop = (n-ifac)/(2*ifac)
-
-    ibad = 1
-    IF (lot>nfft) GO TO 180
-    ibase = 0
-    jbase = 0
-    igo = ifac - 1
-    IF (igo==7) igo = 6
-    ibad = 2
-    IF (igo<1 .OR. igo>6) GO TO 180
-    GO TO (10,40,70,100,130,160) igo
-
-    ! Coding for factor 2
-
-10  CONTINUE
-    ia = 1
-    ib = ia + (2*m-la)*inc1
-    ja = 1
-    jb = ja + jink
-
-    IF (la==m) GO TO 30
-
-    DO l = 1, la
-       i = ibase
-       j = jbase
-!DIR$ IVDEP
-!CDIR NODEP
-!OCL NOVREC
-       DO ijk = 1, lot
-          c(ja+j) = a(ia+i) + a(ib+i)
-          c(jb+j) = a(ia+i) - a(ib+i)
-          i = i + inc3
-          j = j + inc4
-       END DO
-       ibase = ibase + inc1
-       jbase = jbase + inc2
-    END DO
-    ia = ia + iink
-    iink = 2*iink
-    ib = ib - iink
-    ibase = 0
-    jbase = jbase + jump
-    jump = 2*jump + jink
-    IF (ia==ib) GO TO 20
-    DO k = la, kstop, la
-       kb = k + k
-       c1 = trigs(kb+1)
-       s1 = trigs(kb+2)
-       ibase = 0
-       DO l = 1, la
-          i = ibase
-          j = jbase
-!DIR$ IVDEP
-!CDIR NODEP
-!OCL NOVREC
-          DO ijk = 1, lot
-             c(ja+j) = a(ia+i) + a(ib+i)
-             d(ja+j) = b(ia+i) - b(ib+i)
-             c(jb+j) = c1*(a(ia+i)-a(ib+i)) - s1*(b(ia+i)+b(ib+i))
-             d(jb+j) = s1*(a(ia+i)-a(ib+i)) + c1*(b(ia+i)+b(ib+i))
-             i = i + inc3
-             j = j + inc4
-          END DO
-          ibase = ibase + inc1
-          jbase = jbase + inc2
-       END DO
-       ia = ia + iink
-       ib = ib - iink
-       jbase = jbase + jump
-    END DO
-    IF (ia>ib) GO TO 170
-20  CONTINUE
-    ibase = 0
-    DO l = 1, la
-       i = ibase
-       j = jbase
-!DIR$ IVDEP
-!CDIR NODEP
-!OCL NOVREC
-       DO ijk = 1, lot
-          c(ja+j) = a(ia+i)
-          c(jb+j) = -b(ia+i)
-          i = i + inc3
-          j = j + inc4
-       END DO
-       ibase = ibase + inc1
-       jbase = jbase + inc2
-    END DO
-
-    GO TO 170
-30  CONTINUE
-    DO l = 1, la
-       i = ibase
-       j = jbase
-!DIR$ IVDEP
-!CDIR NODEP
-!OCL NOVREC
-       DO ijk = 1, lot
-          c(ja+j) = 2.0_wp*(a(ia+i)+a(ib+i))
-          c(jb+j) = 2.0_wp*(a(ia+i)-a(ib+i))
-          i = i + inc3
-          j = j + inc4
-       END DO
-       ibase = ibase + inc1
-       jbase = jbase + inc2
-    END DO
-    GO TO 170
-
-    ! Coding for factor 3
-
-40  CONTINUE
-    ia = 1
-    ib = ia + (2*m-la)*inc1
-    ic = ib
-    ja = 1
-    jb = ja + jink
-    jc = jb + jink
-
-    IF (la==m) GO TO 60
-
-    DO l = 1, la
-       i = ibase
-       j = jbase
-!DIR$ IVDEP
-!CDIR NODEP
-!OCL NOVREC
-       DO ijk = 1, lot
-          c(ja+j) = a(ia+i) + a(ib+i)
-          c(jb+j) = (a(ia+i)-0.5_wp*a(ib+i)) - (sin60*(b(ib+i)))
-          c(jc+j) = (a(ia+i)-0.5_wp*a(ib+i)) + (sin60*(b(ib+i)))
-          i = i + inc3
-          j = j + inc4
-       END DO
-       ibase = ibase + inc1
-       jbase = jbase + inc2
-    END DO
-    ia = ia + iink
-    iink = 2*iink
-    ib = ib + iink
-    ic = ic - iink
-    jbase = jbase + jump
-    jump = 2*jump + jink
-    IF (ia==ic) GO TO 50
-    DO k = la, kstop, la
-       kb = k + k
-       kc = kb + kb
-       c1 = trigs(kb+1)
-       s1 = trigs(kb+2)
-       c2 = trigs(kc+1)
-       s2 = trigs(kc+2)
-       ibase = 0
-       DO l = 1, la
-          i = ibase
-          j = jbase
-!DIR$ IVDEP
-!CDIR NODEP
-!OCL NOVREC
-          DO ijk = 1, lot
-             c(ja+j) = a(ia+i) + (a(ib+i)+a(ic+i))
-             d(ja+j) = b(ia+i) + (b(ib+i)-b(ic+i))
-             c(jb+j) = c1*((a(ia+i)-0.5_wp*(a(ib+i)+a(ic+i)))-(sin60*(b(ib+i)+ &
-                  &            b(ic+i))))                                      &
-                  &    - s1*((b(ia+i)-0.5_wp*(b(ib+i)-b(ic+i)))+(sin60*(a(ib+i)- &
-                  &            a(ic+i))))
-             d(jb+j) = s1*((a(ia+i)-0.5_wp*(a(ib+i)+a(ic+i)))-(sin60*(b(ib+i)+ &
-                  &            b(ic+i))))                                      &
-                  &    + c1*((b(ia+i)-0.5_wp*(b(ib+i)-b(ic+i)))+(sin60*(a(ib+i)- &
-                  &            a(ic+i))))
-             c(jc+j) = c2*((a(ia+i)-0.5_wp*(a(ib+i)+a(ic+i)))+(sin60*(b(ib+i)+ &
-                  &            b(ic+i))))                                      &
-                  &    - s2*((b(ia+i)-0.5_wp*(b(ib+i)-b(ic+i)))-(sin60*(a(ib+i)- &
-                  &            a(ic+i))))
-             d(jc+j) = s2*((a(ia+i)-0.5_wp*(a(ib+i)+a(ic+i)))+(sin60*(b(ib+i)+ &
-                  &            b(ic+i))))                                      &
-                  &    + c2*((b(ia+i)-0.5_wp*(b(ib+i)-b(ic+i)))-(sin60*(a(ib+i)- &
-                  &            a(ic+i))))
-             i = i + inc3
-             j = j + inc4
-          END DO
-          ibase = ibase + inc1
-          jbase = jbase + inc2
-       END DO
-       ia = ia + iink
-       ib = ib + iink
-       ic = ic - iink
-       jbase = jbase + jump
-    END DO
-    IF (ia>ic) GO TO 170
-50  CONTINUE
-    ibase = 0
-    DO l = 1, la
-       i = ibase
-       j = jbase
-!DIR$ IVDEP
-!CDIR NODEP
-!OCL NOVREC
-       DO ijk = 1, lot
-          c(ja+j) = a(ia+i) + a(ib+i)
-          c(jb+j) = (0.5_wp*a(ia+i)-a(ib+i)) - (sin60*b(ia+i))
-          c(jc+j) = -(0.5_wp*a(ia+i)-a(ib+i)) - (sin60*b(ia+i))
-          i = i + inc3
-          j = j + inc4
-       END DO
-       ibase = ibase + inc1
-       jbase = jbase + inc2
-    END DO
-
-    GO TO 170
-60  CONTINUE
-    ssin60 = 2.0_wp*sin60
-    DO l = 1, la
-       i = ibase
-       j = jbase
-!DIR$ IVDEP
-!CDIR NODEP
-!OCL NOVREC
-       DO ijk = 1, lot
-          c(ja+j) = 2.0_wp*(a(ia+i)+a(ib+i))
-          c(jb+j) = (2.0_wp*a(ia+i)-a(ib+i)) - (ssin60*b(ib+i))
-          c(jc+j) = (2.0_wp*a(ia+i)-a(ib+i)) + (ssin60*b(ib+i))
-          i = i + inc3
-          j = j + inc4
-       END DO
-       ibase = ibase + inc1
-       jbase = jbase + inc2
-    END DO
-    GO TO 170
-
-    ! Coding for factor 4
-
-70  CONTINUE
-    ia = 1
-    ib = ia + (2*m-la)*inc1
-    ic = ib + 2*m*inc1
-    id = ib
-    ja = 1
-    jb = ja + jink
-    jc = jb + jink
-    jd = jc + jink
-
-    IF (la==m) GO TO 90
-
-    DO l = 1, la
-       i = ibase
-       j = jbase
-!DIR$ IVDEP
-!CDIR NODEP
-!OCL NOVREC
-       DO ijk = 1, lot
-          c(ja+j) = (a(ia+i)+a(ic+i)) + a(ib+i)
-          c(jb+j) = (a(ia+i)-a(ic+i)) - b(ib+i)
-          c(jc+j) = (a(ia+i)+a(ic+i)) - a(ib+i)
-          c(jd+j) = (a(ia+i)-a(ic+i)) + b(ib+i)
-          i = i + inc3
-          j = j + inc4
-       END DO
-       ibase = ibase + inc1
-       jbase = jbase + inc2
-    END DO
-    ia = ia + iink
-    iink = 2*iink
-    ib = ib + iink
-    ic = ic - iink
-    id = id - iink
-    jbase = jbase + jump
-    jump = 2*jump + jink
-    IF (ib==ic) GO TO 80
-    DO k = la, kstop, la
-       kb = k + k
-       kc = kb + kb
-       kd = kc + kb
-       c1 = trigs(kb+1)
-       s1 = trigs(kb+2)
-       c2 = trigs(kc+1)
-       s2 = trigs(kc+2)
-       c3 = trigs(kd+1)
-       s3 = trigs(kd+2)
-       ibase = 0
-       DO l = 1, la
-          i = ibase
-          j = jbase
-!DIR$ IVDEP
-!CDIR NODEP
-!OCL NOVREC
-          DO ijk = 1, lot
-             c(ja+j) = (a(ia+i)+a(ic+i)) + (a(ib+i)+a(id+i))
-             d(ja+j) = (b(ia+i)-b(ic+i)) + (b(ib+i)-b(id+i))
-             c(jc+j) = c2*((a(ia+i)+a(ic+i))-(a(ib+i)+a(id+i))) - s2*((b(ia+ &
-                  &            i)-b(ic+i))-(b(ib+i)-b(id+i)))
-             d(jc+j) = s2*((a(ia+i)+a(ic+i))-(a(ib+i)+a(id+i))) + c2*((b(ia+ &
-                  &            i)-b(ic+i))-(b(ib+i)-b(id+i)))
-             c(jb+j) = c1*((a(ia+i)-a(ic+i))-(b(ib+i)+b(id+i))) - s1*((b(ia+ &
-                  &            i)+b(ic+i))+(a(ib+i)-a(id+i)))
-             d(jb+j) = s1*((a(ia+i)-a(ic+i))-(b(ib+i)+b(id+i))) + c1*((b(ia+ &
-                  &            i)+b(ic+i))+(a(ib+i)-a(id+i)))
-             c(jd+j) = c3*((a(ia+i)-a(ic+i))+(b(ib+i)+b(id+i))) - s3*((b(ia+ &
-                  &            i)+b(ic+i))-(a(ib+i)-a(id+i)))
-             d(jd+j) = s3*((a(ia+i)-a(ic+i))+(b(ib+i)+b(id+i))) + c3*((b(ia+ &
-                  &            i)+b(ic+i))-(a(ib+i)-a(id+i)))
-             i = i + inc3
-             j = j + inc4
-          END DO
-          ibase = ibase + inc1
-          jbase = jbase + inc2
-       END DO
-       ia = ia + iink
-       ib = ib + iink
-       ic = ic - iink
-       id = id - iink
-       jbase = jbase + jump
-    END DO
-    IF (ib>ic) GO TO 170
-80  CONTINUE
-    ibase = 0
-    sin45 = SQRT(0.5_wp)
-    DO l = 1, la
-       i = ibase
-       j = jbase
-!DIR$ IVDEP
-!CDIR NODEP
-!OCL NOVREC
-       DO ijk = 1, lot
-          c(ja+j) = a(ia+i) + a(ib+i)
-          c(jb+j) = sin45*((a(ia+i)-a(ib+i))-(b(ia+i)+b(ib+i)))
-          c(jc+j) = b(ib+i) - b(ia+i)
-          c(jd+j) = -sin45*((a(ia+i)-a(ib+i))+(b(ia+i)+b(ib+i)))
-          i = i + inc3
-          j = j + inc4
-       END DO
-       ibase = ibase + inc1
-       jbase = jbase + inc2
-    END DO
-
-    GO TO 170
-90  CONTINUE
-    DO l = 1, la
-       i = ibase
-       j = jbase
-!DIR$ IVDEP
-!CDIR NODEP
-!OCL NOVREC
-       DO ijk = 1, lot
-          c(ja+j) = 2.0_wp*((a(ia+i)+a(ic+i))+a(ib+i))
-          c(jb+j) = 2.0_wp*((a(ia+i)-a(ic+i))-b(ib+i))
-          c(jc+j) = 2.0_wp*((a(ia+i)+a(ic+i))-a(ib+i))
-          c(jd+j) = 2.0_wp*((a(ia+i)-a(ic+i))+b(ib+i))
-          i = i + inc3
-          j = j + inc4
-       END DO
-       ibase = ibase + inc1
-       jbase = jbase + inc2
-    END DO
-
-    ! Coding for factor 5
-
-    GO TO 170
-100 CONTINUE
-    ia = 1
-    ib = ia + (2*m-la)*inc1
-    ic = ib + 2*m*inc1
-    id = ic
-    ie = ib
-    ja = 1
-    jb = ja + jink
-    jc = jb + jink
-    jd = jc + jink
-    je = jd + jink
-
-    IF (la==m) GO TO 120
-
-    DO l = 1, la
-       i = ibase
-       j = jbase
-!DIR$ IVDEP
-!CDIR NODEP
-!OCL NOVREC
-       DO ijk = 1, lot
-          c(ja+j) = a(ia+i) + (a(ib+i)+a(ic+i))
-          c(jb+j) = ((a(ia+i)-0.25_wp*(a(ib+i)+a(ic+i)))+qrt5*(a(ib+i)-a(ic+i))) - &
-               &          (sin72*b(ib+i)+sin36*b(ic+i))
-          c(jc+j) = ((a(ia+i)-0.25_wp*(a(ib+i)+a(ic+i)))-qrt5*(a(ib+i)-a(ic+i))) - &
-               &          (sin36*b(ib+i)-sin72*b(ic+i))
-          c(jd+j) = ((a(ia+i)-0.25_wp*(a(ib+i)+a(ic+i)))-qrt5*(a(ib+i)-a(ic+i))) + &
-               &          (sin36*b(ib+i)-sin72*b(ic+i))
-          c(je+j) = ((a(ia+i)-0.25_wp*(a(ib+i)+a(ic+i)))+qrt5*(a(ib+i)-a(ic+i))) + &
-               &          (sin72*b(ib+i)+sin36*b(ic+i))
-          i = i + inc3
-          j = j + inc4
-       END DO
-       ibase = ibase + inc1
-       jbase = jbase + inc2
-    END DO
-    ia = ia + iink
-    iink = 2*iink
-    ib = ib + iink
-    ic = ic + iink
-    id = id - iink
-    ie = ie - iink
-    jbase = jbase + jump
-    jump = 2*jump + jink
-    IF (ib==id) GO TO 110
-    DO k = la, kstop, la
-       kb = k + k
-       kc = kb + kb
-       kd = kc + kb
-       ke = kd + kb
-       c1 = trigs(kb+1)
-       s1 = trigs(kb+2)
-       c2 = trigs(kc+1)
-       s2 = trigs(kc+2)
-       c3 = trigs(kd+1)
-       s3 = trigs(kd+2)
-       c4 = trigs(ke+1)
-       s4 = trigs(ke+2)
-       ibase = 0
-       DO l = 1, la
-          i = ibase
-          j = jbase
-!DIR$ IVDEP
-!CDIR NODEP
-!OCL NOVREC
-          DO ijk = 1, lot
-
-             a10(ijk) = (a(ia+i)-0.25_wp*((a(ib+i)+a(ie+i))+(a(ic+i)+a(id+i)))) + &
-                  &            qrt5*((a(ib+i)+a(ie+i))-(a(ic+i)+a(id+i)))
-             a20(ijk) = (a(ia+i)-0.25_wp*((a(ib+i)+a(ie+i))+(a(ic+i)+a(id+i)))) - &
-                  &            qrt5*((a(ib+i)+a(ie+i))-(a(ic+i)+a(id+i)))
-             b10(ijk) = (b(ia+i)-0.25_wp*((b(ib+i)-b(ie+i))+(b(ic+i)-b(id+i)))) + &
-                  &            qrt5*((b(ib+i)-b(ie+i))-(b(ic+i)-b(id+i)))
-             b20(ijk) = (b(ia+i)-0.25_wp*((b(ib+i)-b(ie+i))+(b(ic+i)-b(id+i)))) - &
-                  &            qrt5*((b(ib+i)-b(ie+i))-(b(ic+i)-b(id+i)))
-             a11(ijk) = sin72*(b(ib+i)+b(ie+i)) + sin36*(b(ic+i)+b(id+i))
-             a21(ijk) = sin36*(b(ib+i)+b(ie+i)) - sin72*(b(ic+i)+b(id+i))
-             b11(ijk) = sin72*(a(ib+i)-a(ie+i)) + sin36*(a(ic+i)-a(id+i))
-             b21(ijk) = sin36*(a(ib+i)-a(ie+i)) - sin72*(a(ic+i)-a(id+i))
-
-             c(ja+j) = a(ia+i) + ((a(ib+i)+a(ie+i))+(a(ic+i)+a(id+i)))
-             d(ja+j) = b(ia+i) + ((b(ib+i)-b(ie+i))+(b(ic+i)-b(id+i)))
-             c(jb+j) = c1*(a10(ijk)-a11(ijk)) - s1*(b10(ijk)+b11(ijk))
-             d(jb+j) = s1*(a10(ijk)-a11(ijk)) + c1*(b10(ijk)+b11(ijk))
-             c(je+j) = c4*(a10(ijk)+a11(ijk)) - s4*(b10(ijk)-b11(ijk))
-             d(je+j) = s4*(a10(ijk)+a11(ijk)) + c4*(b10(ijk)-b11(ijk))
-             c(jc+j) = c2*(a20(ijk)-a21(ijk)) - s2*(b20(ijk)+b21(ijk))
-             d(jc+j) = s2*(a20(ijk)-a21(ijk)) + c2*(b20(ijk)+b21(ijk))
-             c(jd+j) = c3*(a20(ijk)+a21(ijk)) - s3*(b20(ijk)-b21(ijk))
-             d(jd+j) = s3*(a20(ijk)+a21(ijk)) + c3*(b20(ijk)-b21(ijk))
-
-             i = i + inc3
-             j = j + inc4
-          END DO
-          ibase = ibase + inc1
-          jbase = jbase + inc2
-       END DO
-       ia = ia + iink
-       ib = ib + iink
-       ic = ic + iink
-       id = id - iink
-       ie = ie - iink
-       jbase = jbase + jump
-    END DO
-    IF (ib>id) GO TO 170
-110 CONTINUE
-    ibase = 0
-    DO l = 1, la
-       i = ibase
-       j = jbase
-!DIR$ IVDEP
-!CDIR NODEP
-!OCL NOVREC
-       DO ijk = 1, lot
-          c(ja+j) = (a(ia+i)+a(ib+i)) + a(ic+i)
-          c(jb+j) = (qrt5*(a(ia+i)-a(ib+i))+(0.25_wp*(a(ia+i)+a(ib+i))-a(ic+i))) - &
-               &          (sin36*b(ia+i)+sin72*b(ib+i))
-          c(je+j) = -(qrt5*(a(ia+i)-a(ib+i))+(0.25_wp*(a(ia+i)+a(ib+i))-a(ic+i))) - &
-               &          (sin36*b(ia+i)+sin72*b(ib+i))
-          c(jc+j) = (qrt5*(a(ia+i)-a(ib+i))-(0.25_wp*(a(ia+i)+a(ib+i))-a(ic+i))) - &
-               &          (sin72*b(ia+i)-sin36*b(ib+i))
-          c(jd+j) = -(qrt5*(a(ia+i)-a(ib+i))-(0.25_wp*(a(ia+i)+a(ib+i))-a(ic+i))) - &
-               &          (sin72*b(ia+i)-sin36*b(ib+i))
-          i = i + inc3
-          j = j + inc4
-       END DO
-       ibase = ibase + inc1
-       jbase = jbase + inc2
-    END DO
-
-    GO TO 170
-120 CONTINUE
-    qqrt5 = 2.0_wp*qrt5
-    ssin36 = 2.0_wp*sin36
-    ssin72 = 2.0_wp*sin72
-    DO l = 1, la
-       i = ibase
-       j = jbase
-!DIR$ IVDEP
-!CDIR NODEP
-!OCL NOVREC
-       DO ijk = 1, lot
-          c(ja+j) = 2.0_wp*(a(ia+i)+(a(ib+i)+a(ic+i)))
-          c(jb+j) = (2.0_wp*(a(ia+i)-0.25_wp*(a(ib+i)+a(ic+i)))+qqrt5*(a(ib+i)-a(ic+ &
-               &          i))) - (ssin72*b(ib+i)+ssin36*b(ic+i))
-          c(jc+j) = (2.0_wp*(a(ia+i)-0.25_wp*(a(ib+i)+a(ic+i)))-qqrt5*(a(ib+i)-a(ic+ &
-               &          i))) - (ssin36*b(ib+i)-ssin72*b(ic+i))
-          c(jd+j) = (2.0_wp*(a(ia+i)-0.25_wp*(a(ib+i)+a(ic+i)))-qqrt5*(a(ib+i)-a(ic+ &
-               &          i))) + (ssin36*b(ib+i)-ssin72*b(ic+i))
-          c(je+j) = (2.0_wp*(a(ia+i)-0.25_wp*(a(ib+i)+a(ic+i)))+qqrt5*(a(ib+i)-a(ic+ &
-               &          i))) + (ssin72*b(ib+i)+ssin36*b(ic+i))
-          i = i + inc3
-          j = j + inc4
-       END DO
-       ibase = ibase + inc1
-       jbase = jbase + inc2
-    END DO
-    GO TO 170
-
-    ! Coding for factor 6
-
-130 CONTINUE
-    ia = 1
-    ib = ia + (2*m-la)*inc1
-    ic = ib + 2*m*inc1
-    id = ic + 2*m*inc1
-    ie = ic
-    if = ib
-    ja = 1
-    jb = ja + jink
-    jc = jb + jink
-    jd = jc + jink
-    je = jd + jink
-    jf = je + jink
-
-    IF (la==m) GO TO 150
-
-    DO l = 1, la
-       i = ibase
-       j = jbase
-!DIR$ IVDEP
-!CDIR NODEP
-!OCL NOVREC
-       DO ijk = 1, lot
-          c(ja+j) = (a(ia+i)+a(id+i)) + (a(ib+i)+a(ic+i))
-          c(jd+j) = (a(ia+i)-a(id+i)) - (a(ib+i)-a(ic+i))
-          c(jb+j) = ((a(ia+i)-a(id+i))+0.5_wp*(a(ib+i)-a(ic+i))) - (sin60*(b(ib+ &
-               &          i)+b(ic+i)))
-          c(jf+j) = ((a(ia+i)-a(id+i))+0.5_wp*(a(ib+i)-a(ic+i))) + (sin60*(b(ib+ &
-               &          i)+b(ic+i)))
-          c(jc+j) = ((a(ia+i)+a(id+i))-0.5_wp*(a(ib+i)+a(ic+i))) - (sin60*(b(ib+ &
-               &          i)-b(ic+i)))
-          c(je+j) = ((a(ia+i)+a(id+i))-0.5_wp*(a(ib+i)+a(ic+i))) + (sin60*(b(ib+ &
-               &          i)-b(ic+i)))
-          i = i + inc3
-          j = j + inc4
-       END DO
-       ibase = ibase + inc1
-       jbase = jbase + inc2
-    END DO
-    ia = ia + iink
-    iink = 2*iink
-    ib = ib + iink
-    ic = ic + iink
-    id = id - iink
-    ie = ie - iink
-    if = if - iink
-    jbase = jbase + jump
-    jump = 2*jump + jink
-    IF (ic==id) GO TO 140
-    DO k = la, kstop, la
-       kb = k + k
-       kc = kb + kb
-       kd = kc + kb
-       ke = kd + kb
-       kf = ke + kb
-       c1 = trigs(kb+1)
-       s1 = trigs(kb+2)
-       c2 = trigs(kc+1)
-       s2 = trigs(kc+2)
-       c3 = trigs(kd+1)
-       s3 = trigs(kd+2)
-       c4 = trigs(ke+1)
-       s4 = trigs(ke+2)
-       c5 = trigs(kf+1)
-       s5 = trigs(kf+2)
-       ibase = 0
-       DO l = 1, la
-          i = ibase
-          j = jbase
-!DIR$ IVDEP
-!CDIR NODEP
-!OCL NOVREC
-          DO ijk = 1, lot
-
-             a11(ijk) = (a(ie+i)+a(ib+i)) + (a(ic+i)+a(if+i))
-             a20(ijk) = (a(ia+i)+a(id+i)) - 0.5_wp*a11(ijk)
-             a21(ijk) = sin60*((a(ie+i)+a(ib+i))-(a(ic+i)+a(if+i)))
-             b11(ijk) = (b(ib+i)-b(ie+i)) + (b(ic+i)-b(if+i))
-             b20(ijk) = (b(ia+i)-b(id+i)) - 0.5_wp*b11(ijk)
-             b21(ijk) = sin60*((b(ib+i)-b(ie+i))-(b(ic+i)-b(if+i)))
-
-             c(ja+j) = (a(ia+i)+a(id+i)) + a11(ijk)
-             d(ja+j) = (b(ia+i)-b(id+i)) + b11(ijk)
-             c(jc+j) = c2*(a20(ijk)-b21(ijk)) - s2*(b20(ijk)+a21(ijk))
-             d(jc+j) = s2*(a20(ijk)-b21(ijk)) + c2*(b20(ijk)+a21(ijk))
-             c(je+j) = c4*(a20(ijk)+b21(ijk)) - s4*(b20(ijk)-a21(ijk))
-             d(je+j) = s4*(a20(ijk)+b21(ijk)) + c4*(b20(ijk)-a21(ijk))
-
-             a11(ijk) = (a(ie+i)-a(ib+i)) + (a(ic+i)-a(if+i))
-             b11(ijk) = (b(ie+i)+b(ib+i)) - (b(ic+i)+b(if+i))
-             a20(ijk) = (a(ia+i)-a(id+i)) - 0.5_wp*a11(ijk)
-             a21(ijk) = sin60*((a(ie+i)-a(ib+i))-(a(ic+i)-a(if+i)))
-             b20(ijk) = (b(ia+i)+b(id+i)) + 0.5_wp*b11(ijk)
-             b21(ijk) = sin60*((b(ie+i)+b(ib+i))+(b(ic+i)+b(if+i)))
-
-             c(jd+j) = c3*((a(ia+i)-a(id+i))+a11(ijk)) - s3*((b(ia+i)+b(id+ &
-                  &            i))-b11(ijk))
-             d(jd+j) = s3*((a(ia+i)-a(id+i))+a11(ijk)) + c3*((b(ia+i)+b(id+ &
-                  &            i))-b11(ijk))
-             c(jb+j) = c1*(a20(ijk)-b21(ijk)) - s1*(b20(ijk)-a21(ijk))
-             d(jb+j) = s1*(a20(ijk)-b21(ijk)) + c1*(b20(ijk)-a21(ijk))
-             c(jf+j) = c5*(a20(ijk)+b21(ijk)) - s5*(b20(ijk)+a21(ijk))
-             d(jf+j) = s5*(a20(ijk)+b21(ijk)) + c5*(b20(ijk)+a21(ijk))
-
-             i = i + inc3
-             j = j + inc4
-          END DO
-          ibase = ibase + inc1
-          jbase = jbase + inc2
-       END DO
-       ia = ia + iink
-       ib = ib + iink
-       ic = ic + iink
-       id = id - iink
-       ie = ie - iink
-       if = if - iink
-       jbase = jbase + jump
-    END DO
-    IF (ic>id) GO TO 170
-140 CONTINUE
-    ibase = 0
-    DO l = 1, la
-       i = ibase
-       j = jbase
-!DIR$ IVDEP
-!CDIR NODEP
-!OCL NOVREC
-       DO ijk = 1, lot
-          c(ja+j) = a(ib+i) + (a(ia+i)+a(ic+i))
-          c(jd+j) = b(ib+i) - (b(ia+i)+b(ic+i))
-          c(jb+j) = (sin60*(a(ia+i)-a(ic+i))) - (0.5_wp*(b(ia+i)+b(ic+i))+b(ib+i))
-          c(jf+j) = -(sin60*(a(ia+i)-a(ic+i))) - (0.5_wp*(b(ia+i)+b(ic+i))+b(ib+i))
-          c(jc+j) = sin60*(b(ic+i)-b(ia+i)) + (0.5_wp*(a(ia+i)+a(ic+i))-a(ib+i))
-          c(je+j) = sin60*(b(ic+i)-b(ia+i)) - (0.5_wp*(a(ia+i)+a(ic+i))-a(ib+i))
-          i = i + inc3
-          j = j + inc4
-       END DO
-       ibase = ibase + inc1
-       jbase = jbase + inc2
-    END DO
-
-    GO TO 170
-150 CONTINUE
-    ssin60 = 2.0_wp*sin60
-    DO l = 1, la
-       i = ibase
-       j = jbase
-!DIR$ IVDEP
-!CDIR NODEP
-!OCL NOVREC
-       DO ijk = 1, lot
-          c(ja+j) = (2.0_wp*(a(ia+i)+a(id+i))) + (2.0_wp*(a(ib+i)+a(ic+i)))
-          c(jd+j) = (2.0_wp*(a(ia+i)-a(id+i))) - (2.0_wp*(a(ib+i)-a(ic+i)))
-          c(jb+j) = (2.0_wp*(a(ia+i)-a(id+i))+(a(ib+i)-a(ic+i))) - (ssin60*(b(ib+ &
-               &          i)+b(ic+i)))
-          c(jf+j) = (2.0_wp*(a(ia+i)-a(id+i))+(a(ib+i)-a(ic+i))) + (ssin60*(b(ib+ &
-               &          i)+b(ic+i)))
-          c(jc+j) = (2.0_wp*(a(ia+i)+a(id+i))-(a(ib+i)+a(ic+i))) - (ssin60*(b(ib+ &
-               &          i)-b(ic+i)))
-          c(je+j) = (2.0_wp*(a(ia+i)+a(id+i))-(a(ib+i)+a(ic+i))) + (ssin60*(b(ib+ &
-               &          i)-b(ic+i)))
-          i = i + inc3
-          j = j + inc4
-       END DO
-       ibase = ibase + inc1
-       jbase = jbase + inc2
-    END DO
-    GO TO 170
-
-    ! Coding for factor 8
-
-160 CONTINUE
-    ibad = 3
-    IF (la/=m) GO TO 180
-    ia = 1
-    ib = ia + la*inc1
-    ic = ib + 2*la*inc1
-    id = ic + 2*la*inc1
-    ie = id + 2*la*inc1
-    ja = 1
-    jb = ja + jink
-    jc = jb + jink
-    jd = jc + jink
-    je = jd + jink
-    jf = je + jink
-    jg = jf + jink
-    jh = jg + jink
-    ssin45 = SQRT(2.0_wp)
-
-    DO l = 1, la
-       i = ibase
-       j = jbase
-!DIR$ IVDEP
-!CDIR NODEP
-!OCL NOVREC
-       DO ijk = 1, lot
-          c(ja+j) = 2.0_wp*(((a(ia+i)+a(ie+i))+a(ic+i))+(a(ib+i)+a(id+i)))
-          c(je+j) = 2.0_wp*(((a(ia+i)+a(ie+i))+a(ic+i))-(a(ib+i)+a(id+i)))
-          c(jc+j) = 2.0_wp*(((a(ia+i)+a(ie+i))-a(ic+i))-(b(ib+i)-b(id+i)))
-          c(jg+j) = 2.0_wp*(((a(ia+i)+a(ie+i))-a(ic+i))+(b(ib+i)-b(id+i)))
-          c(jb+j) = 2.0_wp*((a(ia+i)-a(ie+i))-b(ic+i)) + ssin45*((a(ib+i)-a(id+ &
-               &              i))-(b(ib+i)+b(id+i)))
-          c(jf+j) = 2.0_wp*((a(ia+i)-a(ie+i))-b(ic+i)) - ssin45*((a(ib+i)-a(id+ &
-               &              i))-(b(ib+i)+b(id+i)))
-          c(jd+j) = 2.0_wp*((a(ia+i)-a(ie+i))+b(ic+i)) - ssin45*((a(ib+i)-a(id+ &
-               &              i))+(b(ib+i)+b(id+i)))
-          c(jh+j) = 2.0_wp*((a(ia+i)-a(ie+i))+b(ic+i)) + ssin45*((a(ib+i)-a(id+ &
-               &              i))+(b(ib+i)+b(id+i)))
-          i = i + inc3
-          j = j + inc4
-       END DO
-       ibase = ibase + inc1
-       jbase = jbase + inc2
-    END DO
-
-    ! Return
-
-170 CONTINUE
-    ibad = 0
-180 CONTINUE
-    ierr = ibad
-    RETURN
-  END SUBROUTINE rpassm
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Computes factors of n & trigonometric functins required by fft99 & fft991cy
-!> Method: Dimension trigs(n),ifax(1),jfax(10),lfax(7)
-!> subroutine 'set99' - computes factors of n & trigonometric
-!> functins required by fft99 & fft991cy
-!------------------------------------------------------------------------------!
-  SUBROUTINE set99(trigs,ifax,n)
-
-
-    USE control_parameters,                                                    &
-        ONLY:  message_string
-
-    USE kinds
-
-    IMPLICIT NONE
-
-    !  Scalar arguments 
-    INTEGER(iwp) ::  n !< 
-
-    !  Array arguments 
-    INTEGER(iwp) ::  ifax(*)  !< 
-    REAL(wp)     ::  trigs(*) !< 
-
-
-    !  Local scalars: 
-    REAL(wp) ::  angle    !< 
-    REAL(wp) ::  del      !< 
-    INTEGER(iwp) ::  i    !< 
-    INTEGER(iwp) ::  ifac !< 
-    INTEGER(iwp) ::  ixxx !< 
-    INTEGER(iwp) ::  k    !< 
-    INTEGER(iwp) ::  l    !< 
-    INTEGER(iwp) ::  nfax !< 
-    INTEGER(iwp) ::  nhl  !< 
-    INTEGER(iwp) ::  nil  !< 
-    INTEGER(iwp) ::  nu   !< 
-
-    !  Local arrays: 
-    INTEGER(iwp) ::  jfax(10) !< 
-    INTEGER(iwp) ::  lfax(7)  !< 
-
-    !  Intrinsic functions 
-!    INTRINSIC ASIN, COS, MOD, REAL, SIN
-
-    !  Data statements 
-    DATA lfax/6, 8, 5, 4, 3, 2, 1/
-
-
-    !  Executable statements 
-    ixxx = 1
-
-    del = 4.0_wp*ASIN(1.0_wp)/REAL(n,KIND=wp)
-    nil = 0
-    nhl = (n/2) - 1
-    DO k = nil, nhl
-       angle = REAL(k,KIND=wp)*del
-       trigs(2*k+1) = COS(angle)
-       trigs(2*k+2) = SIN(angle)
-    END DO
-
-    ! Find factors of n (8,6,5,4,3,2; only one 8 allowed)
-    ! Look for sixes first, store factors in descending order
-    nu = n
-    ifac = 6
-    k = 0
-    l = 1
-10  CONTINUE
-    IF (MOD(nu,ifac)/=0) GO TO 30
-    k = k + 1
-    jfax(k) = ifac
-    IF (ifac/=8) GO TO 20
-    IF (k==1) GO TO 20
-    jfax(1) = 8
-    jfax(k) = 6
-20  CONTINUE
-    nu = nu/ifac
-    IF (nu==1) GO TO 40
-    IF (ifac/=8) GO TO 10
-30  CONTINUE
-    l = l + 1
-    ifac = lfax(l)
-    IF (ifac>1) GO TO 10
-
-!    WRITE (nout,'(A,I4,A)') ' n =',n,' - Contains illegal factors'
-    message_string = 'number of gridpoints along x or/and y ' // &
-                     'contain illegal  factors' //               &
-                     '&only factors 8,6,5,4,3,2 are allowed' 
-    CALL message( 'temperton_fft', 'PA0311', 1, 2, 0, 6, 0 )
-
-    RETURN
-
-    ! Now reverse order of factors
-40  CONTINUE
-    nfax = k
-    ifax(1) = nfax
-    DO i = 1, nfax
-       ifax(nfax+2-i) = jfax(i)
-    END DO
-    ifax(10) = n
-    RETURN
-  END SUBROUTINE set99
-
- END MODULE temperton_fft
Index: /palm/trunk/SOURCE/temperton_fft_mod.f90
===================================================================
--- /palm/trunk/SOURCE/temperton_fft_mod.f90	(revision 1850)
+++ /palm/trunk/SOURCE/temperton_fft_mod.f90	(revision 1850)
@@ -0,0 +1,2182 @@
+!> @file temperton_fft_mod.f90
+!------------------------------------------------------------------------------!
+!
+! Current revisions:
+! -----------------
+! Module renamed
+! 
+! 
+! Former revisions:
+! -----------------
+! $Id$
+!
+! 1682 2015-10-07 23:56:08Z knoop
+! Code annotations made doxygen readable 
+! 
+! 1342 2014-03-26 17:04:47Z kanani
+! REAL constants defined as wp-kind
+!
+! 1322 2014-03-20 16:38:49Z raasch
+! REAL constants defined as wp-kind
+!
+! 1320 2014-03-20 08:40:49Z raasch
+! ONLY-attribute added to USE-statements,
+! kind-parameters added to all INTEGER and REAL declaration statements,
+! kinds are defined in new module kinds,
+! old module precision_kind is removed,
+! revision history before 2012 removed,
+! comment fields (!:) to be used for variable explanations added to
+! all variable declaration statements 
+!
+! Revision 1.1  2003/03/12 16:41:59  raasch
+! Initial revision
+!
+!
+! Description:
+! ------------
+!> Fast Fourier transformation developed by Clive Temperton, ECMWF.
+!------------------------------------------------------------------------------!
+ MODULE temperton_fft
+
+    USE kinds
+
+    IMPLICIT NONE
+
+    PRIVATE
+
+    PUBLIC set99, fft991cy
+
+
+    INTEGER(iwp)          ::  nfax(10)   !< array used by *fft991*.
+    REAL(wp), ALLOCATABLE ::  trig(:)    !< array used by *fft991*.
+
+!
+!-- nfft: maximum length of calls to *fft.
+#if defined( __nec )
+    INTEGER(iwp), PARAMETER ::  nfft = 256  !< 
+#else
+    INTEGER(iwp), PARAMETER ::  nfft =  32  !< 
+#endif
+
+    INTEGER(iwp), PARAMETER ::  nout =   6  !< standard output stream
+
+CONTAINS
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Calls fortran-versions of fft's.
+!> 
+!> Method:
+!> 
+!> Subroutine 'fft991cy' - multiple fast real periodic transform
+!> supersedes previous routine 'fft991cy'.
+!> 
+!> Real transform of length n performed by removing redundant
+!> operations from complex transform of length n.
+!> 
+!> a       is the array containing input & output data.
+!> work    is an area of size (n+1)*min(lot,nfft).
+!> trigs   is a previously prepared list of trig function values.
+!> ifax    is a previously prepared list of factors of n.
+!> inc     is the increment within each data 'vector'
+!>         (e.g. inc=1 for consecutively stored data).
+!> jump    is the increment between the start of each data vector.
+!> n       is the length of the data vectors.
+!> lot     is the number of data vectors.
+!> isign = +1 for transform from spectral to gridpoint
+!>       = -1 for transform from gridpoint to spectral.
+!> 
+!> ordering of coefficients:
+!> a(0),b(0),a(1),b(1),a(2),b(2),.,a(n/2),b(n/2)
+!> where b(0)=b(n/2)=0; (n+2) locations required.
+!> 
+!> ordering of data:
+!> x(0),x(1),x(2),.,x(n-1), 0 , 0 ; (n+2) locations required.
+!> 
+!> Vectorization is achieved on cray by doing the transforms
+!> in parallel.
+!> 
+!> n must be composed of factors 2,3 & 5 but does not have to be even.
+!> 
+!> definition of transforms:
+!> 
+!> isign=+1: x(j)=sum(k=0,.,n-1)(c(k)*exp(2*i*j*k*pi/n))
+!> where c(k)=a(k)+i*b(k) and c(n-k)=a(k)-i*b(k)
+!> 
+!> isign=-1: a(k)=(1/n)*sum(j=0,.,n-1)(x(j)*cos(2*j*k*pi/n))
+!> b(k)=-(1/n)*sum(j=0,.,n-1)(x(j)*sin(2*j*k*pi/n))
+!> 
+!> calls fortran-versions of fft's  !!!
+!> dimension a(n),work(n),trigs(n),ifax(1)
+!------------------------------------------------------------------------------!
+  SUBROUTINE fft991cy(a,work,trigs,ifax,inc,jump,n,lot,isign)
+
+    USE kinds
+
+    IMPLICIT NONE
+
+    !  Scalar arguments 
+    INTEGER(iwp) ::  inc   !< 
+    INTEGER(iwp) ::  isign !< 
+    INTEGER(iwp) ::  jump  !< 
+    INTEGER(iwp) ::  lot   !< 
+    INTEGER(iwp) ::  n     !< 
+
+    !  Array arguments 
+    REAL(wp)     ::  a(*)     !< 
+    REAL(wp)     ::  trigs(*) !< 
+    REAL(wp)     ::  work(*)  !< 
+    INTEGER(iwp) ::  ifax(*)  !< 
+
+    !  Local scalars: 
+    INTEGER(iwp) ::  i      !< 
+    INTEGER(iwp) ::  ia     !< 
+    INTEGER(iwp) ::  ibase  !< 
+    INTEGER(iwp) ::  ierr   !< 
+    INTEGER(iwp) ::  ifac   !< 
+    INTEGER(iwp) ::  igo    !< 
+    INTEGER(iwp) ::  ii     !< 
+    INTEGER(iwp) ::  istart !< 
+    INTEGER(iwp) ::  ix     !< 
+    INTEGER(iwp) ::  iz     !< 
+    INTEGER(iwp) ::  j      !< 
+    INTEGER(iwp) ::  jbase  !< 
+    INTEGER(iwp) ::  jj     !< 
+    INTEGER(iwp) ::  k      !< 
+    INTEGER(iwp) ::  la     !< 
+    INTEGER(iwp) ::  nb     !< 
+    INTEGER(iwp) ::  nblox  !< 
+    INTEGER(iwp) ::  nfax   !< 
+    INTEGER(iwp) ::  nvex   !< 
+    INTEGER(iwp) ::  nx     !< 
+
+    !  Intrinsic functions 
+!    INTRINSIC MOD
+
+
+    !  Executable statements 
+
+    IF (ifax(10)/=n) CALL set99(trigs,ifax,n)
+    nfax = ifax(1)
+    nx = n + 1
+    IF (MOD(n,2)==1) nx = n
+    nblox = 1 + (lot-1)/nfft
+    nvex = lot - (nblox-1)*nfft
+    IF (isign==-1) GO TO 50
+
+    ! isign=+1, spectral to gridpoint transform
+
+    istart = 1
+    DO nb = 1, nblox
+       ia = istart
+       i = istart
+!DIR$ IVDEP
+!CDIR NODEP
+!OCL NOVREC
+       DO j = 1, nvex
+          a(i+inc) = 0.5_wp*a(i)
+          i = i + jump
+       END DO
+       IF (MOD(n,2)==1) GO TO 10
+       i = istart + n*inc
+       DO j = 1, nvex
+          a(i) = 0.5_wp*a(i)
+          i = i + jump
+       END DO
+10     CONTINUE
+       ia = istart + inc
+       la = 1
+       igo = + 1
+
+       DO k = 1, nfax
+          ifac = ifax(k+1)
+          ierr = -1
+          IF (igo==-1) GO TO 20
+          CALL rpassm(a(ia),a(ia+la*inc),work(1),work(ifac*la+1),trigs,inc,1, &
+               &          jump,nx,nvex,n,ifac,la,ierr)
+          GO TO 30
+20        CONTINUE
+          CALL rpassm(work(1),work(la+1),a(ia),a(ia+ifac*la*inc),trigs,1,inc,nx, &
+               &          jump,nvex,n,ifac,la,ierr)
+30        CONTINUE
+          IF (ierr/=0) GO TO 100
+          la = ifac*la
+          igo = -igo
+          ia = istart
+       END DO
+
+       ! If necessary, copy results back to a
+
+       IF (MOD(nfax,2)==0) GO TO 40
+       ibase = 1
+       jbase = ia
+       DO jj = 1, nvex
+          i = ibase
+          j = jbase
+          DO ii = 1, n
+             a(j) = work(i)
+             i = i + 1
+             j = j + inc
+          END DO
+          ibase = ibase + nx
+          jbase = jbase + jump
+       END DO
+40     CONTINUE
+
+       ! Fill in zeros at end
+
+       ix = istart + n*inc
+!DIR$ IVDEP
+!CDIR NODEP
+!OCL NOVREC
+       DO j = 1, nvex
+          a(ix) = 0.0_wp
+          a(ix+inc) = 0.0_wp
+          ix = ix + jump
+       END DO
+
+       istart = istart + nvex*jump
+       nvex = nfft
+    END DO
+    RETURN
+
+    ! isign=-1, gridpoint to spectral transform
+
+50  CONTINUE
+    istart = 1
+    DO nb = 1, nblox
+       ia = istart
+       la = n
+       igo = + 1
+
+       DO k = 1, nfax
+          ifac = ifax(nfax+2-k)
+          la = la/ifac
+          ierr = -1
+          IF (igo==-1) GO TO 60
+          CALL qpassm(a(ia),a(ia+ifac*la*inc),work(1),work(la+1),trigs,inc,1, &
+               &          jump,nx,nvex,n,ifac,la,ierr)
+          GO TO 70
+60        CONTINUE
+          CALL qpassm(work(1),work(ifac*la+1),a(ia),a(ia+la*inc),trigs,1,inc,nx, &
+               &          jump,nvex,n,ifac,la,ierr)
+70        CONTINUE
+          IF (ierr/=0) GO TO 100
+          igo = -igo
+          ia = istart + inc
+       END DO
+
+       ! If necessary, copy results back to a
+
+       IF (MOD(nfax,2)==0) GO TO 80
+       ibase = 1
+       jbase = ia
+       DO jj = 1, nvex
+          i = ibase
+          j = jbase
+          DO ii = 1, n
+             a(j) = work(i)
+             i = i + 1
+             j = j + inc
+          END DO
+          ibase = ibase + nx
+          jbase = jbase + jump
+       END DO
+80     CONTINUE
+
+       ! Shift a(0) & fill in zero imag parts
+
+       ix = istart
+!DIR$ IVDEP
+!CDIR NODEP
+!OCL NOVREC
+       DO j = 1, nvex
+          a(ix) = a(ix+inc)
+          a(ix+inc) = 0.0_wp
+          ix = ix + jump
+       END DO
+       IF (MOD(n,2)==1) GO TO 90
+       iz = istart + (n+1)*inc
+       DO j = 1, nvex
+          a(iz) = 0.0_wp
+          iz = iz + jump
+       END DO
+90     CONTINUE
+
+       istart = istart + nvex*jump
+       nvex = nfft
+    END DO
+    RETURN
+
+    ! Error messages
+
+100 CONTINUE
+
+    SELECT CASE (ierr)
+    CASE (:-1)
+       WRITE (nout,'(A,I5,A)') ' Vector length =',nvex,', greater than nfft'
+    CASE (0)
+       WRITE (nout,'(A,I3,A)') ' Factor =',ifac,', not catered for'
+    CASE (1:)
+       WRITE (nout,'(A,I3,A)') ' Factor =',ifac,', only catered for if la*ifac=n'
+    END SELECT
+
+    RETURN
+  END SUBROUTINE fft991cy
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Performs one pass through data as part of 
+!> multiple real fft (fourier analysis) routine.
+!> 
+!> Method:
+!> 
+!> a       is first real input vector
+!>         equivalence b(1) with a(ifac*la*inc1+1)
+!> c       is first real output vector
+!>         equivalence d(1) with c(la*inc2+1)
+!> trigs   is a precalculated list of sines & cosines
+!> inc1    is the addressing increment for a
+!> inc2    is the addressing increment for c
+!> inc3    is the increment between input vectors a
+!> inc4    is the increment between output vectors c
+!> lot     is the number of vectors
+!> n       is the length of the vectors
+!> ifac    is the current factor of n
+!>         la = n/(product of factors used so far)
+!> ierr    is an error indicator:
+!>         0 - pass completed without error
+!>         1 - lot greater than nfft
+!>         2 - ifac not catered for
+!>         3 - ifac only catered for if la=n/ifac
+!------------------------------------------------------------------------------!
+  SUBROUTINE qpassm(a,b,c,d,trigs,inc1,inc2,inc3,inc4,lot,n,ifac,la,ierr)
+
+    USE kinds
+
+    IMPLICIT NONE 
+
+    !  Scalar arguments 
+    INTEGER(iwp) ::  ierr !< 
+    INTEGER(iwp) ::  ifac !< 
+    INTEGER(iwp) ::  inc1 !< 
+    INTEGER(iwp) ::  inc2 !< 
+    INTEGER(iwp) ::  inc3 !< 
+    INTEGER(iwp) ::  inc4 !< 
+    INTEGER(iwp) ::  la   !< 
+    INTEGER(iwp) ::  lot  !< 
+    INTEGER(iwp) ::  n    !< 
+
+    !  Array arguments 
+    ! REAL :: a(n),b(n),c(n),d(n),trigs(n)
+    REAL(wp) ::  a(*)     !< 
+    REAL(wp) ::  b(*)     !< 
+    REAL(wp) ::  c(*)     !< 
+    REAL(wp) ::  d(*)     !< 
+    REAL(wp) ::  trigs(*) !<
+ 
+    !  Local scalars: 
+    REAL(wp) ::  a0     !< 
+    REAL(wp) ::  a1     !< 
+    REAL(wp) ::  a10    !< 
+    REAL(wp) ::  a11    !< 
+    REAL(wp) ::  a2     !< 
+    REAL(wp) ::  a20    !< 
+    REAL(wp) ::  a21    !< 
+    REAL(wp) ::  a3     !< 
+    REAL(wp) ::  a4     !< 
+    REAL(wp) ::  a5     !< 
+    REAL(wp) ::  a6     !< 
+    REAL(wp) ::  b0     !< 
+    REAL(wp) ::  b1     !< 
+    REAL(wp) ::  b10    !< 
+    REAL(wp) ::  b11    !< 
+    REAL(wp) ::  b2     !< 
+    REAL(wp) ::  b20    !< 
+    REAL(wp) ::  b21    !< 
+    REAL(wp) ::  b3     !< 
+    REAL(wp) ::  b4     !< 
+    REAL(wp) ::  b5     !< 
+    REAL(wp) ::  b6     !< 
+    REAL(wp) ::  c1     !< 
+    REAL(wp) ::  c2     !< 
+    REAL(wp) ::  c3     !< 
+    REAL(wp) ::  c4     !< 
+    REAL(wp) ::  c5     !< 
+    REAL(wp) ::  qrt5   !< 
+    REAL(wp) ::  s1     !< 
+    REAL(wp) ::  s2     !< 
+    REAL(wp) ::  s3     !< 
+    REAL(wp) ::  s4     !< 
+    REAL(wp) ::  s5     !< 
+    REAL(wp) ::  sin36  !< 
+    REAL(wp) ::  sin45  !< 
+    REAL(wp) ::  sin60  !< 
+    REAL(wp) ::  sin72  !< 
+    REAL(wp) ::  z      !< 
+    REAL(wp) ::  zqrt5  !< 
+    REAL(wp) ::  zsin36 !< 
+    REAL(wp) ::  zsin45 !< 
+    REAL(wp) ::  zsin60 !< 
+    REAL(wp) ::  zsin72 !< 
+
+    INTEGER(iwp) ::  i     !< 
+    INTEGER(iwp) ::  ia    !< 
+    INTEGER(iwp) ::  ib    !< 
+    INTEGER(iwp) ::  ibad  !< 
+    INTEGER(iwp) ::  ibase !< 
+    INTEGER(iwp) ::  ic    !< 
+    INTEGER(iwp) ::  id    !< 
+    INTEGER(iwp) ::  ie    !< 
+    INTEGER(iwp) ::  if    !< 
+    INTEGER(iwp) ::  ig    !< 
+    INTEGER(iwp) ::  igo   !< 
+    INTEGER(iwp) ::  ih    !< 
+    INTEGER(iwp) ::  iink  !< 
+    INTEGER(iwp) ::  ijk   !< 
+    INTEGER(iwp) ::  ijump !< 
+    INTEGER(iwp) ::  j     !< 
+    INTEGER(iwp) ::  ja    !< 
+    INTEGER(iwp) ::  jb    !< 
+    INTEGER(iwp) ::  jbase !< 
+    INTEGER(iwp) ::  jc    !< 
+    INTEGER(iwp) ::  jd    !< 
+    INTEGER(iwp) ::  je    !< 
+    INTEGER(iwp) ::  jf    !< 
+    INTEGER(iwp) ::  jink  !< 
+    INTEGER(iwp) ::  k     !< 
+    INTEGER(iwp) ::  kb    !< 
+    INTEGER(iwp) ::  kc    !< 
+    INTEGER(iwp) ::  kd    !< 
+    INTEGER(iwp) ::  ke    !< 
+    INTEGER(iwp) ::  kf    !< 
+    INTEGER(iwp) ::  kstop !< 
+    INTEGER(iwp) ::  l     !< 
+    INTEGER(iwp) ::  m     !< 
+
+    !  Intrinsic functions 
+!    INTRINSIC REAL, SQRT
+
+    !  Data statements 
+    DATA sin36/0.587785252292473_wp/, sin72/0.951056516295154_wp/, &
+         &      qrt5/0.559016994374947_wp/, sin60/0.866025403784437_wp/
+
+
+    !  Executable statements 
+
+    m = n/ifac
+    iink = la*inc1
+    jink = la*inc2
+    ijump = (ifac-1)*iink
+    kstop = (n-ifac)/(2*ifac)
+
+    ibad = 1
+    IF (lot>nfft) GO TO 180
+    ibase = 0
+    jbase = 0
+    igo = ifac - 1
+    IF (igo==7) igo = 6
+    ibad = 2
+    IF (igo<1 .OR. igo>6) GO TO 180
+    GO TO (10,40,70,100,130,160) igo
+
+    ! Coding for factor 2
+
+10  CONTINUE
+    ia = 1
+    ib = ia + iink
+    ja = 1
+    jb = ja + (2*m-la)*inc2
+
+    IF (la==m) GO TO 30
+
+    DO l = 1, la
+       i = ibase
+       j = jbase
+!DIR$ IVDEP
+!CDIR NODEP
+!OCL NOVREC
+       DO ijk = 1, lot
+          c(ja+j) = a(ia+i) + a(ib+i)
+          c(jb+j) = a(ia+i) - a(ib+i)
+          i = i + inc3
+          j = j + inc4
+       END DO
+       ibase = ibase + inc1
+       jbase = jbase + inc2
+    END DO
+    ja = ja + jink
+    jink = 2*jink
+    jb = jb - jink
+    ibase = ibase + ijump
+    ijump = 2*ijump + iink
+    IF (ja==jb) GO TO 20
+    DO k = la, kstop, la
+       kb = k + k
+       c1 = trigs(kb+1)
+       s1 = trigs(kb+2)
+       jbase = 0
+       DO l = 1, la
+          i = ibase
+          j = jbase
+!DIR$ IVDEP
+!CDIR NODEP
+!OCL NOVREC
+          DO ijk = 1, lot
+             c(ja+j) = a(ia+i) + (c1*a(ib+i)+s1*b(ib+i))
+             c(jb+j) = a(ia+i) - (c1*a(ib+i)+s1*b(ib+i))
+             d(ja+j) = (c1*b(ib+i)-s1*a(ib+i)) + b(ia+i)
+             d(jb+j) = (c1*b(ib+i)-s1*a(ib+i)) - b(ia+i)
+             i = i + inc3
+             j = j + inc4
+          END DO
+          ibase = ibase + inc1
+          jbase = jbase + inc2
+       END DO
+       ibase = ibase + ijump
+       ja = ja + jink
+       jb = jb - jink
+    END DO
+    IF (ja>jb) GO TO 170
+20  CONTINUE
+    jbase = 0
+    DO l = 1, la
+       i = ibase
+       j = jbase
+!DIR$ IVDEP
+!CDIR NODEP
+!OCL NOVREC
+       DO ijk = 1, lot
+          c(ja+j) = a(ia+i)
+          d(ja+j) = -a(ib+i)
+          i = i + inc3
+          j = j + inc4
+       END DO
+       ibase = ibase + inc1
+       jbase = jbase + inc2
+    END DO
+
+    GO TO 170
+30  CONTINUE
+    z = 1.0_wp/REAL(n,KIND=wp)
+    DO l = 1, la
+       i = ibase
+       j = jbase
+!DIR$ IVDEP
+!CDIR NODEP
+!OCL NOVREC
+       DO ijk = 1, lot
+          c(ja+j) = z*(a(ia+i)+a(ib+i))
+          c(jb+j) = z*(a(ia+i)-a(ib+i))
+          i = i + inc3
+          j = j + inc4
+       END DO
+       ibase = ibase + inc1
+       jbase = jbase + inc2
+    END DO
+    GO TO 170
+
+    ! Coding for factor 3
+
+40  CONTINUE
+    ia = 1
+    ib = ia + iink
+    ic = ib + iink
+    ja = 1
+    jb = ja + (2*m-la)*inc2
+    jc = jb
+
+    IF (la==m) GO TO 60
+
+    DO l = 1, la
+       i = ibase
+       j = jbase
+!DIR$ IVDEP
+!CDIR NODEP
+!OCL NOVREC
+       DO ijk = 1, lot
+          c(ja+j) = a(ia+i) + (a(ib+i)+a(ic+i))
+          c(jb+j) = a(ia+i) - 0.5_wp*(a(ib+i)+a(ic+i))
+          d(jb+j) = sin60*(a(ic+i)-a(ib+i))
+          i = i + inc3
+          j = j + inc4
+       END DO
+       ibase = ibase + inc1
+       jbase = jbase + inc2
+    END DO
+    ja = ja + jink
+    jink = 2*jink
+    jb = jb + jink
+    jc = jc - jink
+    ibase = ibase + ijump
+    ijump = 2*ijump + iink
+    IF (ja==jc) GO TO 50
+    DO k = la, kstop, la
+       kb = k + k
+       kc = kb + kb
+       c1 = trigs(kb+1)
+       s1 = trigs(kb+2)
+       c2 = trigs(kc+1)
+       s2 = trigs(kc+2)
+       jbase = 0
+       DO l = 1, la
+          i = ibase
+          j = jbase
+!DIR$ IVDEP
+!CDIR NODEP
+!OCL NOVREC
+          DO ijk = 1, lot
+             a1 = (c1*a(ib+i)+s1*b(ib+i)) + (c2*a(ic+i)+s2*b(ic+i))
+             b1 = (c1*b(ib+i)-s1*a(ib+i)) + (c2*b(ic+i)-s2*a(ic+i))
+             a2 = a(ia+i) - 0.5_wp*a1
+             b2 = b(ia+i) - 0.5_wp*b1
+             a3 = sin60*((c1*a(ib+i)+s1*b(ib+i))-(c2*a(ic+i)+s2*b(ic+i)))
+             b3 = sin60*((c1*b(ib+i)-s1*a(ib+i))-(c2*b(ic+i)-s2*a(ic+i)))
+             c(ja+j) = a(ia+i) + a1
+             d(ja+j) = b(ia+i) + b1
+             c(jb+j) = a2 + b3
+             d(jb+j) = b2 - a3
+             c(jc+j) = a2 - b3
+             d(jc+j) = -(b2+a3)
+             i = i + inc3
+             j = j + inc4
+          END DO
+          ibase = ibase + inc1
+          jbase = jbase + inc2
+       END DO
+       ibase = ibase + ijump
+       ja = ja + jink
+       jb = jb + jink
+       jc = jc - jink
+    END DO
+    IF (ja>jc) GO TO 170
+50  CONTINUE
+    jbase = 0
+    DO l = 1, la
+       i = ibase
+       j = jbase
+!DIR$ IVDEP
+!CDIR NODEP
+!OCL NOVREC
+       DO ijk = 1, lot
+          c(ja+j) = a(ia+i) + 0.5_wp*(a(ib+i)-a(ic+i))
+          d(ja+j) = -sin60*(a(ib+i)+a(ic+i))
+          c(jb+j) = a(ia+i) - (a(ib+i)-a(ic+i))
+          i = i + inc3
+          j = j + inc4
+       END DO
+       ibase = ibase + inc1
+       jbase = jbase + inc2
+    END DO
+
+    GO TO 170
+60  CONTINUE
+    z = 1.0_wp/REAL(n,KIND=wp)
+    zsin60 = z*sin60
+    DO l = 1, la
+       i = ibase
+       j = jbase
+!DIR$ IVDEP
+!CDIR NODEP
+!OCL NOVREC
+       DO ijk = 1, lot
+          c(ja+j) = z*(a(ia+i)+(a(ib+i)+a(ic+i)))
+          c(jb+j) = z*(a(ia+i)-0.5_wp*(a(ib+i)+a(ic+i)))
+          d(jb+j) = zsin60*(a(ic+i)-a(ib+i))
+          i = i + inc3
+          j = j + inc4
+       END DO
+       ibase = ibase + inc1
+       jbase = jbase + inc2
+    END DO
+    GO TO 170
+
+    ! Coding for factor 4
+
+70  CONTINUE
+    ia = 1
+    ib = ia + iink
+    ic = ib + iink
+    id = ic + iink
+    ja = 1
+    jb = ja + (2*m-la)*inc2
+    jc = jb + 2*m*inc2
+    jd = jb
+
+    IF (la==m) GO TO 90
+
+    DO l = 1, la
+       i = ibase
+       j = jbase
+!DIR$ IVDEP
+!CDIR NODEP
+!OCL NOVREC
+       DO ijk = 1, lot
+          c(ja+j) = (a(ia+i)+a(ic+i)) + (a(ib+i)+a(id+i))
+          c(jc+j) = (a(ia+i)+a(ic+i)) - (a(ib+i)+a(id+i))
+          c(jb+j) = a(ia+i) - a(ic+i)
+          d(jb+j) = a(id+i) - a(ib+i)
+          i = i + inc3
+          j = j + inc4
+       END DO
+       ibase = ibase + inc1
+       jbase = jbase + inc2
+    END DO
+    ja = ja + jink
+    jink = 2*jink
+    jb = jb + jink
+    jc = jc - jink
+    jd = jd - jink
+    ibase = ibase + ijump
+    ijump = 2*ijump + iink
+    IF (jb==jc) GO TO 80
+    DO k = la, kstop, la
+       kb = k + k
+       kc = kb + kb
+       kd = kc + kb
+       c1 = trigs(kb+1)
+       s1 = trigs(kb+2)
+       c2 = trigs(kc+1)
+       s2 = trigs(kc+2)
+       c3 = trigs(kd+1)
+       s3 = trigs(kd+2)
+       jbase = 0
+       DO l = 1, la
+          i = ibase
+          j = jbase
+!DIR$ IVDEP
+!CDIR NODEP
+!OCL NOVREC
+          DO ijk = 1, lot
+             a0 = a(ia+i) + (c2*a(ic+i)+s2*b(ic+i))
+             a2 = a(ia+i) - (c2*a(ic+i)+s2*b(ic+i))
+             a1 = (c1*a(ib+i)+s1*b(ib+i)) + (c3*a(id+i)+s3*b(id+i))
+             a3 = (c1*a(ib+i)+s1*b(ib+i)) - (c3*a(id+i)+s3*b(id+i))
+             b0 = b(ia+i) + (c2*b(ic+i)-s2*a(ic+i))
+             b2 = b(ia+i) - (c2*b(ic+i)-s2*a(ic+i))
+             b1 = (c1*b(ib+i)-s1*a(ib+i)) + (c3*b(id+i)-s3*a(id+i))
+             b3 = (c1*b(ib+i)-s1*a(ib+i)) - (c3*b(id+i)-s3*a(id+i))
+             c(ja+j) = a0 + a1
+             c(jc+j) = a0 - a1
+             d(ja+j) = b0 + b1
+             d(jc+j) = b1 - b0
+             c(jb+j) = a2 + b3
+             c(jd+j) = a2 - b3
+             d(jb+j) = b2 - a3
+             d(jd+j) = -(b2+a3)
+             i = i + inc3
+             j = j + inc4
+          END DO
+          ibase = ibase + inc1
+          jbase = jbase + inc2
+       END DO
+       ibase = ibase + ijump
+       ja = ja + jink
+       jb = jb + jink
+       jc = jc - jink
+       jd = jd - jink
+    END DO
+    IF (jb>jc) GO TO 170
+80  CONTINUE
+    sin45 = SQRT(0.5_wp)
+    jbase = 0
+    DO l = 1, la
+       i = ibase
+       j = jbase
+!DIR$ IVDEP
+!CDIR NODEP
+!OCL NOVREC
+       DO ijk = 1, lot
+          c(ja+j) = a(ia+i) + sin45*(a(ib+i)-a(id+i))
+          c(jb+j) = a(ia+i) - sin45*(a(ib+i)-a(id+i))
+          d(ja+j) = -a(ic+i) - sin45*(a(ib+i)+a(id+i))
+          d(jb+j) = a(ic+i) - sin45*(a(ib+i)+a(id+i))
+          i = i + inc3
+          j = j + inc4
+       END DO
+       ibase = ibase + inc1
+       jbase = jbase + inc2
+    END DO
+
+    GO TO 170
+90  CONTINUE
+    z = 1.0_wp/REAL(n,KIND=wp)
+    DO l = 1, la
+       i = ibase
+       j = jbase
+!DIR$ IVDEP
+!CDIR NODEP
+!OCL NOVREC
+       DO ijk = 1, lot
+          c(ja+j) = z*((a(ia+i)+a(ic+i))+(a(ib+i)+a(id+i)))
+          c(jc+j) = z*((a(ia+i)+a(ic+i))-(a(ib+i)+a(id+i)))
+          c(jb+j) = z*(a(ia+i)-a(ic+i))
+          d(jb+j) = z*(a(id+i)-a(ib+i))
+          i = i + inc3
+          j = j + inc4
+       END DO
+       ibase = ibase + inc1
+       jbase = jbase + inc2
+    END DO
+    GO TO 170
+
+    ! Coding for factor 5
+
+100 CONTINUE
+    ia = 1
+    ib = ia + iink
+    ic = ib + iink
+    id = ic + iink
+    ie = id + iink
+    ja = 1
+    jb = ja + (2*m-la)*inc2
+    jc = jb + 2*m*inc2
+    jd = jc
+    je = jb
+
+    IF (la==m) GO TO 120
+
+    DO l = 1, la
+       i = ibase
+       j = jbase
+!DIR$ IVDEP
+!CDIR NODEP
+!OCL NOVREC
+       DO ijk = 1, lot
+          a1 = a(ib+i) + a(ie+i)
+          a3 = a(ib+i) - a(ie+i)
+          a2 = a(ic+i) + a(id+i)
+          a4 = a(ic+i) - a(id+i)
+          a5 = a(ia+i) - 0.25_wp*(a1+a2)
+          a6 = qrt5*(a1-a2)
+          c(ja+j) = a(ia+i) + (a1+a2)
+          c(jb+j) = a5 + a6
+          c(jc+j) = a5 - a6
+          d(jb+j) = -sin72*a3 - sin36*a4
+          d(jc+j) = -sin36*a3 + sin72*a4
+          i = i + inc3
+          j = j + inc4
+       END DO
+       ibase = ibase + inc1
+       jbase = jbase + inc2
+    END DO
+    ja = ja + jink
+    jink = 2*jink
+    jb = jb + jink
+    jc = jc + jink
+    jd = jd - jink
+    je = je - jink
+    ibase = ibase + ijump
+    ijump = 2*ijump + iink
+    IF (jb==jd) GO TO 110
+    DO k = la, kstop, la
+       kb = k + k
+       kc = kb + kb
+       kd = kc + kb
+       ke = kd + kb
+       c1 = trigs(kb+1)
+       s1 = trigs(kb+2)
+       c2 = trigs(kc+1)
+       s2 = trigs(kc+2)
+       c3 = trigs(kd+1)
+       s3 = trigs(kd+2)
+       c4 = trigs(ke+1)
+       s4 = trigs(ke+2)
+       jbase = 0
+       DO l = 1, la
+          i = ibase
+          j = jbase
+!DIR$ IVDEP
+!CDIR NODEP
+!OCL NOVREC
+          DO ijk = 1, lot
+             a1 = (c1*a(ib+i)+s1*b(ib+i)) + (c4*a(ie+i)+s4*b(ie+i))
+             a3 = (c1*a(ib+i)+s1*b(ib+i)) - (c4*a(ie+i)+s4*b(ie+i))
+             a2 = (c2*a(ic+i)+s2*b(ic+i)) + (c3*a(id+i)+s3*b(id+i))
+             a4 = (c2*a(ic+i)+s2*b(ic+i)) - (c3*a(id+i)+s3*b(id+i))
+             b1 = (c1*b(ib+i)-s1*a(ib+i)) + (c4*b(ie+i)-s4*a(ie+i))
+             b3 = (c1*b(ib+i)-s1*a(ib+i)) - (c4*b(ie+i)-s4*a(ie+i))
+             b2 = (c2*b(ic+i)-s2*a(ic+i)) + (c3*b(id+i)-s3*a(id+i))
+             b4 = (c2*b(ic+i)-s2*a(ic+i)) - (c3*b(id+i)-s3*a(id+i))
+             a5 = a(ia+i) - 0.25_wp*(a1+a2)
+             a6 = qrt5*(a1-a2)
+             b5 = b(ia+i) - 0.25_wp*(b1+b2)
+             b6 = qrt5*(b1-b2)
+             a10 = a5 + a6
+             a20 = a5 - a6
+             b10 = b5 + b6
+             b20 = b5 - b6
+             a11 = sin72*b3 + sin36*b4
+             a21 = sin36*b3 - sin72*b4
+             b11 = sin72*a3 + sin36*a4
+             b21 = sin36*a3 - sin72*a4
+             c(ja+j) = a(ia+i) + (a1+a2)
+             c(jb+j) = a10 + a11
+             c(je+j) = a10 - a11
+             c(jc+j) = a20 + a21
+             c(jd+j) = a20 - a21
+             d(ja+j) = b(ia+i) + (b1+b2)
+             d(jb+j) = b10 - b11
+             d(je+j) = -(b10+b11)
+             d(jc+j) = b20 - b21
+             d(jd+j) = -(b20+b21)
+             i = i + inc3
+             j = j + inc4
+          END DO
+          ibase = ibase + inc1
+          jbase = jbase + inc2
+       END DO
+       ibase = ibase + ijump
+       ja = ja + jink
+       jb = jb + jink
+       jc = jc + jink
+       jd = jd - jink
+       je = je - jink
+    END DO
+    IF (jb>jd) GO TO 170
+110 CONTINUE
+    jbase = 0
+    DO l = 1, la
+       i = ibase
+       j = jbase
+!DIR$ IVDEP
+!CDIR NODEP
+!OCL NOVREC
+       DO ijk = 1, lot
+          a1 = a(ib+i) + a(ie+i)
+          a3 = a(ib+i) - a(ie+i)
+          a2 = a(ic+i) + a(id+i)
+          a4 = a(ic+i) - a(id+i)
+          a5 = a(ia+i) + 0.25_wp*(a3-a4)
+          a6 = qrt5*(a3+a4)
+          c(ja+j) = a5 + a6
+          c(jb+j) = a5 - a6
+          c(jc+j) = a(ia+i) - (a3-a4)
+          d(ja+j) = -sin36*a1 - sin72*a2
+          d(jb+j) = -sin72*a1 + sin36*a2
+          i = i + inc3
+          j = j + inc4
+       END DO
+       ibase = ibase + inc1
+       jbase = jbase + inc2
+    END DO
+
+    GO TO 170
+120 CONTINUE
+    z = 1.0_wp/REAL(n,KIND=wp)
+    zqrt5 = z*qrt5
+    zsin36 = z*sin36
+    zsin72 = z*sin72
+    DO l = 1, la
+       i = ibase
+       j = jbase
+!DIR$ IVDEP
+!CDIR NODEP
+!OCL NOVREC
+       DO ijk = 1, lot
+          a1 = a(ib+i) + a(ie+i)
+          a3 = a(ib+i) - a(ie+i)
+          a2 = a(ic+i) + a(id+i)
+          a4 = a(ic+i) - a(id+i)
+          a5 = z*(a(ia+i)-0.25_wp*(a1+a2))
+          a6 = zqrt5*(a1-a2)
+          c(ja+j) = z*(a(ia+i)+(a1+a2))
+          c(jb+j) = a5 + a6
+          c(jc+j) = a5 - a6
+          d(jb+j) = -zsin72*a3 - zsin36*a4
+          d(jc+j) = -zsin36*a3 + zsin72*a4
+          i = i + inc3
+          j = j + inc4
+       END DO
+       ibase = ibase + inc1
+       jbase = jbase + inc2
+    END DO
+    GO TO 170
+
+    ! Coding for factor 6
+
+130 CONTINUE
+    ia = 1
+    ib = ia + iink
+    ic = ib + iink
+    id = ic + iink
+    ie = id + iink
+    if = ie + iink
+    ja = 1
+    jb = ja + (2*m-la)*inc2
+    jc = jb + 2*m*inc2
+    jd = jc + 2*m*inc2
+    je = jc
+    jf = jb
+
+    IF (la==m) GO TO 150
+
+    DO l = 1, la
+       i = ibase
+       j = jbase
+!DIR$ IVDEP
+!CDIR NODEP
+!OCL NOVREC
+       DO ijk = 1, lot
+          a11 = (a(ic+i)+a(if+i)) + (a(ib+i)+a(ie+i))
+          c(ja+j) = (a(ia+i)+a(id+i)) + a11
+          c(jc+j) = (a(ia+i)+a(id+i)-0.5_wp*a11)
+          d(jc+j) = sin60*((a(ic+i)+a(if+i))-(a(ib+i)+a(ie+i)))
+          a11 = (a(ic+i)-a(if+i)) + (a(ie+i)-a(ib+i))
+          c(jb+j) = (a(ia+i)-a(id+i)) - 0.5_wp*a11
+          d(jb+j) = sin60*((a(ie+i)-a(ib+i))-(a(ic+i)-a(if+i)))
+          c(jd+j) = (a(ia+i)-a(id+i)) + a11
+          i = i + inc3
+          j = j + inc4
+       END DO
+       ibase = ibase + inc1
+       jbase = jbase + inc2
+    END DO
+    ja = ja + jink
+    jink = 2*jink
+    jb = jb + jink
+    jc = jc + jink
+    jd = jd - jink
+    je = je - jink
+    jf = jf - jink
+    ibase = ibase + ijump
+    ijump = 2*ijump + iink
+    IF (jc==jd) GO TO 140
+    DO k = la, kstop, la
+       kb = k + k
+       kc = kb + kb
+       kd = kc + kb
+       ke = kd + kb
+       kf = ke + kb
+       c1 = trigs(kb+1)
+       s1 = trigs(kb+2)
+       c2 = trigs(kc+1)
+       s2 = trigs(kc+2)
+       c3 = trigs(kd+1)
+       s3 = trigs(kd+2)
+       c4 = trigs(ke+1)
+       s4 = trigs(ke+2)
+       c5 = trigs(kf+1)
+       s5 = trigs(kf+2)
+       jbase = 0
+       DO l = 1, la
+          i = ibase
+          j = jbase
+!DIR$ IVDEP
+!CDIR NODEP
+!OCL NOVREC
+          DO ijk = 1, lot
+             a1 = c1*a(ib+i) + s1*b(ib+i)
+             b1 = c1*b(ib+i) - s1*a(ib+i)
+             a2 = c2*a(ic+i) + s2*b(ic+i)
+             b2 = c2*b(ic+i) - s2*a(ic+i)
+             a3 = c3*a(id+i) + s3*b(id+i)
+             b3 = c3*b(id+i) - s3*a(id+i)
+             a4 = c4*a(ie+i) + s4*b(ie+i)
+             b4 = c4*b(ie+i) - s4*a(ie+i)
+             a5 = c5*a(if+i) + s5*b(if+i)
+             b5 = c5*b(if+i) - s5*a(if+i)
+             a11 = (a2+a5) + (a1+a4)
+             a20 = (a(ia+i)+a3) - 0.5_wp*a11
+             a21 = sin60*((a2+a5)-(a1+a4))
+             b11 = (b2+b5) + (b1+b4)
+             b20 = (b(ia+i)+b3) - 0.5_wp*b11
+             b21 = sin60*((b2+b5)-(b1+b4))
+             c(ja+j) = (a(ia+i)+a3) + a11
+             d(ja+j) = (b(ia+i)+b3) + b11
+             c(jc+j) = a20 - b21
+             d(jc+j) = a21 + b20
+             c(je+j) = a20 + b21
+             d(je+j) = a21 - b20
+             a11 = (a2-a5) + (a4-a1)
+             a20 = (a(ia+i)-a3) - 0.5_wp*a11
+             a21 = sin60*((a4-a1)-(a2-a5))
+             b11 = (b5-b2) - (b4-b1)
+             b20 = (b3-b(ia+i)) - 0.5_wp*b11
+             b21 = sin60*((b5-b2)+(b4-b1))
+             c(jb+j) = a20 - b21
+             d(jb+j) = a21 - b20
+             c(jd+j) = a11 + (a(ia+i)-a3)
+             d(jd+j) = b11 + (b3-b(ia+i))
+             c(jf+j) = a20 + b21
+             d(jf+j) = a21 + b20
+             i = i + inc3
+             j = j + inc4
+          END DO
+          ibase = ibase + inc1
+          jbase = jbase + inc2
+       END DO
+       ibase = ibase + ijump
+       ja = ja + jink
+       jb = jb + jink
+       jc = jc + jink
+       jd = jd - jink
+       je = je - jink
+       jf = jf - jink
+    END DO
+    IF (jc>jd) GO TO 170
+140 CONTINUE
+    jbase = 0
+    DO l = 1, la
+       i = ibase
+       j = jbase
+!DIR$ IVDEP
+!CDIR NODEP
+!OCL NOVREC
+       DO ijk = 1, lot
+          c(ja+j) = (a(ia+i)+0.5_wp*(a(ic+i)-a(ie+i))) + sin60*(a(ib+i)-a(if+i))
+          d(ja+j) = -(a(id+i)+0.5_wp*(a(ib+i)+a(if+i))) - sin60*(a(ic+i)+a(ie+i))
+          c(jb+j) = a(ia+i) - (a(ic+i)-a(ie+i))
+          d(jb+j) = a(id+i) - (a(ib+i)+a(if+i))
+          c(jc+j) = (a(ia+i)+0.5_wp*(a(ic+i)-a(ie+i))) - sin60*(a(ib+i)-a(if+i))
+          d(jc+j) = -(a(id+i)+0.5_wp*(a(ib+i)+a(if+i))) + sin60*(a(ic+i)+a(ie+i))
+          i = i + inc3
+          j = j + inc4
+       END DO
+       ibase = ibase + inc1
+       jbase = jbase + inc2
+    END DO
+
+    GO TO 170
+150 CONTINUE
+    z = 1.0_wp/REAL(n,KIND=wp)
+    zsin60 = z*sin60
+    DO l = 1, la
+       i = ibase
+       j = jbase
+!DIR$ IVDEP
+!CDIR NODEP
+!OCL NOVREC
+       DO ijk = 1, lot
+          a11 = (a(ic+i)+a(if+i)) + (a(ib+i)+a(ie+i))
+          c(ja+j) = z*((a(ia+i)+a(id+i))+a11)
+          c(jc+j) = z*((a(ia+i)+a(id+i))-0.5_wp*a11)
+          d(jc+j) = zsin60*((a(ic+i)+a(if+i))-(a(ib+i)+a(ie+i)))
+          a11 = (a(ic+i)-a(if+i)) + (a(ie+i)-a(ib+i))
+          c(jb+j) = z*((a(ia+i)-a(id+i))-0.5_wp*a11)
+          d(jb+j) = zsin60*((a(ie+i)-a(ib+i))-(a(ic+i)-a(if+i)))
+          c(jd+j) = z*((a(ia+i)-a(id+i))+a11)
+          i = i + inc3
+          j = j + inc4
+       END DO
+       ibase = ibase + inc1
+       jbase = jbase + inc2
+    END DO
+    GO TO 170
+
+    ! Coding for factor 8
+
+160 CONTINUE
+    ibad = 3
+    IF (la/=m) GO TO 180
+    ia = 1
+    ib = ia + iink
+    ic = ib + iink
+    id = ic + iink
+    ie = id + iink
+    if = ie + iink
+    ig = if + iink
+    ih = ig + iink
+    ja = 1
+    jb = ja + la*inc2
+    jc = jb + 2*m*inc2
+    jd = jc + 2*m*inc2
+    je = jd + 2*m*inc2
+    z = 1.0_wp/REAL(n,KIND=wp)
+    zsin45 = z*SQRT(0.5_wp)
+
+    DO l = 1, la
+       i = ibase
+       j = jbase
+!DIR$ IVDEP
+!CDIR NODEP
+!OCL NOVREC
+       DO ijk = 1, lot
+          c(ja+j) = z*(((a(ia+i)+a(ie+i))+(a(ic+i)+a(ig+i)))+((a(id+i)+ &
+               &          a(ih+i))+(a(ib+i)+a(if+i))))
+          c(je+j) = z*(((a(ia+i)+a(ie+i))+(a(ic+i)+a(ig+i)))-((a(id+i)+ &
+               &          a(ih+i))+(a(ib+i)+a(if+i))))
+          c(jc+j) = z*((a(ia+i)+a(ie+i))-(a(ic+i)+a(ig+i)))
+          d(jc+j) = z*((a(id+i)+a(ih+i))-(a(ib+i)+a(if+i)))
+          c(jb+j) = z*(a(ia+i)-a(ie+i)) + zsin45*((a(ih+i)-a(id+i))-(a(if+ &
+               &          i)-a(ib+i)))
+          c(jd+j) = z*(a(ia+i)-a(ie+i)) - zsin45*((a(ih+i)-a(id+i))-(a(if+ &
+               &          i)-a(ib+i)))
+          d(jb+j) = zsin45*((a(ih+i)-a(id+i))+(a(if+i)-a(ib+i))) + &
+               &          z*(a(ig+i)-a(ic+i))
+          d(jd+j) = zsin45*((a(ih+i)-a(id+i))+(a(if+i)-a(ib+i))) - &
+               &          z*(a(ig+i)-a(ic+i))
+          i = i + inc3
+          j = j + inc4
+       END DO
+       ibase = ibase + inc1
+       jbase = jbase + inc2
+    END DO
+
+    ! Return
+
+170 CONTINUE
+    ibad = 0
+180 CONTINUE
+    ierr = ibad
+    RETURN
+  END SUBROUTINE qpassm
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> @todo Missing subroutine description.
+!------------------------------------------------------------------------------!
+  SUBROUTINE rpassm(a,b,c,d,trigs,inc1,inc2,inc3,inc4,lot,n,ifac,la,ierr)
+    ! Dimension a(n),b(n),c(n),d(n),trigs(n)
+
+    USE kinds
+
+    IMPLICIT NONE
+
+    !  Scalar arguments 
+    INTEGER(iwp) ::  ierr !< 
+    INTEGER(iwp) ::  ifac !< 
+    INTEGER(iwp) ::  inc1 !< 
+    INTEGER(iwp) ::  inc2 !< 
+    INTEGER(iwp) ::  inc3 !< 
+    INTEGER(iwp) ::  inc4 !< 
+    INTEGER(iwp) ::  la   !< 
+    INTEGER(iwp) ::  lot  !< 
+    INTEGER(iwp) ::  n    !< 
+
+    !  Array arguments 
+    REAL(wp) ::  a(*)     !< 
+    REAL(wp) ::  b(*)     !< 
+    REAL(wp) ::  c(*)     !< 
+    REAL(wp) ::  d(*)     !< 
+    REAL(wp) ::  trigs(*) !< 
+
+    !  Local scalars: 
+    REAL(wp) ::  c1     !< 
+    REAL(wp) ::  c2     !< 
+    REAL(wp) ::  c3     !< 
+    REAL(wp) ::  c4     !< 
+    REAL(wp) ::  c5     !< 
+    REAL(wp) ::  qqrt5  !< 
+    REAL(wp) ::  qrt5   !< 
+    REAL(wp) ::  s1     !< 
+    REAL(wp) ::  s2     !< 
+    REAL(wp) ::  s3     !< 
+    REAL(wp) ::  s4     !< 
+    REAL(wp) ::  s5     !< 
+    REAL(wp) ::  sin36  !< 
+    REAL(wp) ::  sin45  !< 
+    REAL(wp) ::  sin60  !< 
+    REAL(wp) ::  sin72  !< 
+    REAL(wp) ::  ssin36 !< 
+    REAL(wp) ::  ssin45 !< 
+    REAL(wp) ::  ssin60 !< 
+    REAL(wp) ::  ssin72 !< 
+
+    INTEGER(iwp) ::  i     !< 
+    INTEGER(iwp) ::  ia    !< 
+    INTEGER(iwp) ::  ib    !< 
+    INTEGER(iwp) ::  ibad  !< 
+    INTEGER(iwp) ::  ibase !< 
+    INTEGER(iwp) ::  ic    !< 
+    INTEGER(iwp) ::  id    !< 
+    INTEGER(iwp) ::  ie    !< 
+    INTEGER(iwp) ::  if    !< 
+    INTEGER(iwp) ::  igo   !< 
+    INTEGER(iwp) ::  iink  !< 
+    INTEGER(iwp) ::  ijk   !< 
+    INTEGER(iwp) ::  j     !< 
+    INTEGER(iwp) ::  ja    !< 
+    INTEGER(iwp) ::  jb    !< 
+    INTEGER(iwp) ::  jbase !< 
+    INTEGER(iwp) ::  jc    !< 
+    INTEGER(iwp) ::  jd    !< 
+    INTEGER(iwp) ::  je    !< 
+    INTEGER(iwp) ::  jf    !< 
+    INTEGER(iwp) ::  jg    !< 
+    INTEGER(iwp) ::  jh    !< 
+    INTEGER(iwp) ::  jink  !< 
+    INTEGER(iwp) ::  jump  !< 
+    INTEGER(iwp) ::  k     !< 
+    INTEGER(iwp) ::  kb    !< 
+    INTEGER(iwp) ::  kc    !< 
+    INTEGER(iwp) ::  kd    !< 
+    INTEGER(iwp) ::  ke    !< 
+    INTEGER(iwp) ::  kf    !< 
+    INTEGER(iwp) ::  kstop !< 
+    INTEGER(iwp) ::  l     !< 
+    INTEGER(iwp) ::  m     !< 
+
+    !  Local arrays: 
+    REAL(wp) ::  a10(nfft) !< 
+    REAL(wp) ::  a11(nfft) !< 
+    REAL(wp) ::  a20(nfft) !< 
+    REAL(wp) ::  a21(nfft) !< 
+    REAL(wp) ::  b10(nfft) !< 
+    REAL(wp) ::  b11(nfft) !< 
+    REAL(wp) ::  b20(nfft) !< 
+    REAL(wp) ::  b21(nfft) !< 
+
+    !  Intrinsic functions 
+!    INTRINSIC SQRT
+
+    !  Data statements 
+    DATA sin36/0.587785252292473_wp/, sin72/0.951056516295154_wp/, &
+         &      qrt5/0.559016994374947_wp/, sin60/0.866025403784437_wp/
+
+
+    !  Executable statements 
+
+    m = n/ifac
+    iink = la*inc1
+    jink = la*inc2
+    jump = (ifac-1)*jink
+    kstop = (n-ifac)/(2*ifac)
+
+    ibad = 1
+    IF (lot>nfft) GO TO 180
+    ibase = 0
+    jbase = 0
+    igo = ifac - 1
+    IF (igo==7) igo = 6
+    ibad = 2
+    IF (igo<1 .OR. igo>6) GO TO 180
+    GO TO (10,40,70,100,130,160) igo
+
+    ! Coding for factor 2
+
+10  CONTINUE
+    ia = 1
+    ib = ia + (2*m-la)*inc1
+    ja = 1
+    jb = ja + jink
+
+    IF (la==m) GO TO 30
+
+    DO l = 1, la
+       i = ibase
+       j = jbase
+!DIR$ IVDEP
+!CDIR NODEP
+!OCL NOVREC
+       DO ijk = 1, lot
+          c(ja+j) = a(ia+i) + a(ib+i)
+          c(jb+j) = a(ia+i) - a(ib+i)
+          i = i + inc3
+          j = j + inc4
+       END DO
+       ibase = ibase + inc1
+       jbase = jbase + inc2
+    END DO
+    ia = ia + iink
+    iink = 2*iink
+    ib = ib - iink
+    ibase = 0
+    jbase = jbase + jump
+    jump = 2*jump + jink
+    IF (ia==ib) GO TO 20
+    DO k = la, kstop, la
+       kb = k + k
+       c1 = trigs(kb+1)
+       s1 = trigs(kb+2)
+       ibase = 0
+       DO l = 1, la
+          i = ibase
+          j = jbase
+!DIR$ IVDEP
+!CDIR NODEP
+!OCL NOVREC
+          DO ijk = 1, lot
+             c(ja+j) = a(ia+i) + a(ib+i)
+             d(ja+j) = b(ia+i) - b(ib+i)
+             c(jb+j) = c1*(a(ia+i)-a(ib+i)) - s1*(b(ia+i)+b(ib+i))
+             d(jb+j) = s1*(a(ia+i)-a(ib+i)) + c1*(b(ia+i)+b(ib+i))
+             i = i + inc3
+             j = j + inc4
+          END DO
+          ibase = ibase + inc1
+          jbase = jbase + inc2
+       END DO
+       ia = ia + iink
+       ib = ib - iink
+       jbase = jbase + jump
+    END DO
+    IF (ia>ib) GO TO 170
+20  CONTINUE
+    ibase = 0
+    DO l = 1, la
+       i = ibase
+       j = jbase
+!DIR$ IVDEP
+!CDIR NODEP
+!OCL NOVREC
+       DO ijk = 1, lot
+          c(ja+j) = a(ia+i)
+          c(jb+j) = -b(ia+i)
+          i = i + inc3
+          j = j + inc4
+       END DO
+       ibase = ibase + inc1
+       jbase = jbase + inc2
+    END DO
+
+    GO TO 170
+30  CONTINUE
+    DO l = 1, la
+       i = ibase
+       j = jbase
+!DIR$ IVDEP
+!CDIR NODEP
+!OCL NOVREC
+       DO ijk = 1, lot
+          c(ja+j) = 2.0_wp*(a(ia+i)+a(ib+i))
+          c(jb+j) = 2.0_wp*(a(ia+i)-a(ib+i))
+          i = i + inc3
+          j = j + inc4
+       END DO
+       ibase = ibase + inc1
+       jbase = jbase + inc2
+    END DO
+    GO TO 170
+
+    ! Coding for factor 3
+
+40  CONTINUE
+    ia = 1
+    ib = ia + (2*m-la)*inc1
+    ic = ib
+    ja = 1
+    jb = ja + jink
+    jc = jb + jink
+
+    IF (la==m) GO TO 60
+
+    DO l = 1, la
+       i = ibase
+       j = jbase
+!DIR$ IVDEP
+!CDIR NODEP
+!OCL NOVREC
+       DO ijk = 1, lot
+          c(ja+j) = a(ia+i) + a(ib+i)
+          c(jb+j) = (a(ia+i)-0.5_wp*a(ib+i)) - (sin60*(b(ib+i)))
+          c(jc+j) = (a(ia+i)-0.5_wp*a(ib+i)) + (sin60*(b(ib+i)))
+          i = i + inc3
+          j = j + inc4
+       END DO
+       ibase = ibase + inc1
+       jbase = jbase + inc2
+    END DO
+    ia = ia + iink
+    iink = 2*iink
+    ib = ib + iink
+    ic = ic - iink
+    jbase = jbase + jump
+    jump = 2*jump + jink
+    IF (ia==ic) GO TO 50
+    DO k = la, kstop, la
+       kb = k + k
+       kc = kb + kb
+       c1 = trigs(kb+1)
+       s1 = trigs(kb+2)
+       c2 = trigs(kc+1)
+       s2 = trigs(kc+2)
+       ibase = 0
+       DO l = 1, la
+          i = ibase
+          j = jbase
+!DIR$ IVDEP
+!CDIR NODEP
+!OCL NOVREC
+          DO ijk = 1, lot
+             c(ja+j) = a(ia+i) + (a(ib+i)+a(ic+i))
+             d(ja+j) = b(ia+i) + (b(ib+i)-b(ic+i))
+             c(jb+j) = c1*((a(ia+i)-0.5_wp*(a(ib+i)+a(ic+i)))-(sin60*(b(ib+i)+ &
+                  &            b(ic+i))))                                      &
+                  &    - s1*((b(ia+i)-0.5_wp*(b(ib+i)-b(ic+i)))+(sin60*(a(ib+i)- &
+                  &            a(ic+i))))
+             d(jb+j) = s1*((a(ia+i)-0.5_wp*(a(ib+i)+a(ic+i)))-(sin60*(b(ib+i)+ &
+                  &            b(ic+i))))                                      &
+                  &    + c1*((b(ia+i)-0.5_wp*(b(ib+i)-b(ic+i)))+(sin60*(a(ib+i)- &
+                  &            a(ic+i))))
+             c(jc+j) = c2*((a(ia+i)-0.5_wp*(a(ib+i)+a(ic+i)))+(sin60*(b(ib+i)+ &
+                  &            b(ic+i))))                                      &
+                  &    - s2*((b(ia+i)-0.5_wp*(b(ib+i)-b(ic+i)))-(sin60*(a(ib+i)- &
+                  &            a(ic+i))))
+             d(jc+j) = s2*((a(ia+i)-0.5_wp*(a(ib+i)+a(ic+i)))+(sin60*(b(ib+i)+ &
+                  &            b(ic+i))))                                      &
+                  &    + c2*((b(ia+i)-0.5_wp*(b(ib+i)-b(ic+i)))-(sin60*(a(ib+i)- &
+                  &            a(ic+i))))
+             i = i + inc3
+             j = j + inc4
+          END DO
+          ibase = ibase + inc1
+          jbase = jbase + inc2
+       END DO
+       ia = ia + iink
+       ib = ib + iink
+       ic = ic - iink
+       jbase = jbase + jump
+    END DO
+    IF (ia>ic) GO TO 170
+50  CONTINUE
+    ibase = 0
+    DO l = 1, la
+       i = ibase
+       j = jbase
+!DIR$ IVDEP
+!CDIR NODEP
+!OCL NOVREC
+       DO ijk = 1, lot
+          c(ja+j) = a(ia+i) + a(ib+i)
+          c(jb+j) = (0.5_wp*a(ia+i)-a(ib+i)) - (sin60*b(ia+i))
+          c(jc+j) = -(0.5_wp*a(ia+i)-a(ib+i)) - (sin60*b(ia+i))
+          i = i + inc3
+          j = j + inc4
+       END DO
+       ibase = ibase + inc1
+       jbase = jbase + inc2
+    END DO
+
+    GO TO 170
+60  CONTINUE
+    ssin60 = 2.0_wp*sin60
+    DO l = 1, la
+       i = ibase
+       j = jbase
+!DIR$ IVDEP
+!CDIR NODEP
+!OCL NOVREC
+       DO ijk = 1, lot
+          c(ja+j) = 2.0_wp*(a(ia+i)+a(ib+i))
+          c(jb+j) = (2.0_wp*a(ia+i)-a(ib+i)) - (ssin60*b(ib+i))
+          c(jc+j) = (2.0_wp*a(ia+i)-a(ib+i)) + (ssin60*b(ib+i))
+          i = i + inc3
+          j = j + inc4
+       END DO
+       ibase = ibase + inc1
+       jbase = jbase + inc2
+    END DO
+    GO TO 170
+
+    ! Coding for factor 4
+
+70  CONTINUE
+    ia = 1
+    ib = ia + (2*m-la)*inc1
+    ic = ib + 2*m*inc1
+    id = ib
+    ja = 1
+    jb = ja + jink
+    jc = jb + jink
+    jd = jc + jink
+
+    IF (la==m) GO TO 90
+
+    DO l = 1, la
+       i = ibase
+       j = jbase
+!DIR$ IVDEP
+!CDIR NODEP
+!OCL NOVREC
+       DO ijk = 1, lot
+          c(ja+j) = (a(ia+i)+a(ic+i)) + a(ib+i)
+          c(jb+j) = (a(ia+i)-a(ic+i)) - b(ib+i)
+          c(jc+j) = (a(ia+i)+a(ic+i)) - a(ib+i)
+          c(jd+j) = (a(ia+i)-a(ic+i)) + b(ib+i)
+          i = i + inc3
+          j = j + inc4
+       END DO
+       ibase = ibase + inc1
+       jbase = jbase + inc2
+    END DO
+    ia = ia + iink
+    iink = 2*iink
+    ib = ib + iink
+    ic = ic - iink
+    id = id - iink
+    jbase = jbase + jump
+    jump = 2*jump + jink
+    IF (ib==ic) GO TO 80
+    DO k = la, kstop, la
+       kb = k + k
+       kc = kb + kb
+       kd = kc + kb
+       c1 = trigs(kb+1)
+       s1 = trigs(kb+2)
+       c2 = trigs(kc+1)
+       s2 = trigs(kc+2)
+       c3 = trigs(kd+1)
+       s3 = trigs(kd+2)
+       ibase = 0
+       DO l = 1, la
+          i = ibase
+          j = jbase
+!DIR$ IVDEP
+!CDIR NODEP
+!OCL NOVREC
+          DO ijk = 1, lot
+             c(ja+j) = (a(ia+i)+a(ic+i)) + (a(ib+i)+a(id+i))
+             d(ja+j) = (b(ia+i)-b(ic+i)) + (b(ib+i)-b(id+i))
+             c(jc+j) = c2*((a(ia+i)+a(ic+i))-(a(ib+i)+a(id+i))) - s2*((b(ia+ &
+                  &            i)-b(ic+i))-(b(ib+i)-b(id+i)))
+             d(jc+j) = s2*((a(ia+i)+a(ic+i))-(a(ib+i)+a(id+i))) + c2*((b(ia+ &
+                  &            i)-b(ic+i))-(b(ib+i)-b(id+i)))
+             c(jb+j) = c1*((a(ia+i)-a(ic+i))-(b(ib+i)+b(id+i))) - s1*((b(ia+ &
+                  &            i)+b(ic+i))+(a(ib+i)-a(id+i)))
+             d(jb+j) = s1*((a(ia+i)-a(ic+i))-(b(ib+i)+b(id+i))) + c1*((b(ia+ &
+                  &            i)+b(ic+i))+(a(ib+i)-a(id+i)))
+             c(jd+j) = c3*((a(ia+i)-a(ic+i))+(b(ib+i)+b(id+i))) - s3*((b(ia+ &
+                  &            i)+b(ic+i))-(a(ib+i)-a(id+i)))
+             d(jd+j) = s3*((a(ia+i)-a(ic+i))+(b(ib+i)+b(id+i))) + c3*((b(ia+ &
+                  &            i)+b(ic+i))-(a(ib+i)-a(id+i)))
+             i = i + inc3
+             j = j + inc4
+          END DO
+          ibase = ibase + inc1
+          jbase = jbase + inc2
+       END DO
+       ia = ia + iink
+       ib = ib + iink
+       ic = ic - iink
+       id = id - iink
+       jbase = jbase + jump
+    END DO
+    IF (ib>ic) GO TO 170
+80  CONTINUE
+    ibase = 0
+    sin45 = SQRT(0.5_wp)
+    DO l = 1, la
+       i = ibase
+       j = jbase
+!DIR$ IVDEP
+!CDIR NODEP
+!OCL NOVREC
+       DO ijk = 1, lot
+          c(ja+j) = a(ia+i) + a(ib+i)
+          c(jb+j) = sin45*((a(ia+i)-a(ib+i))-(b(ia+i)+b(ib+i)))
+          c(jc+j) = b(ib+i) - b(ia+i)
+          c(jd+j) = -sin45*((a(ia+i)-a(ib+i))+(b(ia+i)+b(ib+i)))
+          i = i + inc3
+          j = j + inc4
+       END DO
+       ibase = ibase + inc1
+       jbase = jbase + inc2
+    END DO
+
+    GO TO 170
+90  CONTINUE
+    DO l = 1, la
+       i = ibase
+       j = jbase
+!DIR$ IVDEP
+!CDIR NODEP
+!OCL NOVREC
+       DO ijk = 1, lot
+          c(ja+j) = 2.0_wp*((a(ia+i)+a(ic+i))+a(ib+i))
+          c(jb+j) = 2.0_wp*((a(ia+i)-a(ic+i))-b(ib+i))
+          c(jc+j) = 2.0_wp*((a(ia+i)+a(ic+i))-a(ib+i))
+          c(jd+j) = 2.0_wp*((a(ia+i)-a(ic+i))+b(ib+i))
+          i = i + inc3
+          j = j + inc4
+       END DO
+       ibase = ibase + inc1
+       jbase = jbase + inc2
+    END DO
+
+    ! Coding for factor 5
+
+    GO TO 170
+100 CONTINUE
+    ia = 1
+    ib = ia + (2*m-la)*inc1
+    ic = ib + 2*m*inc1
+    id = ic
+    ie = ib
+    ja = 1
+    jb = ja + jink
+    jc = jb + jink
+    jd = jc + jink
+    je = jd + jink
+
+    IF (la==m) GO TO 120
+
+    DO l = 1, la
+       i = ibase
+       j = jbase
+!DIR$ IVDEP
+!CDIR NODEP
+!OCL NOVREC
+       DO ijk = 1, lot
+          c(ja+j) = a(ia+i) + (a(ib+i)+a(ic+i))
+          c(jb+j) = ((a(ia+i)-0.25_wp*(a(ib+i)+a(ic+i)))+qrt5*(a(ib+i)-a(ic+i))) - &
+               &          (sin72*b(ib+i)+sin36*b(ic+i))
+          c(jc+j) = ((a(ia+i)-0.25_wp*(a(ib+i)+a(ic+i)))-qrt5*(a(ib+i)-a(ic+i))) - &
+               &          (sin36*b(ib+i)-sin72*b(ic+i))
+          c(jd+j) = ((a(ia+i)-0.25_wp*(a(ib+i)+a(ic+i)))-qrt5*(a(ib+i)-a(ic+i))) + &
+               &          (sin36*b(ib+i)-sin72*b(ic+i))
+          c(je+j) = ((a(ia+i)-0.25_wp*(a(ib+i)+a(ic+i)))+qrt5*(a(ib+i)-a(ic+i))) + &
+               &          (sin72*b(ib+i)+sin36*b(ic+i))
+          i = i + inc3
+          j = j + inc4
+       END DO
+       ibase = ibase + inc1
+       jbase = jbase + inc2
+    END DO
+    ia = ia + iink
+    iink = 2*iink
+    ib = ib + iink
+    ic = ic + iink
+    id = id - iink
+    ie = ie - iink
+    jbase = jbase + jump
+    jump = 2*jump + jink
+    IF (ib==id) GO TO 110
+    DO k = la, kstop, la
+       kb = k + k
+       kc = kb + kb
+       kd = kc + kb
+       ke = kd + kb
+       c1 = trigs(kb+1)
+       s1 = trigs(kb+2)
+       c2 = trigs(kc+1)
+       s2 = trigs(kc+2)
+       c3 = trigs(kd+1)
+       s3 = trigs(kd+2)
+       c4 = trigs(ke+1)
+       s4 = trigs(ke+2)
+       ibase = 0
+       DO l = 1, la
+          i = ibase
+          j = jbase
+!DIR$ IVDEP
+!CDIR NODEP
+!OCL NOVREC
+          DO ijk = 1, lot
+
+             a10(ijk) = (a(ia+i)-0.25_wp*((a(ib+i)+a(ie+i))+(a(ic+i)+a(id+i)))) + &
+                  &            qrt5*((a(ib+i)+a(ie+i))-(a(ic+i)+a(id+i)))
+             a20(ijk) = (a(ia+i)-0.25_wp*((a(ib+i)+a(ie+i))+(a(ic+i)+a(id+i)))) - &
+                  &            qrt5*((a(ib+i)+a(ie+i))-(a(ic+i)+a(id+i)))
+             b10(ijk) = (b(ia+i)-0.25_wp*((b(ib+i)-b(ie+i))+(b(ic+i)-b(id+i)))) + &
+                  &            qrt5*((b(ib+i)-b(ie+i))-(b(ic+i)-b(id+i)))
+             b20(ijk) = (b(ia+i)-0.25_wp*((b(ib+i)-b(ie+i))+(b(ic+i)-b(id+i)))) - &
+                  &            qrt5*((b(ib+i)-b(ie+i))-(b(ic+i)-b(id+i)))
+             a11(ijk) = sin72*(b(ib+i)+b(ie+i)) + sin36*(b(ic+i)+b(id+i))
+             a21(ijk) = sin36*(b(ib+i)+b(ie+i)) - sin72*(b(ic+i)+b(id+i))
+             b11(ijk) = sin72*(a(ib+i)-a(ie+i)) + sin36*(a(ic+i)-a(id+i))
+             b21(ijk) = sin36*(a(ib+i)-a(ie+i)) - sin72*(a(ic+i)-a(id+i))
+
+             c(ja+j) = a(ia+i) + ((a(ib+i)+a(ie+i))+(a(ic+i)+a(id+i)))
+             d(ja+j) = b(ia+i) + ((b(ib+i)-b(ie+i))+(b(ic+i)-b(id+i)))
+             c(jb+j) = c1*(a10(ijk)-a11(ijk)) - s1*(b10(ijk)+b11(ijk))
+             d(jb+j) = s1*(a10(ijk)-a11(ijk)) + c1*(b10(ijk)+b11(ijk))
+             c(je+j) = c4*(a10(ijk)+a11(ijk)) - s4*(b10(ijk)-b11(ijk))
+             d(je+j) = s4*(a10(ijk)+a11(ijk)) + c4*(b10(ijk)-b11(ijk))
+             c(jc+j) = c2*(a20(ijk)-a21(ijk)) - s2*(b20(ijk)+b21(ijk))
+             d(jc+j) = s2*(a20(ijk)-a21(ijk)) + c2*(b20(ijk)+b21(ijk))
+             c(jd+j) = c3*(a20(ijk)+a21(ijk)) - s3*(b20(ijk)-b21(ijk))
+             d(jd+j) = s3*(a20(ijk)+a21(ijk)) + c3*(b20(ijk)-b21(ijk))
+
+             i = i + inc3
+             j = j + inc4
+          END DO
+          ibase = ibase + inc1
+          jbase = jbase + inc2
+       END DO
+       ia = ia + iink
+       ib = ib + iink
+       ic = ic + iink
+       id = id - iink
+       ie = ie - iink
+       jbase = jbase + jump
+    END DO
+    IF (ib>id) GO TO 170
+110 CONTINUE
+    ibase = 0
+    DO l = 1, la
+       i = ibase
+       j = jbase
+!DIR$ IVDEP
+!CDIR NODEP
+!OCL NOVREC
+       DO ijk = 1, lot
+          c(ja+j) = (a(ia+i)+a(ib+i)) + a(ic+i)
+          c(jb+j) = (qrt5*(a(ia+i)-a(ib+i))+(0.25_wp*(a(ia+i)+a(ib+i))-a(ic+i))) - &
+               &          (sin36*b(ia+i)+sin72*b(ib+i))
+          c(je+j) = -(qrt5*(a(ia+i)-a(ib+i))+(0.25_wp*(a(ia+i)+a(ib+i))-a(ic+i))) - &
+               &          (sin36*b(ia+i)+sin72*b(ib+i))
+          c(jc+j) = (qrt5*(a(ia+i)-a(ib+i))-(0.25_wp*(a(ia+i)+a(ib+i))-a(ic+i))) - &
+               &          (sin72*b(ia+i)-sin36*b(ib+i))
+          c(jd+j) = -(qrt5*(a(ia+i)-a(ib+i))-(0.25_wp*(a(ia+i)+a(ib+i))-a(ic+i))) - &
+               &          (sin72*b(ia+i)-sin36*b(ib+i))
+          i = i + inc3
+          j = j + inc4
+       END DO
+       ibase = ibase + inc1
+       jbase = jbase + inc2
+    END DO
+
+    GO TO 170
+120 CONTINUE
+    qqrt5 = 2.0_wp*qrt5
+    ssin36 = 2.0_wp*sin36
+    ssin72 = 2.0_wp*sin72
+    DO l = 1, la
+       i = ibase
+       j = jbase
+!DIR$ IVDEP
+!CDIR NODEP
+!OCL NOVREC
+       DO ijk = 1, lot
+          c(ja+j) = 2.0_wp*(a(ia+i)+(a(ib+i)+a(ic+i)))
+          c(jb+j) = (2.0_wp*(a(ia+i)-0.25_wp*(a(ib+i)+a(ic+i)))+qqrt5*(a(ib+i)-a(ic+ &
+               &          i))) - (ssin72*b(ib+i)+ssin36*b(ic+i))
+          c(jc+j) = (2.0_wp*(a(ia+i)-0.25_wp*(a(ib+i)+a(ic+i)))-qqrt5*(a(ib+i)-a(ic+ &
+               &          i))) - (ssin36*b(ib+i)-ssin72*b(ic+i))
+          c(jd+j) = (2.0_wp*(a(ia+i)-0.25_wp*(a(ib+i)+a(ic+i)))-qqrt5*(a(ib+i)-a(ic+ &
+               &          i))) + (ssin36*b(ib+i)-ssin72*b(ic+i))
+          c(je+j) = (2.0_wp*(a(ia+i)-0.25_wp*(a(ib+i)+a(ic+i)))+qqrt5*(a(ib+i)-a(ic+ &
+               &          i))) + (ssin72*b(ib+i)+ssin36*b(ic+i))
+          i = i + inc3
+          j = j + inc4
+       END DO
+       ibase = ibase + inc1
+       jbase = jbase + inc2
+    END DO
+    GO TO 170
+
+    ! Coding for factor 6
+
+130 CONTINUE
+    ia = 1
+    ib = ia + (2*m-la)*inc1
+    ic = ib + 2*m*inc1
+    id = ic + 2*m*inc1
+    ie = ic
+    if = ib
+    ja = 1
+    jb = ja + jink
+    jc = jb + jink
+    jd = jc + jink
+    je = jd + jink
+    jf = je + jink
+
+    IF (la==m) GO TO 150
+
+    DO l = 1, la
+       i = ibase
+       j = jbase
+!DIR$ IVDEP
+!CDIR NODEP
+!OCL NOVREC
+       DO ijk = 1, lot
+          c(ja+j) = (a(ia+i)+a(id+i)) + (a(ib+i)+a(ic+i))
+          c(jd+j) = (a(ia+i)-a(id+i)) - (a(ib+i)-a(ic+i))
+          c(jb+j) = ((a(ia+i)-a(id+i))+0.5_wp*(a(ib+i)-a(ic+i))) - (sin60*(b(ib+ &
+               &          i)+b(ic+i)))
+          c(jf+j) = ((a(ia+i)-a(id+i))+0.5_wp*(a(ib+i)-a(ic+i))) + (sin60*(b(ib+ &
+               &          i)+b(ic+i)))
+          c(jc+j) = ((a(ia+i)+a(id+i))-0.5_wp*(a(ib+i)+a(ic+i))) - (sin60*(b(ib+ &
+               &          i)-b(ic+i)))
+          c(je+j) = ((a(ia+i)+a(id+i))-0.5_wp*(a(ib+i)+a(ic+i))) + (sin60*(b(ib+ &
+               &          i)-b(ic+i)))
+          i = i + inc3
+          j = j + inc4
+       END DO
+       ibase = ibase + inc1
+       jbase = jbase + inc2
+    END DO
+    ia = ia + iink
+    iink = 2*iink
+    ib = ib + iink
+    ic = ic + iink
+    id = id - iink
+    ie = ie - iink
+    if = if - iink
+    jbase = jbase + jump
+    jump = 2*jump + jink
+    IF (ic==id) GO TO 140
+    DO k = la, kstop, la
+       kb = k + k
+       kc = kb + kb
+       kd = kc + kb
+       ke = kd + kb
+       kf = ke + kb
+       c1 = trigs(kb+1)
+       s1 = trigs(kb+2)
+       c2 = trigs(kc+1)
+       s2 = trigs(kc+2)
+       c3 = trigs(kd+1)
+       s3 = trigs(kd+2)
+       c4 = trigs(ke+1)
+       s4 = trigs(ke+2)
+       c5 = trigs(kf+1)
+       s5 = trigs(kf+2)
+       ibase = 0
+       DO l = 1, la
+          i = ibase
+          j = jbase
+!DIR$ IVDEP
+!CDIR NODEP
+!OCL NOVREC
+          DO ijk = 1, lot
+
+             a11(ijk) = (a(ie+i)+a(ib+i)) + (a(ic+i)+a(if+i))
+             a20(ijk) = (a(ia+i)+a(id+i)) - 0.5_wp*a11(ijk)
+             a21(ijk) = sin60*((a(ie+i)+a(ib+i))-(a(ic+i)+a(if+i)))
+             b11(ijk) = (b(ib+i)-b(ie+i)) + (b(ic+i)-b(if+i))
+             b20(ijk) = (b(ia+i)-b(id+i)) - 0.5_wp*b11(ijk)
+             b21(ijk) = sin60*((b(ib+i)-b(ie+i))-(b(ic+i)-b(if+i)))
+
+             c(ja+j) = (a(ia+i)+a(id+i)) + a11(ijk)
+             d(ja+j) = (b(ia+i)-b(id+i)) + b11(ijk)
+             c(jc+j) = c2*(a20(ijk)-b21(ijk)) - s2*(b20(ijk)+a21(ijk))
+             d(jc+j) = s2*(a20(ijk)-b21(ijk)) + c2*(b20(ijk)+a21(ijk))
+             c(je+j) = c4*(a20(ijk)+b21(ijk)) - s4*(b20(ijk)-a21(ijk))
+             d(je+j) = s4*(a20(ijk)+b21(ijk)) + c4*(b20(ijk)-a21(ijk))
+
+             a11(ijk) = (a(ie+i)-a(ib+i)) + (a(ic+i)-a(if+i))
+             b11(ijk) = (b(ie+i)+b(ib+i)) - (b(ic+i)+b(if+i))
+             a20(ijk) = (a(ia+i)-a(id+i)) - 0.5_wp*a11(ijk)
+             a21(ijk) = sin60*((a(ie+i)-a(ib+i))-(a(ic+i)-a(if+i)))
+             b20(ijk) = (b(ia+i)+b(id+i)) + 0.5_wp*b11(ijk)
+             b21(ijk) = sin60*((b(ie+i)+b(ib+i))+(b(ic+i)+b(if+i)))
+
+             c(jd+j) = c3*((a(ia+i)-a(id+i))+a11(ijk)) - s3*((b(ia+i)+b(id+ &
+                  &            i))-b11(ijk))
+             d(jd+j) = s3*((a(ia+i)-a(id+i))+a11(ijk)) + c3*((b(ia+i)+b(id+ &
+                  &            i))-b11(ijk))
+             c(jb+j) = c1*(a20(ijk)-b21(ijk)) - s1*(b20(ijk)-a21(ijk))
+             d(jb+j) = s1*(a20(ijk)-b21(ijk)) + c1*(b20(ijk)-a21(ijk))
+             c(jf+j) = c5*(a20(ijk)+b21(ijk)) - s5*(b20(ijk)+a21(ijk))
+             d(jf+j) = s5*(a20(ijk)+b21(ijk)) + c5*(b20(ijk)+a21(ijk))
+
+             i = i + inc3
+             j = j + inc4
+          END DO
+          ibase = ibase + inc1
+          jbase = jbase + inc2
+       END DO
+       ia = ia + iink
+       ib = ib + iink
+       ic = ic + iink
+       id = id - iink
+       ie = ie - iink
+       if = if - iink
+       jbase = jbase + jump
+    END DO
+    IF (ic>id) GO TO 170
+140 CONTINUE
+    ibase = 0
+    DO l = 1, la
+       i = ibase
+       j = jbase
+!DIR$ IVDEP
+!CDIR NODEP
+!OCL NOVREC
+       DO ijk = 1, lot
+          c(ja+j) = a(ib+i) + (a(ia+i)+a(ic+i))
+          c(jd+j) = b(ib+i) - (b(ia+i)+b(ic+i))
+          c(jb+j) = (sin60*(a(ia+i)-a(ic+i))) - (0.5_wp*(b(ia+i)+b(ic+i))+b(ib+i))
+          c(jf+j) = -(sin60*(a(ia+i)-a(ic+i))) - (0.5_wp*(b(ia+i)+b(ic+i))+b(ib+i))
+          c(jc+j) = sin60*(b(ic+i)-b(ia+i)) + (0.5_wp*(a(ia+i)+a(ic+i))-a(ib+i))
+          c(je+j) = sin60*(b(ic+i)-b(ia+i)) - (0.5_wp*(a(ia+i)+a(ic+i))-a(ib+i))
+          i = i + inc3
+          j = j + inc4
+       END DO
+       ibase = ibase + inc1
+       jbase = jbase + inc2
+    END DO
+
+    GO TO 170
+150 CONTINUE
+    ssin60 = 2.0_wp*sin60
+    DO l = 1, la
+       i = ibase
+       j = jbase
+!DIR$ IVDEP
+!CDIR NODEP
+!OCL NOVREC
+       DO ijk = 1, lot
+          c(ja+j) = (2.0_wp*(a(ia+i)+a(id+i))) + (2.0_wp*(a(ib+i)+a(ic+i)))
+          c(jd+j) = (2.0_wp*(a(ia+i)-a(id+i))) - (2.0_wp*(a(ib+i)-a(ic+i)))
+          c(jb+j) = (2.0_wp*(a(ia+i)-a(id+i))+(a(ib+i)-a(ic+i))) - (ssin60*(b(ib+ &
+               &          i)+b(ic+i)))
+          c(jf+j) = (2.0_wp*(a(ia+i)-a(id+i))+(a(ib+i)-a(ic+i))) + (ssin60*(b(ib+ &
+               &          i)+b(ic+i)))
+          c(jc+j) = (2.0_wp*(a(ia+i)+a(id+i))-(a(ib+i)+a(ic+i))) - (ssin60*(b(ib+ &
+               &          i)-b(ic+i)))
+          c(je+j) = (2.0_wp*(a(ia+i)+a(id+i))-(a(ib+i)+a(ic+i))) + (ssin60*(b(ib+ &
+               &          i)-b(ic+i)))
+          i = i + inc3
+          j = j + inc4
+       END DO
+       ibase = ibase + inc1
+       jbase = jbase + inc2
+    END DO
+    GO TO 170
+
+    ! Coding for factor 8
+
+160 CONTINUE
+    ibad = 3
+    IF (la/=m) GO TO 180
+    ia = 1
+    ib = ia + la*inc1
+    ic = ib + 2*la*inc1
+    id = ic + 2*la*inc1
+    ie = id + 2*la*inc1
+    ja = 1
+    jb = ja + jink
+    jc = jb + jink
+    jd = jc + jink
+    je = jd + jink
+    jf = je + jink
+    jg = jf + jink
+    jh = jg + jink
+    ssin45 = SQRT(2.0_wp)
+
+    DO l = 1, la
+       i = ibase
+       j = jbase
+!DIR$ IVDEP
+!CDIR NODEP
+!OCL NOVREC
+       DO ijk = 1, lot
+          c(ja+j) = 2.0_wp*(((a(ia+i)+a(ie+i))+a(ic+i))+(a(ib+i)+a(id+i)))
+          c(je+j) = 2.0_wp*(((a(ia+i)+a(ie+i))+a(ic+i))-(a(ib+i)+a(id+i)))
+          c(jc+j) = 2.0_wp*(((a(ia+i)+a(ie+i))-a(ic+i))-(b(ib+i)-b(id+i)))
+          c(jg+j) = 2.0_wp*(((a(ia+i)+a(ie+i))-a(ic+i))+(b(ib+i)-b(id+i)))
+          c(jb+j) = 2.0_wp*((a(ia+i)-a(ie+i))-b(ic+i)) + ssin45*((a(ib+i)-a(id+ &
+               &              i))-(b(ib+i)+b(id+i)))
+          c(jf+j) = 2.0_wp*((a(ia+i)-a(ie+i))-b(ic+i)) - ssin45*((a(ib+i)-a(id+ &
+               &              i))-(b(ib+i)+b(id+i)))
+          c(jd+j) = 2.0_wp*((a(ia+i)-a(ie+i))+b(ic+i)) - ssin45*((a(ib+i)-a(id+ &
+               &              i))+(b(ib+i)+b(id+i)))
+          c(jh+j) = 2.0_wp*((a(ia+i)-a(ie+i))+b(ic+i)) + ssin45*((a(ib+i)-a(id+ &
+               &              i))+(b(ib+i)+b(id+i)))
+          i = i + inc3
+          j = j + inc4
+       END DO
+       ibase = ibase + inc1
+       jbase = jbase + inc2
+    END DO
+
+    ! Return
+
+170 CONTINUE
+    ibad = 0
+180 CONTINUE
+    ierr = ibad
+    RETURN
+  END SUBROUTINE rpassm
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Computes factors of n & trigonometric functins required by fft99 & fft991cy
+!> Method: Dimension trigs(n),ifax(1),jfax(10),lfax(7)
+!> subroutine 'set99' - computes factors of n & trigonometric
+!> functins required by fft99 & fft991cy
+!------------------------------------------------------------------------------!
+  SUBROUTINE set99(trigs,ifax,n)
+
+
+    USE control_parameters,                                                    &
+        ONLY:  message_string
+
+    USE kinds
+
+    IMPLICIT NONE
+
+    !  Scalar arguments 
+    INTEGER(iwp) ::  n !< 
+
+    !  Array arguments 
+    INTEGER(iwp) ::  ifax(*)  !< 
+    REAL(wp)     ::  trigs(*) !< 
+
+
+    !  Local scalars: 
+    REAL(wp) ::  angle    !< 
+    REAL(wp) ::  del      !< 
+    INTEGER(iwp) ::  i    !< 
+    INTEGER(iwp) ::  ifac !< 
+    INTEGER(iwp) ::  ixxx !< 
+    INTEGER(iwp) ::  k    !< 
+    INTEGER(iwp) ::  l    !< 
+    INTEGER(iwp) ::  nfax !< 
+    INTEGER(iwp) ::  nhl  !< 
+    INTEGER(iwp) ::  nil  !< 
+    INTEGER(iwp) ::  nu   !< 
+
+    !  Local arrays: 
+    INTEGER(iwp) ::  jfax(10) !< 
+    INTEGER(iwp) ::  lfax(7)  !< 
+
+    !  Intrinsic functions 
+!    INTRINSIC ASIN, COS, MOD, REAL, SIN
+
+    !  Data statements 
+    DATA lfax/6, 8, 5, 4, 3, 2, 1/
+
+
+    !  Executable statements 
+    ixxx = 1
+
+    del = 4.0_wp*ASIN(1.0_wp)/REAL(n,KIND=wp)
+    nil = 0
+    nhl = (n/2) - 1
+    DO k = nil, nhl
+       angle = REAL(k,KIND=wp)*del
+       trigs(2*k+1) = COS(angle)
+       trigs(2*k+2) = SIN(angle)
+    END DO
+
+    ! Find factors of n (8,6,5,4,3,2; only one 8 allowed)
+    ! Look for sixes first, store factors in descending order
+    nu = n
+    ifac = 6
+    k = 0
+    l = 1
+10  CONTINUE
+    IF (MOD(nu,ifac)/=0) GO TO 30
+    k = k + 1
+    jfax(k) = ifac
+    IF (ifac/=8) GO TO 20
+    IF (k==1) GO TO 20
+    jfax(1) = 8
+    jfax(k) = 6
+20  CONTINUE
+    nu = nu/ifac
+    IF (nu==1) GO TO 40
+    IF (ifac/=8) GO TO 10
+30  CONTINUE
+    l = l + 1
+    ifac = lfax(l)
+    IF (ifac>1) GO TO 10
+
+!    WRITE (nout,'(A,I4,A)') ' n =',n,' - Contains illegal factors'
+    message_string = 'number of gridpoints along x or/and y ' // &
+                     'contain illegal  factors' //               &
+                     '&only factors 8,6,5,4,3,2 are allowed' 
+    CALL message( 'temperton_fft', 'PA0311', 1, 2, 0, 6, 0 )
+
+    RETURN
+
+    ! Now reverse order of factors
+40  CONTINUE
+    nfax = k
+    ifax(1) = nfax
+    DO i = 1, nfax
+       ifax(nfax+2-i) = jfax(i)
+    END DO
+    ifax(10) = n
+    RETURN
+  END SUBROUTINE set99
+
+ END MODULE temperton_fft
Index: lm/trunk/SOURCE/tridia_solver.f90
===================================================================
--- /palm/trunk/SOURCE/tridia_solver.f90	(revision 1849)
+++ 	(revision )
@@ -1,692 +1,0 @@
-!> @file tridia_solver.f90
-!--------------------------------------------------------------------------------!
-! This file is part of PALM.
-!
-! PALM is free software: you can redistribute it and/or modify it under the terms
-! of the GNU General Public License as published by the Free Software Foundation,
-! either version 3 of the License, or (at your option) any later version.
-!
-! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
-! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
-! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along with
-! PALM. If not, see <http://www.gnu.org/licenses/>.
-!
-! Copyright 1997-2016 Leibniz Universitaet Hannover
-!--------------------------------------------------------------------------------!
-!
-! Current revisions:
-! ------------------
-!
-!
-! Former revisions:
-! -----------------
-! $Id$
-!
-! 1815 2016-04-06 13:49:59Z raasch
-! cpp-switch intel11 removed
-!
-! 1808 2016-04-05 19:44:00Z raasch
-! test output removed
-!
-! 1804 2016-04-05 16:30:18Z maronga
-! Removed code for parameter file check (__check)
-! 
-! 1682 2015-10-07 23:56:08Z knoop
-! Code annotations made doxygen readable 
-! 
-! 1406 2014-05-16 13:47:01Z raasch
-! bugfix for pgi 14.4: declare create moved after array declaration
-! 
-! 1342 2014-03-26 17:04:47Z kanani
-! REAL constants defined as wp-kind
-!
-! 1322 2014-03-20 16:38:49Z raasch
-! REAL functions provided with KIND-attribute
-!
-! 1320 2014-03-20 08:40:49Z raasch
-! ONLY-attribute added to USE-statements,
-! kind-parameters added to all INTEGER and REAL declaration statements,
-! kinds are defined in new module kinds,
-! old module precision_kind is removed,
-! revision history before 2012 removed,
-! comment fields (!:) to be used for variable explanations added to
-! all variable declaration statements 
-!
-! 1257 2013-11-08 15:18:40Z raasch
-! openacc loop and loop vector clauses removed, declare create moved after
-! the FORTRAN declaration statement
-!
-! 1221 2013-09-10 08:59:13Z raasch
-! dummy argument tri in 1d-routines replaced by tri_for_1d because of name
-! conflict with arry tri in module arrays_3d
-!
-! 1216 2013-08-26 09:31:42Z raasch
-! +tridia_substi_overlap for handling overlapping fft / transposition
-!
-! 1212 2013-08-15 08:46:27Z raasch
-! Initial revision.
-! Routines have been moved to seperate module from former file poisfft to here.
-! The tridiagonal matrix coefficients of array tri are calculated only once at
-! the beginning, i.e. routine split is called within tridia_init.
-!
-!
-! Description:
-! ------------
-!> solves the linear system of equations:
-!>
-!> -(4 pi^2(i^2/(dx^2*nnx^2)+j^2/(dy^2*nny^2))+
-!>   1/(dzu(k)*dzw(k))+1/(dzu(k-1)*dzw(k)))*p(i,j,k)+
-!> 1/(dzu(k)*dzw(k))*p(i,j,k+1)+1/(dzu(k-1)*dzw(k))*p(i,j,k-1)=d(i,j,k)
-!>
-!> by using the Thomas algorithm
-!------------------------------------------------------------------------------!
- MODULE tridia_solver
- 
-
-    USE indices,                                                               &
-        ONLY:  nx, ny, nz
-
-    USE kinds
-
-    USE transpose_indices,                                                     &
-        ONLY:  nxl_z, nyn_z, nxr_z, nys_z
-
-    IMPLICIT NONE
-
-    REAL(wp), DIMENSION(:,:), ALLOCATABLE ::  ddzuw !< 
-
-    PRIVATE
-
-    INTERFACE tridia_substi
-       MODULE PROCEDURE tridia_substi
-    END INTERFACE tridia_substi
-
-    INTERFACE tridia_substi_overlap
-       MODULE PROCEDURE tridia_substi_overlap
-    END INTERFACE tridia_substi_overlap
-
-    PUBLIC  tridia_substi, tridia_substi_overlap, tridia_init, tridia_1dd
-
- CONTAINS
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> @todo Missing subroutine description.
-!------------------------------------------------------------------------------!
-    SUBROUTINE tridia_init
-
-       USE arrays_3d,                                                          &
-           ONLY:  ddzu_pres, ddzw
-
-       USE kinds
-
-       IMPLICIT NONE
-
-       INTEGER(iwp) ::  k !< 
-
-       ALLOCATE( ddzuw(0:nz-1,3) )
-
-       DO  k = 0, nz-1
-          ddzuw(k,1) = ddzu_pres(k+1) * ddzw(k+1)
-          ddzuw(k,2) = ddzu_pres(k+2) * ddzw(k+1)
-          ddzuw(k,3) = -1.0_wp * &
-                       ( ddzu_pres(k+2) * ddzw(k+1) + ddzu_pres(k+1) * ddzw(k+1) )
-       ENDDO
-!
-!--    Calculate constant coefficients of the tridiagonal matrix
-       CALL maketri
-       CALL split
-
-    END SUBROUTINE tridia_init
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Computes the i- and j-dependent component of the matrix
-!> Provide the constant coefficients of the tridiagonal matrix for solution
-!> of the Poisson equation in Fourier space.
-!> The coefficients are computed following the method of
-!> Schmidt et al. (DFVLR-Mitteilung 84-15), which departs from Stephan
-!> Siano's original version by discretizing the Poisson equation,
-!> before it is Fourier-transformed.
-!------------------------------------------------------------------------------!
-    SUBROUTINE maketri
-
-
-          USE arrays_3d,                                                       &
-              ONLY:  tric
-
-          USE constants,                                                       &
-              ONLY:  pi
-
-          USE control_parameters,                                              &
-              ONLY:  ibc_p_b, ibc_p_t
-
-          USE grid_variables,                                                  &
-              ONLY:  dx, dy
-
-
-          USE kinds
-
-          IMPLICIT NONE
-
-          INTEGER(iwp) ::  i    !< 
-          INTEGER(iwp) ::  j    !< 
-          INTEGER(iwp) ::  k    !< 
-          INTEGER(iwp) ::  nnxh !< 
-          INTEGER(iwp) ::  nnyh !< 
-
-          REAL(wp)    ::  ll(nxl_z:nxr_z,nys_z:nyn_z) !< 
-          !$acc declare create( ll )
-
-
-          nnxh = ( nx + 1 ) / 2
-          nnyh = ( ny + 1 ) / 2
-
-          !$acc kernels present( tric )
-          DO  j = nys_z, nyn_z
-             DO  i = nxl_z, nxr_z
-                IF ( j >= 0  .AND.  j <= nnyh )  THEN
-                   IF ( i >= 0  .AND.  i <= nnxh )  THEN
-                      ll(i,j) = 2.0_wp * ( 1.0_wp - COS( ( 2.0_wp * pi * i ) / &
-                                            REAL( nx+1, KIND=wp ) ) ) / ( dx * dx ) + &
-                                2.0_wp * ( 1.0_wp - COS( ( 2.0_wp * pi * j ) / &
-                                            REAL( ny+1, KIND=wp ) ) ) / ( dy * dy )
-                   ELSE
-                      ll(i,j) = 2.0_wp * ( 1.0_wp - COS( ( 2.0_wp * pi * ( nx+1-i ) ) / &
-                                            REAL( nx+1, KIND=wp ) ) ) / ( dx * dx ) + &
-                                2.0_wp * ( 1.0_wp - COS( ( 2.0_wp * pi * j ) / &
-                                            REAL( ny+1, KIND=wp ) ) ) / ( dy * dy )
-                   ENDIF
-                ELSE
-                   IF ( i >= 0  .AND.  i <= nnxh )  THEN
-                      ll(i,j) = 2.0_wp * ( 1.0_wp - COS( ( 2.0_wp * pi * i ) / &
-                                            REAL( nx+1, KIND=wp ) ) ) / ( dx * dx ) + &
-                                2.0_wp * ( 1.0_wp - COS( ( 2.0_wp * pi * ( ny+1-j ) ) / &
-                                            REAL( ny+1, KIND=wp ) ) ) / ( dy * dy )
-                   ELSE
-                      ll(i,j) = 2.0_wp * ( 1.0_wp - COS( ( 2.0_wp * pi * ( nx+1-i ) ) / &
-                                            REAL( nx+1, KIND=wp ) ) ) / ( dx * dx ) + &
-                                2.0_wp * ( 1.0_wp - COS( ( 2.0_wp * pi * ( ny+1-j ) ) / &
-                                            REAL( ny+1, KIND=wp ) ) ) / ( dy * dy )
-                   ENDIF
-                ENDIF
-             ENDDO
-          ENDDO
-
-          DO  k = 0, nz-1
-             DO  j = nys_z, nyn_z
-                DO  i = nxl_z, nxr_z
-                   tric(i,j,k) = ddzuw(k,3) - ll(i,j)
-                ENDDO
-             ENDDO
-          ENDDO
-          !$acc end kernels
-
-          IF ( ibc_p_b == 1 )  THEN
-             !$acc kernels present( tric )
-             DO  j = nys_z, nyn_z
-                DO  i = nxl_z, nxr_z
-                   tric(i,j,0) = tric(i,j,0) + ddzuw(0,1)
-                ENDDO
-             ENDDO
-             !$acc end kernels
-          ENDIF
-          IF ( ibc_p_t == 1 )  THEN
-             !$acc kernels present( tric )
-             DO  j = nys_z, nyn_z
-                DO  i = nxl_z, nxr_z
-                   tric(i,j,nz-1) = tric(i,j,nz-1) + ddzuw(nz-1,2)
-                ENDDO
-             ENDDO
-             !$acc end kernels
-          ENDIF
-
-    END SUBROUTINE maketri
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Substitution (Forward and Backward) (Thomas algorithm)
-!------------------------------------------------------------------------------!
-    SUBROUTINE tridia_substi( ar )
-
-
-          USE arrays_3d,                                                       & 
-              ONLY:  tri
-
-          USE control_parameters,                                              &
-              ONLY:  ibc_p_b, ibc_p_t
-
-          USE kinds
-
-          IMPLICIT NONE
-
-          INTEGER(iwp) ::  i !< 
-          INTEGER(iwp) ::  j !< 
-          INTEGER(iwp) ::  k !< 
-
-          REAL(wp)     ::  ar(nxl_z:nxr_z,nys_z:nyn_z,1:nz) !< 
-
-          REAL(wp), DIMENSION(nxl_z:nxr_z,nys_z:nyn_z,0:nz-1)   ::  ar1 !< 
-          !$acc declare create( ar1 )
-
-!
-!--       Forward substitution
-          DO  k = 0, nz - 1
-             !$acc kernels present( ar, tri )
-             DO  j = nys_z, nyn_z
-                DO  i = nxl_z, nxr_z
-
-                   IF ( k == 0 )  THEN
-                      ar1(i,j,k) = ar(i,j,k+1)
-                   ELSE
-                      ar1(i,j,k) = ar(i,j,k+1) - tri(i,j,k,2) * ar1(i,j,k-1)
-                   ENDIF
-
-                ENDDO
-             ENDDO
-             !$acc end kernels
-          ENDDO
-
-!
-!--       Backward substitution
-!--       Note, the 1.0E-20 in the denominator is due to avoid divisions
-!--       by zero appearing if the pressure bc is set to neumann at the top of
-!--       the model domain.
-          DO  k = nz-1, 0, -1
-             !$acc kernels present( ar, tri )
-             DO  j = nys_z, nyn_z
-                DO  i = nxl_z, nxr_z
-
-                   IF ( k == nz-1 )  THEN
-                      ar(i,j,k+1) = ar1(i,j,k) / ( tri(i,j,k,1) + 1.0E-20_wp )
-                   ELSE
-                      ar(i,j,k+1) = ( ar1(i,j,k) - ddzuw(k,2) * ar(i,j,k+2) ) &
-                              / tri(i,j,k,1)
-                   ENDIF
-                ENDDO
-             ENDDO
-             !$acc end kernels
-          ENDDO
-
-!
-!--       Indices i=0, j=0 correspond to horizontally averaged pressure.
-!--       The respective values of ar should be zero at all k-levels if
-!--       acceleration of horizontally averaged vertical velocity is zero.
-          IF ( ibc_p_b == 1  .AND.  ibc_p_t == 1 )  THEN
-             IF ( nys_z == 0  .AND.  nxl_z == 0 )  THEN
-                !$acc kernels loop present( ar )
-                DO  k = 1, nz
-                   ar(nxl_z,nys_z,k) = 0.0_wp
-                ENDDO
-                !$acc end kernels loop
-             ENDIF
-          ENDIF
-
-    END SUBROUTINE tridia_substi
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Substitution (Forward and Backward) (Thomas algorithm)
-!------------------------------------------------------------------------------!
-    SUBROUTINE tridia_substi_overlap( ar, jj )
-
-
-          USE arrays_3d,                                                       &
-              ONLY:  tri
-
-          USE control_parameters,                                              &
-              ONLY:  ibc_p_b, ibc_p_t
-
-          USE kinds
-
-          IMPLICIT NONE
-
-          INTEGER(iwp) ::  i  !< 
-          INTEGER(iwp) ::  j  !< 
-          INTEGER(iwp) ::  jj !< 
-          INTEGER(iwp) ::  k  !< 
-
-          REAL(wp)     ::  ar(nxl_z:nxr_z,nys_z:nyn_z,1:nz) !< 
-
-          REAL(wp), DIMENSION(nxl_z:nxr_z,nys_z:nyn_z,0:nz-1) ::  ar1 !<
-          !$acc declare create( ar1 )
-
-!
-!--       Forward substitution
-          DO  k = 0, nz - 1
-             !$acc kernels present( ar, tri )
-             !$acc loop
-             DO  j = nys_z, nyn_z
-                DO  i = nxl_z, nxr_z
-
-                   IF ( k == 0 )  THEN
-                      ar1(i,j,k) = ar(i,j,k+1)
-                   ELSE
-                      ar1(i,j,k) = ar(i,j,k+1) - tri(i,jj,k,2) * ar1(i,j,k-1)
-                   ENDIF
-
-                ENDDO
-             ENDDO
-             !$acc end kernels
-          ENDDO
-
-!
-!--       Backward substitution
-!--       Note, the 1.0E-20 in the denominator is due to avoid divisions
-!--       by zero appearing if the pressure bc is set to neumann at the top of
-!--       the model domain.
-          DO  k = nz-1, 0, -1
-             !$acc kernels present( ar, tri )
-             !$acc loop
-             DO  j = nys_z, nyn_z
-                DO  i = nxl_z, nxr_z
-
-                   IF ( k == nz-1 )  THEN
-                      ar(i,j,k+1) = ar1(i,j,k) / ( tri(i,jj,k,1) + 1.0E-20_wp )
-                   ELSE
-                      ar(i,j,k+1) = ( ar1(i,j,k) - ddzuw(k,2) * ar(i,j,k+2) ) &
-                              / tri(i,jj,k,1)
-                   ENDIF
-                ENDDO
-             ENDDO
-             !$acc end kernels
-          ENDDO
-
-!
-!--       Indices i=0, j=0 correspond to horizontally averaged pressure.
-!--       The respective values of ar should be zero at all k-levels if
-!--       acceleration of horizontally averaged vertical velocity is zero.
-          IF ( ibc_p_b == 1  .AND.  ibc_p_t == 1 )  THEN
-             IF ( nys_z == 0  .AND.  nxl_z == 0 )  THEN
-                !$acc kernels loop present( ar )
-                DO  k = 1, nz
-                   ar(nxl_z,nys_z,k) = 0.0_wp
-                ENDDO
-             ENDIF
-          ENDIF
-
-    END SUBROUTINE tridia_substi_overlap
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Splitting of the tridiagonal matrix (Thomas algorithm)
-!------------------------------------------------------------------------------!
-    SUBROUTINE split
-
-
-          USE arrays_3d,                                                       & 
-              ONLY:  tri, tric
-
-          USE kinds
-
-          IMPLICIT NONE
-
-          INTEGER(iwp) ::  i !< 
-          INTEGER(iwp) ::  j !< 
-          INTEGER(iwp) ::  k !< 
-!
-!--       Splitting
-          !$acc kernels present( tri, tric )
-          !$acc loop
-          DO  j = nys_z, nyn_z
-             !$acc loop vector( 32 )
-             DO  i = nxl_z, nxr_z
-                tri(i,j,0,1) = tric(i,j,0)
-             ENDDO
-          ENDDO
-          !$acc end kernels
-
-          DO  k = 1, nz-1
-             !$acc kernels present( tri, tric )
-             !$acc loop
-             DO  j = nys_z, nyn_z
-                !$acc loop vector( 32 )
-                DO  i = nxl_z, nxr_z
-                   tri(i,j,k,2) = ddzuw(k,1) / tri(i,j,k-1,1)
-                   tri(i,j,k,1) = tric(i,j,k) - ddzuw(k-1,2) * tri(i,j,k,2)
-                ENDDO
-             ENDDO
-             !$acc end kernels
-          ENDDO
-
-    END SUBROUTINE split
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Solves the linear system of equations for a 1d-decomposition along x (see
-!> tridia)
-!>
-!> @attention when using the intel compilers older than 12.0, array tri must
-!>            be passed as an argument to the contained subroutines. Otherwise
-!>            addres faults will occur. This feature can be activated with
-!>            cpp-switch __intel11
-!>            On NEC, tri should not be passed (except for routine substi_1dd)
-!>            because this causes very bad performance.
-!------------------------------------------------------------------------------!
- 
-    SUBROUTINE tridia_1dd( ddx2, ddy2, nx, ny, j, ar, tri_for_1d )
-
-
-       USE arrays_3d,                                                          &
-           ONLY:  ddzu_pres, ddzw
-
-       USE control_parameters,                                                 &
-           ONLY:  ibc_p_b, ibc_p_t
-
-       USE kinds
-
-       IMPLICIT NONE
-
-       INTEGER(iwp) ::  i                  !< 
-       INTEGER(iwp) ::  j                  !< 
-       INTEGER(iwp) ::  k                  !< 
-       INTEGER(iwp) ::  nnyh               !< 
-       INTEGER(iwp) ::  nx                 !< 
-       INTEGER(iwp) ::  ny                 !< 
-       INTEGER(iwp) ::  omp_get_thread_num !< 
-       INTEGER(iwp) ::  tn                 !< 
-
-       REAL(wp)     ::  ddx2 !< 
-       REAL(wp)     ::  ddy2 !< 
-
-       REAL(wp), DIMENSION(0:nx,1:nz)     ::  ar         !< 
-       REAL(wp), DIMENSION(5,0:nx,0:nz-1) ::  tri_for_1d !< 
-
-
-       nnyh = ( ny + 1 ) / 2
-
-!
-!--    Define constant elements of the tridiagonal matrix.
-!--    The compiler on SX6 does loop exchange. If 0:nx is a high power of 2,
-!--    the exchanged loops create bank conflicts. The following directive
-!--    prohibits loop exchange and the loops perform much better.
-!CDIR NOLOOPCHG
-       DO  k = 0, nz-1
-          DO  i = 0,nx
-             tri_for_1d(2,i,k) = ddzu_pres(k+1) * ddzw(k+1)
-             tri_for_1d(3,i,k) = ddzu_pres(k+2) * ddzw(k+1)
-          ENDDO
-       ENDDO
-
-       IF ( j <= nnyh )  THEN
-          CALL maketri_1dd( j )
-       ELSE
-          CALL maketri_1dd( ny+1-j )
-       ENDIF
-
-       CALL split_1dd
-       CALL substi_1dd( ar, tri_for_1d )
-
-    CONTAINS
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> computes the i- and j-dependent component of the matrix
-!------------------------------------------------------------------------------!
-       SUBROUTINE maketri_1dd( j )
-
-          USE constants,                                                       &
-              ONLY:  pi
-
-          USE kinds
-
-          IMPLICIT NONE
-
-          INTEGER(iwp) ::  i    !< 
-          INTEGER(iwp) ::  j    !< 
-          INTEGER(iwp) ::  k    !< 
-          INTEGER(iwp) ::  nnxh !< 
-
-          REAL(wp)     ::  a !< 
-          REAL(wp)     ::  c !< 
-
-          REAL(wp), DIMENSION(0:nx) ::  l !< 
-
-
-          nnxh = ( nx + 1 ) / 2
-!
-!--       Provide the tridiagonal matrix for solution of the Poisson equation in
-!--       Fourier space. The coefficients are computed following the method of
-!--       Schmidt et al. (DFVLR-Mitteilung 84-15), which departs from Stephan
-!--       Siano's original version by discretizing the Poisson equation,
-!--       before it is Fourier-transformed
-          DO  i = 0, nx
-             IF ( i >= 0 .AND. i <= nnxh ) THEN
-                l(i) = 2.0_wp * ( 1.0_wp - COS( ( 2.0_wp * pi * i ) / &
-                                   REAL( nx+1, KIND=wp ) ) ) * ddx2 + &
-                       2.0_wp * ( 1.0_wp - COS( ( 2.0_wp * pi * j ) / &
-                                   REAL( ny+1, KIND=wp ) ) ) * ddy2
-             ELSE
-                l(i) = 2.0_wp * ( 1.0_wp - COS( ( 2.0_wp * pi * ( nx+1-i ) ) / &
-                                   REAL( nx+1, KIND=wp ) ) ) * ddx2 + &
-                       2.0_wp * ( 1.0_wp - COS( ( 2.0_wp * pi * j ) / &
-                                   REAL( ny+1, KIND=wp ) ) ) * ddy2
-             ENDIF
-          ENDDO
-
-          DO  k = 0, nz-1
-             DO  i = 0, nx
-                a = -1.0_wp * ddzu_pres(k+2) * ddzw(k+1)
-                c = -1.0_wp * ddzu_pres(k+1) * ddzw(k+1)
-                tri_for_1d(1,i,k) = a + c - l(i)
-             ENDDO
-          ENDDO
-          IF ( ibc_p_b == 1 )  THEN
-             DO  i = 0, nx
-                tri_for_1d(1,i,0) = tri_for_1d(1,i,0) + tri_for_1d(2,i,0)
-             ENDDO
-          ENDIF
-          IF ( ibc_p_t == 1 )  THEN
-             DO  i = 0, nx
-                tri_for_1d(1,i,nz-1) = tri_for_1d(1,i,nz-1) + tri_for_1d(3,i,nz-1)
-             ENDDO
-          ENDIF
-
-       END SUBROUTINE maketri_1dd
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Splitting of the tridiagonal matrix (Thomas algorithm)
-!------------------------------------------------------------------------------!
-       SUBROUTINE split_1dd
-
-          IMPLICIT NONE
-
-          INTEGER(iwp) ::  i !< 
-          INTEGER(iwp) ::  k !< 
-
-
-!
-!--       Splitting
-          DO  i = 0, nx
-             tri_for_1d(4,i,0) = tri_for_1d(1,i,0)
-          ENDDO
-          DO  k = 1, nz-1
-             DO  i = 0, nx
-                tri_for_1d(5,i,k) = tri_for_1d(2,i,k) / tri_for_1d(4,i,k-1)
-                tri_for_1d(4,i,k) = tri_for_1d(1,i,k) - tri_for_1d(3,i,k-1) * tri_for_1d(5,i,k)
-             ENDDO
-          ENDDO
-
-       END SUBROUTINE split_1dd
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Substitution (Forward and Backward) (Thomas algorithm)
-!------------------------------------------------------------------------------!
-       SUBROUTINE substi_1dd( ar, tri_for_1d )
-
-
-          IMPLICIT NONE
-
-          INTEGER(iwp) ::  i !< 
-          INTEGER(iwp) ::  k !< 
-
-          REAL(wp), DIMENSION(0:nx,nz)       ::  ar         !< 
-          REAL(wp), DIMENSION(0:nx,0:nz-1)   ::  ar1        !< 
-          REAL(wp), DIMENSION(5,0:nx,0:nz-1) ::  tri_for_1d !< 
-
-!
-!--       Forward substitution
-          DO  i = 0, nx
-             ar1(i,0) = ar(i,1)
-          ENDDO
-          DO  k = 1, nz-1
-             DO  i = 0, nx
-                ar1(i,k) = ar(i,k+1) - tri_for_1d(5,i,k) * ar1(i,k-1)
-             ENDDO
-          ENDDO
-
-!
-!--       Backward substitution
-!--       Note, the add of 1.0E-20 in the denominator is due to avoid divisions
-!--       by zero appearing if the pressure bc is set to neumann at the top of
-!--       the model domain.
-          DO  i = 0, nx
-             ar(i,nz) = ar1(i,nz-1) / ( tri_for_1d(4,i,nz-1) + 1.0E-20_wp )
-          ENDDO
-          DO  k = nz-2, 0, -1
-             DO  i = 0, nx
-                ar(i,k+1) = ( ar1(i,k) - tri_for_1d(3,i,k) * ar(i,k+2) ) &
-                            / tri_for_1d(4,i,k)
-             ENDDO
-          ENDDO
-
-!
-!--       Indices i=0, j=0 correspond to horizontally averaged pressure.
-!--       The respective values of ar should be zero at all k-levels if
-!--       acceleration of horizontally averaged vertical velocity is zero.
-          IF ( ibc_p_b == 1  .AND.  ibc_p_t == 1 )  THEN
-             IF ( j == 0 )  THEN
-                DO  k = 1, nz
-                   ar(0,k) = 0.0_wp
-                ENDDO
-             ENDIF
-          ENDIF
-
-       END SUBROUTINE substi_1dd
-
-    END SUBROUTINE tridia_1dd
-
-
- END MODULE tridia_solver
Index: /palm/trunk/SOURCE/tridia_solver_mod.f90
===================================================================
--- /palm/trunk/SOURCE/tridia_solver_mod.f90	(revision 1850)
+++ /palm/trunk/SOURCE/tridia_solver_mod.f90	(revision 1850)
@@ -0,0 +1,693 @@
+!> @file tridia_solver_mod.f90
+!--------------------------------------------------------------------------------!
+! This file is part of PALM.
+!
+! PALM is free software: you can redistribute it and/or modify it under the terms
+! of the GNU General Public License as published by the Free Software Foundation,
+! either version 3 of the License, or (at your option) any later version.
+!
+! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
+! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
+! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along with
+! PALM. If not, see <http://www.gnu.org/licenses/>.
+!
+! Copyright 1997-2016 Leibniz Universitaet Hannover
+!--------------------------------------------------------------------------------!
+!
+! Current revisions:
+! ------------------
+! Module renamed
+!
+!
+! Former revisions:
+! -----------------
+! $Id$
+!
+! 1815 2016-04-06 13:49:59Z raasch
+! cpp-switch intel11 removed
+!
+! 1808 2016-04-05 19:44:00Z raasch
+! test output removed
+!
+! 1804 2016-04-05 16:30:18Z maronga
+! Removed code for parameter file check (__check)
+! 
+! 1682 2015-10-07 23:56:08Z knoop
+! Code annotations made doxygen readable 
+! 
+! 1406 2014-05-16 13:47:01Z raasch
+! bugfix for pgi 14.4: declare create moved after array declaration
+! 
+! 1342 2014-03-26 17:04:47Z kanani
+! REAL constants defined as wp-kind
+!
+! 1322 2014-03-20 16:38:49Z raasch
+! REAL functions provided with KIND-attribute
+!
+! 1320 2014-03-20 08:40:49Z raasch
+! ONLY-attribute added to USE-statements,
+! kind-parameters added to all INTEGER and REAL declaration statements,
+! kinds are defined in new module kinds,
+! old module precision_kind is removed,
+! revision history before 2012 removed,
+! comment fields (!:) to be used for variable explanations added to
+! all variable declaration statements 
+!
+! 1257 2013-11-08 15:18:40Z raasch
+! openacc loop and loop vector clauses removed, declare create moved after
+! the FORTRAN declaration statement
+!
+! 1221 2013-09-10 08:59:13Z raasch
+! dummy argument tri in 1d-routines replaced by tri_for_1d because of name
+! conflict with arry tri in module arrays_3d
+!
+! 1216 2013-08-26 09:31:42Z raasch
+! +tridia_substi_overlap for handling overlapping fft / transposition
+!
+! 1212 2013-08-15 08:46:27Z raasch
+! Initial revision.
+! Routines have been moved to seperate module from former file poisfft to here.
+! The tridiagonal matrix coefficients of array tri are calculated only once at
+! the beginning, i.e. routine split is called within tridia_init.
+!
+!
+! Description:
+! ------------
+!> solves the linear system of equations:
+!>
+!> -(4 pi^2(i^2/(dx^2*nnx^2)+j^2/(dy^2*nny^2))+
+!>   1/(dzu(k)*dzw(k))+1/(dzu(k-1)*dzw(k)))*p(i,j,k)+
+!> 1/(dzu(k)*dzw(k))*p(i,j,k+1)+1/(dzu(k-1)*dzw(k))*p(i,j,k-1)=d(i,j,k)
+!>
+!> by using the Thomas algorithm
+!------------------------------------------------------------------------------!
+ MODULE tridia_solver
+ 
+
+    USE indices,                                                               &
+        ONLY:  nx, ny, nz
+
+    USE kinds
+
+    USE transpose_indices,                                                     &
+        ONLY:  nxl_z, nyn_z, nxr_z, nys_z
+
+    IMPLICIT NONE
+
+    REAL(wp), DIMENSION(:,:), ALLOCATABLE ::  ddzuw !< 
+
+    PRIVATE
+
+    INTERFACE tridia_substi
+       MODULE PROCEDURE tridia_substi
+    END INTERFACE tridia_substi
+
+    INTERFACE tridia_substi_overlap
+       MODULE PROCEDURE tridia_substi_overlap
+    END INTERFACE tridia_substi_overlap
+
+    PUBLIC  tridia_substi, tridia_substi_overlap, tridia_init, tridia_1dd
+
+ CONTAINS
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> @todo Missing subroutine description.
+!------------------------------------------------------------------------------!
+    SUBROUTINE tridia_init
+
+       USE arrays_3d,                                                          &
+           ONLY:  ddzu_pres, ddzw
+
+       USE kinds
+
+       IMPLICIT NONE
+
+       INTEGER(iwp) ::  k !< 
+
+       ALLOCATE( ddzuw(0:nz-1,3) )
+
+       DO  k = 0, nz-1
+          ddzuw(k,1) = ddzu_pres(k+1) * ddzw(k+1)
+          ddzuw(k,2) = ddzu_pres(k+2) * ddzw(k+1)
+          ddzuw(k,3) = -1.0_wp * &
+                       ( ddzu_pres(k+2) * ddzw(k+1) + ddzu_pres(k+1) * ddzw(k+1) )
+       ENDDO
+!
+!--    Calculate constant coefficients of the tridiagonal matrix
+       CALL maketri
+       CALL split
+
+    END SUBROUTINE tridia_init
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Computes the i- and j-dependent component of the matrix
+!> Provide the constant coefficients of the tridiagonal matrix for solution
+!> of the Poisson equation in Fourier space.
+!> The coefficients are computed following the method of
+!> Schmidt et al. (DFVLR-Mitteilung 84-15), which departs from Stephan
+!> Siano's original version by discretizing the Poisson equation,
+!> before it is Fourier-transformed.
+!------------------------------------------------------------------------------!
+    SUBROUTINE maketri
+
+
+          USE arrays_3d,                                                       &
+              ONLY:  tric
+
+          USE constants,                                                       &
+              ONLY:  pi
+
+          USE control_parameters,                                              &
+              ONLY:  ibc_p_b, ibc_p_t
+
+          USE grid_variables,                                                  &
+              ONLY:  dx, dy
+
+
+          USE kinds
+
+          IMPLICIT NONE
+
+          INTEGER(iwp) ::  i    !< 
+          INTEGER(iwp) ::  j    !< 
+          INTEGER(iwp) ::  k    !< 
+          INTEGER(iwp) ::  nnxh !< 
+          INTEGER(iwp) ::  nnyh !< 
+
+          REAL(wp)    ::  ll(nxl_z:nxr_z,nys_z:nyn_z) !< 
+          !$acc declare create( ll )
+
+
+          nnxh = ( nx + 1 ) / 2
+          nnyh = ( ny + 1 ) / 2
+
+          !$acc kernels present( tric )
+          DO  j = nys_z, nyn_z
+             DO  i = nxl_z, nxr_z
+                IF ( j >= 0  .AND.  j <= nnyh )  THEN
+                   IF ( i >= 0  .AND.  i <= nnxh )  THEN
+                      ll(i,j) = 2.0_wp * ( 1.0_wp - COS( ( 2.0_wp * pi * i ) / &
+                                            REAL( nx+1, KIND=wp ) ) ) / ( dx * dx ) + &
+                                2.0_wp * ( 1.0_wp - COS( ( 2.0_wp * pi * j ) / &
+                                            REAL( ny+1, KIND=wp ) ) ) / ( dy * dy )
+                   ELSE
+                      ll(i,j) = 2.0_wp * ( 1.0_wp - COS( ( 2.0_wp * pi * ( nx+1-i ) ) / &
+                                            REAL( nx+1, KIND=wp ) ) ) / ( dx * dx ) + &
+                                2.0_wp * ( 1.0_wp - COS( ( 2.0_wp * pi * j ) / &
+                                            REAL( ny+1, KIND=wp ) ) ) / ( dy * dy )
+                   ENDIF
+                ELSE
+                   IF ( i >= 0  .AND.  i <= nnxh )  THEN
+                      ll(i,j) = 2.0_wp * ( 1.0_wp - COS( ( 2.0_wp * pi * i ) / &
+                                            REAL( nx+1, KIND=wp ) ) ) / ( dx * dx ) + &
+                                2.0_wp * ( 1.0_wp - COS( ( 2.0_wp * pi * ( ny+1-j ) ) / &
+                                            REAL( ny+1, KIND=wp ) ) ) / ( dy * dy )
+                   ELSE
+                      ll(i,j) = 2.0_wp * ( 1.0_wp - COS( ( 2.0_wp * pi * ( nx+1-i ) ) / &
+                                            REAL( nx+1, KIND=wp ) ) ) / ( dx * dx ) + &
+                                2.0_wp * ( 1.0_wp - COS( ( 2.0_wp * pi * ( ny+1-j ) ) / &
+                                            REAL( ny+1, KIND=wp ) ) ) / ( dy * dy )
+                   ENDIF
+                ENDIF
+             ENDDO
+          ENDDO
+
+          DO  k = 0, nz-1
+             DO  j = nys_z, nyn_z
+                DO  i = nxl_z, nxr_z
+                   tric(i,j,k) = ddzuw(k,3) - ll(i,j)
+                ENDDO
+             ENDDO
+          ENDDO
+          !$acc end kernels
+
+          IF ( ibc_p_b == 1 )  THEN
+             !$acc kernels present( tric )
+             DO  j = nys_z, nyn_z
+                DO  i = nxl_z, nxr_z
+                   tric(i,j,0) = tric(i,j,0) + ddzuw(0,1)
+                ENDDO
+             ENDDO
+             !$acc end kernels
+          ENDIF
+          IF ( ibc_p_t == 1 )  THEN
+             !$acc kernels present( tric )
+             DO  j = nys_z, nyn_z
+                DO  i = nxl_z, nxr_z
+                   tric(i,j,nz-1) = tric(i,j,nz-1) + ddzuw(nz-1,2)
+                ENDDO
+             ENDDO
+             !$acc end kernels
+          ENDIF
+
+    END SUBROUTINE maketri
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Substitution (Forward and Backward) (Thomas algorithm)
+!------------------------------------------------------------------------------!
+    SUBROUTINE tridia_substi( ar )
+
+
+          USE arrays_3d,                                                       & 
+              ONLY:  tri
+
+          USE control_parameters,                                              &
+              ONLY:  ibc_p_b, ibc_p_t
+
+          USE kinds
+
+          IMPLICIT NONE
+
+          INTEGER(iwp) ::  i !< 
+          INTEGER(iwp) ::  j !< 
+          INTEGER(iwp) ::  k !< 
+
+          REAL(wp)     ::  ar(nxl_z:nxr_z,nys_z:nyn_z,1:nz) !< 
+
+          REAL(wp), DIMENSION(nxl_z:nxr_z,nys_z:nyn_z,0:nz-1)   ::  ar1 !< 
+          !$acc declare create( ar1 )
+
+!
+!--       Forward substitution
+          DO  k = 0, nz - 1
+             !$acc kernels present( ar, tri )
+             DO  j = nys_z, nyn_z
+                DO  i = nxl_z, nxr_z
+
+                   IF ( k == 0 )  THEN
+                      ar1(i,j,k) = ar(i,j,k+1)
+                   ELSE
+                      ar1(i,j,k) = ar(i,j,k+1) - tri(i,j,k,2) * ar1(i,j,k-1)
+                   ENDIF
+
+                ENDDO
+             ENDDO
+             !$acc end kernels
+          ENDDO
+
+!
+!--       Backward substitution
+!--       Note, the 1.0E-20 in the denominator is due to avoid divisions
+!--       by zero appearing if the pressure bc is set to neumann at the top of
+!--       the model domain.
+          DO  k = nz-1, 0, -1
+             !$acc kernels present( ar, tri )
+             DO  j = nys_z, nyn_z
+                DO  i = nxl_z, nxr_z
+
+                   IF ( k == nz-1 )  THEN
+                      ar(i,j,k+1) = ar1(i,j,k) / ( tri(i,j,k,1) + 1.0E-20_wp )
+                   ELSE
+                      ar(i,j,k+1) = ( ar1(i,j,k) - ddzuw(k,2) * ar(i,j,k+2) ) &
+                              / tri(i,j,k,1)
+                   ENDIF
+                ENDDO
+             ENDDO
+             !$acc end kernels
+          ENDDO
+
+!
+!--       Indices i=0, j=0 correspond to horizontally averaged pressure.
+!--       The respective values of ar should be zero at all k-levels if
+!--       acceleration of horizontally averaged vertical velocity is zero.
+          IF ( ibc_p_b == 1  .AND.  ibc_p_t == 1 )  THEN
+             IF ( nys_z == 0  .AND.  nxl_z == 0 )  THEN
+                !$acc kernels loop present( ar )
+                DO  k = 1, nz
+                   ar(nxl_z,nys_z,k) = 0.0_wp
+                ENDDO
+                !$acc end kernels loop
+             ENDIF
+          ENDIF
+
+    END SUBROUTINE tridia_substi
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Substitution (Forward and Backward) (Thomas algorithm)
+!------------------------------------------------------------------------------!
+    SUBROUTINE tridia_substi_overlap( ar, jj )
+
+
+          USE arrays_3d,                                                       &
+              ONLY:  tri
+
+          USE control_parameters,                                              &
+              ONLY:  ibc_p_b, ibc_p_t
+
+          USE kinds
+
+          IMPLICIT NONE
+
+          INTEGER(iwp) ::  i  !< 
+          INTEGER(iwp) ::  j  !< 
+          INTEGER(iwp) ::  jj !< 
+          INTEGER(iwp) ::  k  !< 
+
+          REAL(wp)     ::  ar(nxl_z:nxr_z,nys_z:nyn_z,1:nz) !< 
+
+          REAL(wp), DIMENSION(nxl_z:nxr_z,nys_z:nyn_z,0:nz-1) ::  ar1 !<
+          !$acc declare create( ar1 )
+
+!
+!--       Forward substitution
+          DO  k = 0, nz - 1
+             !$acc kernels present( ar, tri )
+             !$acc loop
+             DO  j = nys_z, nyn_z
+                DO  i = nxl_z, nxr_z
+
+                   IF ( k == 0 )  THEN
+                      ar1(i,j,k) = ar(i,j,k+1)
+                   ELSE
+                      ar1(i,j,k) = ar(i,j,k+1) - tri(i,jj,k,2) * ar1(i,j,k-1)
+                   ENDIF
+
+                ENDDO
+             ENDDO
+             !$acc end kernels
+          ENDDO
+
+!
+!--       Backward substitution
+!--       Note, the 1.0E-20 in the denominator is due to avoid divisions
+!--       by zero appearing if the pressure bc is set to neumann at the top of
+!--       the model domain.
+          DO  k = nz-1, 0, -1
+             !$acc kernels present( ar, tri )
+             !$acc loop
+             DO  j = nys_z, nyn_z
+                DO  i = nxl_z, nxr_z
+
+                   IF ( k == nz-1 )  THEN
+                      ar(i,j,k+1) = ar1(i,j,k) / ( tri(i,jj,k,1) + 1.0E-20_wp )
+                   ELSE
+                      ar(i,j,k+1) = ( ar1(i,j,k) - ddzuw(k,2) * ar(i,j,k+2) ) &
+                              / tri(i,jj,k,1)
+                   ENDIF
+                ENDDO
+             ENDDO
+             !$acc end kernels
+          ENDDO
+
+!
+!--       Indices i=0, j=0 correspond to horizontally averaged pressure.
+!--       The respective values of ar should be zero at all k-levels if
+!--       acceleration of horizontally averaged vertical velocity is zero.
+          IF ( ibc_p_b == 1  .AND.  ibc_p_t == 1 )  THEN
+             IF ( nys_z == 0  .AND.  nxl_z == 0 )  THEN
+                !$acc kernels loop present( ar )
+                DO  k = 1, nz
+                   ar(nxl_z,nys_z,k) = 0.0_wp
+                ENDDO
+             ENDIF
+          ENDIF
+
+    END SUBROUTINE tridia_substi_overlap
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Splitting of the tridiagonal matrix (Thomas algorithm)
+!------------------------------------------------------------------------------!
+    SUBROUTINE split
+
+
+          USE arrays_3d,                                                       & 
+              ONLY:  tri, tric
+
+          USE kinds
+
+          IMPLICIT NONE
+
+          INTEGER(iwp) ::  i !< 
+          INTEGER(iwp) ::  j !< 
+          INTEGER(iwp) ::  k !< 
+!
+!--       Splitting
+          !$acc kernels present( tri, tric )
+          !$acc loop
+          DO  j = nys_z, nyn_z
+             !$acc loop vector( 32 )
+             DO  i = nxl_z, nxr_z
+                tri(i,j,0,1) = tric(i,j,0)
+             ENDDO
+          ENDDO
+          !$acc end kernels
+
+          DO  k = 1, nz-1
+             !$acc kernels present( tri, tric )
+             !$acc loop
+             DO  j = nys_z, nyn_z
+                !$acc loop vector( 32 )
+                DO  i = nxl_z, nxr_z
+                   tri(i,j,k,2) = ddzuw(k,1) / tri(i,j,k-1,1)
+                   tri(i,j,k,1) = tric(i,j,k) - ddzuw(k-1,2) * tri(i,j,k,2)
+                ENDDO
+             ENDDO
+             !$acc end kernels
+          ENDDO
+
+    END SUBROUTINE split
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Solves the linear system of equations for a 1d-decomposition along x (see
+!> tridia)
+!>
+!> @attention when using the intel compilers older than 12.0, array tri must
+!>            be passed as an argument to the contained subroutines. Otherwise
+!>            addres faults will occur. This feature can be activated with
+!>            cpp-switch __intel11
+!>            On NEC, tri should not be passed (except for routine substi_1dd)
+!>            because this causes very bad performance.
+!------------------------------------------------------------------------------!
+ 
+    SUBROUTINE tridia_1dd( ddx2, ddy2, nx, ny, j, ar, tri_for_1d )
+
+
+       USE arrays_3d,                                                          &
+           ONLY:  ddzu_pres, ddzw
+
+       USE control_parameters,                                                 &
+           ONLY:  ibc_p_b, ibc_p_t
+
+       USE kinds
+
+       IMPLICIT NONE
+
+       INTEGER(iwp) ::  i                  !< 
+       INTEGER(iwp) ::  j                  !< 
+       INTEGER(iwp) ::  k                  !< 
+       INTEGER(iwp) ::  nnyh               !< 
+       INTEGER(iwp) ::  nx                 !< 
+       INTEGER(iwp) ::  ny                 !< 
+       INTEGER(iwp) ::  omp_get_thread_num !< 
+       INTEGER(iwp) ::  tn                 !< 
+
+       REAL(wp)     ::  ddx2 !< 
+       REAL(wp)     ::  ddy2 !< 
+
+       REAL(wp), DIMENSION(0:nx,1:nz)     ::  ar         !< 
+       REAL(wp), DIMENSION(5,0:nx,0:nz-1) ::  tri_for_1d !< 
+
+
+       nnyh = ( ny + 1 ) / 2
+
+!
+!--    Define constant elements of the tridiagonal matrix.
+!--    The compiler on SX6 does loop exchange. If 0:nx is a high power of 2,
+!--    the exchanged loops create bank conflicts. The following directive
+!--    prohibits loop exchange and the loops perform much better.
+!CDIR NOLOOPCHG
+       DO  k = 0, nz-1
+          DO  i = 0,nx
+             tri_for_1d(2,i,k) = ddzu_pres(k+1) * ddzw(k+1)
+             tri_for_1d(3,i,k) = ddzu_pres(k+2) * ddzw(k+1)
+          ENDDO
+       ENDDO
+
+       IF ( j <= nnyh )  THEN
+          CALL maketri_1dd( j )
+       ELSE
+          CALL maketri_1dd( ny+1-j )
+       ENDIF
+
+       CALL split_1dd
+       CALL substi_1dd( ar, tri_for_1d )
+
+    CONTAINS
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> computes the i- and j-dependent component of the matrix
+!------------------------------------------------------------------------------!
+       SUBROUTINE maketri_1dd( j )
+
+          USE constants,                                                       &
+              ONLY:  pi
+
+          USE kinds
+
+          IMPLICIT NONE
+
+          INTEGER(iwp) ::  i    !< 
+          INTEGER(iwp) ::  j    !< 
+          INTEGER(iwp) ::  k    !< 
+          INTEGER(iwp) ::  nnxh !< 
+
+          REAL(wp)     ::  a !< 
+          REAL(wp)     ::  c !< 
+
+          REAL(wp), DIMENSION(0:nx) ::  l !< 
+
+
+          nnxh = ( nx + 1 ) / 2
+!
+!--       Provide the tridiagonal matrix for solution of the Poisson equation in
+!--       Fourier space. The coefficients are computed following the method of
+!--       Schmidt et al. (DFVLR-Mitteilung 84-15), which departs from Stephan
+!--       Siano's original version by discretizing the Poisson equation,
+!--       before it is Fourier-transformed
+          DO  i = 0, nx
+             IF ( i >= 0 .AND. i <= nnxh ) THEN
+                l(i) = 2.0_wp * ( 1.0_wp - COS( ( 2.0_wp * pi * i ) / &
+                                   REAL( nx+1, KIND=wp ) ) ) * ddx2 + &
+                       2.0_wp * ( 1.0_wp - COS( ( 2.0_wp * pi * j ) / &
+                                   REAL( ny+1, KIND=wp ) ) ) * ddy2
+             ELSE
+                l(i) = 2.0_wp * ( 1.0_wp - COS( ( 2.0_wp * pi * ( nx+1-i ) ) / &
+                                   REAL( nx+1, KIND=wp ) ) ) * ddx2 + &
+                       2.0_wp * ( 1.0_wp - COS( ( 2.0_wp * pi * j ) / &
+                                   REAL( ny+1, KIND=wp ) ) ) * ddy2
+             ENDIF
+          ENDDO
+
+          DO  k = 0, nz-1
+             DO  i = 0, nx
+                a = -1.0_wp * ddzu_pres(k+2) * ddzw(k+1)
+                c = -1.0_wp * ddzu_pres(k+1) * ddzw(k+1)
+                tri_for_1d(1,i,k) = a + c - l(i)
+             ENDDO
+          ENDDO
+          IF ( ibc_p_b == 1 )  THEN
+             DO  i = 0, nx
+                tri_for_1d(1,i,0) = tri_for_1d(1,i,0) + tri_for_1d(2,i,0)
+             ENDDO
+          ENDIF
+          IF ( ibc_p_t == 1 )  THEN
+             DO  i = 0, nx
+                tri_for_1d(1,i,nz-1) = tri_for_1d(1,i,nz-1) + tri_for_1d(3,i,nz-1)
+             ENDDO
+          ENDIF
+
+       END SUBROUTINE maketri_1dd
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Splitting of the tridiagonal matrix (Thomas algorithm)
+!------------------------------------------------------------------------------!
+       SUBROUTINE split_1dd
+
+          IMPLICIT NONE
+
+          INTEGER(iwp) ::  i !< 
+          INTEGER(iwp) ::  k !< 
+
+
+!
+!--       Splitting
+          DO  i = 0, nx
+             tri_for_1d(4,i,0) = tri_for_1d(1,i,0)
+          ENDDO
+          DO  k = 1, nz-1
+             DO  i = 0, nx
+                tri_for_1d(5,i,k) = tri_for_1d(2,i,k) / tri_for_1d(4,i,k-1)
+                tri_for_1d(4,i,k) = tri_for_1d(1,i,k) - tri_for_1d(3,i,k-1) * tri_for_1d(5,i,k)
+             ENDDO
+          ENDDO
+
+       END SUBROUTINE split_1dd
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Substitution (Forward and Backward) (Thomas algorithm)
+!------------------------------------------------------------------------------!
+       SUBROUTINE substi_1dd( ar, tri_for_1d )
+
+
+          IMPLICIT NONE
+
+          INTEGER(iwp) ::  i !< 
+          INTEGER(iwp) ::  k !< 
+
+          REAL(wp), DIMENSION(0:nx,nz)       ::  ar         !< 
+          REAL(wp), DIMENSION(0:nx,0:nz-1)   ::  ar1        !< 
+          REAL(wp), DIMENSION(5,0:nx,0:nz-1) ::  tri_for_1d !< 
+
+!
+!--       Forward substitution
+          DO  i = 0, nx
+             ar1(i,0) = ar(i,1)
+          ENDDO
+          DO  k = 1, nz-1
+             DO  i = 0, nx
+                ar1(i,k) = ar(i,k+1) - tri_for_1d(5,i,k) * ar1(i,k-1)
+             ENDDO
+          ENDDO
+
+!
+!--       Backward substitution
+!--       Note, the add of 1.0E-20 in the denominator is due to avoid divisions
+!--       by zero appearing if the pressure bc is set to neumann at the top of
+!--       the model domain.
+          DO  i = 0, nx
+             ar(i,nz) = ar1(i,nz-1) / ( tri_for_1d(4,i,nz-1) + 1.0E-20_wp )
+          ENDDO
+          DO  k = nz-2, 0, -1
+             DO  i = 0, nx
+                ar(i,k+1) = ( ar1(i,k) - tri_for_1d(3,i,k) * ar(i,k+2) ) &
+                            / tri_for_1d(4,i,k)
+             ENDDO
+          ENDDO
+
+!
+!--       Indices i=0, j=0 correspond to horizontally averaged pressure.
+!--       The respective values of ar should be zero at all k-levels if
+!--       acceleration of horizontally averaged vertical velocity is zero.
+          IF ( ibc_p_b == 1  .AND.  ibc_p_t == 1 )  THEN
+             IF ( j == 0 )  THEN
+                DO  k = 1, nz
+                   ar(0,k) = 0.0_wp
+                ENDDO
+             ENDIF
+          ENDIF
+
+       END SUBROUTINE substi_1dd
+
+    END SUBROUTINE tridia_1dd
+
+
+ END MODULE tridia_solver
Index: lm/trunk/SOURCE/user_actions.f90
===================================================================
--- /palm/trunk/SOURCE/user_actions.f90	(revision 1849)
+++ 	(revision )
@@ -1,239 +1,0 @@
-!> @file user_actions.f90
-!--------------------------------------------------------------------------------!
-! This file is part of PALM.
-!
-! PALM is free software: you can redistribute it and/or modify it under the terms
-! of the GNU General Public License as published by the Free Software Foundation,
-! either version 3 of the License, or (at your option) any later version.
-!
-! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
-! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
-! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along with
-! PALM. If not, see <http://www.gnu.org/licenses/>.
-!
-! Copyright 1997-2016 Leibniz Universitaet Hannover
-!--------------------------------------------------------------------------------!
-!
-! Current revisions:
-! ------------------
-!
-! 
-! Former revisions:
-! -----------------
-! $Id$
-!
-! 1822 2016-04-07 07:49:42Z hoffmann
-! qr/nr-tendency removed.
-!
-! 1682 2015-10-07 23:56:08Z knoop
-! Code annotations made doxygen readable 
-! 
-! 1353 2014-04-08 15:21:23Z heinze
-! REAL constants provided with KIND-attribute
-! 
-! 1320 2014-03-20 08:40:49Z raasch
-! kind-parameters added to all INTEGER and REAL declaration statements,
-! kinds are defined in new module kinds,
-! revision history before 2012 removed,
-! comment fields (!:) to be used for variable explanations added to
-! all variable declaration statements 
-!
-! 1318 2014-03-17 13:35:16Z raasch
-! module interfaces removed
-!
-! 1053 2012-11-13 17:11:03Z hoffmann
-! +qr-tendency, nr-tendency
-!
-! 1036 2012-10-22 13:43:42Z raasch
-! code put under GPL (PALM 3.9)
-!
-! 211 2008-11-11 04:46:24Z raasch
-! Former file user_interface.f90 split into one file per subroutine
-!
-! Description:
-! ------------
-!> Execution of user-defined actions before or after single timesteps
-!------------------------------------------------------------------------------!
- MODULE user_actions_mod
- 
-
-    PRIVATE
-    PUBLIC user_actions
-
-    INTERFACE user_actions
-       MODULE PROCEDURE user_actions
-       MODULE PROCEDURE user_actions_ij
-    END INTERFACE user_actions
-
- CONTAINS
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Call for all grid points
-!------------------------------------------------------------------------------!
-    SUBROUTINE user_actions( location )
-
-       USE control_parameters
-
-       USE cpulog
-
-       USE indices
-
-       USE kinds
-
-       USE pegrid
-
-       USE user
-
-       USE arrays_3d
-
-       IMPLICIT NONE
-
-       CHARACTER (LEN=*) ::  location !< 
-
-       INTEGER(iwp) ::  i !< 
-       INTEGER(iwp) ::  j !< 
-       INTEGER(iwp) ::  k !< 
-
-       CALL cpu_log( log_point(24), 'user_actions', 'start' )
-
-!
-!--    Here the user-defined actions follow
-!--    No calls for single grid points are allowed at locations before and
-!--    after the timestep, since these calls are not within an i,j-loop
-       SELECT CASE ( location )
-
-          CASE ( 'before_timestep' )
-!
-!--          Enter actions to be done before every timestep here
-
-
-          CASE ( 'after_integration' )
-!
-!--          Enter actions to be done after every time integration (before
-!--          data output)
-!--          Sample for user-defined output:
-!             DO  i = nxlg, nxrg
-!                DO  j = nysg, nyng
-!                   DO  k = nzb, nzt
-!                      u2(k,j,i) = u(k,j,i)**2
-!                   ENDDO
-!                ENDDO
-!             ENDDO
-!             DO  i = nxlg, nxr
-!                DO  j = nysg, nyn
-!                   DO  k = nzb, nzt+1
-!                      ustvst(k,j,i) =  &
-!                         ( 0.5_wp * ( u(k,j,i) + u(k,j,i+1) ) - hom(k,1,1,0) ) * &
-!                         ( 0.5_wp * ( v(k,j,i) + v(k,j+1,i) ) - hom(k,1,2,0) )
-!                   ENDDO
-!                ENDDO
-!             ENDDO
-
-
-          CASE ( 'after_timestep' )
-!
-!--          Enter actions to be done after every timestep here
-
-
-          CASE ( 'u-tendency' )
-!
-!--          Enter actions to be done in the u-tendency term here
-
-
-          CASE ( 'v-tendency' )
-
-
-          CASE ( 'w-tendency' )
-
-
-          CASE ( 'pt-tendency' )
-
-
-          CASE ( 'sa-tendency' )
-
-
-          CASE ( 'e-tendency' )
-
-
-          CASE ( 'q-tendency' )
-
-
-          CASE DEFAULT
-             message_string = 'unknown location "' // location // '"'
-             CALL message( 'user_actions', 'UI0001', 1, 2, 0, 6, 0 )
-
-       END SELECT
-
-       CALL cpu_log( log_point(24), 'user_actions', 'stop' )
-
-    END SUBROUTINE user_actions
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Call for grid point i,j
-!------------------------------------------------------------------------------!
-    SUBROUTINE user_actions_ij( i, j, location )
-
-       USE control_parameters
-       USE kinds
-       USE pegrid
-       USE user
-
-       IMPLICIT NONE
-
-       CHARACTER (LEN=*) ::  location
-
-       INTEGER(iwp) ::  i
-       INTEGER(iwp) ::  idum
-       INTEGER(iwp) ::  j
-
-!
-!--    Here the user-defined actions follow
-       SELECT CASE ( location )
-
-          CASE ( 'u-tendency' )
-!
-!--          Enter actions to be done in the u-tendency term here
-
-
-          CASE ( 'v-tendency' )
-
-
-          CASE ( 'w-tendency' )
-
-
-          CASE ( 'pt-tendency' )
-
-
-          CASE ( 'sa-tendency' )
-
-
-          CASE ( 'e-tendency' )
-
-
-          CASE ( 'q-tendency' )
-
-
-          CASE ( 'before_timestep', 'after_integration', 'after_timestep' )
-             message_string = 'location "' // location // '" is not ' // &
-                             'allowed to be called with parameters "i" and "j"'
-             CALL message( 'user_actions', 'UI0002', 1, 2, 0, 6, 0 )
-
-
-          CASE DEFAULT
-             message_string = 'unknown location "' // location // '"'
-             CALL message( 'user_actions', 'UI0001', 1, 2, 0, 6, 0 )
-             
-
-       END SELECT
-
-    END SUBROUTINE user_actions_ij
-
- END MODULE user_actions_mod
Index: /palm/trunk/SOURCE/user_actions_mod.f90
===================================================================
--- /palm/trunk/SOURCE/user_actions_mod.f90	(revision 1850)
+++ /palm/trunk/SOURCE/user_actions_mod.f90	(revision 1850)
@@ -0,0 +1,240 @@
+!> @file user_actions_mod.f90
+!--------------------------------------------------------------------------------!
+! This file is part of PALM.
+!
+! PALM is free software: you can redistribute it and/or modify it under the terms
+! of the GNU General Public License as published by the Free Software Foundation,
+! either version 3 of the License, or (at your option) any later version.
+!
+! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
+! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
+! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along with
+! PALM. If not, see <http://www.gnu.org/licenses/>.
+!
+! Copyright 1997-2016 Leibniz Universitaet Hannover
+!--------------------------------------------------------------------------------!
+!
+! Current revisions:
+! ------------------
+! Module renamed
+!
+! 
+! Former revisions:
+! -----------------
+! $Id$
+!
+! 1822 2016-04-07 07:49:42Z hoffmann
+! qr/nr-tendency removed.
+!
+! 1682 2015-10-07 23:56:08Z knoop
+! Code annotations made doxygen readable 
+! 
+! 1353 2014-04-08 15:21:23Z heinze
+! REAL constants provided with KIND-attribute
+! 
+! 1320 2014-03-20 08:40:49Z raasch
+! kind-parameters added to all INTEGER and REAL declaration statements,
+! kinds are defined in new module kinds,
+! revision history before 2012 removed,
+! comment fields (!:) to be used for variable explanations added to
+! all variable declaration statements 
+!
+! 1318 2014-03-17 13:35:16Z raasch
+! module interfaces removed
+!
+! 1053 2012-11-13 17:11:03Z hoffmann
+! +qr-tendency, nr-tendency
+!
+! 1036 2012-10-22 13:43:42Z raasch
+! code put under GPL (PALM 3.9)
+!
+! 211 2008-11-11 04:46:24Z raasch
+! Former file user_interface.f90 split into one file per subroutine
+!
+! Description:
+! ------------
+!> Execution of user-defined actions before or after single timesteps
+!------------------------------------------------------------------------------!
+ MODULE user_actions_mod
+ 
+
+    PRIVATE
+    PUBLIC user_actions
+
+    INTERFACE user_actions
+       MODULE PROCEDURE user_actions
+       MODULE PROCEDURE user_actions_ij
+    END INTERFACE user_actions
+
+ CONTAINS
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Call for all grid points
+!------------------------------------------------------------------------------!
+    SUBROUTINE user_actions( location )
+
+       USE control_parameters
+
+       USE cpulog
+
+       USE indices
+
+       USE kinds
+
+       USE pegrid
+
+       USE user
+
+       USE arrays_3d
+
+       IMPLICIT NONE
+
+       CHARACTER (LEN=*) ::  location !< 
+
+       INTEGER(iwp) ::  i !< 
+       INTEGER(iwp) ::  j !< 
+       INTEGER(iwp) ::  k !< 
+
+       CALL cpu_log( log_point(24), 'user_actions', 'start' )
+
+!
+!--    Here the user-defined actions follow
+!--    No calls for single grid points are allowed at locations before and
+!--    after the timestep, since these calls are not within an i,j-loop
+       SELECT CASE ( location )
+
+          CASE ( 'before_timestep' )
+!
+!--          Enter actions to be done before every timestep here
+
+
+          CASE ( 'after_integration' )
+!
+!--          Enter actions to be done after every time integration (before
+!--          data output)
+!--          Sample for user-defined output:
+!             DO  i = nxlg, nxrg
+!                DO  j = nysg, nyng
+!                   DO  k = nzb, nzt
+!                      u2(k,j,i) = u(k,j,i)**2
+!                   ENDDO
+!                ENDDO
+!             ENDDO
+!             DO  i = nxlg, nxr
+!                DO  j = nysg, nyn
+!                   DO  k = nzb, nzt+1
+!                      ustvst(k,j,i) =  &
+!                         ( 0.5_wp * ( u(k,j,i) + u(k,j,i+1) ) - hom(k,1,1,0) ) * &
+!                         ( 0.5_wp * ( v(k,j,i) + v(k,j+1,i) ) - hom(k,1,2,0) )
+!                   ENDDO
+!                ENDDO
+!             ENDDO
+
+
+          CASE ( 'after_timestep' )
+!
+!--          Enter actions to be done after every timestep here
+
+
+          CASE ( 'u-tendency' )
+!
+!--          Enter actions to be done in the u-tendency term here
+
+
+          CASE ( 'v-tendency' )
+
+
+          CASE ( 'w-tendency' )
+
+
+          CASE ( 'pt-tendency' )
+
+
+          CASE ( 'sa-tendency' )
+
+
+          CASE ( 'e-tendency' )
+
+
+          CASE ( 'q-tendency' )
+
+
+          CASE DEFAULT
+             message_string = 'unknown location "' // location // '"'
+             CALL message( 'user_actions', 'UI0001', 1, 2, 0, 6, 0 )
+
+       END SELECT
+
+       CALL cpu_log( log_point(24), 'user_actions', 'stop' )
+
+    END SUBROUTINE user_actions
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Call for grid point i,j
+!------------------------------------------------------------------------------!
+    SUBROUTINE user_actions_ij( i, j, location )
+
+       USE control_parameters
+       USE kinds
+       USE pegrid
+       USE user
+
+       IMPLICIT NONE
+
+       CHARACTER (LEN=*) ::  location
+
+       INTEGER(iwp) ::  i
+       INTEGER(iwp) ::  idum
+       INTEGER(iwp) ::  j
+
+!
+!--    Here the user-defined actions follow
+       SELECT CASE ( location )
+
+          CASE ( 'u-tendency' )
+!
+!--          Enter actions to be done in the u-tendency term here
+
+
+          CASE ( 'v-tendency' )
+
+
+          CASE ( 'w-tendency' )
+
+
+          CASE ( 'pt-tendency' )
+
+
+          CASE ( 'sa-tendency' )
+
+
+          CASE ( 'e-tendency' )
+
+
+          CASE ( 'q-tendency' )
+
+
+          CASE ( 'before_timestep', 'after_integration', 'after_timestep' )
+             message_string = 'location "' // location // '" is not ' // &
+                             'allowed to be called with parameters "i" and "j"'
+             CALL message( 'user_actions', 'UI0002', 1, 2, 0, 6, 0 )
+
+
+          CASE DEFAULT
+             message_string = 'unknown location "' // location // '"'
+             CALL message( 'user_actions', 'UI0001', 1, 2, 0, 6, 0 )
+             
+
+       END SELECT
+
+    END SUBROUTINE user_actions_ij
+
+ END MODULE user_actions_mod
Index: lm/trunk/SOURCE/user_module.f90
===================================================================
--- /palm/trunk/SOURCE/user_module.f90	(revision 1849)
+++ 	(revision )
@@ -1,72 +1,0 @@
-!> @file user_module.f90
-!--------------------------------------------------------------------------------!
-! This file is part of PALM.
-!
-! PALM is free software: you can redistribute it and/or modify it under the terms
-! of the GNU General Public License as published by the Free Software Foundation,
-! either version 3 of the License, or (at your option) any later version.
-!
-! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
-! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
-! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along with
-! PALM. If not, see <http://www.gnu.org/licenses/>.
-!
-! Copyright 1997-2016 Leibniz Universitaet Hannover
-!--------------------------------------------------------------------------------!
-!
-! Current revisions:
-! -----------------
-! 
-! 
-! Former revisions:
-! -----------------
-! $Id$
-!
-! 1682 2015-10-07 23:56:08Z knoop
-! Code annotations made doxygen readable 
-!
-! 1320 2014-03-20 08:40:49Z raasch
-! kind-parameters added to all INTEGER and REAL declaration statements, 
-! kinds are defined in new module kinds, 
-! old module precision_kind is removed,
-! revision history before 2012 removed,
-! comment fields (!:) to be used for variable explanations added to
-! all variable declaration statements 
-!
-! 1036 2012-10-22 13:43:42Z raasch
-! code put under GPL (PALM 3.9)
-!
-! Revision 1.1  1998/03/24 15:29:04  raasch
-! Initial revision
-!
-!
-! Description:
-! ------------
-!> Declaration of user-defined variables. This module may only be used
-!> in the user-defined routines (contained in user_interface.f90).
-!------------------------------------------------------------------------------!
- MODULE user
- 
-
-    USE kinds
-
-    IMPLICIT NONE
-
-    INTEGER(iwp) ::  dots_num_palm   !< 
-    INTEGER(iwp) ::  user_idummy     !< 
-    
-    LOGICAL ::  user_defined_namelist_found = .FALSE.   !< 
-    
-    REAL(wp) ::  user_rdummy   !< 
-
-!
-!-- Sample for user-defined output
-!    REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::  u2       !< user defined array
-!    REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::  u2_av    !< user defined array
-!    REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::  ustvst   !< user defined array
-
-    SAVE
-
- END MODULE user
Index: /palm/trunk/SOURCE/user_module_mod.f90
===================================================================
--- /palm/trunk/SOURCE/user_module_mod.f90	(revision 1850)
+++ /palm/trunk/SOURCE/user_module_mod.f90	(revision 1850)
@@ -0,0 +1,73 @@
+!> @file user_module_mod.f90
+!--------------------------------------------------------------------------------!
+! This file is part of PALM.
+!
+! PALM is free software: you can redistribute it and/or modify it under the terms
+! of the GNU General Public License as published by the Free Software Foundation,
+! either version 3 of the License, or (at your option) any later version.
+!
+! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
+! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
+! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along with
+! PALM. If not, see <http://www.gnu.org/licenses/>.
+!
+! Copyright 1997-2016 Leibniz Universitaet Hannover
+!--------------------------------------------------------------------------------!
+!
+! Current revisions:
+! -----------------
+! Module renamed
+! 
+! 
+! Former revisions:
+! -----------------
+! $Id$
+!
+! 1682 2015-10-07 23:56:08Z knoop
+! Code annotations made doxygen readable 
+!
+! 1320 2014-03-20 08:40:49Z raasch
+! kind-parameters added to all INTEGER and REAL declaration statements, 
+! kinds are defined in new module kinds, 
+! old module precision_kind is removed,
+! revision history before 2012 removed,
+! comment fields (!:) to be used for variable explanations added to
+! all variable declaration statements 
+!
+! 1036 2012-10-22 13:43:42Z raasch
+! code put under GPL (PALM 3.9)
+!
+! Revision 1.1  1998/03/24 15:29:04  raasch
+! Initial revision
+!
+!
+! Description:
+! ------------
+!> Declaration of user-defined variables. This module may only be used
+!> in the user-defined routines (contained in user_interface.f90).
+!------------------------------------------------------------------------------!
+ MODULE user
+ 
+
+    USE kinds
+
+    IMPLICIT NONE
+
+    INTEGER(iwp) ::  dots_num_palm   !< 
+    INTEGER(iwp) ::  user_idummy     !< 
+    
+    LOGICAL ::  user_defined_namelist_found = .FALSE.   !< 
+    
+    REAL(wp) ::  user_rdummy   !< 
+
+!
+!-- Sample for user-defined output
+!    REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::  u2       !< user defined array
+!    REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::  u2_av    !< user defined array
+!    REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::  ustvst   !< user defined array
+
+    SAVE
+
+ END MODULE user
Index: lm/trunk/SOURCE/wall_fluxes.f90
===================================================================
--- /palm/trunk/SOURCE/wall_fluxes.f90	(revision 1849)
+++ 	(revision )
@@ -1,1104 +1,0 @@
-!> @file wall_fluxes.f90
-!--------------------------------------------------------------------------------!
-! This file is part of PALM.
-!
-! PALM is free software: you can redistribute it and/or modify it under the terms
-! of the GNU General Public License as published by the Free Software Foundation,
-! either version 3 of the License, or (at your option) any later version.
-!
-! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
-! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
-! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along with
-! PALM. If not, see <http://www.gnu.org/licenses/>.
-!
-! Copyright 1997-2016 Leibniz Universitaet Hannover
-!--------------------------------------------------------------------------------!
-!
-! Current revisions:
-! -----------------
-! 
-! 
-! Former revisions:
-! -----------------
-! $Id$
-!
-! 1691 2015-10-26 16:17:44Z maronga
-! Renamed rif_min and rif_max with zeta_min and zeta_max, respectively.
-! 
-! 1682 2015-10-07 23:56:08Z knoop
-! Code annotations made doxygen readable 
-! 
-! 1374 2014-04-25 12:55:07Z raasch
-! pt removed from acc-present-list
-! 
-! 1353 2014-04-08 15:21:23Z heinze
-! REAL constants provided with KIND-attribute
-!
-! 1320 2014-03-20 08:40:49Z raasch
-! ONLY-attribute added to USE-statements,
-! kind-parameters added to all INTEGER and REAL declaration statements, 
-! kinds are defined in new module kinds, 
-! old module precision_kind is removed,
-! revision history before 2012 removed,
-! comment fields (!:) to be used for variable explanations added to
-! all variable declaration statements 
-!
-! 1257 2013-11-08 15:18:40Z raasch
-! openacc loop and loop vector clauses removed
-!
-! 1153 2013-05-10 14:33:08Z raasch
-! code adjustments of accelerator version required by PGI 12.3 / CUDA 5.0
-!
-! 1128 2013-04-12 06:19:32Z raasch
-! loop index bounds in accelerator version replaced by i_left, i_right, j_south,
-! j_north
-!
-! 1036 2012-10-22 13:43:42Z raasch
-! code put under GPL (PALM 3.9)
-!
-! 1015 2012-09-27 09:23:24Z raasch
-! accelerator version (*_acc) added
-!
-! Initial version (2007/03/07)
-!
-! Description:
-! ------------
-!> Calculates momentum fluxes at vertical walls assuming Monin-Obukhov
-!> similarity.
-!> Indices: usvs a=1, vsus b=1, wsvs c1=1, wsus c2=1 (other=0).
-!> The all-gridpoint version of wall_fluxes_e is not used so far, because
-!> it gives slightly different results from the ij-version for some unknown
-!> reason.
-!>
-!> @todo Rename rif to zeta throughout the routine
-!------------------------------------------------------------------------------!
- MODULE wall_fluxes_mod
- 
-    PRIVATE
-    PUBLIC wall_fluxes, wall_fluxes_acc, wall_fluxes_e, wall_fluxes_e_acc
-    
-    INTERFACE wall_fluxes
-       MODULE PROCEDURE wall_fluxes
-       MODULE PROCEDURE wall_fluxes_ij
-    END INTERFACE wall_fluxes
-    
-    INTERFACE wall_fluxes_acc
-       MODULE PROCEDURE wall_fluxes_acc
-    END INTERFACE wall_fluxes_acc
-
-    INTERFACE wall_fluxes_e
-       MODULE PROCEDURE wall_fluxes_e
-       MODULE PROCEDURE wall_fluxes_e_ij
-    END INTERFACE wall_fluxes_e
- 
-    INTERFACE wall_fluxes_e_acc
-       MODULE PROCEDURE wall_fluxes_e_acc
-    END INTERFACE wall_fluxes_e_acc
-
- CONTAINS
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Call for all grid points
-!------------------------------------------------------------------------------!
-    SUBROUTINE wall_fluxes( wall_flux, a, b, c1, c2, nzb_uvw_inner,            &
-                            nzb_uvw_outer, wall )
-
-       USE arrays_3d,                                                          &
-           ONLY:  rif_wall, u, v, w, z0, pt
-       
-       USE control_parameters,                                                 &
-           ONLY:  g, kappa, zeta_max, zeta_min
-       
-       USE grid_variables,                                                     &
-           ONLY:  dx, dy
-       
-       USE indices,                                                            &
-           ONLY:  nxl, nxlg, nxr, nxrg, nyn, nyng, nys, nysg, nzb, nzt
-       
-       USE kinds
-       
-       USE statistics,                                                         &
-           ONLY:  hom
-
-       IMPLICIT NONE
-
-       INTEGER(iwp) ::  i            !< 
-       INTEGER(iwp) ::  j            !< 
-       INTEGER(iwp) ::  k            !< 
-       INTEGER(iwp) ::  wall_index   !< 
-
-       INTEGER(iwp),                                                           &
-          DIMENSION(nysg:nyng,nxlg:nxrg) ::                                    &
-             nzb_uvw_inner   !< 
-       INTEGER(iwp),                                                           &
-          DIMENSION(nysg:nyng,nxlg:nxrg) ::                                    &
-             nzb_uvw_outer   !< 
-       
-       REAL(wp) ::  a           !< 
-       REAL(wp) ::  b           !< 
-       REAL(wp) ::  c1          !< 
-       REAL(wp) ::  c2          !< 
-       REAL(wp) ::  h1          !< 
-       REAL(wp) ::  h2          !< 
-       REAL(wp) ::  zp          !< 
-       REAL(wp) ::  pts         !< 
-       REAL(wp) ::  pt_i        !< 
-       REAL(wp) ::  rifs        !< 
-       REAL(wp) ::  u_i         !< 
-       REAL(wp) ::  v_i         !< 
-       REAL(wp) ::  us_wall     !< 
-       REAL(wp) ::  vel_total   !< 
-       REAL(wp) ::  ws          !< 
-       REAL(wp) ::  wspts       !< 
-
-       REAL(wp),                                                               &
-          DIMENSION(nysg:nyng,nxlg:nxrg) ::                                    &
-             wall   !< 
-       
-       REAL(wp),                                                               &
-          DIMENSION(nzb:nzt+1,nys:nyn,nxl:nxr) ::                              &
-             wall_flux   !< 
-
-
-       zp         = 0.5_wp * ( (a+c1) * dy + (b+c2) * dx )
-       wall_flux  = 0.0_wp
-       wall_index = NINT( a+ 2*b + 3*c1 + 4*c2 )
-
-       DO  i = nxl, nxr
-          DO  j = nys, nyn
-
-             IF ( wall(j,i) /= 0.0_wp )  THEN
-!
-!--             All subsequent variables are computed for the respective
-!--             location where the respective flux is defined.
-                DO  k = nzb_uvw_inner(j,i)+1, nzb_uvw_outer(j,i)
-
-!
-!--                (1) Compute rifs, u_i, v_i, ws, pt' and w'pt'
-                   rifs  = rif_wall(k,j,i,wall_index)
-
-                   u_i   = a * u(k,j,i) + c1 * 0.25_wp *                       &
-                           ( u(k+1,j,i+1) + u(k+1,j,i) + u(k,j,i+1) + u(k,j,i) )
-
-                   v_i   = b * v(k,j,i) + c2 * 0.25_wp *                       &
-                           ( v(k+1,j+1,i) + v(k+1,j,i) + v(k,j+1,i) + v(k,j,i) )
-
-                   ws    = ( c1 + c2 ) * w(k,j,i) + 0.25_wp * (                &
-                     a * ( w(k-1,j,i-1) + w(k-1,j,i) + w(k,j,i-1) + w(k,j,i) ) &
-                   + b * ( w(k-1,j-1,i) + w(k-1,j,i) + w(k,j-1,i) + w(k,j,i) ) &
-                                                              )
-                   pt_i  = 0.5_wp * ( pt(k,j,i) + a *  pt(k,j,i-1) +           &
-                                   b * pt(k,j-1,i) + ( c1 + c2 ) * pt(k+1,j,i) )
-
-                   pts   = pt_i - hom(k,1,4,0)
-                   wspts = ws * pts
-
-!
-!--                (2) Compute wall-parallel absolute velocity vel_total
-                   vel_total = SQRT( ws**2 + (a+c1) * u_i**2 + (b+c2) * v_i**2 )
-
-!
-!--                (3) Compute wall friction velocity us_wall
-                   IF ( rifs >= 0.0_wp )  THEN
-
-!
-!--                   Stable stratification (and neutral)
-                      us_wall = kappa * vel_total / ( LOG( zp / z0(j,i) ) +    &
-                                         5.0_wp * rifs * ( zp - z0(j,i) ) / zp &
-                                                    )
-                   ELSE
-
-!
-!--                   Unstable stratification
-                      h1 = SQRT( SQRT( 1.0_wp - 16.0_wp * rifs ) )
-                      h2 = SQRT( SQRT( 1.0_wp - 16.0_wp * rifs * z0(j,i) / zp ) )
-
-                      us_wall = kappa * vel_total / (                          &
-                           LOG( zp / z0(j,i) ) -                               &
-                           LOG( ( 1.0_wp + h1 )**2 * ( 1.0_wp + h1**2 ) / (    &
-                                ( 1.0_wp + h2 )**2 * ( 1.0_wp + h2**2 )   ) ) +&
-                                2.0_wp * ( ATAN( h1 ) - ATAN( h2 ) )           &
-                                                    )
-                   ENDIF
-
-!
-!--                (4) Compute zp/L (corresponds to neutral Richardson flux
-!--                    number rifs)
-                   rifs = -1.0_wp * zp * kappa * g * wspts /                   &
-                          ( pt_i * ( us_wall**3 + 1E-30 ) )
-
-!
-!--                Limit the value range of the Richardson numbers.
-!--                This is necessary for very small velocities (u,w --> 0),
-!--                because the absolute value of rif can then become very
-!--                large, which in consequence would result in very large
-!--                shear stresses and very small momentum fluxes (both are
-!--                generally unrealistic).
-                   IF ( rifs < zeta_min )  rifs = zeta_min
-                   IF ( rifs > zeta_max )  rifs = zeta_max
-
-!
-!--                (5) Compute wall_flux (u'v', v'u', w'v', or w'u')
-                   IF ( rifs >= 0.0_wp )  THEN
-
-!
-!--                   Stable stratification (and neutral)
-                      wall_flux(k,j,i) = kappa *                               &
-                              ( a*u(k,j,i) + b*v(k,j,i) + (c1+c2)*w(k,j,i) ) / &
-                              (  LOG( zp / z0(j,i) ) +                         &
-                                 5.0_wp * rifs * ( zp - z0(j,i) ) / zp         &
-                              )
-                   ELSE
-
-!
-!--                   Unstable stratification
-                      h1 = SQRT( SQRT( 1.0_wp - 16.0_wp * rifs ) )
-                      h2 = SQRT( SQRT( 1.0_wp - 16.0_wp * rifs * z0(j,i) / zp ) )
-
-                      wall_flux(k,j,i) = kappa *                               &
-                           ( a*u(k,j,i) + b*v(k,j,i) + (c1+c2)*w(k,j,i) ) / (  &
-                           LOG( zp / z0(j,i) ) -                               &
-                           LOG( ( 1.0_wp + h1 )**2 * ( 1.0_wp + h1**2 ) / (    &
-                                ( 1.0_wp + h2 )**2 * ( 1.0_wp + h2**2 )   ) ) +&
-                                2.0_wp * ( ATAN( h1 ) - ATAN( h2 ) )           &
-                                                                            )
-                   ENDIF
-                   wall_flux(k,j,i) = -wall_flux(k,j,i) * us_wall
-
-!
-!--                store rifs for next time step
-                   rif_wall(k,j,i,wall_index) = rifs
-
-                ENDDO
-
-             ENDIF
-
-          ENDDO
-       ENDDO
-
-    END SUBROUTINE wall_fluxes
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Call for all grid points - accelerator version
-!------------------------------------------------------------------------------!
-    SUBROUTINE wall_fluxes_acc( wall_flux, a, b, c1, c2, nzb_uvw_inner,        &
-                                nzb_uvw_outer, wall )
-
-       USE arrays_3d,                                                          &
-           ONLY:  rif_wall, pt, u, v, w, z0
-       
-       USE control_parameters,                                                 &
-           ONLY:  g, kappa, zeta_max, zeta_min
-       
-       USE grid_variables,                                                     &
-           ONLY:  dx, dy
-       
-       USE indices,                                                            &
-           ONLY:  i_left, i_right, j_north, j_south, nxl, nxlg, nxr, nxrg,     &
-                  nyn, nyng, nys, nysg, nzb, nzt
-       
-       USE kinds
-       
-       USE statistics,                                                         &
-           ONLY:  hom
-
-       IMPLICIT NONE
-
-       INTEGER(iwp) ::  i            !< 
-       INTEGER(iwp) ::  j            !< 
-       INTEGER(iwp) ::  k            !< 
-       INTEGER(iwp) ::  max_outer    !< 
-       INTEGER(iwp) ::  min_inner    !< 
-       INTEGER(iwp) ::  wall_index   !< 
-
-       INTEGER(iwp),                                                           &
-          DIMENSION(nysg:nyng,nxlg:nxrg) ::                                    &
-             nzb_uvw_inner   !< 
-       INTEGER(iwp),                                                           &
-          DIMENSION(nysg:nyng,nxlg:nxrg) ::                                    &
-             nzb_uvw_outer   !< 
-       
-       REAL(wp) ::  a           !< 
-       REAL(wp) ::  b           !< 
-       REAL(wp) ::  c1          !< 
-       REAL(wp) ::  c2          !< 
-       REAL(wp) ::  h1          !< 
-       REAL(wp) ::  h2          !< 
-       REAL(wp) ::  zp          !< 
-       REAL(wp) ::  pts         !< 
-       REAL(wp) ::  pt_i        !< 
-       REAL(wp) ::  rifs        !< 
-       REAL(wp) ::  u_i         !< 
-       REAL(wp) ::  v_i         !< 
-       REAL(wp) ::  us_wall     !< 
-       REAL(wp) ::  vel_total   !< 
-       REAL(wp) ::  ws          !< 
-       REAL(wp) ::  wspts       !< 
-
-       REAL(wp),                                                               &
-          DIMENSION(nysg:nyng,nxlg:nxrg) ::                                    &
-             wall   !< 
-       
-       REAL(wp),                                                               &
-          DIMENSION(nzb:nzt+1,nys:nyn,nxl:nxr) ::                              &
-             wall_flux   !< 
-
-
-       zp         = 0.5_wp * ( (a+c1) * dy + (b+c2) * dx )
-       wall_flux  = 0.0_wp
-       wall_index = NINT( a+ 2*b + 3*c1 + 4*c2 )
-
-       min_inner = MINVAL( nzb_uvw_inner(nys:nyn,nxl:nxr) ) + 1
-       max_outer = MINVAL( nzb_uvw_outer(nys:nyn,nxl:nxr) )
-
-       !$acc kernels present( hom, nzb_uvw_inner, nzb_uvw_outer, pt, rif_wall ) &
-       !$acc         present( u, v, w, wall, wall_flux, z0 )
-       !$acc loop independent
-       DO  i = i_left, i_right
-          DO  j = j_south, j_north
-
-             IF ( wall(j,i) /= 0.0_wp )  THEN
-!
-!--             All subsequent variables are computed for the respective
-!--             location where the respective flux is defined.
-                !$acc loop independent
-                DO  k = nzb_uvw_inner(j,i)+1, nzb_uvw_outer(j,i)
-
-!
-!--                (1) Compute rifs, u_i, v_i, ws, pt' and w'pt'
-                   rifs  = rif_wall(k,j,i,wall_index)
-
-                   u_i   = a * u(k,j,i) + c1 * 0.25_wp *                       &
-                           ( u(k+1,j,i+1) + u(k+1,j,i) + u(k,j,i+1) + u(k,j,i) )
-
-                   v_i   = b * v(k,j,i) + c2 * 0.25_wp *                       &
-                           ( v(k+1,j+1,i) + v(k+1,j,i) + v(k,j+1,i) + v(k,j,i) )
-
-                   ws    = ( c1 + c2 ) * w(k,j,i) + 0.25_wp * (                &
-                     a * ( w(k-1,j,i-1) + w(k-1,j,i) + w(k,j,i-1) + w(k,j,i) ) &
-                   + b * ( w(k-1,j-1,i) + w(k-1,j,i) + w(k,j-1,i) + w(k,j,i) ) &
-                                                              )
-                   pt_i  = 0.5_wp * ( pt(k,j,i) + a *  pt(k,j,i-1) +           &
-                                   b * pt(k,j-1,i) + ( c1 + c2 ) * pt(k+1,j,i) )
-
-                   pts   = pt_i - hom(k,1,4,0)
-                   wspts = ws * pts
-
-!
-!--                (2) Compute wall-parallel absolute velocity vel_total
-                   vel_total = SQRT( ws**2 + (a+c1) * u_i**2 + (b+c2) * v_i**2 )
-
-!
-!--                (3) Compute wall friction velocity us_wall
-                   IF ( rifs >= 0.0_wp )  THEN
-
-!
-!--                   Stable stratification (and neutral)
-                      us_wall = kappa * vel_total / ( LOG( zp / z0(j,i) ) +    &
-                                         5.0_wp * rifs * ( zp - z0(j,i) ) / zp &
-                                                    )
-                   ELSE
-
-!
-!--                   Unstable stratification
-                      h1 = SQRT( SQRT( 1.0_wp - 16.0_wp * rifs ) )
-                      h2 = SQRT( SQRT( 1.0_wp - 16.0_wp * rifs * z0(j,i) / zp ) )
-
-                      us_wall = kappa * vel_total / (                          &
-                           LOG( zp / z0(j,i) ) -                               &
-                           LOG( ( 1.0_wp + h1 )**2 * ( 1.0_wp + h1**2 ) / (    &
-                                ( 1.0_wp + h2 )**2 * ( 1.0_wp + h2**2 )   ) ) +&
-                                2.0_wp * ( ATAN( h1 ) - ATAN( h2 ) )           &
-                                                    )
-                   ENDIF
-
-!
-!--                (4) Compute zp/L (corresponds to neutral Richardson flux
-!--                    number rifs)
-                   rifs = -1.0_wp * zp * kappa * g * wspts /                   &
-                          ( pt_i * ( us_wall**3 + 1E-30 ) )
-
-!
-!--                Limit the value range of the Richardson numbers.
-!--                This is necessary for very small velocities (u,w --> 0),
-!--                because the absolute value of rif can then become very
-!--                large, which in consequence would result in very large
-!--                shear stresses and very small momentum fluxes (both are
-!--                generally unrealistic).
-                   IF ( rifs < zeta_min )  rifs = zeta_min
-                   IF ( rifs > zeta_max )  rifs = zeta_max
-
-!
-!--                (5) Compute wall_flux (u'v', v'u', w'v', or w'u')
-                   IF ( rifs >= 0.0_wp )  THEN
-
-!
-!--                   Stable stratification (and neutral)
-                      wall_flux(k,j,i) = kappa *                               &
-                              ( a*u(k,j,i) + b*v(k,j,i) + (c1+c2)*w(k,j,i) ) / &
-                              (  LOG( zp / z0(j,i) ) +                         &
-                                 5.0_wp * rifs * ( zp - z0(j,i) ) / zp         &
-                              )
-                   ELSE
-
-!
-!--                   Unstable stratification
-                      h1 = SQRT( SQRT( 1.0_wp - 16.0_wp * rifs ) )
-                      h2 = SQRT( SQRT( 1.0_wp - 16.0_wp * rifs * z0(j,i) / zp ) )
-
-                      wall_flux(k,j,i) = kappa *                               &
-                           ( a*u(k,j,i) + b*v(k,j,i) + (c1+c2)*w(k,j,i) ) / (  &
-                           LOG( zp / z0(j,i) ) -                               &
-                           LOG( ( 1.0_wp + h1 )**2 * ( 1.0_wp + h1**2 ) / (    &
-                                ( 1.0_wp + h2 )**2 * ( 1.0_wp + h2**2 )   ) ) +&
-                                2.0_wp * ( ATAN( h1 ) - ATAN( h2 ) )           &
-                                                                            )
-                   ENDIF
-                   wall_flux(k,j,i) = -wall_flux(k,j,i) * us_wall
-
-!
-!--                store rifs for next time step
-                   rif_wall(k,j,i,wall_index) = rifs
-
-                ENDDO
-
-             ENDIF
-
-          ENDDO
-       ENDDO
-       !$acc end kernels
-
-    END SUBROUTINE wall_fluxes_acc
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Call for all grid point i,j
-!------------------------------------------------------------------------------!
-    SUBROUTINE wall_fluxes_ij( i, j, nzb_w, nzt_w, wall_flux, a, b, c1, c2 )
-
-       USE arrays_3d,                                                          &
-           ONLY:  rif_wall, pt, u, v, w, z0
-       
-       USE control_parameters,                                                 &
-           ONLY:  g, kappa, zeta_max, zeta_min
-       
-       USE grid_variables,                                                     &
-           ONLY:  dx, dy
-       
-       USE indices,                                                            &
-           ONLY:  nzb, nzt
-       
-       USE kinds
-       
-       USE statistics,                                                         &
-           ONLY:  hom
-
-       IMPLICIT NONE
-
-       INTEGER(iwp) ::  i            !< 
-       INTEGER(iwp) ::  j            !< 
-       INTEGER(iwp) ::  k            !< 
-       INTEGER(iwp) ::  nzb_w        !< 
-       INTEGER(iwp) ::  nzt_w        !< 
-       INTEGER(iwp) ::  wall_index   !< 
-       
-       REAL(wp) ::  a           !< 
-       REAL(wp) ::  b           !< 
-       REAL(wp) ::  c1          !< 
-       REAL(wp) ::  c2          !< 
-       REAL(wp) ::  h1          !< 
-       REAL(wp) ::  h2          !< 
-       REAL(wp) ::  zp          !< 
-       REAL(wp) ::  pts         !< 
-       REAL(wp) ::  pt_i        !< 
-       REAL(wp) ::  rifs        !< 
-       REAL(wp) ::  u_i         !< 
-       REAL(wp) ::  v_i         !< 
-       REAL(wp) ::  us_wall     !< 
-       REAL(wp) ::  vel_total   !< 
-       REAL(wp) ::  ws          !< 
-       REAL(wp) ::  wspts       !< 
-
-       REAL(wp), DIMENSION(nzb:nzt+1) ::  wall_flux   !< 
-
-
-       zp         = 0.5_wp * ( (a+c1) * dy + (b+c2) * dx )
-       wall_flux  = 0.0_wp
-       wall_index = NINT( a+ 2*b + 3*c1 + 4*c2 )
-
-!
-!--    All subsequent variables are computed for the respective location where 
-!--    the respective flux is defined.
-       DO  k = nzb_w, nzt_w
-
-!
-!--       (1) Compute rifs, u_i, v_i, ws, pt' and w'pt'
-          rifs  = rif_wall(k,j,i,wall_index)
-
-          u_i   = a * u(k,j,i) + c1 * 0.25_wp *                                &
-                  ( u(k+1,j,i+1) + u(k+1,j,i) + u(k,j,i+1) + u(k,j,i) )
-
-          v_i   = b * v(k,j,i) + c2 * 0.25_wp *                                &
-                  ( v(k+1,j+1,i) + v(k+1,j,i) + v(k,j+1,i) + v(k,j,i) )
-
-          ws    = ( c1 + c2 ) * w(k,j,i) + 0.25_wp * (                         &
-                     a * ( w(k-1,j,i-1) + w(k-1,j,i) + w(k,j,i-1) + w(k,j,i) ) &
-                   + b * ( w(k-1,j-1,i) + w(k-1,j,i) + w(k,j-1,i) + w(k,j,i) ) &
-                                                     )
-          pt_i  = 0.5_wp * ( pt(k,j,i) + a *  pt(k,j,i-1) + b * pt(k,j-1,i)    &
-                          + ( c1 + c2 ) * pt(k+1,j,i) )
-
-          pts   = pt_i - hom(k,1,4,0)
-          wspts = ws * pts
-
-!
-!--       (2) Compute wall-parallel absolute velocity vel_total
-          vel_total = SQRT( ws**2 + ( a+c1 ) * u_i**2 + ( b+c2 ) * v_i**2 )
-
-!
-!--       (3) Compute wall friction velocity us_wall
-          IF ( rifs >= 0.0_wp )  THEN
-
-!
-!--          Stable stratification (and neutral)
-             us_wall = kappa * vel_total / ( LOG( zp / z0(j,i) ) +             &
-                                         5.0_wp * rifs * ( zp - z0(j,i) ) / zp &
-                                           )
-          ELSE
-
-!
-!--          Unstable stratification
-             h1 = SQRT( SQRT( 1.0_wp - 16.0_wp * rifs ) )
-             h2 = SQRT( SQRT( 1.0_wp - 16.0_wp * rifs * z0(j,i) / zp ) )
-
-             us_wall = kappa * vel_total / (                                   &
-                  LOG( zp / z0(j,i) ) -                                        &
-                  LOG( ( 1.0_wp + h1 )**2 * ( 1.0_wp + h1**2 ) / (             &
-                       ( 1.0_wp + h2 )**2 * ( 1.0_wp + h2**2 )   ) ) +         &
-                       2.0_wp * ( ATAN( h1 ) - ATAN( h2 ) )                    &
-                                           )
-          ENDIF
-
-!
-!--       (4) Compute zp/L (corresponds to neutral Richardson flux number 
-!--           rifs)
-          rifs = -1.0_wp * zp * kappa * g * wspts /                            &
-                  ( pt_i * (us_wall**3 + 1E-30) )
-
-!
-!--       Limit the value range of the Richardson numbers.
-!--       This is necessary for very small velocities (u,w --> 0), because
-!--       the absolute value of rif can then become very large, which in
-!--       consequence would result in very large shear stresses and very
-!--       small momentum fluxes (both are generally unrealistic).
-          IF ( rifs < zeta_min )  rifs = zeta_min
-          IF ( rifs > zeta_max )  rifs = zeta_max
-
-!
-!--       (5) Compute wall_flux (u'v', v'u', w'v', or w'u')
-          IF ( rifs >= 0.0_wp )  THEN
-
-!
-!--          Stable stratification (and neutral)
-             wall_flux(k) = kappa *                                            &
-                            ( a*u(k,j,i) + b*v(k,j,i) + (c1+c2)*w(k,j,i) ) /   &
-                            (  LOG( zp / z0(j,i) ) +                           &
-                               5.0_wp * rifs * ( zp - z0(j,i) ) / zp           &
-                            )
-          ELSE
-
-!
-!--          Unstable stratification
-             h1 = SQRT( SQRT( 1.0_wp - 16.0_wp * rifs ) )
-             h2 = SQRT( SQRT( 1.0_wp - 16.0_wp * rifs * z0(j,i) / zp ) )
-
-             wall_flux(k) = kappa *                                            &
-                  ( a*u(k,j,i) + b*v(k,j,i) + (c1+c2)*w(k,j,i) ) / (           &
-                  LOG( zp / z0(j,i) ) -                                        &
-                  LOG( ( 1.0_wp + h1 )**2 * ( 1.0_wp + h1**2 ) / (             &
-                       ( 1.0_wp + h2 )**2 * ( 1.0_wp + h2**2 )   ) ) +         &
-                       2.0_wp * ( ATAN( h1 ) - ATAN( h2 ) )                    &
-                                                                   )
-          ENDIF
-          wall_flux(k) = -wall_flux(k) * us_wall
-
-!
-!--       store rifs for next time step
-          rif_wall(k,j,i,wall_index) = rifs
-
-       ENDDO
-
-    END SUBROUTINE wall_fluxes_ij
-
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Call for all grid points
-!> Calculates momentum fluxes at vertical walls for routine production_e
-!> assuming Monin-Obukhov similarity.
-!> Indices: usvs a=1, vsus b=1, wsvs c1=1, wsus c2=1 (other=0).
-!------------------------------------------------------------------------------!
-
-    SUBROUTINE wall_fluxes_e( wall_flux, a, b, c1, c2, wall )
-
-
-       USE arrays_3d,                                                          &
-           ONLY:  rif_wall, u, v, w, z0
-       
-       USE control_parameters,                                                 &
-           ONLY:  kappa
-       
-       USE grid_variables,                                                     &
-           ONLY:  dx, dy
-       
-       USE indices,                                                            &
-           ONLY:  nxl, nxlg, nxr, nxrg, nyn, nyng, nys, nysg, nzb,             &
-                  nzb_diff_s_inner, nzb_diff_s_outer, nzt
-       
-       USE kinds
-
-       IMPLICIT NONE
-
-       INTEGER(iwp) ::  i            !< 
-       INTEGER(iwp) ::  j            !< 
-       INTEGER(iwp) ::  k            !< 
-       INTEGER(iwp) ::  kk           !< 
-       INTEGER(iwp) ::  wall_index   !< 
-       
-       REAL(wp) ::  a           !< 
-       REAL(wp) ::  b           !< 
-       REAL(wp) ::  c1          !< 
-       REAL(wp) ::  c2          !< 
-       REAL(wp) ::  h1          !< 
-       REAL(wp) ::  h2          !< 
-       REAL(wp) ::  u_i         !< 
-       REAL(wp) ::  v_i         !< 
-       REAL(wp) ::  us_wall     !< 
-       REAL(wp) ::  vel_total   !< 
-       REAL(wp) ::  vel_zp      !< 
-       REAL(wp) ::  ws          !< 
-       REAL(wp) ::  zp          !< 
-       REAL(wp) ::  rifs        !< 
-
-       REAL(wp),                                                               &
-          DIMENSION(nysg:nyng,nxlg:nxrg) ::                                    &
-             wall   !< 
-       
-       REAL(wp),                                                               &
-          DIMENSION(nzb:nzt+1,nys:nyn,nxl:nxr) ::                              &
-             wall_flux   !< 
-
-
-       zp         = 0.5_wp * ( (a+c1) * dy + (b+c2) * dx )
-       wall_flux  = 0.0_wp
-       wall_index = NINT( a+ 2*b + 3*c1 + 4*c2 )
-
-       DO  i = nxl, nxr
-          DO  j = nys, nyn
-
-             IF ( wall(j,i) /= 0.0_wp )  THEN
-!
-!--             All subsequent variables are computed for scalar locations.
-                DO  k = nzb_diff_s_inner(j,i)-1, nzb_diff_s_outer(j,i)-2
-!
-!--                (1) Compute rifs, u_i, v_i, and ws
-                   IF ( k == nzb_diff_s_inner(j,i)-1 )  THEN
-                      kk = nzb_diff_s_inner(j,i)-1
-                   ELSE
-                      kk = k-1
-                   ENDIF
-                   rifs  = 0.5_wp * (      rif_wall(k,j,i,wall_index) +        &
-                                      a  * rif_wall(k,j,i+1,1)        +        &
-                                      b  * rif_wall(k,j+1,i,2)        +        &
-                                      c1 * rif_wall(kk,j,i,3)         +        &
-                                      c2 * rif_wall(kk,j,i,4)                  &
-                                    )
-
-                   u_i   = 0.5_wp * ( u(k,j,i) + u(k,j,i+1) )
-                   v_i   = 0.5_wp * ( v(k,j,i) + v(k,j+1,i) )
-                   ws    = 0.5_wp * ( w(k,j,i) + w(k-1,j,i) )
-!
-!--                (2) Compute wall-parallel absolute velocity vel_total and
-!--                interpolate appropriate velocity component vel_zp.
-                   vel_total = SQRT( ws**2 + (a+c1) * u_i**2 + (b+c2) * v_i**2 )
-                   vel_zp    = 0.5_wp * ( a * u_i + b * v_i + (c1+c2) * ws )
-!
-!--                (3) Compute wall friction velocity us_wall
-                   IF ( rifs >= 0.0_wp )  THEN
-
-!
-!--                   Stable stratification (and neutral)
-                      us_wall = kappa * vel_total / ( LOG( zp / z0(j,i) ) +    &
-                                         5.0_wp * rifs * ( zp - z0(j,i) ) / zp &
-                                                    )
-                   ELSE
-
-!
-!--                   Unstable stratification
-                      h1 = SQRT( SQRT( 1.0_wp - 16.0_wp * rifs ) )
-                      h2 = SQRT( SQRT( 1.0_wp - 16.0_wp * rifs * z0(j,i) / zp ) )
-
-                      us_wall = kappa * vel_total / (                          &
-                           LOG( zp / z0(j,i) ) -                               &
-                           LOG( ( 1.0_wp + h1 )**2 * ( 1.0_wp + h1**2 ) / (    &
-                                ( 1.0_wp + h2 )**2 * ( 1.0_wp + h2**2 )   ) ) +&
-                                2.0_wp * ( ATAN( h1 ) - ATAN( h2 ) )           &
-                                                    )
-                   ENDIF
-
-!
-!--                Skip step (4) of wall_fluxes, because here rifs is already
-!--                available from (1)
-!
-!--                (5) Compute wall_flux (u'v', v'u', w'v', or w'u')
-
-                   IF ( rifs >= 0.0_wp )  THEN
-
-!
-!--                   Stable stratification (and neutral)
-                      wall_flux(k,j,i) = kappa * vel_zp / ( LOG( zp/z0(j,i) ) +&
-                                         5.0_wp * rifs * ( zp-z0(j,i) ) / zp )
-                   ELSE
-
-!
-!--                   Unstable stratification
-                      h1 = SQRT( SQRT( 1.0_wp - 16.0_wp * rifs ) )
-                      h2 = SQRT( SQRT( 1.0_wp - 16.0_wp * rifs * z0(j,i) / zp ) )
-
-                      wall_flux(k,j,i) = kappa * vel_zp / (                    &
-                           LOG( zp / z0(j,i) ) -                               &
-                           LOG( ( 1.0_wp + h1 )**2 * ( 1.0_wp + h1**2 ) / (    &
-                                ( 1.0_wp + h2 )**2 * ( 1.0_wp + h2**2 )   ) ) +&
-                                2.0_wp * ( ATAN( h1 ) - ATAN( h2 ) )           &
-                                                          )
-                   ENDIF
-                   wall_flux(k,j,i) = - wall_flux(k,j,i) * us_wall
-
-                ENDDO
-
-             ENDIF
-
-          ENDDO
-       ENDDO
-
-    END SUBROUTINE wall_fluxes_e
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Call for all grid points - accelerator version
-!> Calculates momentum fluxes at vertical walls for routine production_e
-!> assuming Monin-Obukhov similarity.
-!> Indices: usvs a=1, vsus b=1, wsvs c1=1, wsus c2=1 (other=0).
-!------------------------------------------------------------------------------!
-    SUBROUTINE wall_fluxes_e_acc( wall_flux, a, b, c1, c2, wall )
-
-
-       USE arrays_3d,                                                          &
-           ONLY:  rif_wall, u, v, w, z0
-       
-       USE control_parameters,                                                 &
-           ONLY:  kappa
-       
-       USE grid_variables,                                                     &
-           ONLY:  dx, dy
-       
-       USE indices,                                                            &
-           ONLY:  i_left, i_right, j_north, j_south, nxl, nxlg, nxr, nxrg,     &
-                  nyn, nyng, nys, nysg, nzb, nzb_diff_s_inner,                 &
-                  nzb_diff_s_outer, nzt
-       
-       USE kinds
-
-       IMPLICIT NONE
-
-       INTEGER(iwp) ::  i            !< 
-       INTEGER(iwp) ::  j            !< 
-       INTEGER(iwp) ::  k            !< 
-       INTEGER(iwp) ::  kk           !< 
-       INTEGER(iwp) ::  max_outer    !< 
-       INTEGER(iwp) ::  min_inner    !< 
-       INTEGER(iwp) ::  wall_index   !< 
-       
-       REAL(wp) ::  a           !< 
-       REAL(wp) ::  b           !< 
-       REAL(wp) ::  c1          !< 
-       REAL(wp) ::  c2          !< 
-       REAL(wp) ::  h1          !< 
-       REAL(wp) ::  h2          !< 
-       REAL(wp) ::  u_i         !< 
-       REAL(wp) ::  v_i         !< 
-       REAL(wp) ::  us_wall     !< 
-       REAL(wp) ::  vel_total   !< 
-       REAL(wp) ::  vel_zp      !< 
-       REAL(wp) ::  ws          !< 
-       REAL(wp) ::  zp          !< 
-       REAL(wp) ::  rifs        !< 
-
-       REAL(wp),                                                               &
-          DIMENSION(nysg:nyng,nxlg:nxrg) ::                                    &
-             wall   !< 
-       
-       REAL(wp),                                                               &
-          DIMENSION(nzb:nzt+1,nys:nyn,nxl:nxr) ::                              &
-             wall_flux   !< 
-
-
-       zp         = 0.5_wp * ( (a+c1) * dy + (b+c2) * dx )
-       wall_flux  = 0.0_wp
-       wall_index = NINT( a+ 2*b + 3*c1 + 4*c2 )
-
-       min_inner = MINVAL( nzb_diff_s_inner(nys:nyn,nxl:nxr) ) - 1
-       max_outer = MAXVAL( nzb_diff_s_outer(nys:nyn,nxl:nxr) ) - 2
-
-       !$acc kernels present( nzb_diff_s_inner, nzb_diff_s_outer, rif_wall )   &
-       !$acc         present( u, v, w, wall, wall_flux, z0 )
-       DO  i = i_left, i_right
-          DO  j = j_south, j_north
-             DO  k = min_inner, max_outer
-!
-!--             All subsequent variables are computed for scalar locations
-                IF ( k >= nzb_diff_s_inner(j,i)-1  .AND.                       &
-                     k <= nzb_diff_s_outer(j,i)-2  .AND.                       &
-                     wall(j,i) /= 0.0_wp )         THEN
-!
-!--                (1) Compute rifs, u_i, v_i, and ws
-                   IF ( k == nzb_diff_s_inner(j,i)-1 )  THEN
-                      kk = nzb_diff_s_inner(j,i)-1
-                   ELSE
-                      kk = k-1
-                   ENDIF
-                   rifs  = 0.5_wp * (      rif_wall(k,j,i,wall_index) +        &
-                                      a  * rif_wall(k,j,i+1,1)        +        &
-                                      b  * rif_wall(k,j+1,i,2)        +        &
-                                      c1 * rif_wall(kk,j,i,3)         +        &
-                                      c2 * rif_wall(kk,j,i,4)                  &
-                                    )
-
-                   u_i   = 0.5_wp * ( u(k,j,i) + u(k,j,i+1) )
-                   v_i   = 0.5_wp * ( v(k,j,i) + v(k,j+1,i) )
-                   ws    = 0.5_wp * ( w(k,j,i) + w(k-1,j,i) )
-!
-!--                (2) Compute wall-parallel absolute velocity vel_total and
-!--                interpolate appropriate velocity component vel_zp.
-                   vel_total = SQRT( ws**2 + (a+c1) * u_i**2 + (b+c2) * v_i**2 )
-                   vel_zp    = 0.5_wp * ( a * u_i + b * v_i + (c1+c2) * ws )
-!
-!--                (3) Compute wall friction velocity us_wall
-                   IF ( rifs >= 0.0_wp )  THEN
-
-!
-!--                   Stable stratification (and neutral)
-                      us_wall = kappa * vel_total / ( LOG( zp / z0(j,i) ) +    &
-                                         5.0_wp * rifs * ( zp - z0(j,i) ) / zp &
-                                                    )
-                   ELSE
-
-!
-!--                   Unstable stratification
-                      h1 = SQRT( SQRT( 1.0_wp - 16.0_wp * rifs ) )
-                      h2 = SQRT( SQRT( 1.0_wp - 16.0_wp * rifs * z0(j,i) / zp ) )
-
-                      us_wall = kappa * vel_total / (                          &
-                           LOG( zp / z0(j,i) ) -                               &
-                           LOG( ( 1.0_wp + h1 )**2 * ( 1.0_wp + h1**2 ) / (    &
-                                ( 1.0_wp + h2 )**2 * ( 1.0_wp + h2**2 )   ) ) +&
-                                2.0_wp * ( ATAN( h1 ) - ATAN( h2 ) )           &
-                                                    )
-                   ENDIF
-
-!
-!--                Skip step (4) of wall_fluxes, because here rifs is already
-!--                available from (1)
-!
-!--                (5) Compute wall_flux (u'v', v'u', w'v', or w'u')
-
-                   IF ( rifs >= 0.0_wp )  THEN
-
-!
-!--                   Stable stratification (and neutral)
-                      wall_flux(k,j,i) = kappa *  vel_zp / (                   &
-                                         LOG( zp/z0(j,i) ) +                   &
-                                         5.0_wp * rifs * ( zp-z0(j,i) ) / zp   &
-                                                           )
-                   ELSE
-
-!
-!--                   Unstable stratification
-                      h1 = SQRT( SQRT( 1.0_wp - 16.0_wp * rifs ) )
-                      h2 = SQRT( SQRT( 1.0_wp - 16.0_wp * rifs * z0(j,i) / zp ) )
-
-                      wall_flux(k,j,i) = kappa * vel_zp / (                    &
-                           LOG( zp / z0(j,i) ) -                               &
-                           LOG( ( 1.0_wp + h1 )**2 * ( 1.0_wp + h1**2 ) / (    &
-                                ( 1.0_wp + h2 )**2 * ( 1.0_wp + h2**2 )   ) ) +&
-                                2.0_wp * ( ATAN( h1 ) - ATAN( h2 ) )           &
-                                                          )
-                   ENDIF
-                   wall_flux(k,j,i) = - wall_flux(k,j,i) * us_wall
-
-                ENDIF
-
-             ENDDO
-          ENDDO
-       ENDDO
-       !$acc end kernels
-
-    END SUBROUTINE wall_fluxes_e_acc
-
-
-!------------------------------------------------------------------------------!
-! Description:
-! ------------
-!> Call for grid point i,j
-!------------------------------------------------------------------------------!
-    SUBROUTINE wall_fluxes_e_ij( i, j, nzb_w, nzt_w, wall_flux, a, b, c1, c2 )
-
-       USE arrays_3d,                                                          &
-           ONLY:  rif_wall, u, v, w, z0
-       
-       USE control_parameters,                                                 &
-           ONLY:  kappa
-       
-       USE grid_variables,                                                     &
-           ONLY:  dx, dy
-       
-       USE indices,                                                            &
-           ONLY:  nzb, nzt
-       
-       USE kinds
-
-       IMPLICIT NONE
-
-       INTEGER(iwp) ::  i            !< 
-       INTEGER(iwp) ::  j            !< 
-       INTEGER(iwp) ::  k            !< 
-       INTEGER(iwp) ::  kk           !< 
-       INTEGER(iwp) ::  nzb_w        !< 
-       INTEGER(iwp) ::  nzt_w        !< 
-       INTEGER(iwp) ::  wall_index   !< 
-       
-       REAL(wp) ::  a           !< 
-       REAL(wp) ::  b           !< 
-       REAL(wp) ::  c1          !< 
-       REAL(wp) ::  c2          !< 
-       REAL(wp) ::  h1          !< 
-       REAL(wp) ::  h2          !< 
-       REAL(wp) ::  u_i         !< 
-       REAL(wp) ::  v_i         !< 
-       REAL(wp) ::  us_wall     !< 
-       REAL(wp) ::  vel_total   !< 
-       REAL(wp) ::  vel_zp      !< 
-       REAL(wp) ::  ws          !< 
-       REAL(wp) ::  zp          !< 
-       REAL(wp) ::  rifs        !< 
-
-       REAL(wp), DIMENSION(nzb:nzt+1) ::  wall_flux   !< 
-
-
-       zp         = 0.5_wp * ( (a+c1) * dy + (b+c2) * dx )
-       wall_flux  = 0.0_wp
-       wall_index = NINT( a+ 2*b + 3*c1 + 4*c2 )
-
-!
-!--    All subsequent variables are computed for scalar locations.
-       DO  k = nzb_w, nzt_w
-
-!
-!--       (1) Compute rifs, u_i, v_i, and ws
-          IF ( k == nzb_w )  THEN
-             kk = nzb_w
-          ELSE
-             kk = k-1
-          ENDIF
-          rifs  = 0.5_wp * (      rif_wall(k,j,i,wall_index) +                 &
-                             a  * rif_wall(k,j,i+1,1)        +                 &
-                             b  * rif_wall(k,j+1,i,2)        +                 &
-                             c1 * rif_wall(kk,j,i,3)         +                 &
-                             c2 * rif_wall(kk,j,i,4)                           &
-                           )
-
-          u_i   = 0.5_wp * ( u(k,j,i) + u(k,j,i+1) )
-          v_i   = 0.5_wp * ( v(k,j,i) + v(k,j+1,i) )
-          ws    = 0.5_wp * ( w(k,j,i) + w(k-1,j,i) )
-!
-!--       (2) Compute wall-parallel absolute velocity vel_total and
-!--       interpolate appropriate velocity component vel_zp.
-          vel_total = SQRT( ws**2 + (a+c1) * u_i**2 + (b+c2) * v_i**2 )
-          vel_zp    = 0.5_wp * ( a * u_i + b * v_i + (c1+c2) * ws )
-!
-!--       (3) Compute wall friction velocity us_wall
-          IF ( rifs >= 0.0_wp )  THEN
-
-!
-!--          Stable stratification (and neutral)
-             us_wall = kappa * vel_total / ( LOG( zp / z0(j,i) ) +             &
-                                         5.0_wp * rifs * ( zp - z0(j,i) ) / zp &
-                                           )
-          ELSE
-
-!
-!--          Unstable stratification
-             h1 = SQRT( SQRT( 1.0_wp - 16.0_wp * rifs ) )
-             h2 = SQRT( SQRT( 1.0_wp - 16.0_wp * rifs * z0(j,i) / zp ) )
-
-             us_wall = kappa * vel_total / (                                   &
-                  LOG( zp / z0(j,i) ) -                                        &
-                  LOG( ( 1.0_wp + h1 )**2 * ( 1.0_wp + h1**2 ) / (             &
-                       ( 1.0_wp + h2 )**2 * ( 1.0_wp + h2**2 )   ) ) +         &
-                       2.0_wp * ( ATAN( h1 ) - ATAN( h2 ) )                    &
-                                           )
-          ENDIF
-
-!
-!--       Skip step (4) of wall_fluxes, because here rifs is already
-!--       available from (1)
-!
-!--       (5) Compute wall_flux (u'v', v'u', w'v', or w'u')
-!--       First interpolate the velocity (this is different from 
-!--       subroutine wall_fluxes because fluxes in subroutine 
-!--       wall_fluxes_e are defined at scalar locations).
-          vel_zp = 0.5_wp * (       a * ( u(k,j,i) + u(k,j,i+1) ) +            &
-                                    b * ( v(k,j,i) + v(k,j+1,i) ) +            &
-                              (c1+c2) * ( w(k,j,i) + w(k-1,j,i) )              &
-                            )
-
-          IF ( rifs >= 0.0_wp )  THEN
-
-!
-!--          Stable stratification (and neutral)
-             wall_flux(k) = kappa *  vel_zp /                                  &
-                     ( LOG( zp/z0(j,i) ) + 5.0_wp * rifs * ( zp-z0(j,i) ) / zp )
-          ELSE
-
-!
-!--          Unstable stratification
-             h1 = SQRT( SQRT( 1.0_wp - 16.0_wp * rifs ) )
-             h2 = SQRT( SQRT( 1.0_wp - 16.0_wp * rifs * z0(j,i) / zp ) )
-
-             wall_flux(k) = kappa * vel_zp / (                                 &
-                  LOG( zp / z0(j,i) ) -                                        &
-                  LOG( ( 1.0_wp + h1 )**2 * ( 1.0_wp + h1**2 ) / (             &
-                       ( 1.0_wp + h2 )**2 * ( 1.0_wp + h2**2 )   ) ) +         &
-                       2.0_wp * ( ATAN( h1 ) - ATAN( h2 ) )                    &
-                                             )
-          ENDIF
-          wall_flux(k) = - wall_flux(k) * us_wall
-
-       ENDDO
-
-    END SUBROUTINE wall_fluxes_e_ij
-
- END MODULE wall_fluxes_mod
Index: /palm/trunk/SOURCE/wall_fluxes_mod.f90
===================================================================
--- /palm/trunk/SOURCE/wall_fluxes_mod.f90	(revision 1850)
+++ /palm/trunk/SOURCE/wall_fluxes_mod.f90	(revision 1850)
@@ -0,0 +1,1105 @@
+!> @file wall_fluxes_mod.f90
+!--------------------------------------------------------------------------------!
+! This file is part of PALM.
+!
+! PALM is free software: you can redistribute it and/or modify it under the terms
+! of the GNU General Public License as published by the Free Software Foundation,
+! either version 3 of the License, or (at your option) any later version.
+!
+! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
+! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
+! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along with
+! PALM. If not, see <http://www.gnu.org/licenses/>.
+!
+! Copyright 1997-2016 Leibniz Universitaet Hannover
+!--------------------------------------------------------------------------------!
+!
+! Current revisions:
+! -----------------
+! Module renamed
+! 
+! 
+! Former revisions:
+! -----------------
+! $Id$
+!
+! 1691 2015-10-26 16:17:44Z maronga
+! Renamed rif_min and rif_max with zeta_min and zeta_max, respectively.
+! 
+! 1682 2015-10-07 23:56:08Z knoop
+! Code annotations made doxygen readable 
+! 
+! 1374 2014-04-25 12:55:07Z raasch
+! pt removed from acc-present-list
+! 
+! 1353 2014-04-08 15:21:23Z heinze
+! REAL constants provided with KIND-attribute
+!
+! 1320 2014-03-20 08:40:49Z raasch
+! ONLY-attribute added to USE-statements,
+! kind-parameters added to all INTEGER and REAL declaration statements, 
+! kinds are defined in new module kinds, 
+! old module precision_kind is removed,
+! revision history before 2012 removed,
+! comment fields (!:) to be used for variable explanations added to
+! all variable declaration statements 
+!
+! 1257 2013-11-08 15:18:40Z raasch
+! openacc loop and loop vector clauses removed
+!
+! 1153 2013-05-10 14:33:08Z raasch
+! code adjustments of accelerator version required by PGI 12.3 / CUDA 5.0
+!
+! 1128 2013-04-12 06:19:32Z raasch
+! loop index bounds in accelerator version replaced by i_left, i_right, j_south,
+! j_north
+!
+! 1036 2012-10-22 13:43:42Z raasch
+! code put under GPL (PALM 3.9)
+!
+! 1015 2012-09-27 09:23:24Z raasch
+! accelerator version (*_acc) added
+!
+! Initial version (2007/03/07)
+!
+! Description:
+! ------------
+!> Calculates momentum fluxes at vertical walls assuming Monin-Obukhov
+!> similarity.
+!> Indices: usvs a=1, vsus b=1, wsvs c1=1, wsus c2=1 (other=0).
+!> The all-gridpoint version of wall_fluxes_e is not used so far, because
+!> it gives slightly different results from the ij-version for some unknown
+!> reason.
+!>
+!> @todo Rename rif to zeta throughout the routine
+!------------------------------------------------------------------------------!
+ MODULE wall_fluxes_mod
+ 
+    PRIVATE
+    PUBLIC wall_fluxes, wall_fluxes_acc, wall_fluxes_e, wall_fluxes_e_acc
+    
+    INTERFACE wall_fluxes
+       MODULE PROCEDURE wall_fluxes
+       MODULE PROCEDURE wall_fluxes_ij
+    END INTERFACE wall_fluxes
+    
+    INTERFACE wall_fluxes_acc
+       MODULE PROCEDURE wall_fluxes_acc
+    END INTERFACE wall_fluxes_acc
+
+    INTERFACE wall_fluxes_e
+       MODULE PROCEDURE wall_fluxes_e
+       MODULE PROCEDURE wall_fluxes_e_ij
+    END INTERFACE wall_fluxes_e
+ 
+    INTERFACE wall_fluxes_e_acc
+       MODULE PROCEDURE wall_fluxes_e_acc
+    END INTERFACE wall_fluxes_e_acc
+
+ CONTAINS
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Call for all grid points
+!------------------------------------------------------------------------------!
+    SUBROUTINE wall_fluxes( wall_flux, a, b, c1, c2, nzb_uvw_inner,            &
+                            nzb_uvw_outer, wall )
+
+       USE arrays_3d,                                                          &
+           ONLY:  rif_wall, u, v, w, z0, pt
+       
+       USE control_parameters,                                                 &
+           ONLY:  g, kappa, zeta_max, zeta_min
+       
+       USE grid_variables,                                                     &
+           ONLY:  dx, dy
+       
+       USE indices,                                                            &
+           ONLY:  nxl, nxlg, nxr, nxrg, nyn, nyng, nys, nysg, nzb, nzt
+       
+       USE kinds
+       
+       USE statistics,                                                         &
+           ONLY:  hom
+
+       IMPLICIT NONE
+
+       INTEGER(iwp) ::  i            !< 
+       INTEGER(iwp) ::  j            !< 
+       INTEGER(iwp) ::  k            !< 
+       INTEGER(iwp) ::  wall_index   !< 
+
+       INTEGER(iwp),                                                           &
+          DIMENSION(nysg:nyng,nxlg:nxrg) ::                                    &
+             nzb_uvw_inner   !< 
+       INTEGER(iwp),                                                           &
+          DIMENSION(nysg:nyng,nxlg:nxrg) ::                                    &
+             nzb_uvw_outer   !< 
+       
+       REAL(wp) ::  a           !< 
+       REAL(wp) ::  b           !< 
+       REAL(wp) ::  c1          !< 
+       REAL(wp) ::  c2          !< 
+       REAL(wp) ::  h1          !< 
+       REAL(wp) ::  h2          !< 
+       REAL(wp) ::  zp          !< 
+       REAL(wp) ::  pts         !< 
+       REAL(wp) ::  pt_i        !< 
+       REAL(wp) ::  rifs        !< 
+       REAL(wp) ::  u_i         !< 
+       REAL(wp) ::  v_i         !< 
+       REAL(wp) ::  us_wall     !< 
+       REAL(wp) ::  vel_total   !< 
+       REAL(wp) ::  ws          !< 
+       REAL(wp) ::  wspts       !< 
+
+       REAL(wp),                                                               &
+          DIMENSION(nysg:nyng,nxlg:nxrg) ::                                    &
+             wall   !< 
+       
+       REAL(wp),                                                               &
+          DIMENSION(nzb:nzt+1,nys:nyn,nxl:nxr) ::                              &
+             wall_flux   !< 
+
+
+       zp         = 0.5_wp * ( (a+c1) * dy + (b+c2) * dx )
+       wall_flux  = 0.0_wp
+       wall_index = NINT( a+ 2*b + 3*c1 + 4*c2 )
+
+       DO  i = nxl, nxr
+          DO  j = nys, nyn
+
+             IF ( wall(j,i) /= 0.0_wp )  THEN
+!
+!--             All subsequent variables are computed for the respective
+!--             location where the respective flux is defined.
+                DO  k = nzb_uvw_inner(j,i)+1, nzb_uvw_outer(j,i)
+
+!
+!--                (1) Compute rifs, u_i, v_i, ws, pt' and w'pt'
+                   rifs  = rif_wall(k,j,i,wall_index)
+
+                   u_i   = a * u(k,j,i) + c1 * 0.25_wp *                       &
+                           ( u(k+1,j,i+1) + u(k+1,j,i) + u(k,j,i+1) + u(k,j,i) )
+
+                   v_i   = b * v(k,j,i) + c2 * 0.25_wp *                       &
+                           ( v(k+1,j+1,i) + v(k+1,j,i) + v(k,j+1,i) + v(k,j,i) )
+
+                   ws    = ( c1 + c2 ) * w(k,j,i) + 0.25_wp * (                &
+                     a * ( w(k-1,j,i-1) + w(k-1,j,i) + w(k,j,i-1) + w(k,j,i) ) &
+                   + b * ( w(k-1,j-1,i) + w(k-1,j,i) + w(k,j-1,i) + w(k,j,i) ) &
+                                                              )
+                   pt_i  = 0.5_wp * ( pt(k,j,i) + a *  pt(k,j,i-1) +           &
+                                   b * pt(k,j-1,i) + ( c1 + c2 ) * pt(k+1,j,i) )
+
+                   pts   = pt_i - hom(k,1,4,0)
+                   wspts = ws * pts
+
+!
+!--                (2) Compute wall-parallel absolute velocity vel_total
+                   vel_total = SQRT( ws**2 + (a+c1) * u_i**2 + (b+c2) * v_i**2 )
+
+!
+!--                (3) Compute wall friction velocity us_wall
+                   IF ( rifs >= 0.0_wp )  THEN
+
+!
+!--                   Stable stratification (and neutral)
+                      us_wall = kappa * vel_total / ( LOG( zp / z0(j,i) ) +    &
+                                         5.0_wp * rifs * ( zp - z0(j,i) ) / zp &
+                                                    )
+                   ELSE
+
+!
+!--                   Unstable stratification
+                      h1 = SQRT( SQRT( 1.0_wp - 16.0_wp * rifs ) )
+                      h2 = SQRT( SQRT( 1.0_wp - 16.0_wp * rifs * z0(j,i) / zp ) )
+
+                      us_wall = kappa * vel_total / (                          &
+                           LOG( zp / z0(j,i) ) -                               &
+                           LOG( ( 1.0_wp + h1 )**2 * ( 1.0_wp + h1**2 ) / (    &
+                                ( 1.0_wp + h2 )**2 * ( 1.0_wp + h2**2 )   ) ) +&
+                                2.0_wp * ( ATAN( h1 ) - ATAN( h2 ) )           &
+                                                    )
+                   ENDIF
+
+!
+!--                (4) Compute zp/L (corresponds to neutral Richardson flux
+!--                    number rifs)
+                   rifs = -1.0_wp * zp * kappa * g * wspts /                   &
+                          ( pt_i * ( us_wall**3 + 1E-30 ) )
+
+!
+!--                Limit the value range of the Richardson numbers.
+!--                This is necessary for very small velocities (u,w --> 0),
+!--                because the absolute value of rif can then become very
+!--                large, which in consequence would result in very large
+!--                shear stresses and very small momentum fluxes (both are
+!--                generally unrealistic).
+                   IF ( rifs < zeta_min )  rifs = zeta_min
+                   IF ( rifs > zeta_max )  rifs = zeta_max
+
+!
+!--                (5) Compute wall_flux (u'v', v'u', w'v', or w'u')
+                   IF ( rifs >= 0.0_wp )  THEN
+
+!
+!--                   Stable stratification (and neutral)
+                      wall_flux(k,j,i) = kappa *                               &
+                              ( a*u(k,j,i) + b*v(k,j,i) + (c1+c2)*w(k,j,i) ) / &
+                              (  LOG( zp / z0(j,i) ) +                         &
+                                 5.0_wp * rifs * ( zp - z0(j,i) ) / zp         &
+                              )
+                   ELSE
+
+!
+!--                   Unstable stratification
+                      h1 = SQRT( SQRT( 1.0_wp - 16.0_wp * rifs ) )
+                      h2 = SQRT( SQRT( 1.0_wp - 16.0_wp * rifs * z0(j,i) / zp ) )
+
+                      wall_flux(k,j,i) = kappa *                               &
+                           ( a*u(k,j,i) + b*v(k,j,i) + (c1+c2)*w(k,j,i) ) / (  &
+                           LOG( zp / z0(j,i) ) -                               &
+                           LOG( ( 1.0_wp + h1 )**2 * ( 1.0_wp + h1**2 ) / (    &
+                                ( 1.0_wp + h2 )**2 * ( 1.0_wp + h2**2 )   ) ) +&
+                                2.0_wp * ( ATAN( h1 ) - ATAN( h2 ) )           &
+                                                                            )
+                   ENDIF
+                   wall_flux(k,j,i) = -wall_flux(k,j,i) * us_wall
+
+!
+!--                store rifs for next time step
+                   rif_wall(k,j,i,wall_index) = rifs
+
+                ENDDO
+
+             ENDIF
+
+          ENDDO
+       ENDDO
+
+    END SUBROUTINE wall_fluxes
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Call for all grid points - accelerator version
+!------------------------------------------------------------------------------!
+    SUBROUTINE wall_fluxes_acc( wall_flux, a, b, c1, c2, nzb_uvw_inner,        &
+                                nzb_uvw_outer, wall )
+
+       USE arrays_3d,                                                          &
+           ONLY:  rif_wall, pt, u, v, w, z0
+       
+       USE control_parameters,                                                 &
+           ONLY:  g, kappa, zeta_max, zeta_min
+       
+       USE grid_variables,                                                     &
+           ONLY:  dx, dy
+       
+       USE indices,                                                            &
+           ONLY:  i_left, i_right, j_north, j_south, nxl, nxlg, nxr, nxrg,     &
+                  nyn, nyng, nys, nysg, nzb, nzt
+       
+       USE kinds
+       
+       USE statistics,                                                         &
+           ONLY:  hom
+
+       IMPLICIT NONE
+
+       INTEGER(iwp) ::  i            !< 
+       INTEGER(iwp) ::  j            !< 
+       INTEGER(iwp) ::  k            !< 
+       INTEGER(iwp) ::  max_outer    !< 
+       INTEGER(iwp) ::  min_inner    !< 
+       INTEGER(iwp) ::  wall_index   !< 
+
+       INTEGER(iwp),                                                           &
+          DIMENSION(nysg:nyng,nxlg:nxrg) ::                                    &
+             nzb_uvw_inner   !< 
+       INTEGER(iwp),                                                           &
+          DIMENSION(nysg:nyng,nxlg:nxrg) ::                                    &
+             nzb_uvw_outer   !< 
+       
+       REAL(wp) ::  a           !< 
+       REAL(wp) ::  b           !< 
+       REAL(wp) ::  c1          !< 
+       REAL(wp) ::  c2          !< 
+       REAL(wp) ::  h1          !< 
+       REAL(wp) ::  h2          !< 
+       REAL(wp) ::  zp          !< 
+       REAL(wp) ::  pts         !< 
+       REAL(wp) ::  pt_i        !< 
+       REAL(wp) ::  rifs        !< 
+       REAL(wp) ::  u_i         !< 
+       REAL(wp) ::  v_i         !< 
+       REAL(wp) ::  us_wall     !< 
+       REAL(wp) ::  vel_total   !< 
+       REAL(wp) ::  ws          !< 
+       REAL(wp) ::  wspts       !< 
+
+       REAL(wp),                                                               &
+          DIMENSION(nysg:nyng,nxlg:nxrg) ::                                    &
+             wall   !< 
+       
+       REAL(wp),                                                               &
+          DIMENSION(nzb:nzt+1,nys:nyn,nxl:nxr) ::                              &
+             wall_flux   !< 
+
+
+       zp         = 0.5_wp * ( (a+c1) * dy + (b+c2) * dx )
+       wall_flux  = 0.0_wp
+       wall_index = NINT( a+ 2*b + 3*c1 + 4*c2 )
+
+       min_inner = MINVAL( nzb_uvw_inner(nys:nyn,nxl:nxr) ) + 1
+       max_outer = MINVAL( nzb_uvw_outer(nys:nyn,nxl:nxr) )
+
+       !$acc kernels present( hom, nzb_uvw_inner, nzb_uvw_outer, pt, rif_wall ) &
+       !$acc         present( u, v, w, wall, wall_flux, z0 )
+       !$acc loop independent
+       DO  i = i_left, i_right
+          DO  j = j_south, j_north
+
+             IF ( wall(j,i) /= 0.0_wp )  THEN
+!
+!--             All subsequent variables are computed for the respective
+!--             location where the respective flux is defined.
+                !$acc loop independent
+                DO  k = nzb_uvw_inner(j,i)+1, nzb_uvw_outer(j,i)
+
+!
+!--                (1) Compute rifs, u_i, v_i, ws, pt' and w'pt'
+                   rifs  = rif_wall(k,j,i,wall_index)
+
+                   u_i   = a * u(k,j,i) + c1 * 0.25_wp *                       &
+                           ( u(k+1,j,i+1) + u(k+1,j,i) + u(k,j,i+1) + u(k,j,i) )
+
+                   v_i   = b * v(k,j,i) + c2 * 0.25_wp *                       &
+                           ( v(k+1,j+1,i) + v(k+1,j,i) + v(k,j+1,i) + v(k,j,i) )
+
+                   ws    = ( c1 + c2 ) * w(k,j,i) + 0.25_wp * (                &
+                     a * ( w(k-1,j,i-1) + w(k-1,j,i) + w(k,j,i-1) + w(k,j,i) ) &
+                   + b * ( w(k-1,j-1,i) + w(k-1,j,i) + w(k,j-1,i) + w(k,j,i) ) &
+                                                              )
+                   pt_i  = 0.5_wp * ( pt(k,j,i) + a *  pt(k,j,i-1) +           &
+                                   b * pt(k,j-1,i) + ( c1 + c2 ) * pt(k+1,j,i) )
+
+                   pts   = pt_i - hom(k,1,4,0)
+                   wspts = ws * pts
+
+!
+!--                (2) Compute wall-parallel absolute velocity vel_total
+                   vel_total = SQRT( ws**2 + (a+c1) * u_i**2 + (b+c2) * v_i**2 )
+
+!
+!--                (3) Compute wall friction velocity us_wall
+                   IF ( rifs >= 0.0_wp )  THEN
+
+!
+!--                   Stable stratification (and neutral)
+                      us_wall = kappa * vel_total / ( LOG( zp / z0(j,i) ) +    &
+                                         5.0_wp * rifs * ( zp - z0(j,i) ) / zp &
+                                                    )
+                   ELSE
+
+!
+!--                   Unstable stratification
+                      h1 = SQRT( SQRT( 1.0_wp - 16.0_wp * rifs ) )
+                      h2 = SQRT( SQRT( 1.0_wp - 16.0_wp * rifs * z0(j,i) / zp ) )
+
+                      us_wall = kappa * vel_total / (                          &
+                           LOG( zp / z0(j,i) ) -                               &
+                           LOG( ( 1.0_wp + h1 )**2 * ( 1.0_wp + h1**2 ) / (    &
+                                ( 1.0_wp + h2 )**2 * ( 1.0_wp + h2**2 )   ) ) +&
+                                2.0_wp * ( ATAN( h1 ) - ATAN( h2 ) )           &
+                                                    )
+                   ENDIF
+
+!
+!--                (4) Compute zp/L (corresponds to neutral Richardson flux
+!--                    number rifs)
+                   rifs = -1.0_wp * zp * kappa * g * wspts /                   &
+                          ( pt_i * ( us_wall**3 + 1E-30 ) )
+
+!
+!--                Limit the value range of the Richardson numbers.
+!--                This is necessary for very small velocities (u,w --> 0),
+!--                because the absolute value of rif can then become very
+!--                large, which in consequence would result in very large
+!--                shear stresses and very small momentum fluxes (both are
+!--                generally unrealistic).
+                   IF ( rifs < zeta_min )  rifs = zeta_min
+                   IF ( rifs > zeta_max )  rifs = zeta_max
+
+!
+!--                (5) Compute wall_flux (u'v', v'u', w'v', or w'u')
+                   IF ( rifs >= 0.0_wp )  THEN
+
+!
+!--                   Stable stratification (and neutral)
+                      wall_flux(k,j,i) = kappa *                               &
+                              ( a*u(k,j,i) + b*v(k,j,i) + (c1+c2)*w(k,j,i) ) / &
+                              (  LOG( zp / z0(j,i) ) +                         &
+                                 5.0_wp * rifs * ( zp - z0(j,i) ) / zp         &
+                              )
+                   ELSE
+
+!
+!--                   Unstable stratification
+                      h1 = SQRT( SQRT( 1.0_wp - 16.0_wp * rifs ) )
+                      h2 = SQRT( SQRT( 1.0_wp - 16.0_wp * rifs * z0(j,i) / zp ) )
+
+                      wall_flux(k,j,i) = kappa *                               &
+                           ( a*u(k,j,i) + b*v(k,j,i) + (c1+c2)*w(k,j,i) ) / (  &
+                           LOG( zp / z0(j,i) ) -                               &
+                           LOG( ( 1.0_wp + h1 )**2 * ( 1.0_wp + h1**2 ) / (    &
+                                ( 1.0_wp + h2 )**2 * ( 1.0_wp + h2**2 )   ) ) +&
+                                2.0_wp * ( ATAN( h1 ) - ATAN( h2 ) )           &
+                                                                            )
+                   ENDIF
+                   wall_flux(k,j,i) = -wall_flux(k,j,i) * us_wall
+
+!
+!--                store rifs for next time step
+                   rif_wall(k,j,i,wall_index) = rifs
+
+                ENDDO
+
+             ENDIF
+
+          ENDDO
+       ENDDO
+       !$acc end kernels
+
+    END SUBROUTINE wall_fluxes_acc
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Call for all grid point i,j
+!------------------------------------------------------------------------------!
+    SUBROUTINE wall_fluxes_ij( i, j, nzb_w, nzt_w, wall_flux, a, b, c1, c2 )
+
+       USE arrays_3d,                                                          &
+           ONLY:  rif_wall, pt, u, v, w, z0
+       
+       USE control_parameters,                                                 &
+           ONLY:  g, kappa, zeta_max, zeta_min
+       
+       USE grid_variables,                                                     &
+           ONLY:  dx, dy
+       
+       USE indices,                                                            &
+           ONLY:  nzb, nzt
+       
+       USE kinds
+       
+       USE statistics,                                                         &
+           ONLY:  hom
+
+       IMPLICIT NONE
+
+       INTEGER(iwp) ::  i            !< 
+       INTEGER(iwp) ::  j            !< 
+       INTEGER(iwp) ::  k            !< 
+       INTEGER(iwp) ::  nzb_w        !< 
+       INTEGER(iwp) ::  nzt_w        !< 
+       INTEGER(iwp) ::  wall_index   !< 
+       
+       REAL(wp) ::  a           !< 
+       REAL(wp) ::  b           !< 
+       REAL(wp) ::  c1          !< 
+       REAL(wp) ::  c2          !< 
+       REAL(wp) ::  h1          !< 
+       REAL(wp) ::  h2          !< 
+       REAL(wp) ::  zp          !< 
+       REAL(wp) ::  pts         !< 
+       REAL(wp) ::  pt_i        !< 
+       REAL(wp) ::  rifs        !< 
+       REAL(wp) ::  u_i         !< 
+       REAL(wp) ::  v_i         !< 
+       REAL(wp) ::  us_wall     !< 
+       REAL(wp) ::  vel_total   !< 
+       REAL(wp) ::  ws          !< 
+       REAL(wp) ::  wspts       !< 
+
+       REAL(wp), DIMENSION(nzb:nzt+1) ::  wall_flux   !< 
+
+
+       zp         = 0.5_wp * ( (a+c1) * dy + (b+c2) * dx )
+       wall_flux  = 0.0_wp
+       wall_index = NINT( a+ 2*b + 3*c1 + 4*c2 )
+
+!
+!--    All subsequent variables are computed for the respective location where 
+!--    the respective flux is defined.
+       DO  k = nzb_w, nzt_w
+
+!
+!--       (1) Compute rifs, u_i, v_i, ws, pt' and w'pt'
+          rifs  = rif_wall(k,j,i,wall_index)
+
+          u_i   = a * u(k,j,i) + c1 * 0.25_wp *                                &
+                  ( u(k+1,j,i+1) + u(k+1,j,i) + u(k,j,i+1) + u(k,j,i) )
+
+          v_i   = b * v(k,j,i) + c2 * 0.25_wp *                                &
+                  ( v(k+1,j+1,i) + v(k+1,j,i) + v(k,j+1,i) + v(k,j,i) )
+
+          ws    = ( c1 + c2 ) * w(k,j,i) + 0.25_wp * (                         &
+                     a * ( w(k-1,j,i-1) + w(k-1,j,i) + w(k,j,i-1) + w(k,j,i) ) &
+                   + b * ( w(k-1,j-1,i) + w(k-1,j,i) + w(k,j-1,i) + w(k,j,i) ) &
+                                                     )
+          pt_i  = 0.5_wp * ( pt(k,j,i) + a *  pt(k,j,i-1) + b * pt(k,j-1,i)    &
+                          + ( c1 + c2 ) * pt(k+1,j,i) )
+
+          pts   = pt_i - hom(k,1,4,0)
+          wspts = ws * pts
+
+!
+!--       (2) Compute wall-parallel absolute velocity vel_total
+          vel_total = SQRT( ws**2 + ( a+c1 ) * u_i**2 + ( b+c2 ) * v_i**2 )
+
+!
+!--       (3) Compute wall friction velocity us_wall
+          IF ( rifs >= 0.0_wp )  THEN
+
+!
+!--          Stable stratification (and neutral)
+             us_wall = kappa * vel_total / ( LOG( zp / z0(j,i) ) +             &
+                                         5.0_wp * rifs * ( zp - z0(j,i) ) / zp &
+                                           )
+          ELSE
+
+!
+!--          Unstable stratification
+             h1 = SQRT( SQRT( 1.0_wp - 16.0_wp * rifs ) )
+             h2 = SQRT( SQRT( 1.0_wp - 16.0_wp * rifs * z0(j,i) / zp ) )
+
+             us_wall = kappa * vel_total / (                                   &
+                  LOG( zp / z0(j,i) ) -                                        &
+                  LOG( ( 1.0_wp + h1 )**2 * ( 1.0_wp + h1**2 ) / (             &
+                       ( 1.0_wp + h2 )**2 * ( 1.0_wp + h2**2 )   ) ) +         &
+                       2.0_wp * ( ATAN( h1 ) - ATAN( h2 ) )                    &
+                                           )
+          ENDIF
+
+!
+!--       (4) Compute zp/L (corresponds to neutral Richardson flux number 
+!--           rifs)
+          rifs = -1.0_wp * zp * kappa * g * wspts /                            &
+                  ( pt_i * (us_wall**3 + 1E-30) )
+
+!
+!--       Limit the value range of the Richardson numbers.
+!--       This is necessary for very small velocities (u,w --> 0), because
+!--       the absolute value of rif can then become very large, which in
+!--       consequence would result in very large shear stresses and very
+!--       small momentum fluxes (both are generally unrealistic).
+          IF ( rifs < zeta_min )  rifs = zeta_min
+          IF ( rifs > zeta_max )  rifs = zeta_max
+
+!
+!--       (5) Compute wall_flux (u'v', v'u', w'v', or w'u')
+          IF ( rifs >= 0.0_wp )  THEN
+
+!
+!--          Stable stratification (and neutral)
+             wall_flux(k) = kappa *                                            &
+                            ( a*u(k,j,i) + b*v(k,j,i) + (c1+c2)*w(k,j,i) ) /   &
+                            (  LOG( zp / z0(j,i) ) +                           &
+                               5.0_wp * rifs * ( zp - z0(j,i) ) / zp           &
+                            )
+          ELSE
+
+!
+!--          Unstable stratification
+             h1 = SQRT( SQRT( 1.0_wp - 16.0_wp * rifs ) )
+             h2 = SQRT( SQRT( 1.0_wp - 16.0_wp * rifs * z0(j,i) / zp ) )
+
+             wall_flux(k) = kappa *                                            &
+                  ( a*u(k,j,i) + b*v(k,j,i) + (c1+c2)*w(k,j,i) ) / (           &
+                  LOG( zp / z0(j,i) ) -                                        &
+                  LOG( ( 1.0_wp + h1 )**2 * ( 1.0_wp + h1**2 ) / (             &
+                       ( 1.0_wp + h2 )**2 * ( 1.0_wp + h2**2 )   ) ) +         &
+                       2.0_wp * ( ATAN( h1 ) - ATAN( h2 ) )                    &
+                                                                   )
+          ENDIF
+          wall_flux(k) = -wall_flux(k) * us_wall
+
+!
+!--       store rifs for next time step
+          rif_wall(k,j,i,wall_index) = rifs
+
+       ENDDO
+
+    END SUBROUTINE wall_fluxes_ij
+
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Call for all grid points
+!> Calculates momentum fluxes at vertical walls for routine production_e
+!> assuming Monin-Obukhov similarity.
+!> Indices: usvs a=1, vsus b=1, wsvs c1=1, wsus c2=1 (other=0).
+!------------------------------------------------------------------------------!
+
+    SUBROUTINE wall_fluxes_e( wall_flux, a, b, c1, c2, wall )
+
+
+       USE arrays_3d,                                                          &
+           ONLY:  rif_wall, u, v, w, z0
+       
+       USE control_parameters,                                                 &
+           ONLY:  kappa
+       
+       USE grid_variables,                                                     &
+           ONLY:  dx, dy
+       
+       USE indices,                                                            &
+           ONLY:  nxl, nxlg, nxr, nxrg, nyn, nyng, nys, nysg, nzb,             &
+                  nzb_diff_s_inner, nzb_diff_s_outer, nzt
+       
+       USE kinds
+
+       IMPLICIT NONE
+
+       INTEGER(iwp) ::  i            !< 
+       INTEGER(iwp) ::  j            !< 
+       INTEGER(iwp) ::  k            !< 
+       INTEGER(iwp) ::  kk           !< 
+       INTEGER(iwp) ::  wall_index   !< 
+       
+       REAL(wp) ::  a           !< 
+       REAL(wp) ::  b           !< 
+       REAL(wp) ::  c1          !< 
+       REAL(wp) ::  c2          !< 
+       REAL(wp) ::  h1          !< 
+       REAL(wp) ::  h2          !< 
+       REAL(wp) ::  u_i         !< 
+       REAL(wp) ::  v_i         !< 
+       REAL(wp) ::  us_wall     !< 
+       REAL(wp) ::  vel_total   !< 
+       REAL(wp) ::  vel_zp      !< 
+       REAL(wp) ::  ws          !< 
+       REAL(wp) ::  zp          !< 
+       REAL(wp) ::  rifs        !< 
+
+       REAL(wp),                                                               &
+          DIMENSION(nysg:nyng,nxlg:nxrg) ::                                    &
+             wall   !< 
+       
+       REAL(wp),                                                               &
+          DIMENSION(nzb:nzt+1,nys:nyn,nxl:nxr) ::                              &
+             wall_flux   !< 
+
+
+       zp         = 0.5_wp * ( (a+c1) * dy + (b+c2) * dx )
+       wall_flux  = 0.0_wp
+       wall_index = NINT( a+ 2*b + 3*c1 + 4*c2 )
+
+       DO  i = nxl, nxr
+          DO  j = nys, nyn
+
+             IF ( wall(j,i) /= 0.0_wp )  THEN
+!
+!--             All subsequent variables are computed for scalar locations.
+                DO  k = nzb_diff_s_inner(j,i)-1, nzb_diff_s_outer(j,i)-2
+!
+!--                (1) Compute rifs, u_i, v_i, and ws
+                   IF ( k == nzb_diff_s_inner(j,i)-1 )  THEN
+                      kk = nzb_diff_s_inner(j,i)-1
+                   ELSE
+                      kk = k-1
+                   ENDIF
+                   rifs  = 0.5_wp * (      rif_wall(k,j,i,wall_index) +        &
+                                      a  * rif_wall(k,j,i+1,1)        +        &
+                                      b  * rif_wall(k,j+1,i,2)        +        &
+                                      c1 * rif_wall(kk,j,i,3)         +        &
+                                      c2 * rif_wall(kk,j,i,4)                  &
+                                    )
+
+                   u_i   = 0.5_wp * ( u(k,j,i) + u(k,j,i+1) )
+                   v_i   = 0.5_wp * ( v(k,j,i) + v(k,j+1,i) )
+                   ws    = 0.5_wp * ( w(k,j,i) + w(k-1,j,i) )
+!
+!--                (2) Compute wall-parallel absolute velocity vel_total and
+!--                interpolate appropriate velocity component vel_zp.
+                   vel_total = SQRT( ws**2 + (a+c1) * u_i**2 + (b+c2) * v_i**2 )
+                   vel_zp    = 0.5_wp * ( a * u_i + b * v_i + (c1+c2) * ws )
+!
+!--                (3) Compute wall friction velocity us_wall
+                   IF ( rifs >= 0.0_wp )  THEN
+
+!
+!--                   Stable stratification (and neutral)
+                      us_wall = kappa * vel_total / ( LOG( zp / z0(j,i) ) +    &
+                                         5.0_wp * rifs * ( zp - z0(j,i) ) / zp &
+                                                    )
+                   ELSE
+
+!
+!--                   Unstable stratification
+                      h1 = SQRT( SQRT( 1.0_wp - 16.0_wp * rifs ) )
+                      h2 = SQRT( SQRT( 1.0_wp - 16.0_wp * rifs * z0(j,i) / zp ) )
+
+                      us_wall = kappa * vel_total / (                          &
+                           LOG( zp / z0(j,i) ) -                               &
+                           LOG( ( 1.0_wp + h1 )**2 * ( 1.0_wp + h1**2 ) / (    &
+                                ( 1.0_wp + h2 )**2 * ( 1.0_wp + h2**2 )   ) ) +&
+                                2.0_wp * ( ATAN( h1 ) - ATAN( h2 ) )           &
+                                                    )
+                   ENDIF
+
+!
+!--                Skip step (4) of wall_fluxes, because here rifs is already
+!--                available from (1)
+!
+!--                (5) Compute wall_flux (u'v', v'u', w'v', or w'u')
+
+                   IF ( rifs >= 0.0_wp )  THEN
+
+!
+!--                   Stable stratification (and neutral)
+                      wall_flux(k,j,i) = kappa * vel_zp / ( LOG( zp/z0(j,i) ) +&
+                                         5.0_wp * rifs * ( zp-z0(j,i) ) / zp )
+                   ELSE
+
+!
+!--                   Unstable stratification
+                      h1 = SQRT( SQRT( 1.0_wp - 16.0_wp * rifs ) )
+                      h2 = SQRT( SQRT( 1.0_wp - 16.0_wp * rifs * z0(j,i) / zp ) )
+
+                      wall_flux(k,j,i) = kappa * vel_zp / (                    &
+                           LOG( zp / z0(j,i) ) -                               &
+                           LOG( ( 1.0_wp + h1 )**2 * ( 1.0_wp + h1**2 ) / (    &
+                                ( 1.0_wp + h2 )**2 * ( 1.0_wp + h2**2 )   ) ) +&
+                                2.0_wp * ( ATAN( h1 ) - ATAN( h2 ) )           &
+                                                          )
+                   ENDIF
+                   wall_flux(k,j,i) = - wall_flux(k,j,i) * us_wall
+
+                ENDDO
+
+             ENDIF
+
+          ENDDO
+       ENDDO
+
+    END SUBROUTINE wall_fluxes_e
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Call for all grid points - accelerator version
+!> Calculates momentum fluxes at vertical walls for routine production_e
+!> assuming Monin-Obukhov similarity.
+!> Indices: usvs a=1, vsus b=1, wsvs c1=1, wsus c2=1 (other=0).
+!------------------------------------------------------------------------------!
+    SUBROUTINE wall_fluxes_e_acc( wall_flux, a, b, c1, c2, wall )
+
+
+       USE arrays_3d,                                                          &
+           ONLY:  rif_wall, u, v, w, z0
+       
+       USE control_parameters,                                                 &
+           ONLY:  kappa
+       
+       USE grid_variables,                                                     &
+           ONLY:  dx, dy
+       
+       USE indices,                                                            &
+           ONLY:  i_left, i_right, j_north, j_south, nxl, nxlg, nxr, nxrg,     &
+                  nyn, nyng, nys, nysg, nzb, nzb_diff_s_inner,                 &
+                  nzb_diff_s_outer, nzt
+       
+       USE kinds
+
+       IMPLICIT NONE
+
+       INTEGER(iwp) ::  i            !< 
+       INTEGER(iwp) ::  j            !< 
+       INTEGER(iwp) ::  k            !< 
+       INTEGER(iwp) ::  kk           !< 
+       INTEGER(iwp) ::  max_outer    !< 
+       INTEGER(iwp) ::  min_inner    !< 
+       INTEGER(iwp) ::  wall_index   !< 
+       
+       REAL(wp) ::  a           !< 
+       REAL(wp) ::  b           !< 
+       REAL(wp) ::  c1          !< 
+       REAL(wp) ::  c2          !< 
+       REAL(wp) ::  h1          !< 
+       REAL(wp) ::  h2          !< 
+       REAL(wp) ::  u_i         !< 
+       REAL(wp) ::  v_i         !< 
+       REAL(wp) ::  us_wall     !< 
+       REAL(wp) ::  vel_total   !< 
+       REAL(wp) ::  vel_zp      !< 
+       REAL(wp) ::  ws          !< 
+       REAL(wp) ::  zp          !< 
+       REAL(wp) ::  rifs        !< 
+
+       REAL(wp),                                                               &
+          DIMENSION(nysg:nyng,nxlg:nxrg) ::                                    &
+             wall   !< 
+       
+       REAL(wp),                                                               &
+          DIMENSION(nzb:nzt+1,nys:nyn,nxl:nxr) ::                              &
+             wall_flux   !< 
+
+
+       zp         = 0.5_wp * ( (a+c1) * dy + (b+c2) * dx )
+       wall_flux  = 0.0_wp
+       wall_index = NINT( a+ 2*b + 3*c1 + 4*c2 )
+
+       min_inner = MINVAL( nzb_diff_s_inner(nys:nyn,nxl:nxr) ) - 1
+       max_outer = MAXVAL( nzb_diff_s_outer(nys:nyn,nxl:nxr) ) - 2
+
+       !$acc kernels present( nzb_diff_s_inner, nzb_diff_s_outer, rif_wall )   &
+       !$acc         present( u, v, w, wall, wall_flux, z0 )
+       DO  i = i_left, i_right
+          DO  j = j_south, j_north
+             DO  k = min_inner, max_outer
+!
+!--             All subsequent variables are computed for scalar locations
+                IF ( k >= nzb_diff_s_inner(j,i)-1  .AND.                       &
+                     k <= nzb_diff_s_outer(j,i)-2  .AND.                       &
+                     wall(j,i) /= 0.0_wp )         THEN
+!
+!--                (1) Compute rifs, u_i, v_i, and ws
+                   IF ( k == nzb_diff_s_inner(j,i)-1 )  THEN
+                      kk = nzb_diff_s_inner(j,i)-1
+                   ELSE
+                      kk = k-1
+                   ENDIF
+                   rifs  = 0.5_wp * (      rif_wall(k,j,i,wall_index) +        &
+                                      a  * rif_wall(k,j,i+1,1)        +        &
+                                      b  * rif_wall(k,j+1,i,2)        +        &
+                                      c1 * rif_wall(kk,j,i,3)         +        &
+                                      c2 * rif_wall(kk,j,i,4)                  &
+                                    )
+
+                   u_i   = 0.5_wp * ( u(k,j,i) + u(k,j,i+1) )
+                   v_i   = 0.5_wp * ( v(k,j,i) + v(k,j+1,i) )
+                   ws    = 0.5_wp * ( w(k,j,i) + w(k-1,j,i) )
+!
+!--                (2) Compute wall-parallel absolute velocity vel_total and
+!--                interpolate appropriate velocity component vel_zp.
+                   vel_total = SQRT( ws**2 + (a+c1) * u_i**2 + (b+c2) * v_i**2 )
+                   vel_zp    = 0.5_wp * ( a * u_i + b * v_i + (c1+c2) * ws )
+!
+!--                (3) Compute wall friction velocity us_wall
+                   IF ( rifs >= 0.0_wp )  THEN
+
+!
+!--                   Stable stratification (and neutral)
+                      us_wall = kappa * vel_total / ( LOG( zp / z0(j,i) ) +    &
+                                         5.0_wp * rifs * ( zp - z0(j,i) ) / zp &
+                                                    )
+                   ELSE
+
+!
+!--                   Unstable stratification
+                      h1 = SQRT( SQRT( 1.0_wp - 16.0_wp * rifs ) )
+                      h2 = SQRT( SQRT( 1.0_wp - 16.0_wp * rifs * z0(j,i) / zp ) )
+
+                      us_wall = kappa * vel_total / (                          &
+                           LOG( zp / z0(j,i) ) -                               &
+                           LOG( ( 1.0_wp + h1 )**2 * ( 1.0_wp + h1**2 ) / (    &
+                                ( 1.0_wp + h2 )**2 * ( 1.0_wp + h2**2 )   ) ) +&
+                                2.0_wp * ( ATAN( h1 ) - ATAN( h2 ) )           &
+                                                    )
+                   ENDIF
+
+!
+!--                Skip step (4) of wall_fluxes, because here rifs is already
+!--                available from (1)
+!
+!--                (5) Compute wall_flux (u'v', v'u', w'v', or w'u')
+
+                   IF ( rifs >= 0.0_wp )  THEN
+
+!
+!--                   Stable stratification (and neutral)
+                      wall_flux(k,j,i) = kappa *  vel_zp / (                   &
+                                         LOG( zp/z0(j,i) ) +                   &
+                                         5.0_wp * rifs * ( zp-z0(j,i) ) / zp   &
+                                                           )
+                   ELSE
+
+!
+!--                   Unstable stratification
+                      h1 = SQRT( SQRT( 1.0_wp - 16.0_wp * rifs ) )
+                      h2 = SQRT( SQRT( 1.0_wp - 16.0_wp * rifs * z0(j,i) / zp ) )
+
+                      wall_flux(k,j,i) = kappa * vel_zp / (                    &
+                           LOG( zp / z0(j,i) ) -                               &
+                           LOG( ( 1.0_wp + h1 )**2 * ( 1.0_wp + h1**2 ) / (    &
+                                ( 1.0_wp + h2 )**2 * ( 1.0_wp + h2**2 )   ) ) +&
+                                2.0_wp * ( ATAN( h1 ) - ATAN( h2 ) )           &
+                                                          )
+                   ENDIF
+                   wall_flux(k,j,i) = - wall_flux(k,j,i) * us_wall
+
+                ENDIF
+
+             ENDDO
+          ENDDO
+       ENDDO
+       !$acc end kernels
+
+    END SUBROUTINE wall_fluxes_e_acc
+
+
+!------------------------------------------------------------------------------!
+! Description:
+! ------------
+!> Call for grid point i,j
+!------------------------------------------------------------------------------!
+    SUBROUTINE wall_fluxes_e_ij( i, j, nzb_w, nzt_w, wall_flux, a, b, c1, c2 )
+
+       USE arrays_3d,                                                          &
+           ONLY:  rif_wall, u, v, w, z0
+       
+       USE control_parameters,                                                 &
+           ONLY:  kappa
+       
+       USE grid_variables,                                                     &
+           ONLY:  dx, dy
+       
+       USE indices,                                                            &
+           ONLY:  nzb, nzt
+       
+       USE kinds
+
+       IMPLICIT NONE
+
+       INTEGER(iwp) ::  i            !< 
+       INTEGER(iwp) ::  j            !< 
+       INTEGER(iwp) ::  k            !< 
+       INTEGER(iwp) ::  kk           !< 
+       INTEGER(iwp) ::  nzb_w        !< 
+       INTEGER(iwp) ::  nzt_w        !< 
+       INTEGER(iwp) ::  wall_index   !< 
+       
+       REAL(wp) ::  a           !< 
+       REAL(wp) ::  b           !< 
+       REAL(wp) ::  c1          !< 
+       REAL(wp) ::  c2          !< 
+       REAL(wp) ::  h1          !< 
+       REAL(wp) ::  h2          !< 
+       REAL(wp) ::  u_i         !< 
+       REAL(wp) ::  v_i         !< 
+       REAL(wp) ::  us_wall     !< 
+       REAL(wp) ::  vel_total   !< 
+       REAL(wp) ::  vel_zp      !< 
+       REAL(wp) ::  ws          !< 
+       REAL(wp) ::  zp          !< 
+       REAL(wp) ::  rifs        !< 
+
+       REAL(wp), DIMENSION(nzb:nzt+1) ::  wall_flux   !< 
+
+
+       zp         = 0.5_wp * ( (a+c1) * dy + (b+c2) * dx )
+       wall_flux  = 0.0_wp
+       wall_index = NINT( a+ 2*b + 3*c1 + 4*c2 )
+
+!
+!--    All subsequent variables are computed for scalar locations.
+       DO  k = nzb_w, nzt_w
+
+!
+!--       (1) Compute rifs, u_i, v_i, and ws
+          IF ( k == nzb_w )  THEN
+             kk = nzb_w
+          ELSE
+             kk = k-1
+          ENDIF
+          rifs  = 0.5_wp * (      rif_wall(k,j,i,wall_index) +                 &
+                             a  * rif_wall(k,j,i+1,1)        +                 &
+                             b  * rif_wall(k,j+1,i,2)        +                 &
+                             c1 * rif_wall(kk,j,i,3)         +                 &
+                             c2 * rif_wall(kk,j,i,4)                           &
+                           )
+
+          u_i   = 0.5_wp * ( u(k,j,i) + u(k,j,i+1) )
+          v_i   = 0.5_wp * ( v(k,j,i) + v(k,j+1,i) )
+          ws    = 0.5_wp * ( w(k,j,i) + w(k-1,j,i) )
+!
+!--       (2) Compute wall-parallel absolute velocity vel_total and
+!--       interpolate appropriate velocity component vel_zp.
+          vel_total = SQRT( ws**2 + (a+c1) * u_i**2 + (b+c2) * v_i**2 )
+          vel_zp    = 0.5_wp * ( a * u_i + b * v_i + (c1+c2) * ws )
+!
+!--       (3) Compute wall friction velocity us_wall
+          IF ( rifs >= 0.0_wp )  THEN
+
+!
+!--          Stable stratification (and neutral)
+             us_wall = kappa * vel_total / ( LOG( zp / z0(j,i) ) +             &
+                                         5.0_wp * rifs * ( zp - z0(j,i) ) / zp &
+                                           )
+          ELSE
+
+!
+!--          Unstable stratification
+             h1 = SQRT( SQRT( 1.0_wp - 16.0_wp * rifs ) )
+             h2 = SQRT( SQRT( 1.0_wp - 16.0_wp * rifs * z0(j,i) / zp ) )
+
+             us_wall = kappa * vel_total / (                                   &
+                  LOG( zp / z0(j,i) ) -                                        &
+                  LOG( ( 1.0_wp + h1 )**2 * ( 1.0_wp + h1**2 ) / (             &
+                       ( 1.0_wp + h2 )**2 * ( 1.0_wp + h2**2 )   ) ) +         &
+                       2.0_wp * ( ATAN( h1 ) - ATAN( h2 ) )                    &
+                                           )
+          ENDIF
+
+!
+!--       Skip step (4) of wall_fluxes, because here rifs is already
+!--       available from (1)
+!
+!--       (5) Compute wall_flux (u'v', v'u', w'v', or w'u')
+!--       First interpolate the velocity (this is different from 
+!--       subroutine wall_fluxes because fluxes in subroutine 
+!--       wall_fluxes_e are defined at scalar locations).
+          vel_zp = 0.5_wp * (       a * ( u(k,j,i) + u(k,j,i+1) ) +            &
+                                    b * ( v(k,j,i) + v(k,j+1,i) ) +            &
+                              (c1+c2) * ( w(k,j,i) + w(k-1,j,i) )              &
+                            )
+
+          IF ( rifs >= 0.0_wp )  THEN
+
+!
+!--          Stable stratification (and neutral)
+             wall_flux(k) = kappa *  vel_zp /                                  &
+                     ( LOG( zp/z0(j,i) ) + 5.0_wp * rifs * ( zp-z0(j,i) ) / zp )
+          ELSE
+
+!
+!--          Unstable stratification
+             h1 = SQRT( SQRT( 1.0_wp - 16.0_wp * rifs ) )
+             h2 = SQRT( SQRT( 1.0_wp - 16.0_wp * rifs * z0(j,i) / zp ) )
+
+             wall_flux(k) = kappa * vel_zp / (                                 &
+                  LOG( zp / z0(j,i) ) -                                        &
+                  LOG( ( 1.0_wp + h1 )**2 * ( 1.0_wp + h1**2 ) / (             &
+                       ( 1.0_wp + h2 )**2 * ( 1.0_wp + h2**2 )   ) ) +         &
+                       2.0_wp * ( ATAN( h1 ) - ATAN( h2 ) )                    &
+                                             )
+          ENDIF
+          wall_flux(k) = - wall_flux(k) * us_wall
+
+       ENDDO
+
+    END SUBROUTINE wall_fluxes_e_ij
+
+ END MODULE wall_fluxes_mod
