Index: palm/trunk/SOURCE/advec_ws.f90
===================================================================
--- palm/trunk/SOURCE/advec_ws.f90 (revision 3581)
+++ palm/trunk/SOURCE/advec_ws.f90 (revision 3582)
@@ -20,5 +20,6 @@
! Current revisions:
! ------------------
-!
+! Move the control parameter "salsa" from salsa_mod to control_parameters
+! (M. Kurppa)
!
! Former revisions:
@@ -317,5 +318,5 @@
USE control_parameters, &
ONLY: humidity, loop_optimization, passive_scalar, ocean_mode, &
- rans_tke_e, ws_scheme_mom, ws_scheme_sca
+ rans_tke_e, ws_scheme_mom, ws_scheme_sca, salsa
USE indices, &
@@ -399,8 +400,9 @@
sums_wssas_ws_l = 0.0_wp
ENDIF
-!
-!-- Mona: Now always allocated
- ALLOCATE( sums_salsa_ws_l(nzb:nzt+1,0:threads_per_task-1) )
- sums_salsa_ws_l = 0.0_wp
+
+ IF ( salsa ) THEN
+ ALLOCATE( sums_salsa_ws_l(nzb:nzt+1,0:threads_per_task-1) )
+ sums_salsa_ws_l = 0.0_wp
+ ENDIF
ENDIF
@@ -1115,5 +1117,5 @@
USE control_parameters, &
ONLY: humidity, passive_scalar, ocean_mode, ws_scheme_mom, &
- ws_scheme_sca
+ ws_scheme_sca, salsa
USE kinds
@@ -1158,8 +1160,6 @@
ENDIF
IF ( ocean_mode ) sums_wssas_ws_l = 0.0_wp
-
- sums_salsa_ws_l = 0.0_wp
-
-
+ IF ( salsa ) sums_salsa_ws_l = 0.0_wp
+
ENDIF
Index: palm/trunk/SOURCE/average_3d_data.f90
===================================================================
--- palm/trunk/SOURCE/average_3d_data.f90 (revision 3581)
+++ palm/trunk/SOURCE/average_3d_data.f90 (revision 3582)
@@ -20,6 +20,7 @@
! Current revisions:
! -----------------
-!
-!
+! Move the control parameter "salsa" from salsa_mod to control_parameters
+! (M. Kurppa)
+!
! Former revisions:
! -----------------
@@ -177,5 +178,5 @@
USE control_parameters, &
ONLY: air_chemistry, average_count_3d, biometeorology, doav, doav_n, &
- land_surface, ocean_mode, urban_surface, varnamelength
+ land_surface, ocean_mode, salsa, urban_surface, varnamelength
USE cpulog, &
@@ -200,5 +201,5 @@
USE salsa_mod, &
- ONLY: salsa, salsa_3d_data_averaging
+ ONLY: salsa_3d_data_averaging
USE turbulence_closure_mod, &
Index: palm/trunk/SOURCE/boundary_conds.f90
===================================================================
--- palm/trunk/SOURCE/boundary_conds.f90 (revision 3581)
+++ palm/trunk/SOURCE/boundary_conds.f90 (revision 3582)
@@ -20,5 +20,6 @@
! Current revisions:
! -----------------
-!
+! Move the control parameter "salsa" from salsa_mod to control_parameters
+! (M. Kurppa)
!
! Former revisions:
@@ -225,9 +226,9 @@
bc_dirichlet_s, bc_radiation_l, bc_radiation_n, bc_radiation_r, &
bc_radiation_s, bc_pt_t_val, bc_q_t_val, bc_s_t_val, &
- child_domain, constant_diffusion, coupling_mode, &
- dt_3d, humidity, ibc_pt_b, ibc_pt_t, ibc_q_b, ibc_q_t, ibc_s_b, &
- ibc_s_t, ibc_uv_b, ibc_uv_t, &
- intermediate_timestep_count, nesting_offline, nudging, &
- ocean_mode, passive_scalar, rans_mode, rans_tke_e, tsc, use_cmax
+ child_domain, constant_diffusion, coupling_mode, dt_3d, &
+ humidity, ibc_pt_b, ibc_pt_t, ibc_q_b, ibc_q_t, ibc_s_b, &
+ ibc_s_t, ibc_uv_b, ibc_uv_t, intermediate_timestep_count, &
+ nesting_offline, nudging, ocean_mode, passive_scalar, rans_mode,&
+ rans_tke_e, tsc, salsa, use_cmax
USE grid_variables, &
@@ -248,5 +249,5 @@
USE salsa_mod, &
- ONLY: salsa, salsa_boundary_conds
+ ONLY: salsa_boundary_conds
USE surface_mod, &
Index: palm/trunk/SOURCE/check_parameters.f90
===================================================================
--- palm/trunk/SOURCE/check_parameters.f90 (revision 3581)
+++ palm/trunk/SOURCE/check_parameters.f90 (revision 3582)
@@ -20,4 +20,6 @@
! Current revisions:
! -----------------
+! Move the control parameter "salsa" from salsa_mod to control_parameters
+! (M. Kurppa)
!
!
@@ -813,5 +815,5 @@
USE salsa_mod, &
- ONLY: salsa, salsa_check_data_output, salsa_check_parameters
+ ONLY: salsa_check_data_output, salsa_check_parameters
USE spectra_mod, &
@@ -821,6 +823,4 @@
USE subsidence_mod
-
- USE statistics
USE surface_output_mod, &
Index: palm/trunk/SOURCE/chem_emissions_mod.f90
===================================================================
--- palm/trunk/SOURCE/chem_emissions_mod.f90 (revision 3581)
+++ palm/trunk/SOURCE/chem_emissions_mod.f90 (revision 3582)
@@ -22,5 +22,7 @@
! Current revisions:
! ------------------
-!
+! - Removed salsa dependency.
+! - Enabled PARAMETRIZED mode for default surfaces when LSM is not applied but
+! salsa is (M. Kurppa)
!
! Former revisions:
@@ -890,6 +892,4 @@
USE indices, &
ONLY: nnx,nny,nnz
- USE salsa_mod, &
- ONLY: salsa
USE surface_mod, &
ONLY: surf_lsm_h,surf_def_h,surf_usm_h
@@ -1462,74 +1462,4 @@
ENDDO
- ELSEIF ( salsa ) THEN
- DO m = 1, surf_def_h(0)%ns
- i = surf_def_h(0)%i(m)
- j = surf_def_h(0)%j(m)
- k = surf_def_h(0)%k(m)
-
-
- IF ( street_type_f%var(j,i) >= main_street_id .AND. &
- street_type_f%var(j,i) < max_street_id ) &
- THEN
-
- !> Cycle over already matched species
- DO ispec=1,nspec_out
-
- !> PMs are already in mass units:micrograms: have to be converted to kilograms
- IF ( TRIM(spc_names(match_spec_model(ispec)))=="PM1" &
- .OR. TRIM(spc_names(match_spec_model(ispec)))=="PM25" &
- .OR. TRIM(spc_names(match_spec_model(ispec)))=="PM10")&
- THEN
-
- surf_def_h(0)%cssws(match_spec_model(ispec),m) = &
- emiss_factor_main(match_spec_input(ispec)) * &
- emis_distribution(1,j,i,ispec) * rho_air(k) /&
- time_factor(1)
- ELSE
-
- !> Other Species: inputs are micromoles: have to be converted
- surf_def_h(0)%cssws(match_spec_model(ispec),m) = &
- emiss_factor_main(match_spec_input(ispec)) * &
- emis_distribution(1,j,i,ispec) * &
- conv_to_ratio(k,j,i) * rho_air(k) / time_factor(1)
- ENDIF
- ENDDO
-
- ELSEIF ( street_type_f%var(j,i) >= side_street_id .AND. &
- street_type_f%var(j,i) < main_street_id ) &
- THEN
-
- !> Cycle over already matched species
- DO ispec=1,nspec_out
-
- !> PMs are already in mass units: micrograms
- IF ( TRIM(spc_names(match_spec_model(ispec)))=="PM1" &
- .OR. TRIM(spc_names(match_spec_model(ispec)))=="PM25" &
- .OR. TRIM(spc_names(match_spec_model(ispec)))=="PM10")&
- THEN
-
- surf_def_h(0)%cssws(match_spec_model(ispec),m) = &
- emiss_factor_side(match_spec_input(ispec)) * &
- emis_distribution(1,j,i,ispec) * rho_air(k) / &
- time_factor(1)
- ELSE
-
- surf_def_h(0)%cssws(match_spec_model(ispec),m) = &
- emiss_factor_side(match_spec_input(ispec)) * &
- emis_distribution(1,j,i,ispec) * &
- conv_to_ratio(k,j,i) * rho_air(k) / time_factor(1)
- ENDIF
-
- ENDDO
-
- ELSE
-
- !> If no street type is defined, then assign null emissions to all the species
- surf_def_h(0)%cssws(:,m) = 0.0_wp
-
- ENDIF
-
- ENDDO
-
ENDIF
Index: palm/trunk/SOURCE/data_output_2d.f90
===================================================================
--- palm/trunk/SOURCE/data_output_2d.f90 (revision 3581)
+++ palm/trunk/SOURCE/data_output_2d.f90 (revision 3582)
@@ -20,5 +20,6 @@
! Current revisions:
! ------------------
-!
+! Move the control parameter "salsa" from salsa_mod to control_parameters
+! (M. Kurppa)
!
! Former revisions:
@@ -294,5 +295,5 @@
ibc_uv_b, io_blocks, io_group, land_surface, message_string, &
ntdim_2d_xy, ntdim_2d_xz, ntdim_2d_yz, &
- ocean_mode, psolver, section, simulated_time, &
+ ocean_mode, psolver, salsa, section, simulated_time, &
time_since_reference_point
@@ -334,5 +335,5 @@
USE salsa_mod, &
- ONLY: salsa, salsa_data_output_2d
+ ONLY: salsa_data_output_2d
USE surface_mod, &
@@ -1353,6 +1354,7 @@
IF ( .NOT. found .AND. salsa ) THEN
- CALL salsa_data_output_2d( av, do2d(av,ivar), found, grid, &
- mode, local_pf, two_d )
+ CALL salsa_data_output_2d( av, do2d(av,ivar), found, grid, &
+ mode, local_pf, two_d, nzb_do, &
+ nzt_do)
ENDIF
Index: palm/trunk/SOURCE/data_output_3d.f90
===================================================================
--- palm/trunk/SOURCE/data_output_3d.f90 (revision 3581)
+++ palm/trunk/SOURCE/data_output_3d.f90 (revision 3582)
@@ -20,6 +20,7 @@
! Current revisions:
! ------------------
-!
-!
+! Move the control parameter "salsa" from salsa_mod to control_parameters
+! (M. Kurppa)
+!
! Former revisions:
! -----------------
@@ -254,5 +255,5 @@
io_blocks, io_group, land_surface, message_string, &
ntdim_3d, nz_do3d, ocean_mode, plant_canopy, &
- psolver, simulated_time, time_since_reference_point, &
+ psolver, salsa, simulated_time, time_since_reference_point, &
urban_surface, varnamelength
@@ -302,5 +303,5 @@
USE salsa_mod, &
- ONLY: salsa, salsa_data_output_3d
+ ONLY: salsa_data_output_3d
USE turbulence_closure_mod, &
@@ -791,5 +792,6 @@
!-- SALSA output
IF ( .NOT. found .AND. salsa ) THEN
- CALL salsa_data_output_3d( av, do3d(av,ivar), found, local_pf )
+ CALL salsa_data_output_3d( av, do3d(av,ivar), found, local_pf, &
+ nzb_do, nzt_do )
resorted = .TRUE.
ENDIF
Index: palm/trunk/SOURCE/data_output_mask.f90
===================================================================
--- palm/trunk/SOURCE/data_output_mask.f90 (revision 3581)
+++ palm/trunk/SOURCE/data_output_mask.f90 (revision 3582)
@@ -20,5 +20,5 @@
! Current revisions:
! -----------------
-!
+! Move the control parameter "salsa" from salsa_mod.f90 to control_parameters
!
! Former revisions:
@@ -165,5 +165,5 @@
mask_j, mask_k, mask_size, mask_size_l, mask_start_l, &
mask_surface, &
- max_masks, message_string, mid, nz_do3d, simulated_time
+ max_masks, message_string, mid, nz_do3d, salsa, simulated_time
USE cpulog, &
ONLY: cpu_log, log_point
@@ -193,5 +193,5 @@
USE salsa_mod, &
- ONLY: salsa, salsa_data_output_mask
+ ONLY: salsa_data_output_mask
USE surface_mod, &
Index: palm/trunk/SOURCE/header.f90
===================================================================
--- palm/trunk/SOURCE/header.f90 (revision 3581)
+++ palm/trunk/SOURCE/header.f90 (revision 3582)
@@ -20,6 +20,7 @@
! Current revisions:
! -----------------
-!
-!
+! Move the control parameter "salsa" from salsa_mod to control_parameters
+! (M. Kurppa)
+!
! Former revisions:
! -----------------
@@ -501,5 +502,5 @@
USE salsa_mod, &
- ONLY: salsa, salsa_header
+ ONLY: salsa_header
USE spectra_mod, &
Index: palm/trunk/SOURCE/init_3d_model.f90
===================================================================
--- palm/trunk/SOURCE/init_3d_model.f90 (revision 3581)
+++ palm/trunk/SOURCE/init_3d_model.f90 (revision 3582)
@@ -20,5 +20,6 @@
! Current revisions:
! ------------------
-!
+! Move the control parameter "salsa" from salsa_mod to control_parameters
+! (M. Kurppa)
!
! Former revisions:
@@ -655,5 +656,5 @@
USE salsa_mod, &
- ONLY: salsa, salsa_init, salsa_init_arrays
+ ONLY: salsa_init, salsa_init_arrays
USE statistics, &
Index: palm/trunk/SOURCE/init_masks.f90
===================================================================
--- palm/trunk/SOURCE/init_masks.f90 (revision 3581)
+++ palm/trunk/SOURCE/init_masks.f90 (revision 3582)
@@ -20,5 +20,6 @@
! Current revisions:
! -----------------
-!
+! Move the control parameter "salsa" from salsa_mod to control_parameters
+! (M. Kurppa)
!
! Former revisions:
@@ -173,5 +174,5 @@
mask_x_loop, mask_xyz_dimension, mask_y, mask_y_loop, mask_z, &
mask_z_loop, max_masks, message_string, mid, &
- passive_scalar, ocean_mode, varnamelength
+ passive_scalar, ocean_mode, salsa, varnamelength
USE grid_variables, &
@@ -190,10 +191,10 @@
USE pegrid
-
+
USE radiation_model_mod, &
ONLY: radiation, radiation_check_data_output
USE salsa_mod, &
- ONLY: salsa, salsa_check_data_output
+ ONLY: salsa_check_data_output
IMPLICIT NONE
Index: palm/trunk/SOURCE/modules.f90
===================================================================
--- palm/trunk/SOURCE/modules.f90 (revision 3581)
+++ palm/trunk/SOURCE/modules.f90 (revision 3582)
@@ -20,5 +20,6 @@
! Current revisions:
! ------------------
-!
+! Move the control parameter "salsa" from salsa_mod to control_parameters
+! (M. Kurppa)
!
! Former revisions:
@@ -1387,4 +1388,5 @@
LOGICAL :: run_control_header = .FALSE. !< onetime output of RUN_CONTROL header
LOGICAL :: run_coupled = .TRUE. !< internal switch telling PALM to run in coupled mode (i.e. to exchange surface data) in case of atmosphere-ocean coupling
+ LOGICAL :: salsa = .FALSE. !< switch for the sectional aerosol module salsa
LOGICAL :: scalar_rayleigh_damping = .TRUE. !< namelist parameter
LOGICAL :: sloping_surface = .FALSE. !< use sloped surface? (namelist parameter alpha_surface)
Index: palm/trunk/SOURCE/netcdf_interface_mod.f90
===================================================================
--- palm/trunk/SOURCE/netcdf_interface_mod.f90 (revision 3581)
+++ palm/trunk/SOURCE/netcdf_interface_mod.f90 (revision 3582)
@@ -20,5 +20,6 @@
! Current revisions:
! ------------------
-!
+! Move the control parameter "salsa" from salsa_mod to control_parameters
+! (M. Kurppa)
!
! Former revisions:
@@ -646,5 +647,5 @@
message_string, mid, ntdim_2d_xy, ntdim_2d_xz, &
ntdim_2d_yz, ntdim_3d, nz_do3d, ocean_mode, plant_canopy, &
- run_description_header, section, simulated_time, &
+ run_description_header, salsa, section, simulated_time, &
simulated_time_at_begin, skip_time_data_output_av, &
skip_time_do2d_xy, skip_time_do2d_xz, skip_time_do2d_yz, &
@@ -684,5 +685,5 @@
USE salsa_mod, &
- ONLY: salsa, salsa_define_netcdf_grid
+ ONLY: salsa_define_netcdf_grid
USE spectra_mod, &
@@ -1147,5 +1148,5 @@
CALL salsa_define_netcdf_grid( domask(mid,av,i), found, &
grid_x, grid_y, grid_z )
- ENDIF
+ ENDIF
!
!-- Now check for user-defined quantities
@@ -1910,5 +1911,5 @@
grid_y, grid_z )
ENDIF
-
+!
!-- Check for user-defined quantities
IF ( .NOT. found ) THEN
@@ -2856,5 +2857,5 @@
grid_z )
ENDIF
-
+
!
!-- Check for SALSA quantities
@@ -3758,5 +3759,4 @@
grid_z )
ENDIF
-
!
!-- Check for SALSA quantities
@@ -4618,5 +4618,4 @@
grid_z )
ENDIF
-
!
!-- Check for SALSA quantities
Index: palm/trunk/SOURCE/plant_canopy_model_mod.f90
===================================================================
--- palm/trunk/SOURCE/plant_canopy_model_mod.f90 (revision 3581)
+++ palm/trunk/SOURCE/plant_canopy_model_mod.f90 (revision 3582)
@@ -22,5 +22,5 @@
! Current revisions:
! ------------------
-!
+! Formatting adjustments
!
! Former revisions:
@@ -1679,16 +1679,16 @@
! to include also the dependecy to the radiation
! in the plant canopy box
- pc_transpiration_rate(kk,j,i) = - lsec &
- * lad_s(kk,j,i) * &
- SQRT( ( 0.5_wp * ( u(k,j,i) + &
- u(k,j,i+1) ) &
- )**2 + &
- ( 0.5_wp * ( v(k,j,i) + &
- v(k,j+1,i) ) &
- )**2 + &
- ( 0.5_wp * ( w(k-1,j,i) + &
- w(k,j,i) ) &
- )**2 &
- ) * &
+ pc_transpiration_rate(kk,j,i) = - lsec &
+ * lad_s(kk,j,i) * &
+ SQRT( ( 0.5_wp * ( u(k,j,i) + &
+ u(k,j,i+1) ) &
+ )**2 + &
+ ( 0.5_wp * ( v(k,j,i) + &
+ v(k,j+1,i) ) &
+ )**2 + &
+ ( 0.5_wp * ( w(k-1,j,i) + &
+ w(k,j,i) ) &
+ )**2 &
+ ) * &
( q(k,j,i) - lsc )
ENDIF
@@ -2001,5 +2001,6 @@
DO k = k_wall + 1, k_wall + pch_index_ji(j,i)
kk = k - k_wall !- lad arrays are defined flat
- tend(k,j,i) = tend(k,j,i) + pc_heating_rate(kk,j,i) - pc_latent_rate(kk,j,i)
+ tend(k,j,i) = tend(k,j,i) + pc_heating_rate(kk,j,i) - &
+ pc_latent_rate(kk,j,i)
ENDDO
ELSE
@@ -2024,16 +2025,16 @@
! to include also the dependecy to the radiation
! in the plant canopy box
- pc_transpiration_rate(kk,j,i) = - lsec &
- * lad_s(kk,j,i) * &
- SQRT( ( 0.5_wp * ( u(k,j,i) + &
- u(k,j,i+1) ) &
- )**2 + &
- ( 0.5_wp * ( v(k,j,i) + &
- v(k,j+1,i) ) &
- )**2 + &
- ( 0.5_wp * ( w(k-1,j,i) + &
- w(k,j,i) ) &
- )**2 &
- ) * &
+ pc_transpiration_rate(kk,j,i) = - lsec &
+ * lad_s(kk,j,i) * &
+ SQRT( ( 0.5_wp * ( u(k,j,i) + &
+ u(k,j,i+1) ) &
+ )**2 + &
+ ( 0.5_wp * ( v(k,j,i) + &
+ v(k,j+1,i) ) &
+ )**2 + &
+ ( 0.5_wp * ( w(k-1,j,i) + &
+ w(k,j,i) ) &
+ )**2 &
+ ) * &
( q(k,j,i) - lsc )
ENDIF
Index: palm/trunk/SOURCE/prognostic_equations.f90
===================================================================
--- palm/trunk/SOURCE/prognostic_equations.f90 (revision 3581)
+++ palm/trunk/SOURCE/prognostic_equations.f90 (revision 3582)
@@ -20,5 +20,6 @@
! Current revisions:
! ------------------
-!
+! Move the control parameter "salsa" from salsa_mod to control_parameters
+! (M. Kurppa)
!
! Former revisions:
@@ -373,5 +374,5 @@
use_upstream_for_tke, wind_turbine, ws_scheme_mom, &
ws_scheme_sca, urban_surface, land_surface, &
- time_since_reference_point
+ time_since_reference_point, salsa
USE coriolis_mod, &
@@ -415,5 +416,5 @@
USE salsa_mod, &
ONLY: aerosol_mass, aerosol_number, dt_salsa, last_salsa_time, nbins, &
- ncc_tot, ngast, salsa, salsa_boundary_conds, salsa_diagnostics, &
+ ncc_tot, ngast, salsa_boundary_conds, salsa_diagnostics, &
salsa_driver, salsa_gas, salsa_gases_from_chem, salsa_tendency, &
skip_time_do_salsa
@@ -548,5 +549,4 @@
ENDIF
-
!
!-- Run SALSA and aerosol dynamic processes. SALSA is run with a longer time
Index: palm/trunk/SOURCE/read_restart_data_mod.f90
===================================================================
--- palm/trunk/SOURCE/read_restart_data_mod.f90 (revision 3581)
+++ palm/trunk/SOURCE/read_restart_data_mod.f90 (revision 3582)
@@ -20,5 +20,6 @@
! Current revisions:
! -----------------
-!
+! Move the control parameter "salsa" from salsa_mod to control_parameters
+! (M. Kurppa)
!
! Former revisions:
@@ -1087,5 +1088,5 @@
USE salsa_mod, &
- ONLY: salsa, salsa_rrd_local
+ ONLY: salsa_rrd_local
USE surface_mod, &
@@ -1910,9 +1911,10 @@
nyn_on_file, nysf, nysc, &
nys_on_file, found )
-!
-!-- Read salsa restart data
- IF ( .NOT. found .AND. salsa ) THEN
- CALL salsa_rrd_local
- ENDIF
+
+ IF ( .NOT. found .AND. salsa ) CALL salsa_rrd_local( i, &
+ k, nxlf, nxlc, nxl_on_file, nxrf, &
+ nxrc, nxr_on_file, nynf, nync, &
+ nyn_on_file, nysf, nysc, &
+ nys_on_file, tmp_3d, found )
!
Index: palm/trunk/SOURCE/salsa_mod.f90
===================================================================
--- palm/trunk/SOURCE/salsa_mod.f90 (revision 3581)
+++ palm/trunk/SOURCE/salsa_mod.f90 (revision 3582)
@@ -15,4 +15,5 @@
! PALM. If not, see .
!
+! Copyright 2018-2018 University of Helsinki
! Copyright 1997-2018 Leibniz Universitaet Hannover
!--------------------------------------------------------------------------------!
@@ -20,6 +21,10 @@
! Current revisions:
! -----------------
-!
-!
+! - Moved the control parameter "salsa" from salsa_mod.f90 to control_parameters
+! - Updated salsa_rrd_local and salsa_wrd_local
+! - Add target attribute
+! - Revise initialization in case of restarts
+! - Revise masked data output
+!
! Former revisions:
! -----------------
@@ -44,6 +49,6 @@
! Authors:
! --------
-! @author monakurppa
-!
+! @author Mona Kurppa (University of Helsinki)
+!
!
! Description:
@@ -60,6 +65,4 @@
!>
!> @todo Implement turbulent inflow of aerosols in inflow_turbulence.
-!> @todo Deposition on walls and horizontal surfaces calculated from the aerosol
-!> dry radius, not wet
!> @todo Deposition on subgrid scale vegetation
!> @todo Deposition on vegetation calculated by default for deciduous broadleaf
@@ -197,5 +200,4 @@
!< chemical components
LOGICAL :: read_restart_data_salsa = .FALSE. !< read restart data for salsa
- LOGICAL :: salsa = .FALSE. !< SALSA master switch
LOGICAL :: salsa_gases_from_chem = .FALSE. !< Transfer the gaseous
!< components to SALSA from
@@ -420,9 +422,11 @@
!< OC
!-- Integrated:
- REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: LDSA_av !< lung deposited
- !< surface area
- REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: Ntot_av !< total number conc.
- REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: PM25_av !< PM2.5
- REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: PM10_av !< PM10
+ REAL(wp), ALLOCATABLE, DIMENSION(:,:,:), TARGET :: LDSA_av !< lung-
+ !< deposited
+ !< surface area
+ REAL(wp), ALLOCATABLE, DIMENSION(:,:,:), TARGET :: Ntot_av !< total number
+ !< conc.
+ REAL(wp), ALLOCATABLE, DIMENSION(:,:,:), TARGET :: PM25_av !< PM2.5
+ REAL(wp), ALLOCATABLE, DIMENSION(:,:,:), TARGET :: PM10_av !< PM10
!-- In the particle phase:
REAL(wp), ALLOCATABLE, DIMENSION(:,:,:), TARGET :: s_BC_av !< black carbon
@@ -435,9 +439,8 @@
REAL(wp), ALLOCATABLE, DIMENSION(:,:,:), TARGET :: s_SS_av !< sea salt
!-- Bins:
- REAL(wp), ALLOCATABLE, DIMENSION(:,:,:,:) :: mbins_av !< bin mass
- !< concentration
- REAL(wp), ALLOCATABLE, DIMENSION(:,:,:,:) :: Nbins_av !< bin number
- !< concentration
-
+ REAL(wp), ALLOCATABLE, DIMENSION(:,:,:,:), TARGET :: mbins_av !< bin mass
+ REAL(wp), ALLOCATABLE, DIMENSION(:,:,:,:), TARGET :: Nbins_av !< bin number
+
+
!
!-- PALM interfaces:
@@ -564,4 +567,5 @@
mconc_2, nbins, ncc, ncc_tot, nclim, nconc_2, ngast, prtcl, Ra_dry, &
salsa_gas, sedim_vd
+
CONTAINS
@@ -688,6 +692,5 @@
!
-!-- Set flag that indicates that the new module is switched on
-!-- Note that this parameter needs to be declared in modules.f90
+!-- Enable salsa (salsa switch in modules.f90)
salsa = .TRUE.
@@ -1230,82 +1233,79 @@
ENDDO
- IF ( nldepo ) sedim_vd = 0.0_wp
+ IF ( nldepo ) sedim_vd = 0.0_wp
+
+ DO b = 1, nbins
+ IF ( .NOT. read_restart_data_salsa ) aerosol_number(b)%conc = nclim
+ aerosol_number(b)%conc_p = 0.0_wp
+ aerosol_number(b)%tconc_m = 0.0_wp
+ aerosol_number(b)%flux_s = 0.0_wp
+ aerosol_number(b)%diss_s = 0.0_wp
+ aerosol_number(b)%flux_l = 0.0_wp
+ aerosol_number(b)%diss_l = 0.0_wp
+ aerosol_number(b)%init = nclim
+ aerosol_number(b)%sums_ws_l = 0.0_wp
+ ENDDO
+ DO c = 1, ncc_tot*nbins
+ IF ( .NOT. read_restart_data_salsa ) aerosol_mass(c)%conc = mclim
+ aerosol_mass(c)%conc_p = 0.0_wp
+ aerosol_mass(c)%tconc_m = 0.0_wp
+ aerosol_mass(c)%flux_s = 0.0_wp
+ aerosol_mass(c)%diss_s = 0.0_wp
+ aerosol_mass(c)%flux_l = 0.0_wp
+ aerosol_mass(c)%diss_l = 0.0_wp
+ aerosol_mass(c)%init = mclim
+ aerosol_mass(c)%sums_ws_l = 0.0_wp
+ ENDDO
+
+ IF ( .NOT. salsa_gases_from_chem ) THEN
+ DO g = 1, ngast
+ salsa_gas(g)%conc_p = 0.0_wp
+ salsa_gas(g)%tconc_m = 0.0_wp
+ salsa_gas(g)%flux_s = 0.0_wp
+ salsa_gas(g)%diss_s = 0.0_wp
+ salsa_gas(g)%flux_l = 0.0_wp
+ salsa_gas(g)%diss_l = 0.0_wp
+ salsa_gas(g)%sums_ws_l = 0.0_wp
+ ENDDO
+ IF ( .NOT. read_restart_data_salsa ) THEN
+ salsa_gas(1)%conc = H2SO4_init
+ salsa_gas(2)%conc = HNO3_init
+ salsa_gas(3)%conc = NH3_init
+ salsa_gas(4)%conc = OCNV_init
+ salsa_gas(5)%conc = OCSV_init
+ ENDIF
+!
+!-- Set initial value for gas compound tracers and initial values
+ salsa_gas(1)%init = H2SO4_init
+ salsa_gas(2)%init = HNO3_init
+ salsa_gas(3)%init = NH3_init
+ salsa_gas(4)%init = OCNV_init
+ salsa_gas(5)%init = OCSV_init
+ ENDIF
+!
+!-- Aerosol radius in each bin: dry and wet (m)
+ Ra_dry = 1.0E-10_wp
!
-!-- Initilisation actions that are NOT conducted for restart runs
- IF ( .NOT. read_restart_data_salsa ) THEN
-
- DO b = 1, nbins
- aerosol_number(b)%conc = nclim
- aerosol_number(b)%conc_p = 0.0_wp
- aerosol_number(b)%tconc_m = 0.0_wp
- aerosol_number(b)%flux_s = 0.0_wp
- aerosol_number(b)%diss_s = 0.0_wp
- aerosol_number(b)%flux_l = 0.0_wp
- aerosol_number(b)%diss_l = 0.0_wp
- aerosol_number(b)%init = nclim
- aerosol_number(b)%sums_ws_l = 0.0_wp
+!-- Initialise aerosol tracers
+ aero(:)%vhilim = 0.0_wp
+ aero(:)%vlolim = 0.0_wp
+ aero(:)%vratiohi = 0.0_wp
+ aero(:)%vratiolo = 0.0_wp
+ aero(:)%dmid = 0.0_wp
+!
+!-- Initialise the sectional particle size distribution
+ CALL set_sizebins()
+!
+!-- Initialise location-dependent aerosol size distributions and
+!-- chemical compositions:
+ CALL aerosol_init
+!
+!-- Initalisation run of SALSA
+ DO i = nxl, nxr
+ DO j = nys, nyn
+ CALL salsa_driver( i, j, 1 )
+ CALL salsa_diagnostics( i, j )
ENDDO
- DO c = 1, ncc_tot*nbins
- aerosol_mass(c)%conc = mclim
- aerosol_mass(c)%conc_p = 0.0_wp
- aerosol_mass(c)%tconc_m = 0.0_wp
- aerosol_mass(c)%flux_s = 0.0_wp
- aerosol_mass(c)%diss_s = 0.0_wp
- aerosol_mass(c)%flux_l = 0.0_wp
- aerosol_mass(c)%diss_l = 0.0_wp
- aerosol_mass(c)%init = mclim
- aerosol_mass(c)%sums_ws_l = 0.0_wp
- ENDDO
-
- IF ( .NOT. salsa_gases_from_chem ) THEN
- DO g = 1, ngast
- salsa_gas(g)%conc_p = 0.0_wp
- salsa_gas(g)%tconc_m = 0.0_wp
- salsa_gas(g)%flux_s = 0.0_wp
- salsa_gas(g)%diss_s = 0.0_wp
- salsa_gas(g)%flux_l = 0.0_wp
- salsa_gas(g)%diss_l = 0.0_wp
- salsa_gas(g)%sums_ws_l = 0.0_wp
- ENDDO
-
-!
-!-- Set initial value for gas compound tracers and initial values
- salsa_gas(1)%conc = H2SO4_init
- salsa_gas(1)%init = H2SO4_init
- salsa_gas(2)%conc = HNO3_init
- salsa_gas(2)%init = HNO3_init
- salsa_gas(3)%conc = NH3_init
- salsa_gas(3)%init = NH3_init
- salsa_gas(4)%conc = OCNV_init
- salsa_gas(4)%init = OCNV_init
- salsa_gas(5)%conc = OCSV_init
- salsa_gas(5)%init = OCSV_init
- ENDIF
-!
-!-- Aerosol radius in each bin: dry and wet (m)
- Ra_dry = 1.0E-10_wp
-!
-!-- Initialise aerosol tracers
- aero(:)%vhilim = 0.0_wp
- aero(:)%vlolim = 0.0_wp
- aero(:)%vratiohi = 0.0_wp
- aero(:)%vratiolo = 0.0_wp
- aero(:)%dmid = 0.0_wp
-!
-!-- Initialise the sectional particle size distribution
- CALL set_sizebins()
-!
-!-- Initialise location-dependent aerosol size distributions and
-!-- chemical compositions:
- CALL aerosol_init
-!
-!-- Initalisation run of SALSA
- DO i = nxl, nxr
- DO j = nys, nyn
- CALL salsa_driver( i, j, 1 )
- CALL salsa_diagnostics( i, j )
- ENDDO
- ENDDO
- ENDIF
+ ENDDO
!
!-- Set the aerosol and gas sources
@@ -1419,6 +1419,6 @@
USE netcdf_data_input_mod, &
- ONLY: get_attribute, netcdf_data_input_get_dimension_length, &
- get_variable, open_read_file
+ ONLY: get_attribute, get_variable, &
+ netcdf_data_input_get_dimension_length, open_read_file
IMPLICIT NONE
@@ -1485,5 +1485,6 @@
!
!-- Input heights
- CALL netcdf_data_input_get_dimension_length( id_faero, nz_file, "profile_z" )
+ CALL netcdf_data_input_get_dimension_length( id_faero, nz_file, &
+ "profile_z" )
ALLOCATE( pr_z(nz_file), pr_mass_fracs_a(maxspec,nz_file), &
@@ -1628,5 +1629,6 @@
!
!-- Input heights
- CALL netcdf_data_input_get_dimension_length( id_fchem, nz_file, "profile_z" )
+ CALL netcdf_data_input_get_dimension_length( id_fchem, nz_file, &
+ "profile_z" )
ALLOCATE( pr_z(nz_file), pr_gas(ngast,nz_file) )
CALL get_variable( id_fchem, 'profile_z', pr_z )
@@ -2025,5 +2027,7 @@
!> This routine reads the respective restart data.
!------------------------------------------------------------------------------!
- SUBROUTINE salsa_rrd_local
+ SUBROUTINE salsa_rrd_local( i, k, nxlf, nxlc, nxl_on_file, nxrf, nxrc, &
+ nxr_on_file, nynf, nync, nyn_on_file, nysf, &
+ nysc, nys_on_file, tmp_3d, found )
@@ -2035,42 +2039,57 @@
INTEGER(iwp) :: g !<
INTEGER(iwp) :: i !<
- INTEGER(iwp) :: j !<
- INTEGER(iwp) :: k !<
+ INTEGER(iwp) :: k !<
+ INTEGER(iwp) :: nxlc !<
+ INTEGER(iwp) :: nxlf !<
+ INTEGER(iwp) :: nxl_on_file !<
+ INTEGER(iwp) :: nxrc !<
+ INTEGER(iwp) :: nxrf !<
+ INTEGER(iwp) :: nxr_on_file !<
+ INTEGER(iwp) :: nync !<
+ INTEGER(iwp) :: nynf !<
+ INTEGER(iwp) :: nyn_on_file !<
+ INTEGER(iwp) :: nysc !<
+ INTEGER(iwp) :: nysf !<
+ INTEGER(iwp) :: nys_on_file !<
+
+ LOGICAL, INTENT(OUT) :: found
+
+ REAL(wp), &
+ DIMENSION(nzb:nzt+1,nys_on_file-nbgp:nyn_on_file+nbgp,nxl_on_file-nbgp:nxr_on_file+nbgp) :: tmp_3d !<
+
+ found = .FALSE.
IF ( read_restart_data_salsa ) THEN
- READ ( 13 ) field_char
-
- DO WHILE ( TRIM( field_char ) /= '*** end salsa ***' )
+
+ SELECT CASE ( restart_string(1:length) )
- DO b = 1, nbins
- READ ( 13 ) aero(b)%vlolim
- READ ( 13 ) aero(b)%vhilim
- READ ( 13 ) aero(b)%dmid
- READ ( 13 ) aero(b)%vratiohi
- READ ( 13 ) aero(b)%vratiolo
- ENDDO
-
- DO i = nxl, nxr
- DO j = nys, nyn
- DO k = nzb+1, nzt
- DO b = 1, nbins
- READ ( 13 ) aerosol_number(b)%conc(k,j,i)
- DO c = 1, ncc_tot
- READ ( 13 ) aerosol_mass((c-1)*nbins+b)%conc(k,j,i)
- ENDDO
- ENDDO
- IF ( .NOT. salsa_gases_from_chem ) THEN
- DO g = 1, ngast
- READ ( 13 ) salsa_gas(g)%conc(k,j,i)
- ENDDO
- ENDIF
- ENDDO
+ CASE ( 'aerosol_number' )
+ DO b = 1, nbins
+ IF ( k == 1 ) READ ( 13 ) tmp_3d
+ aerosol_number(b)%conc(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
+ tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
+ found = .TRUE.
ENDDO
- ENDDO
-
- READ ( 13 ) field_char
-
- ENDDO
+ CASE ( 'aerosol_mass' )
+ DO c = 1, ncc_tot * nbins
+ IF ( k == 1 ) READ ( 13 ) tmp_3d
+ aerosol_mass(c)%conc(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
+ tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
+ found = .TRUE.
+ ENDDO
+
+ CASE ( 'salsa_gas' )
+ DO g = 1, ngast
+ IF ( k == 1 ) READ ( 13 ) tmp_3d
+ salsa_gas(g)%conc(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
+ tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
+ found = .TRUE.
+ ENDDO
+
+ CASE DEFAULT
+ found = .FALSE.
+
+ END SELECT
ENDIF
@@ -2093,37 +2112,21 @@
INTEGER(iwp) :: c !<
INTEGER(iwp) :: g !<
- INTEGER(iwp) :: i !<
- INTEGER(iwp) :: j !<
- INTEGER(iwp) :: k !<
IF ( write_binary .AND. write_binary_salsa ) THEN
-
- DO b = 1, nbins
- WRITE ( 14 ) aero(b)%vlolim
- WRITE ( 14 ) aero(b)%vhilim
- WRITE ( 14 ) aero(b)%dmid
- WRITE ( 14 ) aero(b)%vratiohi
- WRITE ( 14 ) aero(b)%vratiolo
+
+ CALL wrd_write_string( 'aerosol_number' )
+ DO b = 1, nbins
+ WRITE ( 14 ) aerosol_number(b)%conc
ENDDO
- DO i = nxl, nxr
- DO j = nys, nyn
- DO k = nzb+1, nzt
- DO b = 1, nbins
- WRITE ( 14 ) aerosol_number(b)%conc(k,j,i)
- DO c = 1, ncc_tot
- WRITE ( 14 ) aerosol_mass((c-1)*nbins+b)%conc(k,j,i)
- ENDDO
- ENDDO
- IF ( .NOT. salsa_gases_from_chem ) THEN
- DO g = 1, ngast
- WRITE ( 14 ) salsa_gas(g)%conc(k,j,i)
- ENDDO
- ENDIF
- ENDDO
- ENDDO
+ CALL wrd_write_string( 'aerosol_mass' )
+ DO c = 1, nbins*ncc_tot
+ WRITE ( 14 ) aerosol_mass(c)%conc
ENDDO
- WRITE ( 14 ) '*** end salsa *** '
+ CALL wrd_write_string( 'salsa_gas' )
+ DO g = 1, ngast
+ WRITE ( 14 ) salsa_gas(g)%conc
+ ENDDO
ENDIF
@@ -2765,33 +2768,33 @@
USE arrays_3d, &
ONLY: p, pt, q, zu
-
+
USE basic_constants_and_equations_mod, &
- ONLY: barometric_formula, exner_function, ideal_gas_law_rho, magnus
-
+ ONLY: barometric_formula, exner_function, ideal_gas_law_rho, magnus
+
USE control_parameters, &
ONLY: pt_surface, surface_pressure
-
+
IMPLICIT NONE
INTEGER(iwp), INTENT(in) :: i
- INTEGER(iwp), INTENT(in) :: j
+ INTEGER(iwp), INTENT(in) :: j
REAL(wp), DIMENSION(:), INTENT(inout) :: adn_ij
- REAL(wp), DIMENSION(:), INTENT(inout) :: p_ij
+ REAL(wp), DIMENSION(:), INTENT(inout) :: p_ij
REAL(wp), DIMENSION(:), INTENT(inout) :: temp_ij
REAL(wp), DIMENSION(:), INTENT(inout), OPTIONAL :: cw_ij
- REAL(wp), DIMENSION(:), INTENT(inout), OPTIONAL :: cs_ij
- REAL(wp), DIMENSION(nzb:nzt+1) :: e_s !< saturation vapour pressure
+ REAL(wp), DIMENSION(:), INTENT(inout), OPTIONAL :: cs_ij
+ REAL(wp), DIMENSION(nzb:nzt+1) :: e_s !< saturation vapour pressure
!< over water (Pa)
REAL(wp) :: t_surface !< absolute surface temperature (K)
!
!-- Pressure p_ijk (Pa) = hydrostatic pressure + perturbation pressure (p)
- t_surface = pt_surface * exner_function( surface_pressure )
- p_ij(:) = 100.0_wp * barometric_formula( zu, t_surface, surface_pressure ) &
+ t_surface = pt_surface * exner_function( surface_pressure * 100.0_wp )
+ p_ij(:) = barometric_formula( zu, t_surface, surface_pressure * 100.0_wp ) &
+ p(:,j,i)
!
!-- Absolute ambient temperature (K)
- temp_ij(:) = pt(:,j,i) * exner_function( p_ij(:) )
-!
-!-- Air density
+ temp_ij(:) = pt(:,j,i) * exner_function( p_ij(:) )
+!
+!-- Air density
adn_ij(:) = ideal_gas_law_rho( p_ij(:), temp_ij(:) )
!
@@ -2803,8 +2806,9 @@
!-- Saturation mixing ratio r_s (kg/kg) from vapour pressure at temp (Pa)
IF ( PRESENT( cs_ij ) ) THEN
- e_s(:) = magnus( temp_ij(:) )
- cs_ij(:) = ( 0.622_wp * e_s / ( p_ij(:) - e_s(:) ) ) * adn_ij(:)
+ e_s(:) = 611.0_wp * EXP( alv_d_rv * ( 3.6609E-3_wp - 1.0_wp / &
+ temp_ij(:) ) )! magnus( temp_ij(:) )
+ cs_ij(:) = ( 0.622_wp * e_s / ( p_ij(:) - e_s(:) ) ) * adn_ij(:)
ENDIF
-
+
END SUBROUTINE salsa_thrm_ij
@@ -7877,6 +7881,6 @@
USE netcdf_data_input_mod, &
- ONLY: get_attribute, netcdf_data_input_get_dimension_length, &
- get_variable, open_read_file
+ ONLY: get_attribute, get_variable, &
+ netcdf_data_input_get_dimension_length, open_read_file
USE surface_mod, &
@@ -7985,5 +7989,6 @@
!
!-- Index of gaseous compounds
- CALL netcdf_data_input_get_dimension_length( id_fchem, ng_file, "nspecies" )
+ CALL netcdf_data_input_get_dimension_length( id_fchem, ng_file, &
+ "nspecies" )
IF ( ng_file < 5 ) THEN
message_string = 'Some gaseous emissions missing.'
@@ -8200,5 +8205,6 @@
!
!-- Emission time step
- CALL netcdf_data_input_get_dimension_length( id_faero, n_dt, 'dt_emission' )
+ CALL netcdf_data_input_get_dimension_length( id_faero, n_dt, &
+ 'dt_emission' )
IF ( n_dt > 1 ) THEN
CALL location_message( ' salsa_set_source: hourly emission data'//&
@@ -8410,5 +8416,5 @@
DO n = 1, ncat_emission
DO g = 1, ngast
- IF ( .NOT. salsa_gas(g)%source(n,j,i) > 0.0_wp ) THEN
+ IF ( salsa_gas(g)%source(n,j,i) < 0.0_wp ) THEN
salsa_gas(g)%source(n,j,i) = 0.0_wp
CYCLE
@@ -9138,6 +9144,6 @@
DO j = nysg, nyng
DO k = nzb, nzt+1
- PM25_av(k,j,i) = PM25_av(k,j,i) &
- / REAL( average_count_3d, KIND=wp )
+ PM25_av(k,j,i) = PM25_av(k,j,i) / &
+ REAL( average_count_3d, KIND=wp )
ENDDO
ENDDO
@@ -9148,6 +9154,6 @@
DO j = nysg, nyng
DO k = nzb, nzt+1
- PM10_av(k,j,i) = PM10_av(k,j,i) &
- / REAL( average_count_3d, KIND=wp )
+ PM10_av(k,j,i) = PM10_av(k,j,i) / &
+ REAL( average_count_3d, KIND=wp )
ENDDO
ENDDO
@@ -9168,6 +9174,6 @@
DO j = nysg, nyng
DO k = nzb, nzt+1
- to_be_resorted(k,j,i) = to_be_resorted(k,j,i) &
- / REAL( average_count_3d, KIND=wp )
+ to_be_resorted(k,j,i) = to_be_resorted(k,j,i) / &
+ REAL( average_count_3d, KIND=wp )
ENDDO
ENDDO
@@ -9188,10 +9194,11 @@
!> Subroutine defining 2D output variables
!------------------------------------------------------------------------------!
- SUBROUTINE salsa_data_output_2d( av, variable, found, grid, mode, &
- local_pf, two_d )
+ SUBROUTINE salsa_data_output_2d( av, variable, found, grid, mode, local_pf, &
+ two_d, nzb_do, nzt_do )
USE indices
USE kinds
+
IMPLICIT NONE
@@ -9202,26 +9209,30 @@
CHARACTER (LEN=5) :: vari !< trimmed format of variable
- INTEGER(iwp) :: av !<
- INTEGER(iwp) :: b !<
- INTEGER(iwp) :: c !<
- INTEGER(iwp) :: i !<
- INTEGER(iwp) :: icc !< index of a chemical compound
- INTEGER(iwp) :: j !<
- INTEGER(iwp) :: k !<
-
- LOGICAL :: found !<
- LOGICAL :: two_d !< flag parameter that indicates 2D variables
- !< (horizontal cross sections)
-
- REAL(wp) :: df !< For calculating LDSA: fraction of particles
- !< depositing in the alveolar (or tracheobronchial)
- !< region of the lung. Depends on the particle size
- REAL(wp) :: mean_d !< Particle diameter in micrometres
- REAL(wp) :: nc !< Particle number concentration in units 1/cm**3
- REAL(wp), DIMENSION(nxl:nxr,nys:nyn,nzb:nzt+1) :: local_pf !< local
- !< array to which output data is resorted to
- REAL(wp) :: temp_bin !<
- REAL(wp), DIMENSION(:,:,:), POINTER :: to_be_resorted !< points to
- !< selected output variable
+ INTEGER(iwp) :: av !<
+ INTEGER(iwp) :: b !< running index: size bins
+ INTEGER(iwp) :: c !< running index: mass bins
+ INTEGER(iwp) :: i !<
+ INTEGER(iwp) :: icc !< index of a chemical compound
+ INTEGER(iwp) :: j !<
+ INTEGER(iwp) :: k !<
+ INTEGER(iwp) :: nzb_do !<
+ INTEGER(iwp) :: nzt_do !<
+
+ LOGICAL :: found !<
+ LOGICAL :: two_d !< flag parameter that indicates 2D variables
+ !< (horizontal cross sections)
+
+ REAL(wp) :: df !< For calculating LDSA: fraction of particles
+ !< depositing in the alveolar (or tracheobronchial)
+ !< region of the lung. Depends on the particle size
+ REAL(wp) :: fill_value = -9999.0_wp !< value for the _FillValue attribute
+ REAL(wp) :: mean_d !< Particle diameter in micrometres
+ REAL(wp) :: nc !< Particle number concentration in units 1/cm**3
+ REAL(wp) :: temp_bin !< temporary array for calculating output variables
+
+ REAL(wp), DIMENSION(nxl:nxr,nys:nyn,nzb_do:nzt_do) :: local_pf !< output
+
+ REAL(wp), DIMENSION(:,:,:), POINTER :: to_be_resorted !< pointer
+
found = .TRUE.
@@ -9238,7 +9249,7 @@
DO i = nxl, nxr
DO j = nys, nyn
- DO k = nzb, nzt+1
+ DO k = nzb_do, nzt_do
local_pf(i,j,k) = MERGE( salsa_gas(icc)%conc(k,j,i), &
- REAL( -999.0_wp, KIND = wp ), &
+ REAL( fill_value, KIND = wp ), &
BTEST( wall_flags_0(k,j,i), 0 ) )
ENDDO
@@ -9253,7 +9264,7 @@
DO i = nxl, nxr
DO j = nys, nyn
- DO k = nzb, nzt+1
+ DO k = nzb_do, nzt_do
local_pf(i,j,k) = MERGE( to_be_resorted(k,j,i), &
- REAL( -999.0_wp, KIND = wp ), &
+ REAL( fill_value, KIND = wp ), &
BTEST( wall_flags_0(k,j,i), 0 ) )
ENDDO
@@ -9268,5 +9279,5 @@
DO i = nxl, nxr
DO j = nys, nyn
- DO k = nzb, nzt+1
+ DO k = nzb_do, nzt_do
temp_bin = 0.0_wp
DO b = 1, nbins
@@ -9286,6 +9297,6 @@
temp_bin = temp_bin + pi * mean_d**2.0_wp * df * nc
ENDDO
- local_pf(i,j,k) = MERGE( temp_bin, REAL( -999.0_wp, &
- KIND = wp ), BTEST( wall_flags_0(k,j,i), 0 ) )
+ local_pf(i,j,k) = MERGE( temp_bin, REAL( fill_value, KIND = &
+ wp ), BTEST( wall_flags_0(k,j,i), 0 ) )
ENDDO
ENDDO
@@ -9294,7 +9305,8 @@
DO i = nxl, nxr
DO j = nys, nyn
- DO k = nzb, nzt+1
- local_pf(i,j,k) = MERGE( LDSA_av(k,j,i), REAL( -999.0_wp, &
- KIND = wp ), BTEST( wall_flags_0(k,j,i), 0 ) )
+ DO k = nzb_do, nzt_do
+ local_pf(i,j,k) = MERGE( LDSA_av(k,j,i), REAL( fill_value, &
+ KIND = wp ), BTEST( &
+ wall_flags_0(k,j,i), 0 ) )
ENDDO
ENDDO
@@ -9303,12 +9315,28 @@
IF ( mode == 'xy' ) grid = 'zu'
-
- ELSEIF ( TRIM( variable(1:6) ) == 'N_bin1' ) THEN
+
+ ELSEIF ( TRIM( variable(1:5) ) == 'N_bin' ) THEN
+
+ vari = TRIM( variable( 6:LEN( TRIM( variable ) ) - 3 ) )
+
+ IF ( TRIM( vari ) == '1' ) b = 1
+ IF ( TRIM( vari ) == '2' ) b = 2
+ IF ( TRIM( vari ) == '3' ) b = 3
+ IF ( TRIM( vari ) == '4' ) b = 4
+ IF ( TRIM( vari ) == '5' ) b = 5
+ IF ( TRIM( vari ) == '6' ) b = 6
+ IF ( TRIM( vari ) == '7' ) b = 7
+ IF ( TRIM( vari ) == '8' ) b = 8
+ IF ( TRIM( vari ) == '9' ) b = 9
+ IF ( TRIM( vari ) == '10' ) b = 10
+ IF ( TRIM( vari ) == '11' ) b = 11
+ IF ( TRIM( vari ) == '12' ) b = 12
+
IF ( av == 0 ) THEN
DO i = nxl, nxr
DO j = nys, nyn
- DO k = nzb, nzt+1
- local_pf(i,j,k) = MERGE( aerosol_number(1)%conc(k,j,i), &
- REAL( -999.0_wp, KIND = wp ), &
+ DO k = nzb_do, nzt_do
+ local_pf(i,j,k) = MERGE( aerosol_number(b)%conc(k,j,i), &
+ REAL( fill_value, KIND = wp ), &
BTEST( wall_flags_0(k,j,i), 0 ) )
ENDDO
@@ -9318,7 +9346,7 @@
DO i = nxl, nxr
DO j = nys, nyn
- DO k = nzb, nzt+1
- local_pf(i,j,k) = MERGE( Nbins_av(k,j,i,1), &
- REAL( -999.0_wp, KIND = wp ), &
+ DO k = nzb_do, nzt_do
+ local_pf(i,j,k) = MERGE( Nbins_av(k,j,i,b), &
+ REAL( fill_value, KIND = wp ), &
BTEST( wall_flags_0(k,j,i), 0 ) )
ENDDO
@@ -9326,13 +9354,18 @@
ENDDO
ENDIF
-
- ELSEIF ( TRIM( variable(1:6) ) == 'N_bin2' ) THEN
+
+ IF ( mode == 'xy' ) grid = 'zu'
+
+ ELSEIF ( TRIM( variable(1:4) ) == 'Ntot' ) THEN
IF ( av == 0 ) THEN
DO i = nxl, nxr
DO j = nys, nyn
- DO k = nzb, nzt+1
- local_pf(i,j,k) = MERGE( aerosol_number(2)%conc(k,j,i), &
- REAL( -999.0_wp, KIND = wp ), &
- BTEST( wall_flags_0(k,j,i), 0 ) )
+ DO k = nzb_do, nzt_do
+ temp_bin = 0.0_wp
+ DO b = 1, nbins
+ temp_bin = temp_bin + aerosol_number(b)%conc(k,j,i)
+ ENDDO
+ local_pf(i,j,k) = MERGE( temp_bin, REAL( fill_value, KIND = &
+ wp ), BTEST( wall_flags_0(k,j,i), 0 ) )
ENDDO
ENDDO
@@ -9341,21 +9374,44 @@
DO i = nxl, nxr
DO j = nys, nyn
- DO k = nzb, nzt+1
- local_pf(i,j,k) = MERGE( Nbins_av(k,j,i,2), &
- REAL( -999.0_wp, KIND = wp ), &
- BTEST( wall_flags_0(k,j,i), 0 ) )
+ DO k = nzb_do, nzt_do
+ local_pf(i,j,k) = MERGE( Ntot_av(k,j,i), REAL( fill_value, &
+ KIND = wp ), BTEST( &
+ wall_flags_0(k,j,i), 0 ) )
ENDDO
ENDDO
ENDDO
ENDIF
+
+ IF ( mode == 'xy' ) grid = 'zu'
+
+
+ ELSEIF ( TRIM( variable(1:5) ) == 'm_bin' ) THEN
- ELSEIF ( TRIM( variable(1:6) ) == 'N_bin3' ) THEN
+ vari = TRIM( variable( 6:LEN( TRIM( variable ) ) - 3 ) )
+
+ IF ( TRIM( vari ) == '1' ) b = 1
+ IF ( TRIM( vari ) == '2' ) b = 2
+ IF ( TRIM( vari ) == '3' ) b = 3
+ IF ( TRIM( vari ) == '4' ) b = 4
+ IF ( TRIM( vari ) == '5' ) b = 5
+ IF ( TRIM( vari ) == '6' ) b = 6
+ IF ( TRIM( vari ) == '7' ) b = 7
+ IF ( TRIM( vari ) == '8' ) b = 8
+ IF ( TRIM( vari ) == '9' ) b = 9
+ IF ( TRIM( vari ) == '10' ) b = 10
+ IF ( TRIM( vari ) == '11' ) b = 11
+ IF ( TRIM( vari ) == '12' ) b = 12
+
IF ( av == 0 ) THEN
DO i = nxl, nxr
DO j = nys, nyn
- DO k = nzb, nzt+1
- local_pf(i,j,k) = MERGE( aerosol_number(3)%conc(k,j,i), &
- REAL( -999.0_wp, KIND = wp ), &
- BTEST( wall_flags_0(k,j,i), 0 ) )
+ DO k = nzb_do, nzt_do
+ temp_bin = 0.0_wp
+ DO c = b, ncc_tot * nbins, nbins
+ temp_bin = temp_bin + aerosol_mass(c)%conc(k,j,i)
+ ENDDO
+ local_pf(i,j,k) = MERGE( temp_bin, REAL( fill_value, &
+ KIND = wp ), BTEST( &
+ wall_flags_0(k,j,i), 0 ) )
ENDDO
ENDDO
@@ -9364,547 +9420,14 @@
DO i = nxl, nxr
DO j = nys, nyn
- DO k = nzb, nzt+1
- local_pf(i,j,k) = MERGE( Nbins_av(k,j,i,3), &
- REAL( -999.0_wp, KIND = wp ), &
- BTEST( wall_flags_0(k,j,i), 0 ) )
+ DO k = nzb_do, nzt_do
+ local_pf(i,j,k) = MERGE( mbins_av(k,j,i,b), REAL( fill_value,&
+ KIND = wp ), BTEST( &
+ wall_flags_0(k,j,i), 0 ) )
ENDDO
ENDDO
ENDDO
ENDIF
-
- ELSEIF ( TRIM( variable(1:6) ) == 'N_bin4' ) THEN
- IF ( av == 0 ) THEN
- DO i = nxl, nxr
- DO j = nys, nyn
- DO k = nzb, nzt+1
- local_pf(i,j,k) = MERGE( aerosol_number(4)%conc(k,j,i), &
- REAL( -999.0_wp, KIND = wp ), &
- BTEST( wall_flags_0(k,j,i), 0 ) )
- ENDDO
- ENDDO
- ENDDO
- ELSE
- DO i = nxl, nxr
- DO j = nys, nyn
- DO k = nzb, nzt+1
- local_pf(i,j,k) = MERGE( Nbins_av(k,j,i,4), &
- REAL( -999.0_wp, KIND = wp ), &
- BTEST( wall_flags_0(k,j,i), 0 ) )
- ENDDO
- ENDDO
- ENDDO
- ENDIF
- ELSEIF ( TRIM( variable(1:6) ) == 'N_bin5' ) THEN
- IF ( av == 0 ) THEN
- DO i = nxl, nxr
- DO j = nys, nyn
- DO k = nzb, nzt+1
- local_pf(i,j,k) = MERGE( aerosol_number(5)%conc(k,j,i), &
- REAL( -999.0_wp, KIND = wp ), &
- BTEST( wall_flags_0(k,j,i), 0 ) )
- ENDDO
- ENDDO
- ENDDO
- ELSE
- DO i = nxl, nxr
- DO j = nys, nyn
- DO k = nzb, nzt+1
- local_pf(i,j,k) = MERGE( Nbins_av(k,j,i,5), &
- REAL( -999.0_wp, KIND = wp ), &
- BTEST( wall_flags_0(k,j,i), 0 ) )
- ENDDO
- ENDDO
- ENDDO
- ENDIF
-
- ELSEIF ( TRIM( variable(1:6) ) == 'N_bin6' ) THEN
- IF ( av == 0 ) THEN
- DO i = nxl, nxr
- DO j = nys, nyn
- DO k = nzb, nzt+1
- local_pf(i,j,k) = MERGE( aerosol_number(6)%conc(k,j,i), &
- REAL( -999.0_wp, KIND = wp ), &
- BTEST( wall_flags_0(k,j,i), 0 ) )
- ENDDO
- ENDDO
- ENDDO
- ELSE
- DO i = nxl, nxr
- DO j = nys, nyn
- DO k = nzb, nzt+1
- local_pf(i,j,k) = MERGE( Nbins_av(k,j,i,6), &
- REAL( -999.0_wp, KIND = wp ), &
- BTEST( wall_flags_0(k,j,i), 0 ) )
- ENDDO
- ENDDO
- ENDDO
- ENDIF
-
- ELSEIF ( TRIM( variable(1:6) ) == 'N_bin7' ) THEN
- IF ( av == 0 ) THEN
- DO i = nxl, nxr
- DO j = nys, nyn
- DO k = nzb, nzt+1
- local_pf(i,j,k) = MERGE( aerosol_number(7)%conc(k,j,i), &
- REAL( -999.0_wp, KIND = wp ), &
- BTEST( wall_flags_0(k,j,i), 0 ) )
- ENDDO
- ENDDO
- ENDDO
- ELSE
- DO i = nxl, nxr
- DO j = nys, nyn
- DO k = nzb, nzt+1
- local_pf(i,j,k) = MERGE( Nbins_av(k,j,i,7), &
- REAL( -999.0_wp, KIND = wp ), &
- BTEST( wall_flags_0(k,j,i), 0 ) )
- ENDDO
- ENDDO
- ENDDO
- ENDIF
-
- ELSEIF ( TRIM( variable(1:6) ) == 'N_bin8' ) THEN
- IF ( av == 0 ) THEN
- DO i = nxl, nxr
- DO j = nys, nyn
- DO k = nzb, nzt+1
- local_pf(i,j,k) = MERGE( aerosol_number(8)%conc(k,j,i), &
- REAL( -999.0_wp, KIND = wp ), &
- BTEST( wall_flags_0(k,j,i), 0 ) )
- ENDDO
- ENDDO
- ENDDO
- ELSE
- DO i = nxl, nxr
- DO j = nys, nyn
- DO k = nzb, nzt+1
- local_pf(i,j,k) = MERGE( Nbins_av(k,j,i,8), &
- REAL( -999.0_wp, KIND = wp ), &
- BTEST( wall_flags_0(k,j,i), 0 ) )
- ENDDO
- ENDDO
- ENDDO
- ENDIF
-
- ELSEIF ( TRIM( variable(1:6) ) == 'N_bin9' ) THEN
- IF ( av == 0 ) THEN
- DO i = nxl, nxr
- DO j = nys, nyn
- DO k = nzb, nzt+1
- local_pf(i,j,k) = MERGE( aerosol_number(9)%conc(k,j,i), &
- REAL( -999.0_wp, KIND = wp ), &
- BTEST( wall_flags_0(k,j,i), 0 ) )
- ENDDO
- ENDDO
- ENDDO
- ELSE
- DO i = nxl, nxr
- DO j = nys, nyn
- DO k = nzb, nzt+1
- local_pf(i,j,k) = MERGE( Nbins_av(k,j,i,9), &
- REAL( -999.0_wp, KIND = wp ), &
- BTEST( wall_flags_0(k,j,i), 0 ) )
- ENDDO
- ENDDO
- ENDDO
- ENDIF
-
- ELSEIF ( TRIM( variable(1:7) ) == 'N_bin10' ) THEN
- IF ( av == 0 ) THEN
- DO i = nxl, nxr
- DO j = nys, nyn
- DO k = nzb, nzt+1
- local_pf(i,j,k) = MERGE( aerosol_number(10)%conc(k,j,i), &
- REAL( -999.0_wp, KIND = wp ), &
- BTEST( wall_flags_0(k,j,i), 0 ) )
- ENDDO
- ENDDO
- ENDDO
- ELSE
- DO i = nxl, nxr
- DO j = nys, nyn
- DO k = nzb, nzt+1
- local_pf(i,j,k) = MERGE( Nbins_av(k,j,i,10), &
- REAL( -999.0_wp, KIND = wp ), &
- BTEST( wall_flags_0(k,j,i), 0 ) )
- ENDDO
- ENDDO
- ENDDO
- ENDIF
-
- ELSEIF ( TRIM( variable(1:7) ) == 'N_bin11' ) THEN
- IF ( av == 0 ) THEN
- DO i = nxl, nxr
- DO j = nys, nyn
- DO k = nzb, nzt+1
- local_pf(i,j,k) = MERGE( aerosol_number(11)%conc(k,j,i), &
- REAL( -999.0_wp, KIND = wp ), &
- BTEST( wall_flags_0(k,j,i), 0 ) )
- ENDDO
- ENDDO
- ENDDO
- ELSE
- DO i = nxl, nxr
- DO j = nys, nyn
- DO k = nzb, nzt+1
- local_pf(i,j,k) = MERGE( Nbins_av(k,j,i,11), &
- REAL( -999.0_wp, KIND = wp ), &
- BTEST( wall_flags_0(k,j,i), 0 ) )
- ENDDO
- ENDDO
- ENDDO
- ENDIF
-
- ELSEIF ( TRIM( variable(1:7) ) == 'N_bin12' ) THEN
- IF ( av == 0 ) THEN
- DO i = nxl, nxr
- DO j = nys, nyn
- DO k = nzb, nzt+1
- local_pf(i,j,k) = MERGE( aerosol_number(12)%conc(k,j,i), &
- REAL( -999.0_wp, KIND = wp ), &
- BTEST( wall_flags_0(k,j,i), 0 ) )
- ENDDO
- ENDDO
- ENDDO
- ELSE
- DO i = nxl, nxr
- DO j = nys, nyn
- DO k = nzb, nzt+1
- local_pf(i,j,k) = MERGE( Nbins_av(k,j,i,12), &
- REAL( -999.0_wp, KIND = wp ), &
- BTEST( wall_flags_0(k,j,i), 0 ) )
- ENDDO
- ENDDO
- ENDDO
- ENDIF
-
- ELSEIF ( TRIM( variable(1:4) ) == 'Ntot' ) THEN
- IF ( av == 0 ) THEN
- DO i = nxl, nxr
- DO j = nys, nyn
- DO k = nzb, nzt+1
- temp_bin = 0.0_wp
- DO b = 1, nbins
- temp_bin = temp_bin + aerosol_number(b)%conc(k,j,i)
- ENDDO
- local_pf(i,j,k) = MERGE( temp_bin, REAL( -999.0_wp, &
- KIND = wp ), BTEST( wall_flags_0(k,j,i), 0 ) )
- ENDDO
- ENDDO
- ENDDO
- ELSE
- DO i = nxl, nxr
- DO j = nys, nyn
- DO k = nzb, nzt+1
- local_pf(i,j,k) = MERGE( Ntot_av(k,j,i), REAL( -999.0_wp, &
- KIND = wp ), BTEST( wall_flags_0(k,j,i), 0 ) )
- ENDDO
- ENDDO
- ENDDO
- ENDIF
-
IF ( mode == 'xy' ) grid = 'zu'
-
-
- ELSEIF ( TRIM( variable(1:6) ) == 'm_bin1' ) THEN
- IF ( av == 0 ) THEN
- DO i = nxl, nxr
- DO j = nys, nyn
- DO k = nzb, nzt+1
- temp_bin = 0.0_wp
- DO c = 1, ncc_tot*nbins, nbins
- temp_bin = temp_bin + aerosol_mass(c)%conc(k,j,i)
- ENDDO
- local_pf(i,j,k) = MERGE( temp_bin, REAL( -999.0_wp, &
- KIND = wp ), BTEST( wall_flags_0(k,j,i), 0 ) )
- ENDDO
- ENDDO
- ENDDO
- ELSE
- DO i = nxl, nxr
- DO j = nys, nyn
- DO k = nzb, nzt+1
- local_pf(i,j,k) = MERGE( mbins_av(k,j,i,1), REAL( -999.0_wp,&
- KIND = wp ), BTEST( wall_flags_0(k,j,i), 0 ) )
- ENDDO
- ENDDO
- ENDDO
- ENDIF
-
- ELSEIF ( TRIM( variable(1:6) ) == 'm_bin2' ) THEN
- IF ( av == 0 ) THEN
- DO i = nxl, nxr
- DO j = nys, nyn
- DO k = nzb, nzt+1
- temp_bin = 0.0_wp
- DO c = 2, ncc_tot*nbins, nbins
- temp_bin = temp_bin + aerosol_mass(c)%conc(k,j,i)
- ENDDO
- local_pf(i,j,k) = MERGE( temp_bin, REAL( -999.0_wp, &
- KIND = wp ), BTEST( wall_flags_0(k,j,i), 0 ) )
- ENDDO
- ENDDO
- ENDDO
- ELSE
- DO i = nxl, nxr
- DO j = nys, nyn
- DO k = nzb, nzt+1
- local_pf(i,j,k) = MERGE( mbins_av(k,j,i,2), REAL( -999.0_wp,&
- KIND = wp ), BTEST( wall_flags_0(k,j,i), 0 ) )
- ENDDO
- ENDDO
- ENDDO
- ENDIF
-
- ELSEIF ( TRIM( variable(1:6) ) == 'm_bin3' ) THEN
- IF ( av == 0 ) THEN
- DO i = nxl, nxr
- DO j = nys, nyn
- DO k = nzb, nzt+1
- temp_bin = 0.0_wp
- DO c = 3, ncc_tot*nbins, nbins
- temp_bin = temp_bin + aerosol_mass(c)%conc(k,j,i)
- ENDDO
- local_pf(i,j,k) = MERGE( temp_bin, REAL( -999.0_wp, &
- KIND = wp ), BTEST( wall_flags_0(k,j,i), 0 ) )
- ENDDO
- ENDDO
- ENDDO
- ELSE
- DO i = nxl, nxr
- DO j = nys, nyn
- DO k = nzb, nzt+1
- local_pf(i,j,k) = MERGE( mbins_av(k,j,i,3), REAL( -999.0_wp,&
- KIND = wp ), BTEST( wall_flags_0(k,j,i), 0 ) )
- ENDDO
- ENDDO
- ENDDO
- ENDIF
-
- ELSEIF ( TRIM( variable(1:6) ) == 'm_bin4' ) THEN
- IF ( av == 0 ) THEN
- DO i = nxl, nxr
- DO j = nys, nyn
- DO k = nzb, nzt+1
- temp_bin = 0.0_wp
- DO c = 4, ncc_tot*nbins, nbins
- temp_bin = temp_bin + aerosol_mass(c)%conc(k,j,i)
- ENDDO
- local_pf(i,j,k) = MERGE( temp_bin, REAL( -999.0_wp, &
- KIND = wp ), BTEST( wall_flags_0(k,j,i), 0 ) )
- ENDDO
- ENDDO
- ENDDO
- ELSE
- DO i = nxl, nxr
- DO j = nys, nyn
- DO k = nzb, nzt+1
- local_pf(i,j,k) = MERGE( mbins_av(k,j,i,4), REAL( -999.0_wp,&
- KIND = wp ), BTEST( wall_flags_0(k,j,i), 0 ) )
- ENDDO
- ENDDO
- ENDDO
- ENDIF
-
- ELSEIF ( TRIM( variable(1:6) ) == 'm_bin5' ) THEN
- IF ( av == 0 ) THEN
- DO i = nxl, nxr
- DO j = nys, nyn
- DO k = nzb, nzt+1
- temp_bin = 0.0_wp
- DO c = 5, ncc_tot*nbins, nbins
- temp_bin = temp_bin + aerosol_mass(c)%conc(k,j,i)
- ENDDO
- local_pf(i,j,k) = MERGE( temp_bin, REAL( -999.0_wp, &
- KIND = wp ), BTEST( wall_flags_0(k,j,i), 0 ) )
- ENDDO
- ENDDO
- ENDDO
- ELSE
- DO i = nxl, nxr
- DO j = nys, nyn
- DO k = nzb, nzt+1
- local_pf(i,j,k) = MERGE( mbins_av(k,j,i,5), REAL( -999.0_wp,&
- KIND = wp ), BTEST( wall_flags_0(k,j,i), 0 ) )
- ENDDO
- ENDDO
- ENDDO
- ENDIF
-
- ELSEIF ( TRIM( variable(1:6) ) == 'm_bin6' ) THEN
- IF ( av == 0 ) THEN
- DO i = nxl, nxr
- DO j = nys, nyn
- DO k = nzb, nzt+1
- temp_bin = 0.0_wp
- DO c = 6, ncc_tot*nbins, nbins
- temp_bin = temp_bin + aerosol_mass(c)%conc(k,j,i)
- ENDDO
- local_pf(i,j,k) = MERGE( temp_bin, REAL( -999.0_wp, &
- KIND = wp ), BTEST( wall_flags_0(k,j,i), 0 ) )
- ENDDO
- ENDDO
- ENDDO
- ELSE
- DO i = nxl, nxr
- DO j = nys, nyn
- DO k = nzb, nzt+1
- local_pf(i,j,k) = MERGE( mbins_av(k,j,i,6), REAL( -999.0_wp,&
- KIND = wp ), BTEST( wall_flags_0(k,j,i), 0 ) )
- ENDDO
- ENDDO
- ENDDO
- ENDIF
-
- ELSEIF ( TRIM( variable(1:6) ) == 'm_bin7' ) THEN
- IF ( av == 0 ) THEN
- DO i = nxl, nxr
- DO j = nys, nyn
- DO k = nzb, nzt+1
- temp_bin = 0.0_wp
- DO c = 7, ncc_tot*nbins, nbins
- temp_bin = temp_bin + aerosol_mass(c)%conc(k,j,i)
- ENDDO
- local_pf(i,j,k) = MERGE( temp_bin, REAL( -999.0_wp, &
- KIND = wp ), BTEST( wall_flags_0(k,j,i), 0 ) )
- ENDDO
- ENDDO
- ENDDO
- ELSE
- DO i = nxl, nxr
- DO j = nys, nyn
- DO k = nzb, nzt+1
- local_pf(i,j,k) = MERGE( mbins_av(k,j,i,7), REAL( -999.0_wp,&
- KIND = wp ), BTEST( wall_flags_0(k,j,i), 0 ) )
- ENDDO
- ENDDO
- ENDDO
- ENDIF
-
- ELSEIF ( TRIM( variable(1:6) ) == 'm_bin8' ) THEN
- IF ( av == 0 ) THEN
- DO i = nxl, nxr
- DO j = nys, nyn
- DO k = nzb, nzt+1
- temp_bin = 0.0_wp
- DO c = 8, ncc_tot*nbins, nbins
- temp_bin = temp_bin + aerosol_mass(c)%conc(k,j,i)
- ENDDO
- local_pf(i,j,k) = MERGE( temp_bin, REAL( -999.0_wp, &
- KIND = wp ), BTEST( wall_flags_0(k,j,i), 0 ) )
- ENDDO
- ENDDO
- ENDDO
- ELSE
- DO i = nxl, nxr
- DO j = nys, nyn
- DO k = nzb, nzt+1
- local_pf(i,j,k) = MERGE( mbins_av(k,j,i,8), REAL( -999.0_wp,&
- KIND = wp ), BTEST( wall_flags_0(k,j,i), 0 ) )
- ENDDO
- ENDDO
- ENDDO
- ENDIF
-
- ELSEIF ( TRIM( variable(1:6) ) == 'm_bin9' ) THEN
- IF ( av == 0 ) THEN
- DO i = nxl, nxr
- DO j = nys, nyn
- DO k = nzb, nzt+1
- temp_bin = 0.0_wp
- DO c = 9, ncc_tot*nbins, nbins
- temp_bin = temp_bin + aerosol_mass(c)%conc(k,j,i)
- ENDDO
- local_pf(i,j,k) = MERGE( temp_bin, REAL( -999.0_wp, &
- KIND = wp ), BTEST( wall_flags_0(k,j,i), 0 ) )
- ENDDO
- ENDDO
- ENDDO
- ELSE
- DO i = nxl, nxr
- DO j = nys, nyn
- DO k = nzb, nzt+1
- local_pf(i,j,k) = MERGE( mbins_av(k,j,i,9), REAL( -999.0_wp,&
- KIND = wp ), BTEST( wall_flags_0(k,j,i), 0 ) )
- ENDDO
- ENDDO
- ENDDO
- ENDIF
-
- ELSEIF ( TRIM( variable(1:7) ) == 'm_bin10' ) THEN
- IF ( av == 0 ) THEN
- DO i = nxl, nxr
- DO j = nys, nyn
- DO k = nzb, nzt+1
- temp_bin = 0.0_wp
- DO c = 10, ncc_tot*nbins, nbins
- temp_bin = temp_bin + aerosol_mass(c)%conc(k,j,i)
- ENDDO
- local_pf(i,j,k) = MERGE( temp_bin, REAL( -999.0_wp, &
- KIND = wp ), BTEST( wall_flags_0(k,j,i), 0 ) )
- ENDDO
- ENDDO
- ENDDO
- ELSE
- DO i = nxl, nxr
- DO j = nys, nyn
- DO k = nzb, nzt+1
- local_pf(i,j,k) = MERGE( mbins_av(k,j,i,10), REAL( &
- -999.0_wp, KIND = wp ), BTEST( wall_flags_0(k,j,i), 0 ) )
- ENDDO
- ENDDO
- ENDDO
- ENDIF
-
- ELSEIF ( TRIM( variable(1:7) ) == 'm_bin11' ) THEN
- IF ( av == 0 ) THEN
- DO i = nxl, nxr
- DO j = nys, nyn
- DO k = nzb, nzt+1
- temp_bin = 0.0_wp
- DO c = 11, ncc_tot*nbins, nbins
- temp_bin = temp_bin + aerosol_mass(c)%conc(k,j,i)
- ENDDO
- local_pf(i,j,k) = MERGE( temp_bin, REAL( -999.0_wp, &
- KIND = wp ), BTEST( wall_flags_0(k,j,i), 0 ) )
- ENDDO
- ENDDO
- ENDDO
- ELSE
- DO i = nxl, nxr
- DO j = nys, nyn
- DO k = nzb, nzt+1
- local_pf(i,j,k) = MERGE( mbins_av(k,j,i,11), REAL( &
- -999.0_wp, KIND = wp ), BTEST( wall_flags_0(k,j,i), 0 ) )
- ENDDO
- ENDDO
- ENDDO
- ENDIF
-
- ELSEIF ( TRIM( variable(1:7) ) == 'm_bin12' ) THEN
- IF ( av == 0 ) THEN
- DO i = nxl, nxr
- DO j = nys, nyn
- DO k = nzb, nzt+1
- temp_bin = 0.0_wp
- DO c = 12, ncc_tot*nbins, nbins
- temp_bin = temp_bin + aerosol_mass(c)%conc(k,j,i)
- ENDDO
- local_pf(i,j,k) = MERGE( temp_bin, REAL( -999.0_wp, &
- KIND = wp ), BTEST( wall_flags_0(k,j,i), 0 ) )
- ENDDO
- ENDDO
- ENDDO
- ELSE
- DO i = nxl, nxr
- DO j = nys, nyn
- DO k = nzb, nzt+1
- local_pf(i,j,k) = MERGE( mbins_av(k,j,i,12), REAL( &
- -999.0_wp, KIND = wp ), BTEST( wall_flags_0(k,j,i), 0 ) )
- ENDDO
- ENDDO
- ENDDO
- ENDIF
ELSEIF ( TRIM( variable(1:5) ) == 'PM2.5' ) THEN
@@ -9912,5 +9435,5 @@
DO i = nxl, nxr
DO j = nys, nyn
- DO k = nzb, nzt+1
+ DO k = nzb_do, nzt_do
temp_bin = 0.0_wp
DO b = 1, nbins
@@ -9921,6 +9444,7 @@
ENDIF
ENDDO
- local_pf(i,j,k) = MERGE( temp_bin, REAL( -999.0_wp, &
- KIND = wp ), BTEST( wall_flags_0(k,j,i), 0 ) )
+ local_pf(i,j,k) = MERGE( temp_bin, REAL( fill_value, &
+ KIND = wp ), BTEST( &
+ wall_flags_0(k,j,i), 0 ) )
ENDDO
ENDDO
@@ -9929,7 +9453,8 @@
DO i = nxl, nxr
DO j = nys, nyn
- DO k = nzb, nzt+1
- local_pf(i,j,k) = MERGE( PM25_av(k,j,i), REAL( -999.0_wp, &
- KIND = wp ), BTEST( wall_flags_0(k,j,i), 0 ) )
+ DO k = nzb_do, nzt_do
+ local_pf(i,j,k) = MERGE( PM25_av(k,j,i), REAL( fill_value, &
+ KIND = wp ), BTEST( &
+ wall_flags_0(k,j,i), 0 ) )
ENDDO
ENDDO
@@ -9944,5 +9469,5 @@
DO i = nxl, nxr
DO j = nys, nyn
- DO k = nzb, nzt+1
+ DO k = nzb_do, nzt_do
temp_bin = 0.0_wp
DO b = 1, nbins
@@ -9953,6 +9478,7 @@
ENDIF
ENDDO
- local_pf(i,j,k) = MERGE( temp_bin, REAL( -999.0_wp, &
- KIND = wp ), BTEST( wall_flags_0(k,j,i), 0 ) )
+ local_pf(i,j,k) = MERGE( temp_bin, REAL( fill_value, &
+ KIND = wp ), BTEST( &
+ wall_flags_0(k,j,i), 0 ) )
ENDDO
ENDDO
@@ -9961,7 +9487,8 @@
DO i = nxl, nxr
DO j = nys, nyn
- DO k = nzb, nzt+1
- local_pf(i,j,k) = MERGE( PM10_av(k,j,i), REAL( -999.0_wp, &
- KIND = wp ), BTEST( wall_flags_0(k,j,i), 0 ) )
+ DO k = nzb_do, nzt_do
+ local_pf(i,j,k) = MERGE( PM10_av(k,j,i), REAL( fill_value, &
+ KIND = wp ), BTEST( &
+ wall_flags_0(k,j,i), 0 ) )
ENDDO
ENDDO
@@ -9978,11 +9505,12 @@
DO i = nxl, nxr
DO j = nys, nyn
- DO k = nzb, nzt+1
+ DO k = nzb_do, nzt_do
temp_bin = 0.0_wp
DO c = ( icc-1 )*nbins+1, icc*nbins, 1
temp_bin = temp_bin + aerosol_mass(c)%conc(k,j,i)
ENDDO
- local_pf(i,j,k) = MERGE( temp_bin, REAL( -999.0_wp, &
- KIND = wp ), BTEST( wall_flags_0(k,j,i), 0 ) )
+ local_pf(i,j,k) = MERGE( temp_bin, REAL( fill_value, &
+ KIND = wp ), BTEST( &
+ wall_flags_0(k,j,i), 0 ) )
ENDDO
ENDDO
@@ -9998,7 +9526,7 @@
DO i = nxl, nxr
DO j = nys, nyn
- DO k = nzb, nzt+1
+ DO k = nzb_do, nzt_do
local_pf(i,j,k) = MERGE( to_be_resorted(k,j,i), &
- REAL( -999.0_wp, KIND = wp ), &
+ REAL( fill_value, KIND = wp ), &
BTEST( wall_flags_0(k,j,i), 0 ) )
ENDDO
@@ -10007,5 +9535,5 @@
ENDIF
ELSE
- local_pf = 0.0_wp
+ local_pf = fill_value
ENDIF
@@ -10027,9 +9555,11 @@
!> Subroutine defining 3D output variables
!------------------------------------------------------------------------------!
- SUBROUTINE salsa_data_output_3d( av, variable, found, local_pf )
+ SUBROUTINE salsa_data_output_3d( av, variable, found, local_pf, nzb_do, &
+ nzt_do )
USE indices
USE kinds
+
IMPLICIT NONE
@@ -10037,24 +9567,28 @@
CHARACTER (LEN=*), INTENT(in) :: variable !<
- INTEGER(iwp) :: av !<
- INTEGER(iwp) :: c !<
- INTEGER(iwp) :: i !<
- INTEGER(iwp) :: icc !< index of a chemical compound
- INTEGER(iwp) :: j !<
- INTEGER(iwp) :: k !<
- INTEGER(iwp) :: n !<
-
- LOGICAL :: found !<
- REAL(wp) :: df !< For calculating LDSA: fraction of particles
- !< depositing in the alveolar (or tracheobronchial)
- !< region of the lung. Depends on the particle size
- REAL(wp) :: mean_d !< Particle diameter in micrometres
- REAL(wp) :: nc !< Particle number concentration in units 1/cm**3
-
- REAL(sp), DIMENSION(nxl:nxr,nys:nyn,nzb:nzt+1) :: local_pf !< local
- !< array to which output data is resorted to
- REAL(wp) :: temp_bin !<
- REAL(wp), DIMENSION(:,:,:), POINTER :: to_be_resorted !< points to
- !< selected output variable
+ INTEGER(iwp) :: av !<
+ INTEGER(iwp) :: b !< running index: size bins
+ INTEGER(iwp) :: c !< running index: mass bins
+ INTEGER(iwp) :: i !<
+ INTEGER(iwp) :: icc !< index of a chemical compound
+ INTEGER(iwp) :: j !<
+ INTEGER(iwp) :: k !<
+ INTEGER(iwp) :: nzb_do !<
+ INTEGER(iwp) :: nzt_do !<
+
+ LOGICAL :: found !<
+
+ REAL(wp) :: df !< For calculating LDSA: fraction of particles
+ !< depositing in the alveolar (or tracheobronchial)
+ !< region of the lung. Depends on the particle size
+ REAL(wp) :: fill_value = -9999.0_wp !< value for the _FillValue attribute
+ REAL(wp) :: mean_d !< Particle diameter in micrometres
+ REAL(wp) :: nc !< Particle number concentration in units 1/cm**3
+ REAL(wp) :: temp_bin !< temporary array for calculating output variables
+
+ REAL(sp), DIMENSION(nxl:nxr,nys:nyn,nzb_do:nzt_do) :: local_pf !< local
+
+ REAL(wp), DIMENSION(:,:,:), POINTER :: to_be_resorted !< pointer
+
found = .TRUE.
@@ -10073,7 +9607,7 @@
DO i = nxl, nxr
DO j = nys, nyn
- DO k = nzb, nzt+1
+ DO k = nzb_do, nzt_do
local_pf(i,j,k) = MERGE( salsa_gas(icc)%conc(k,j,i), &
- REAL( -999.0_wp, KIND = wp ), &
+ REAL( fill_value, KIND = wp ), &
BTEST( wall_flags_0(k,j,i), 0 ) )
ENDDO
@@ -10088,7 +9622,7 @@
DO i = nxl, nxr
DO j = nys, nyn
- DO k = nzb, nzt+1
+ DO k = nzb_do, nzt_do
local_pf(i,j,k) = MERGE( to_be_resorted(k,j,i), &
- REAL( -999.0_wp, KIND = wp ), &
+ REAL( fill_value, KIND = wp ), &
BTEST( wall_flags_0(k,j,i), 0 ) )
ENDDO
@@ -10101,19 +9635,19 @@
DO i = nxl, nxr
DO j = nys, nyn
- DO k = nzb, nzt+1
+ DO k = nzb_do, nzt_do
temp_bin = 0.0_wp
- DO n = 1, nbins
+ DO b = 1, nbins
!
!-- Diameter in micrometres
- mean_d = 1.0E+6_wp * Ra_dry(k,j,i,n) * 2.0_wp
+ mean_d = 1.0E+6_wp * Ra_dry(k,j,i,b) * 2.0_wp
!
!-- Deposition factor: alveolar
df = ( 0.01555_wp / mean_d ) * ( EXP( -0.416_wp * &
- ( LOG( mean_d ) + 2.84_wp )**2.0_wp ) &
- + 19.11_wp * EXP( -0.482_wp * &
- ( LOG( mean_d ) - 1.362_wp )**2.0_wp ) )
+ ( LOG( mean_d ) + 2.84_wp )**2.0_wp ) + 19.11_wp &
+ * EXP( -0.482_wp * ( LOG( mean_d ) - 1.362_wp &
+ )**2.0_wp ) )
!
!-- Number concentration in 1/cm3
- nc = 1.0E-6_wp * aerosol_number(n)%conc(k,j,i)
+ nc = 1.0E-6_wp * aerosol_number(b)%conc(k,j,i)
!
!-- Lung-deposited surface area LDSA (units mum2/cm3)
@@ -10121,5 +9655,5 @@
ENDDO
local_pf(i,j,k) = MERGE( temp_bin, &
- REAL( -999.0_wp, KIND = wp ), &
+ REAL( fill_value, KIND = wp ), &
BTEST( wall_flags_0(k,j,i), 0 ) )
ENDDO
@@ -10129,7 +9663,44 @@
DO i = nxl, nxr
DO j = nys, nyn
- DO k = nzb, nzt+1
+ DO k = nzb_do, nzt_do
local_pf(i,j,k) = MERGE( LDSA_av(k,j,i), &
- REAL( -999.0_wp, KIND = wp ), &
+ REAL( fill_value, KIND = wp ), &
+ BTEST( wall_flags_0(k,j,i), 0 ) )
+ ENDDO
+ ENDDO
+ ENDDO
+ ENDIF
+
+ CASE ( 'N_bin1', 'N_bin2', 'N_bin3', 'N_bin4', 'N_bin5', 'N_bin6', &
+ 'N_bin7', 'N_bin8', 'N_bin9', 'N_bin10' , 'N_bin11', 'N_bin12' )
+ IF ( TRIM( variable(6:) ) == '1' ) b = 1
+ IF ( TRIM( variable(6:) ) == '2' ) b = 2
+ IF ( TRIM( variable(6:) ) == '3' ) b = 3
+ IF ( TRIM( variable(6:) ) == '4' ) b = 4
+ IF ( TRIM( variable(6:) ) == '5' ) b = 5
+ IF ( TRIM( variable(6:) ) == '6' ) b = 6
+ IF ( TRIM( variable(6:) ) == '7' ) b = 7
+ IF ( TRIM( variable(6:) ) == '8' ) b = 8
+ IF ( TRIM( variable(6:) ) == '9' ) b = 9
+ IF ( TRIM( variable(6:) ) == '10' ) b = 10
+ IF ( TRIM( variable(6:) ) == '11' ) b = 11
+ IF ( TRIM( variable(6:) ) == '12' ) b = 12
+
+ IF ( av == 0 ) THEN
+ DO i = nxl, nxr
+ DO j = nys, nyn
+ DO k = nzb_do, nzt_do
+ local_pf(i,j,k) = MERGE( aerosol_number(b)%conc(k,j,i), &
+ REAL( fill_value, KIND = wp ), &
+ BTEST( wall_flags_0(k,j,i), 0 ) )
+ ENDDO
+ ENDDO
+ ENDDO
+ ELSE
+ DO i = nxl, nxr
+ DO j = nys, nyn
+ DO k = nzb_do, nzt_do
+ local_pf(i,j,k) = MERGE( Nbins_av(k,j,i,b), &
+ REAL( fill_value, KIND = wp ), &
BTEST( wall_flags_0(k,j,i), 0 ) )
ENDDO
@@ -10142,11 +9713,11 @@
DO i = nxl, nxr
DO j = nys, nyn
- DO k = nzb, nzt+1
+ DO k = nzb_do, nzt_do
temp_bin = 0.0_wp
- DO n = 1, nbins
- temp_bin = temp_bin + aerosol_number(n)%conc(k,j,i)
+ DO b = 1, nbins
+ temp_bin = temp_bin + aerosol_number(b)%conc(k,j,i)
ENDDO
local_pf(i,j,k) = MERGE( temp_bin, &
- REAL( -999.0_wp, KIND = wp ), &
+ REAL( fill_value, KIND = wp ), &
BTEST( wall_flags_0(k,j,i), 0 ) )
ENDDO
@@ -10156,7 +9727,48 @@
DO i = nxl, nxr
DO j = nys, nyn
- DO k = nzb, nzt+1
+ DO k = nzb_do, nzt_do
local_pf(i,j,k) = MERGE( Ntot_av(k,j,i), &
- REAL( -999.0_wp, KIND = wp ), &
+ REAL( fill_value, KIND = wp ), &
+ BTEST( wall_flags_0(k,j,i), 0 ) )
+ ENDDO
+ ENDDO
+ ENDDO
+ ENDIF
+
+ CASE ( 'm_bin1', 'm_bin2', 'm_bin3', 'm_bin4', 'm_bin5', 'm_bin6', &
+ 'm_bin7', 'm_bin8', 'm_bin9', 'm_bin10' , 'm_bin11', 'm_bin12' )
+ IF ( TRIM( variable(6:) ) == '1' ) b = 1
+ IF ( TRIM( variable(6:) ) == '2' ) b = 2
+ IF ( TRIM( variable(6:) ) == '3' ) b = 3
+ IF ( TRIM( variable(6:) ) == '4' ) b = 4
+ IF ( TRIM( variable(6:) ) == '5' ) b = 5
+ IF ( TRIM( variable(6:) ) == '6' ) b = 6
+ IF ( TRIM( variable(6:) ) == '7' ) b = 7
+ IF ( TRIM( variable(6:) ) == '8' ) b = 8
+ IF ( TRIM( variable(6:) ) == '9' ) b = 9
+ IF ( TRIM( variable(6:) ) == '10' ) b = 10
+ IF ( TRIM( variable(6:) ) == '11' ) b = 11
+ IF ( TRIM( variable(6:) ) == '12' ) b = 12
+
+ IF ( av == 0 ) THEN
+ DO i = nxl, nxr
+ DO j = nys, nyn
+ DO k = nzb_do, nzt_do
+ temp_bin = 0.0_wp
+ DO c = b, ncc_tot * nbins, nbins
+ temp_bin = temp_bin + aerosol_mass(c)%conc(k,j,i)
+ ENDDO
+ local_pf(i,j,k) = MERGE( temp_bin, &
+ REAL( fill_value, KIND = wp ), &
+ BTEST( wall_flags_0(k,j,i), 0 ) )
+ ENDDO
+ ENDDO
+ ENDDO
+ ELSE
+ DO i = nxl, nxr
+ DO j = nys, nyn
+ DO k = nzb_do, nzt_do
+ local_pf(i,j,k) = MERGE( mbins_av(k,j,i,b), &
+ REAL( fill_value, KIND = wp ), &
BTEST( wall_flags_0(k,j,i), 0 ) )
ENDDO
@@ -10169,9 +9781,9 @@
DO i = nxl, nxr
DO j = nys, nyn
- DO k = nzb, nzt+1
+ DO k = nzb_do, nzt_do
temp_bin = 0.0_wp
- DO n = 1, nbins
- IF ( 2.0_wp * Ra_dry(k,j,i,n) <= 2.5E-6_wp ) THEN
- DO c = n, nbins*ncc, nbins
+ DO b = 1, nbins
+ IF ( 2.0_wp * Ra_dry(k,j,i,b) <= 2.5E-6_wp ) THEN
+ DO c = b, nbins * ncc, nbins
temp_bin = temp_bin + aerosol_mass(c)%conc(k,j,i)
ENDDO
@@ -10179,5 +9791,5 @@
ENDDO
local_pf(i,j,k) = MERGE( temp_bin, &
- REAL( -999.0_wp, KIND = wp ), &
+ REAL( fill_value, KIND = wp ), &
BTEST( wall_flags_0(k,j,i), 0 ) )
ENDDO
@@ -10187,7 +9799,7 @@
DO i = nxl, nxr
DO j = nys, nyn
- DO k = nzb, nzt+1
+ DO k = nzb_do, nzt_do
local_pf(i,j,k) = MERGE( PM25_av(k,j,i), &
- REAL( -999.0_wp, KIND = wp ), &
+ REAL( fill_value, KIND = wp ), &
BTEST( wall_flags_0(k,j,i), 0 ) )
ENDDO
@@ -10200,9 +9812,9 @@
DO i = nxl, nxr
DO j = nys, nyn
- DO k = nzb, nzt+1
+ DO k = nzb_do, nzt_do
temp_bin = 0.0_wp
- DO n = 1, nbins
- IF ( 2.0_wp * Ra_dry(k,j,i,n) <= 10.0E-6_wp ) THEN
- DO c = n, nbins*ncc, nbins
+ DO b = 1, nbins
+ IF ( 2.0_wp * Ra_dry(k,j,i,b) <= 10.0E-6_wp ) THEN
+ DO c = b, nbins * ncc, nbins
temp_bin = temp_bin + aerosol_mass(c)%conc(k,j,i)
ENDDO
@@ -10210,5 +9822,5 @@
ENDDO
local_pf(i,j,k) = MERGE( temp_bin, &
- REAL( -999.0_wp, KIND = wp ), &
+ REAL( fill_value, KIND = wp ), &
BTEST( wall_flags_0(k,j,i), 0 ) )
ENDDO
@@ -10218,607 +9830,7 @@
DO i = nxl, nxr
DO j = nys, nyn
- DO k = nzb, nzt+1
+ DO k = nzb_do, nzt_do
local_pf(i,j,k) = MERGE( PM10_av(k,j,i), &
- REAL( -999.0_wp, KIND = wp ), &
- BTEST( wall_flags_0(k,j,i), 0 ) )
- ENDDO
- ENDDO
- ENDDO
- ENDIF
-
- CASE ( 'N_bin1' )
- IF ( av == 0 ) THEN
- DO i = nxl, nxr
- DO j = nys, nyn
- DO k = nzb, nzt+1
- local_pf(i,j,k) = MERGE( aerosol_number(1)%conc(k,j,i), &
- REAL( -999.0_wp, KIND = wp ), &
- BTEST( wall_flags_0(k,j,i), 0 ) )
- ENDDO
- ENDDO
- ENDDO
- ELSE
- DO i = nxl, nxr
- DO j = nys, nyn
- DO k = nzb, nzt+1
- local_pf(i,j,k) = MERGE( Nbins_av(k,j,i,1), &
- REAL( -999.0_wp, KIND = wp ), &
- BTEST( wall_flags_0(k,j,i), 0 ) )
- ENDDO
- ENDDO
- ENDDO
- ENDIF
-
- CASE ( 'N_bin2' )
- IF ( av == 0 ) THEN
- DO i = nxl, nxr
- DO j = nys, nyn
- DO k = nzb, nzt+1
- local_pf(i,j,k) = MERGE( aerosol_number(2)%conc(k,j,i), &
- REAL( -999.0_wp, KIND = wp ), &
- BTEST( wall_flags_0(k,j,i), 0 ) )
- ENDDO
- ENDDO
- ENDDO
- ELSE
- DO i = nxl, nxr
- DO j = nys, nyn
- DO k = nzb, nzt+1
- local_pf(i,j,k) = MERGE( Nbins_av(k,j,i,2), &
- REAL( -999.0_wp, KIND = wp ), &
- BTEST( wall_flags_0(k,j,i), 0 ) )
- ENDDO
- ENDDO
- ENDDO
- ENDIF
-
- CASE ( 'N_bin3' )
- IF ( av == 0 ) THEN
- DO i = nxl, nxr
- DO j = nys, nyn
- DO k = nzb, nzt+1
- local_pf(i,j,k) = MERGE( aerosol_number(3)%conc(k,j,i), &
- REAL( -999.0_wp, KIND = wp ), &
- BTEST( wall_flags_0(k,j,i), 0 ) )
- ENDDO
- ENDDO
- ENDDO
- ELSE
- DO i = nxl, nxr
- DO j = nys, nyn
- DO k = nzb, nzt+1
- local_pf(i,j,k) = MERGE( Nbins_av(k,j,i,3), &
- REAL( -999.0_wp, KIND = wp ), &
- BTEST( wall_flags_0(k,j,i), 0 ) )
- ENDDO
- ENDDO
- ENDDO
- ENDIF
-
- CASE ( 'N_bin4' )
- IF ( av == 0 ) THEN
- DO i = nxl, nxr
- DO j = nys, nyn
- DO k = nzb, nzt+1
- local_pf(i,j,k) = MERGE( aerosol_number(4)%conc(k,j,i), &
- REAL( -999.0_wp, KIND = wp ), &
- BTEST( wall_flags_0(k,j,i), 0 ) )
- ENDDO
- ENDDO
- ENDDO
- ELSE
- DO i = nxl, nxr
- DO j = nys, nyn
- DO k = nzb, nzt+1
- local_pf(i,j,k) = MERGE( Nbins_av(k,j,i,4), &
- REAL( -999.0_wp, KIND = wp ), &
- BTEST( wall_flags_0(k,j,i), 0 ) )
- ENDDO
- ENDDO
- ENDDO
- ENDIF
-
- CASE ( 'N_bin5' )
- IF ( av == 0 ) THEN
- DO i = nxl, nxr
- DO j = nys, nyn
- DO k = nzb, nzt+1
- local_pf(i,j,k) = MERGE( aerosol_number(5)%conc(k,j,i), &
- REAL( -999.0_wp, KIND = wp ), &
- BTEST( wall_flags_0(k,j,i), 0 ) )
- ENDDO
- ENDDO
- ENDDO
- ELSE
- DO i = nxl, nxr
- DO j = nys, nyn
- DO k = nzb, nzt+1
- local_pf(i,j,k) = MERGE( Nbins_av(k,j,i,5), &
- REAL( -999.0_wp, KIND = wp ), &
- BTEST( wall_flags_0(k,j,i), 0 ) )
- ENDDO
- ENDDO
- ENDDO
- ENDIF
-
- CASE ( 'N_bin6' )
- IF ( av == 0 ) THEN
- DO i = nxl, nxr
- DO j = nys, nyn
- DO k = nzb, nzt+1
- local_pf(i,j,k) = MERGE( aerosol_number(6)%conc(k,j,i), &
- REAL( -999.0_wp, KIND = wp ), &
- BTEST( wall_flags_0(k,j,i), 0 ) )
- ENDDO
- ENDDO
- ENDDO
- ELSE
- DO i = nxl, nxr
- DO j = nys, nyn
- DO k = nzb, nzt+1
- local_pf(i,j,k) = MERGE( Nbins_av(k,j,i,6), &
- REAL( -999.0_wp, KIND = wp ), &
- BTEST( wall_flags_0(k,j,i), 0 ) )
- ENDDO
- ENDDO
- ENDDO
- ENDIF
-
- CASE ( 'N_bin7' )
- IF ( av == 0 ) THEN
- DO i = nxl, nxr
- DO j = nys, nyn
- DO k = nzb, nzt+1
- local_pf(i,j,k) = MERGE( aerosol_number(7)%conc(k,j,i), &
- REAL( -999.0_wp, KIND = wp ), &
- BTEST( wall_flags_0(k,j,i), 0 ) )
- ENDDO
- ENDDO
- ENDDO
- ELSE
- DO i = nxl, nxr
- DO j = nys, nyn
- DO k = nzb, nzt+1
- local_pf(i,j,k) = MERGE( Nbins_av(k,j,i,7), &
- REAL( -999.0_wp, KIND = wp ), &
- BTEST( wall_flags_0(k,j,i), 0 ) )
- ENDDO
- ENDDO
- ENDDO
- ENDIF
-
- CASE ( 'N_bin8' )
- IF ( av == 0 ) THEN
- DO i = nxl, nxr
- DO j = nys, nyn
- DO k = nzb, nzt+1
- local_pf(i,j,k) = MERGE( aerosol_number(8)%conc(k,j,i), &
- REAL( -999.0_wp, KIND = wp ), &
- BTEST( wall_flags_0(k,j,i), 0 ) )
- ENDDO
- ENDDO
- ENDDO
- ELSE
- DO i = nxl, nxr
- DO j = nys, nyn
- DO k = nzb, nzt+1
- local_pf(i,j,k) = MERGE( Nbins_av(k,j,i,8), &
- REAL( -999.0_wp, KIND = wp ), &
- BTEST( wall_flags_0(k,j,i), 0 ) )
- ENDDO
- ENDDO
- ENDDO
- ENDIF
-
- CASE ( 'N_bin9' )
- IF ( av == 0 ) THEN
- DO i = nxl, nxr
- DO j = nys, nyn
- DO k = nzb, nzt+1
- local_pf(i,j,k) = MERGE( aerosol_number(9)%conc(k,j,i), &
- REAL( -999.0_wp, KIND = wp ), &
- BTEST( wall_flags_0(k,j,i), 0 ) )
- ENDDO
- ENDDO
- ENDDO
- ELSE
- DO i = nxl, nxr
- DO j = nys, nyn
- DO k = nzb, nzt+1
- local_pf(i,j,k) = MERGE( Nbins_av(k,j,i,9), &
- REAL( -999.0_wp, KIND = wp ), &
- BTEST( wall_flags_0(k,j,i), 0 ) )
- ENDDO
- ENDDO
- ENDDO
- ENDIF
-
- CASE ( 'N_bin10' )
- IF ( av == 0 ) THEN
- DO i = nxl, nxr
- DO j = nys, nyn
- DO k = nzb, nzt+1
- local_pf(i,j,k) = MERGE( aerosol_number(10)%conc(k,j,i), &
- REAL( -999.0_wp, KIND = wp ), &
- BTEST( wall_flags_0(k,j,i), 0 ) )
- ENDDO
- ENDDO
- ENDDO
- ELSE
- DO i = nxl, nxr
- DO j = nys, nyn
- DO k = nzb, nzt+1
- local_pf(i,j,k) = MERGE( Nbins_av(k,j,i,10), &
- REAL( -999.0_wp, KIND = wp ), &
- BTEST( wall_flags_0(k,j,i), 0 ) )
- ENDDO
- ENDDO
- ENDDO
- ENDIF
-
- CASE ( 'N_bin11' )
- IF ( av == 0 ) THEN
- DO i = nxl, nxr
- DO j = nys, nyn
- DO k = nzb, nzt+1
- local_pf(i,j,k) = MERGE( aerosol_number(11)%conc(k,j,i), &
- REAL( -999.0_wp, KIND = wp ), &
- BTEST( wall_flags_0(k,j,i), 0 ) )
- ENDDO
- ENDDO
- ENDDO
- ELSE
- DO i = nxl, nxr
- DO j = nys, nyn
- DO k = nzb, nzt+1
- local_pf(i,j,k) = MERGE( Nbins_av(k,j,i,11), &
- REAL( -999.0_wp, KIND = wp ), &
- BTEST( wall_flags_0(k,j,i), 0 ) )
- ENDDO
- ENDDO
- ENDDO
- ENDIF
-
- CASE ( 'N_bin12' )
- IF ( av == 0 ) THEN
- DO i = nxl, nxr
- DO j = nys, nyn
- DO k = nzb, nzt+1
- local_pf(i,j,k) = MERGE( aerosol_number(12)%conc(k,j,i), &
- REAL( -999.0_wp, KIND = wp ), &
- BTEST( wall_flags_0(k,j,i), 0 ) )
- ENDDO
- ENDDO
- ENDDO
- ELSE
- DO i = nxl, nxr
- DO j = nys, nyn
- DO k = nzb, nzt+1
- local_pf(i,j,k) = MERGE( Nbins_av(k,j,i,12), &
- REAL( -999.0_wp, KIND = wp ), &
- BTEST( wall_flags_0(k,j,i), 0 ) )
- ENDDO
- ENDDO
- ENDDO
- ENDIF
-
- CASE ( 'm_bin1' )
- IF ( av == 0 ) THEN
- DO i = nxl, nxr
- DO j = nys, nyn
- DO k = nzb, nzt+1
- temp_bin = 0.0_wp
- DO c = 1, ncc_tot*nbins, nbins
- temp_bin = temp_bin + aerosol_mass(c)%conc(k,j,i)
- ENDDO
- local_pf(i,j,k) = MERGE( temp_bin, &
- REAL( -999.0_wp, KIND = wp ), &
- BTEST( wall_flags_0(k,j,i), 0 ) )
- ENDDO
- ENDDO
- ENDDO
- ELSE
- DO i = nxl, nxr
- DO j = nys, nyn
- DO k = nzb, nzt+1
- local_pf(i,j,k) = MERGE( mbins_av(k,j,i,1), &
- REAL( -999.0_wp, KIND = wp ), &
- BTEST( wall_flags_0(k,j,i), 0 ) )
- ENDDO
- ENDDO
- ENDDO
- ENDIF
-
- CASE ( 'm_bin2' )
- IF ( av == 0 ) THEN
- DO i = nxl, nxr
- DO j = nys, nyn
- DO k = nzb, nzt+1
- temp_bin = 0.0_wp
- DO c = 2, ncc_tot*nbins, nbins
- temp_bin = temp_bin + aerosol_mass(c)%conc(k,j,i)
- ENDDO
- local_pf(i,j,k) = MERGE( temp_bin, &
- REAL( -999.0_wp, KIND = wp ), &
- BTEST( wall_flags_0(k,j,i), 0 ) )
- ENDDO
- ENDDO
- ENDDO
- ELSE
- DO i = nxl, nxr
- DO j = nys, nyn
- DO k = nzb, nzt+1
- local_pf(i,j,k) = MERGE( mbins_av(k,j,i,2), &
- REAL( -999.0_wp, KIND = wp ), &
- BTEST( wall_flags_0(k,j,i), 0 ) )
- ENDDO
- ENDDO
- ENDDO
- ENDIF
-
- CASE ( 'm_bin3' )
- IF ( av == 0 ) THEN
- DO i = nxl, nxr
- DO j = nys, nyn
- DO k = nzb, nzt+1
- temp_bin = 0.0_wp
- DO c = 3, ncc_tot*nbins, nbins
- temp_bin = temp_bin + aerosol_mass(c)%conc(k,j,i)
- ENDDO
- local_pf(i,j,k) = MERGE( temp_bin, &
- REAL( -999.0_wp, KIND = wp ), &
- BTEST( wall_flags_0(k,j,i), 0 ) )
- ENDDO
- ENDDO
- ENDDO
- ELSE
- DO i = nxl, nxr
- DO j = nys, nyn
- DO k = nzb, nzt+1
- local_pf(i,j,k) = MERGE( mbins_av(k,j,i,3), &
- REAL( -999.0_wp, KIND = wp ), &
- BTEST( wall_flags_0(k,j,i), 0 ) )
- ENDDO
- ENDDO
- ENDDO
- ENDIF
-
- CASE ( 'm_bin4' )
- IF ( av == 0 ) THEN
- DO i = nxl, nxr
- DO j = nys, nyn
- DO k = nzb, nzt+1
- temp_bin = 0.0_wp
- DO c = 4, ncc_tot*nbins, nbins
- temp_bin = temp_bin + aerosol_mass(c)%conc(k,j,i)
- ENDDO
- local_pf(i,j,k) = MERGE( temp_bin, &
- REAL( -999.0_wp, KIND = wp ), &
- BTEST( wall_flags_0(k,j,i), 0 ) )
- ENDDO
- ENDDO
- ENDDO
- ELSE
- DO i = nxl, nxr
- DO j = nys, nyn
- DO k = nzb, nzt+1
- local_pf(i,j,k) = MERGE( mbins_av(k,j,i,4), &
- REAL( -999.0_wp, KIND = wp ), &
- BTEST( wall_flags_0(k,j,i), 0 ) )
- ENDDO
- ENDDO
- ENDDO
- ENDIF
-
- CASE ( 'm_bin5' )
- IF ( av == 0 ) THEN
- DO i = nxl, nxr
- DO j = nys, nyn
- DO k = nzb, nzt+1
- temp_bin = 0.0_wp
- DO c = 5, ncc_tot*nbins, nbins
- temp_bin = temp_bin + aerosol_mass(c)%conc(k,j,i)
- ENDDO
- local_pf(i,j,k) = MERGE( temp_bin, &
- REAL( -999.0_wp, KIND = wp ), &
- BTEST( wall_flags_0(k,j,i), 0 ) )
- ENDDO
- ENDDO
- ENDDO
- ELSE
- DO i = nxl, nxr
- DO j = nys, nyn
- DO k = nzb, nzt+1
- local_pf(i,j,k) = MERGE( mbins_av(k,j,i,5), &
- REAL( -999.0_wp, KIND = wp ), &
- BTEST( wall_flags_0(k,j,i), 0 ) )
- ENDDO
- ENDDO
- ENDDO
- ENDIF
-
- CASE ( 'm_bin6' )
- IF ( av == 0 ) THEN
- DO i = nxl, nxr
- DO j = nys, nyn
- DO k = nzb, nzt+1
- temp_bin = 0.0_wp
- DO c = 6, ncc_tot*nbins, nbins
- temp_bin = temp_bin + aerosol_mass(c)%conc(k,j,i)
- ENDDO
- local_pf(i,j,k) = MERGE( temp_bin, &
- REAL( -999.0_wp, KIND = wp ), &
- BTEST( wall_flags_0(k,j,i), 0 ) )
- ENDDO
- ENDDO
- ENDDO
- ELSE
- DO i = nxl, nxr
- DO j = nys, nyn
- DO k = nzb, nzt+1
- local_pf(i,j,k) = MERGE( mbins_av(k,j,i,6), &
- REAL( -999.0_wp, KIND = wp ), &
- BTEST( wall_flags_0(k,j,i), 0 ) )
- ENDDO
- ENDDO
- ENDDO
- ENDIF
-
- CASE ( 'm_bin7' )
- IF ( av == 0 ) THEN
- DO i = nxl, nxr
- DO j = nys, nyn
- DO k = nzb, nzt+1
- temp_bin = 0.0_wp
- DO c = 7, ncc_tot*nbins, nbins
- temp_bin = temp_bin + aerosol_mass(c)%conc(k,j,i)
- ENDDO
- local_pf(i,j,k) = MERGE( temp_bin, &
- REAL( -999.0_wp, KIND = wp ), &
- BTEST( wall_flags_0(k,j,i), 0 ) )
- ENDDO
- ENDDO
- ENDDO
- ELSE
- DO i = nxl, nxr
- DO j = nys, nyn
- DO k = nzb, nzt+1
- local_pf(i,j,k) = MERGE( mbins_av(k,j,i,7), &
- REAL( -999.0_wp, KIND = wp ), &
- BTEST( wall_flags_0(k,j,i), 0 ) )
- ENDDO
- ENDDO
- ENDDO
- ENDIF
-
- CASE ( 'm_bin8' )
- IF ( av == 0 ) THEN
- DO i = nxl, nxr
- DO j = nys, nyn
- DO k = nzb, nzt+1
- temp_bin = 0.0_wp
- DO c = 8, ncc_tot*nbins, nbins
- temp_bin = temp_bin + aerosol_mass(c)%conc(k,j,i)
- ENDDO
- local_pf(i,j,k) = MERGE( temp_bin, &
- REAL( -999.0_wp, KIND = wp ), &
- BTEST( wall_flags_0(k,j,i), 0 ) )
- ENDDO
- ENDDO
- ENDDO
- ELSE
- DO i = nxl, nxr
- DO j = nys, nyn
- DO k = nzb, nzt+1
- local_pf(i,j,k) = MERGE( mbins_av(k,j,i,8), &
- REAL( -999.0_wp, KIND = wp ), &
- BTEST( wall_flags_0(k,j,i), 0 ) )
- ENDDO
- ENDDO
- ENDDO
- ENDIF
-
- CASE ( 'm_bin9' )
- IF ( av == 0 ) THEN
- DO i = nxl, nxr
- DO j = nys, nyn
- DO k = nzb, nzt+1
- temp_bin = 0.0_wp
- DO c = 9, ncc_tot*nbins, nbins
- temp_bin = temp_bin + aerosol_mass(c)%conc(k,j,i)
- ENDDO
- local_pf(i,j,k) = MERGE( temp_bin, &
- REAL( -999.0_wp, KIND = wp ), &
- BTEST( wall_flags_0(k,j,i), 0 ) )
- ENDDO
- ENDDO
- ENDDO
- ELSE
- DO i = nxl, nxr
- DO j = nys, nyn
- DO k = nzb, nzt+1
- local_pf(i,j,k) = MERGE( mbins_av(k,j,i,9), &
- REAL( -999.0_wp, KIND = wp ), &
- BTEST( wall_flags_0(k,j,i), 0 ) )
- ENDDO
- ENDDO
- ENDDO
- ENDIF
-
- CASE ( 'm_bin10' )
- IF ( av == 0 ) THEN
- DO i = nxl, nxr
- DO j = nys, nyn
- DO k = nzb, nzt+1
- temp_bin = 0.0_wp
- DO c = 10, ncc_tot*nbins, nbins
- temp_bin = temp_bin + aerosol_mass(c)%conc(k,j,i)
- ENDDO
- local_pf(i,j,k) = MERGE( temp_bin, &
- REAL( -999.0_wp, KIND = wp ), &
- BTEST( wall_flags_0(k,j,i), 0 ) )
- ENDDO
- ENDDO
- ENDDO
- ELSE
- DO i = nxl, nxr
- DO j = nys, nyn
- DO k = nzb, nzt+1
- local_pf(i,j,k) = MERGE( mbins_av(k,j,i,10), &
- REAL( -999.0_wp, KIND = wp ), &
- BTEST( wall_flags_0(k,j,i), 0 ) )
- ENDDO
- ENDDO
- ENDDO
- ENDIF
-
- CASE ( 'm_bin11' )
- IF ( av == 0 ) THEN
- DO i = nxl, nxr
- DO j = nys, nyn
- DO k = nzb, nzt+1
- temp_bin = 0.0_wp
- DO c = 11, ncc_tot*nbins, nbins
- temp_bin = temp_bin + aerosol_mass(c)%conc(k,j,i)
- ENDDO
- local_pf(i,j,k) = MERGE( temp_bin, &
- REAL( -999.0_wp, KIND = wp ), &
- BTEST( wall_flags_0(k,j,i), 0 ) )
- ENDDO
- ENDDO
- ENDDO
- ELSE
- DO i = nxl, nxr
- DO j = nys, nyn
- DO k = nzb, nzt+1
- local_pf(i,j,k) = MERGE( mbins_av(k,j,i,11), &
- REAL( -999.0_wp, KIND = wp ), &
- BTEST( wall_flags_0(k,j,i), 0 ) )
- ENDDO
- ENDDO
- ENDDO
- ENDIF
-
- CASE ( 'm_bin12' )
- IF ( av == 0 ) THEN
- DO i = nxl, nxr
- DO j = nys, nyn
- DO k = nzb, nzt+1
- temp_bin = 0.0_wp
- DO c = 12, ncc_tot*nbins, nbins
- temp_bin = temp_bin + aerosol_mass(c)%conc(k,j,i)
- ENDDO
- local_pf(i,j,k) = MERGE( temp_bin, &
- REAL( -999.0_wp, KIND = wp ), &
- BTEST( wall_flags_0(k,j,i), 0 ) )
- ENDDO
- ENDDO
- ENDDO
- ELSE
- DO i = nxl, nxr
- DO j = nys, nyn
- DO k = nzb, nzt+1
- local_pf(i,j,k) = MERGE( mbins_av(k,j,i,12), &
- REAL( -999.0_wp, KIND = wp ), &
+ REAL( fill_value, KIND = wp ), &
BTEST( wall_flags_0(k,j,i), 0 ) )
ENDDO
@@ -10833,5 +9845,5 @@
DO i = nxl, nxr
DO j = nys, nyn
- DO k = nzb, nzt+1
+ DO k = nzb_do, nzt_do
temp_bin = 0.0_wp
DO c = ( icc-1 )*nbins+1, icc*nbins
@@ -10839,5 +9851,5 @@
ENDDO
local_pf(i,j,k) = MERGE( temp_bin, &
- REAL( -999.0_wp, KIND = wp ), &
+ REAL( fill_value, KIND = wp ), &
BTEST( wall_flags_0(k,j,i), 0 ) )
ENDDO
@@ -10854,7 +9866,7 @@
DO i = nxl, nxr
DO j = nys, nyn
- DO k = nzb, nzt+1
+ DO k = nzb_do, nzt_do
local_pf(i,j,k) = MERGE( to_be_resorted(k,j,i), &
- REAL( -999.0_wp, KIND = wp ), &
+ REAL( fill_value, KIND = wp ), &
BTEST( wall_flags_0(k,j,i), 0 ) )
ENDDO
@@ -10878,34 +9890,45 @@
SUBROUTINE salsa_data_output_mask( av, variable, found, local_pf )
+ USE arrays_3d, &
+ ONLY: tend
+
USE control_parameters, &
- ONLY: mask_size_l, mid
+ ONLY: mask_size_l, mask_surface, mid
+
+ USE surface_mod, &
+ ONLY: get_topography_top_index_ji
IMPLICIT NONE
- CHARACTER (LEN=*) :: variable !<
-
- INTEGER(iwp) :: av !<
- INTEGER(iwp) :: c !<
- INTEGER(iwp) :: i !<
- INTEGER(iwp) :: icc !< index of a chemical compound
- INTEGER(iwp) :: j !<
- INTEGER(iwp) :: k !<
- INTEGER(iwp) :: n !<
-
- LOGICAL :: found !<
- REAL(wp) :: df !< For calculating LDSA: fraction of particles
- !< depositing in the alveolar (or tracheobronchial)
- !< region of the lung. Depends on the particle size
- REAL(wp) :: mean_d !< Particle diameter in micrometres
- REAL(wp) :: nc !< Particle number concentration in units 1/cm**3
-
- REAL(wp), &
- DIMENSION(mask_size_l(mid,1),mask_size_l(mid,2),mask_size_l(mid,3)) :: &
- local_pf !<
- REAL(wp) :: temp_bin !<
- REAL(wp), DIMENSION(:,:,:), POINTER :: to_be_resorted !< points to
- !< selected output variable
+ CHARACTER(LEN=5) :: grid !< flag to distinquish between staggered grid
+ CHARACTER(LEN=*) :: variable !<
+ CHARACTER(LEN=7) :: vari !< trimmed format of variable
+
+ INTEGER(iwp) :: av !<
+ INTEGER(iwp) :: b !< loop index for aerosol size number bins
+ INTEGER(iwp) :: c !< loop index for chemical components
+ INTEGER(iwp) :: i !< loop index in x-direction
+ INTEGER(iwp) :: icc !< index of a chemical compound
+ INTEGER(iwp) :: j !< loop index in y-direction
+ INTEGER(iwp) :: k !< loop index in z-direction
+ INTEGER(iwp) :: topo_top_ind !< k index of highest horizontal surface
+
+ LOGICAL :: found !<
+ LOGICAL :: resorted !<
+
+ REAL(wp) :: df !< For calculating LDSA: fraction of particles
+ !< depositing in the alveolar (or tracheobronchial)
+ !< region of the lung. Depends on the particle size
+ REAL(wp) :: mean_d !< Particle diameter in micrometres
+ REAL(wp) :: nc !< Particle number concentration in units 1/cm**3
+ REAL(wp) :: temp_bin !< temporary array for calculating output variables
+
+ REAL(wp), DIMENSION(mask_size_l(mid,1),mask_size_l(mid,2),mask_size_l(mid,3)) :: local_pf !<
+
+ REAL(wp), DIMENSION(:,:,:), POINTER :: to_be_resorted !< pointer
found = .TRUE.
+ resorted = .FALSE.
+ grid = 's'
temp_bin = 0.0_wp
@@ -10913,745 +9936,356 @@
CASE ( 'g_H2SO4', 'g_HNO3', 'g_NH3', 'g_OCNV', 'g_OCSV' )
+ vari = TRIM( variable )
IF ( av == 0 ) THEN
- IF ( TRIM( variable ) == 'g_H2SO4') icc = 1
- IF ( TRIM( variable ) == 'g_HNO3') icc = 2
- IF ( TRIM( variable ) == 'g_NH3') icc = 3
- IF ( TRIM( variable ) == 'g_OCNV') icc = 4
- IF ( TRIM( variable ) == 'g_OCSV') icc = 5
-
- DO i = 1, mask_size_l(mid,1)
- DO j = 1, mask_size_l(mid,2)
- DO k = 1, mask_size_l(mid,3)
- local_pf(i,j,k) = salsa_gas(icc)%conc(mask_k(mid,k), &
- mask_j(mid,j),mask_i(mid,i))
- ENDDO
- ENDDO
- ENDDO
+ IF ( vari == 'g_H2SO4') to_be_resorted => salsa_gas(1)%conc
+ IF ( vari == 'g_HNO3') to_be_resorted => salsa_gas(2)%conc
+ IF ( vari == 'g_NH3') to_be_resorted => salsa_gas(3)%conc
+ IF ( vari == 'g_OCNV') to_be_resorted => salsa_gas(4)%conc
+ IF ( vari == 'g_OCSV') to_be_resorted => salsa_gas(5)%conc
ELSE
- IF ( TRIM( variable(3:) ) == 'H2SO4' ) to_be_resorted => g_H2SO4_av
- IF ( TRIM( variable(3:) ) == 'HNO3' ) to_be_resorted => g_HNO3_av
- IF ( TRIM( variable(3:) ) == 'NH3' ) to_be_resorted => g_NH3_av
- IF ( TRIM( variable(3:) ) == 'OCNV' ) to_be_resorted => g_OCNV_av
- IF ( TRIM( variable(3:) ) == 'OCSV' ) to_be_resorted => g_OCSV_av
- DO i = 1, mask_size_l(mid,1)
- DO j = 1, mask_size_l(mid,2)
- DO k = 1, mask_size_l(mid,3)
- local_pf(i,j,k) = to_be_resorted(mask_k(mid,k), &
- mask_j(mid,j),mask_i(mid,i))
- ENDDO
- ENDDO
- ENDDO
+ IF ( vari == 'g_H2SO4') to_be_resorted => g_H2SO4_av
+ IF ( vari == 'g_HNO3') to_be_resorted => g_HNO3_av
+ IF ( vari == 'g_NH3') to_be_resorted => g_NH3_av
+ IF ( vari == 'g_OCNV') to_be_resorted => g_OCNV_av
+ IF ( vari == 'g_OCSV') to_be_resorted => g_OCSV_av
ENDIF
-
+
CASE ( 'LDSA' )
IF ( av == 0 ) THEN
- DO i = 1, mask_size_l(mid,1)
- DO j = 1, mask_size_l(mid,2)
- DO k = 1, mask_size_l(mid,3)
+ DO i = nxl, nxr
+ DO j = nys, nyn
+ DO k = nzb, nz_do3d
temp_bin = 0.0_wp
- DO n = 1, nbins
+ DO b = 1, nbins
!
!-- Diameter in micrometres
- mean_d = 1.0E+6_wp * Ra_dry(mask_k(mid,k), &
- mask_j(mid,j),mask_i(mid,i),n) * 2.0_wp
+ mean_d = 1.0E+6_wp * Ra_dry(k,j,i,b) * 2.0_wp
!
-!-- Deposition factor: alveolar (use Ra_dry for the size??)
+!-- Deposition factor: alveolar
df = ( 0.01555_wp / mean_d ) * ( EXP( -0.416_wp * &
- ( LOG( mean_d ) + 2.84_wp )**2.0_wp ) &
- + 19.11_wp * EXP( -0.482_wp * &
- ( LOG( mean_d ) - 1.362_wp )**2.0_wp ) )
+ ( LOG( mean_d ) + 2.84_wp )**2.0_wp ) + 19.11_wp &
+ * EXP( -0.482_wp * ( LOG( mean_d ) - 1.362_wp &
+ )**2.0_wp ) )
!
!-- Number concentration in 1/cm3
- nc = 1.0E-6_wp * aerosol_number(n)%conc(mask_k(mid,k),&
- mask_j(mid,j),mask_i(mid,i))
+ nc = 1.0E-6_wp * aerosol_number(b)%conc(k,j,i)
!
!-- Lung-deposited surface area LDSA (units mum2/cm3)
temp_bin = temp_bin + pi * mean_d**2.0_wp * df * nc
ENDDO
- local_pf(i,j,k) = temp_bin
+ tend(k,j,i) = temp_bin
ENDDO
ENDDO
ENDDO
- ELSE
- DO i = 1, mask_size_l(mid,1)
- DO j = 1, mask_size_l(mid,2)
- DO k = 1, mask_size_l(mid,3)
- local_pf(i,j,k) = LDSA_av(mask_k(mid,k), &
- mask_j(mid,j),mask_i(mid,i))
+ IF ( .NOT. mask_surface(mid) ) THEN
+ DO i = 1, mask_size_l(mid,1)
+ DO j = 1, mask_size_l(mid,2)
+ DO k = 1, mask_size_l(mid,3)
+ local_pf(i,j,k) = tend( mask_k(mid,k), mask_j(mid,j),&
+ mask_i(mid,i) )
+ ENDDO
ENDDO
ENDDO
- ENDDO
+ ELSE
+ DO i = 1, mask_size_l(mid,1)
+ DO j = 1, mask_size_l(mid,2)
+ topo_top_ind = get_topography_top_index_ji( mask_j(mid,j),&
+ mask_i(mid,i),&
+ grid )
+ DO k = 1, mask_size_l(mid,3)
+ local_pf(i,j,k) = tend( MIN( topo_top_ind+mask_k(mid,k),&
+ nzt+1 ), &
+ mask_j(mid,j), mask_i(mid,i) )
+ ENDDO
+ ENDDO
+ ENDDO
+ ENDIF
+ resorted = .TRUE.
+ ELSE
+ to_be_resorted => LDSA_av
ENDIF
-
+
+ CASE ( 'N_bin1', 'N_bin2', 'N_bin3', 'N_bin4', 'N_bin5', 'N_bin6', &
+ 'N_bin7', 'N_bin8', 'N_bin9', 'N_bin10' , 'N_bin11', 'N_bin12' )
+ IF ( TRIM( variable(6:) ) == '1' ) b = 1
+ IF ( TRIM( variable(6:) ) == '2' ) b = 2
+ IF ( TRIM( variable(6:) ) == '3' ) b = 3
+ IF ( TRIM( variable(6:) ) == '4' ) b = 4
+ IF ( TRIM( variable(6:) ) == '5' ) b = 5
+ IF ( TRIM( variable(6:) ) == '6' ) b = 6
+ IF ( TRIM( variable(6:) ) == '7' ) b = 7
+ IF ( TRIM( variable(6:) ) == '8' ) b = 8
+ IF ( TRIM( variable(6:) ) == '9' ) b = 9
+ IF ( TRIM( variable(6:) ) == '10' ) b = 10
+ IF ( TRIM( variable(6:) ) == '11' ) b = 11
+ IF ( TRIM( variable(6:) ) == '12' ) b = 12
+
+ IF ( av == 0 ) THEN
+ IF ( .NOT. mask_surface(mid) ) THEN
+ DO i = 1, mask_size_l(mid,1)
+ DO j = 1, mask_size_l(mid,2)
+ DO k = 1, mask_size_l(mid,3)
+ local_pf(i,j,k) = aerosol_number(b)%conc( mask_k(mid,k),&
+ mask_j(mid,j),&
+ mask_i(mid,i) )
+ ENDDO
+ ENDDO
+ ENDDO
+ ELSE
+ DO i = 1, mask_size_l(mid,1)
+ DO j = 1, mask_size_l(mid,2)
+ topo_top_ind = get_topography_top_index_ji( mask_j(mid,j),&
+ mask_i(mid,i),&
+ grid )
+ DO k = 1, mask_size_l(mid,3)
+ local_pf(i,j,k) = aerosol_number(b)%conc( &
+ MIN( topo_top_ind+mask_k(mid,k), &
+ nzt+1 ), &
+ mask_j(mid,j), mask_i(mid,i) )
+ ENDDO
+ ENDDO
+ ENDDO
+ ENDIF
+ resorted = .TRUE.
+ ELSE
+ to_be_resorted => Nbins_av(:,:,:,b)
+ ENDIF
+
CASE ( 'Ntot' )
IF ( av == 0 ) THEN
- DO i = 1, mask_size_l(mid,1)
- DO j = 1, mask_size_l(mid,2)
- DO k = 1, mask_size_l(mid,3)
+ DO i = nxl, nxr
+ DO j = nys, nyn
+ DO k = nzb, nz_do3d
temp_bin = 0.0_wp
- DO n = 1, nbins
- temp_bin = temp_bin + aerosol_number(n)%conc( &
- mask_k(mid,k),mask_j(mid,j),mask_i(mid,i))
+ DO b = 1, nbins
+ temp_bin = temp_bin + aerosol_number(b)%conc(k,j,i)
ENDDO
- local_pf(i,j,k) = temp_bin
+ tend(k,j,i) = temp_bin
ENDDO
ENDDO
- ENDDO
- ELSE
- DO i = 1, mask_size_l(mid,1)
- DO j = 1, mask_size_l(mid,2)
- DO k = 1, mask_size_l(mid,3)
- local_pf(i,j,k) = Ntot_av(mask_k(mid,k), &
- mask_j(mid,j),mask_i(mid,i))
+ ENDDO
+ IF ( .NOT. mask_surface(mid) ) THEN
+ DO i = 1, mask_size_l(mid,1)
+ DO j = 1, mask_size_l(mid,2)
+ DO k = 1, mask_size_l(mid,3)
+ local_pf(i,j,k) = tend( mask_k(mid,k), mask_j(mid,j),&
+ mask_i(mid,i) )
+ ENDDO
ENDDO
ENDDO
- ENDDO
+ ELSE
+ DO i = 1, mask_size_l(mid,1)
+ DO j = 1, mask_size_l(mid,2)
+ topo_top_ind = get_topography_top_index_ji( mask_j(mid,j),&
+ mask_i(mid,i),&
+ grid )
+ DO k = 1, mask_size_l(mid,3)
+ local_pf(i,j,k) = tend( MIN( topo_top_ind+mask_k(mid,k),&
+ nzt+1 ), &
+ mask_j(mid,j), mask_i(mid,i) )
+ ENDDO
+ ENDDO
+ ENDDO
+ ENDIF
+ resorted = .TRUE.
+ ELSE
+ to_be_resorted => Ntot_av
+ ENDIF
+
+ CASE ( 'm_bin1', 'm_bin2', 'm_bin3', 'm_bin4', 'm_bin5', 'm_bin6', &
+ 'm_bin7', 'm_bin8', 'm_bin9', 'm_bin10' , 'm_bin11', 'm_bin12' )
+ IF ( TRIM( variable(6:) ) == '1' ) b = 1
+ IF ( TRIM( variable(6:) ) == '2' ) b = 2
+ IF ( TRIM( variable(6:) ) == '3' ) b = 3
+ IF ( TRIM( variable(6:) ) == '4' ) b = 4
+ IF ( TRIM( variable(6:) ) == '5' ) b = 5
+ IF ( TRIM( variable(6:) ) == '6' ) b = 6
+ IF ( TRIM( variable(6:) ) == '7' ) b = 7
+ IF ( TRIM( variable(6:) ) == '8' ) b = 8
+ IF ( TRIM( variable(6:) ) == '9' ) b = 9
+ IF ( TRIM( variable(6:) ) == '10' ) b = 10
+ IF ( TRIM( variable(6:) ) == '11' ) b = 11
+ IF ( TRIM( variable(6:) ) == '12' ) b = 12
+
+ IF ( av == 0 ) THEN
+ DO i = nxl, nxr
+ DO j = nys, nyn
+ DO k = nzb, nz_do3d
+ temp_bin = 0.0_wp
+ DO c = b, ncc_tot*nbins, nbins
+ temp_bin = temp_bin + aerosol_mass(c)%conc(k,j,i)
+ ENDDO
+ tend(k,j,i) = temp_bin
+ ENDDO
+ ENDDO
+ ENDDO
+ IF ( .NOT. mask_surface(mid) ) THEN
+ DO i = 1, mask_size_l(mid,1)
+ DO j = 1, mask_size_l(mid,2)
+ DO k = 1, mask_size_l(mid,3)
+ local_pf(i,j,k) = tend( mask_k(mid,k), mask_j(mid,j),&
+ mask_i(mid,i) )
+ ENDDO
+ ENDDO
+ ENDDO
+ ELSE
+ DO i = 1, mask_size_l(mid,1)
+ DO j = 1, mask_size_l(mid,2)
+ topo_top_ind = get_topography_top_index_ji( mask_j(mid,j),&
+ mask_i(mid,i),&
+ grid )
+ DO k = 1, mask_size_l(mid,3)
+ local_pf(i,j,k) = tend( MIN( topo_top_ind+mask_k(mid,k),&
+ nzt+1 ), &
+ mask_j(mid,j), mask_i(mid,i) )
+ ENDDO
+ ENDDO
+ ENDDO
+ ENDIF
+ resorted = .TRUE.
+ ELSE
+ to_be_resorted => mbins_av(:,:,:,b)
ENDIF
CASE ( 'PM2.5' )
IF ( av == 0 ) THEN
- DO i = 1, mask_size_l(mid,1)
- DO j = 1, mask_size_l(mid,2)
- DO k = 1, mask_size_l(mid,3)
+ DO i = nxl, nxr
+ DO j = nys, nyn
+ DO k = nzb, nz_do3d
temp_bin = 0.0_wp
- DO n = 1, nbins
- IF ( 2.0_wp * Ra_dry(mask_k(mid,k),mask_j(mid,j), &
- mask_i(mid,i),n) <= 2.5E-6_wp ) THEN
- DO c = n, nbins*ncc, nbins
- temp_bin = temp_bin + aerosol_mass(c)%conc( &
- mask_k(mid,k), mask_j(mid,j),mask_i(mid,i))
+ DO b = 1, nbins
+ IF ( 2.0_wp * Ra_dry(k,j,i,b) <= 2.5E-6_wp ) THEN
+ DO c = b, nbins * ncc, nbins
+ temp_bin = temp_bin + aerosol_mass(c)%conc(k,j,i)
ENDDO
ENDIF
ENDDO
- local_pf(i,j,k) = temp_bin
+ tend(k,j,i) = temp_bin
ENDDO
ENDDO
- ENDDO
- ELSE
- DO i = 1, mask_size_l(mid,1)
- DO j = 1, mask_size_l(mid,2)
- DO k = 1, mask_size_l(mid,3)
- local_pf(i,j,k) = PM25_av(mask_k(mid,k), &
- mask_j(mid,j),mask_i(mid,i))
+ ENDDO
+ IF ( .NOT. mask_surface(mid) ) THEN
+ DO i = 1, mask_size_l(mid,1)
+ DO j = 1, mask_size_l(mid,2)
+ DO k = 1, mask_size_l(mid,3)
+ local_pf(i,j,k) = tend( mask_k(mid,k), mask_j(mid,j),&
+ mask_i(mid,i) )
+ ENDDO
ENDDO
ENDDO
- ENDDO
+ ELSE
+ DO i = 1, mask_size_l(mid,1)
+ DO j = 1, mask_size_l(mid,2)
+ topo_top_ind = get_topography_top_index_ji( mask_j(mid,j),&
+ mask_i(mid,i),&
+ grid )
+ DO k = 1, mask_size_l(mid,3)
+ local_pf(i,j,k) = tend( MIN( topo_top_ind+mask_k(mid,k),&
+ nzt+1 ), &
+ mask_j(mid,j), mask_i(mid,i) )
+ ENDDO
+ ENDDO
+ ENDDO
+ ENDIF
+ resorted = .TRUE.
+ ELSE
+ to_be_resorted => PM25_av
ENDIF
-
+
CASE ( 'PM10' )
IF ( av == 0 ) THEN
- DO i = 1, mask_size_l(mid,1)
- DO j = 1, mask_size_l(mid,2)
- DO k = 1, mask_size_l(mid,3)
+ DO i = nxl, nxr
+ DO j = nys, nyn
+ DO k = nzb, nz_do3d
temp_bin = 0.0_wp
- DO n = 1, nbins
- IF ( 2.0_wp * Ra_dry(mask_k(mid,k),mask_j(mid,j), &
- mask_i(mid,i),n) <= 10.0E-6_wp ) THEN
- DO c = n, nbins*ncc, nbins
- temp_bin = temp_bin + aerosol_mass(c)%conc( &
- mask_k(mid,k),mask_j(mid,j),mask_i(mid,i))
+ DO b = 1, nbins
+ IF ( 2.0_wp * Ra_dry(k,j,i,b) <= 10.0E-6_wp ) THEN
+ DO c = b, nbins * ncc, nbins
+ temp_bin = temp_bin + aerosol_mass(c)%conc(k,j,i)
ENDDO
ENDIF
ENDDO
- local_pf(i,j,k) = temp_bin
+ tend(k,j,i) = temp_bin
ENDDO
ENDDO
- ENDDO
- ELSE
- DO i = 1, mask_size_l(mid,1)
- DO j = 1, mask_size_l(mid,2)
- DO k = 1, mask_size_l(mid,3)
- local_pf(i,j,k) = PM10_av(mask_k(mid,k), &
- mask_j(mid,j),mask_i(mid,i))
+ ENDDO
+ IF ( .NOT. mask_surface(mid) ) THEN
+ DO i = 1, mask_size_l(mid,1)
+ DO j = 1, mask_size_l(mid,2)
+ DO k = 1, mask_size_l(mid,3)
+ local_pf(i,j,k) = tend( mask_k(mid,k), mask_j(mid,j),&
+ mask_i(mid,i) )
+ ENDDO
ENDDO
ENDDO
- ENDDO
- ENDIF
-
- CASE ( 'N_bin1' )
- IF ( av == 0 ) THEN
- DO i = 1, mask_size_l(mid,1)
- DO j = 1, mask_size_l(mid,2)
- DO k = 1, mask_size_l(mid,3)
- local_pf(i,j,k) = aerosol_number(1)%conc(mask_k(mid,k), &
- mask_j(mid,j),mask_i(mid,i))
+ ELSE
+ DO i = 1, mask_size_l(mid,1)
+ DO j = 1, mask_size_l(mid,2)
+ topo_top_ind = get_topography_top_index_ji( mask_j(mid,j),&
+ mask_i(mid,i),&
+ grid )
+ DO k = 1, mask_size_l(mid,3)
+ local_pf(i,j,k) = tend( MIN( topo_top_ind+mask_k(mid,k),&
+ nzt+1 ), &
+ mask_j(mid,j), mask_i(mid,i) )
+ ENDDO
ENDDO
ENDDO
- ENDDO
+ ENDIF
+ resorted = .TRUE.
ELSE
- DO i = 1, mask_size_l(mid,1)
- DO j = 1, mask_size_l(mid,2)
- DO k = 1, mask_size_l(mid,3)
- local_pf(i,j,k) = Nbins_av(mask_k(mid,k), &
- mask_j(mid,j),mask_i(mid,i),1)
- ENDDO
- ENDDO
- ENDDO
- ENDIF
-
- CASE ( 'N_bin2' )
- IF ( av == 0 ) THEN
- DO i = 1, mask_size_l(mid,1)
- DO j = 1, mask_size_l(mid,2)
- DO k = 1, mask_size_l(mid,3)
- local_pf(i,j,k) = aerosol_number(2)%conc(mask_k(mid,k), &
- mask_j(mid,j),mask_i(mid,i))
- ENDDO
- ENDDO
- ENDDO
- ELSE
- DO i = 1, mask_size_l(mid,1)
- DO j = 1, mask_size_l(mid,2)
- DO k = 1, mask_size_l(mid,3)
- local_pf(i,j,k) = Nbins_av(mask_k(mid,k), &
- mask_j(mid,j),mask_i(mid,i),2)
- ENDDO
- ENDDO
- ENDDO
- ENDIF
-
- CASE ( 'N_bin3' )
- IF ( av == 0 ) THEN
- DO i = 1, mask_size_l(mid,1)
- DO j = 1, mask_size_l(mid,2)
- DO k = 1, mask_size_l(mid,3)
- local_pf(i,j,k) = aerosol_number(3)%conc(mask_k(mid,k), &
- mask_j(mid,j),mask_i(mid,i))
- ENDDO
- ENDDO
- ENDDO
- ELSE
- DO i = 1, mask_size_l(mid,1)
- DO j = 1, mask_size_l(mid,2)
- DO k = 1, mask_size_l(mid,3)
- local_pf(i,j,k) = Nbins_av(mask_k(mid,k), &
- mask_j(mid,j),mask_i(mid,i),3)
- ENDDO
- ENDDO
- ENDDO
- ENDIF
-
- CASE ( 'N_bin4' )
- IF ( av == 0 ) THEN
- DO i = 1, mask_size_l(mid,1)
- DO j = 1, mask_size_l(mid,2)
- DO k = 1, mask_size_l(mid,3)
- local_pf(i,j,k) = aerosol_number(4)%conc(mask_k(mid,k), &
- mask_j(mid,j),mask_i(mid,i))
- ENDDO
- ENDDO
- ENDDO
- ELSE
- DO i = 1, mask_size_l(mid,1)
- DO j = 1, mask_size_l(mid,2)
- DO k = 1, mask_size_l(mid,3)
- local_pf(i,j,k) = Nbins_av(mask_k(mid,k), &
- mask_j(mid,j),mask_i(mid,i),4)
- ENDDO
- ENDDO
- ENDDO
- ENDIF
-
- CASE ( 'N_bin5' )
- IF ( av == 0 ) THEN
- DO i = 1, mask_size_l(mid,1)
- DO j = 1, mask_size_l(mid,2)
- DO k = 1, mask_size_l(mid,3)
- local_pf(i,j,k) = aerosol_number(5)%conc(mask_k(mid,k), &
- mask_j(mid,j),mask_i(mid,i))
- ENDDO
- ENDDO
- ENDDO
- ELSE
- DO i = 1, mask_size_l(mid,1)
- DO j = 1, mask_size_l(mid,2)
- DO k = 1, mask_size_l(mid,3)
- local_pf(i,j,k) = Nbins_av(mask_k(mid,k), &
- mask_j(mid,j),mask_i(mid,i),5)
- ENDDO
- ENDDO
- ENDDO
- ENDIF
-
- CASE ( 'N_bin6' )
- IF ( av == 0 ) THEN
- DO i = 1, mask_size_l(mid,1)
- DO j = 1, mask_size_l(mid,2)
- DO k = 1, mask_size_l(mid,3)
- local_pf(i,j,k) = aerosol_number(6)%conc(mask_k(mid,k), &
- mask_j(mid,j),mask_i(mid,i))
- ENDDO
- ENDDO
- ENDDO
- ELSE
- DO i = 1, mask_size_l(mid,1)
- DO j = 1, mask_size_l(mid,2)
- DO k = 1, mask_size_l(mid,3)
- local_pf(i,j,k) = Nbins_av(mask_k(mid,k), &
- mask_j(mid,j),mask_i(mid,i),6)
- ENDDO
- ENDDO
- ENDDO
- ENDIF
-
- CASE ( 'N_bin7' )
- IF ( av == 0 ) THEN
- DO i = 1, mask_size_l(mid,1)
- DO j = 1, mask_size_l(mid,2)
- DO k = 1, mask_size_l(mid,3)
- local_pf(i,j,k) = aerosol_number(7)%conc(mask_k(mid,k), &
- mask_j(mid,j),mask_i(mid,i))
- ENDDO
- ENDDO
- ENDDO
- ELSE
- DO i = 1, mask_size_l(mid,1)
- DO j = 1, mask_size_l(mid,2)
- DO k = 1, mask_size_l(mid,3)
- local_pf(i,j,k) = Nbins_av(mask_k(mid,k), &
- mask_j(mid,j),mask_i(mid,i),7)
- ENDDO
- ENDDO
- ENDDO
- ENDIF
-
- CASE ( 'N_bin8' )
- IF ( av == 0 ) THEN
- DO i = 1, mask_size_l(mid,1)
- DO j = 1, mask_size_l(mid,2)
- DO k = 1, mask_size_l(mid,3)
- local_pf(i,j,k) = aerosol_number(8)%conc(mask_k(mid,k), &
- mask_j(mid,j),mask_i(mid,i))
- ENDDO
- ENDDO
- ENDDO
- ELSE
- DO i = 1, mask_size_l(mid,1)
- DO j = 1, mask_size_l(mid,2)
- DO k = 1, mask_size_l(mid,3)
- local_pf(i,j,k) = Nbins_av(mask_k(mid,k), &
- mask_j(mid,j),mask_i(mid,i),8)
- ENDDO
- ENDDO
- ENDDO
- ENDIF
-
- CASE ( 'N_bin9' )
- IF ( av == 0 ) THEN
- DO i = 1, mask_size_l(mid,1)
- DO j = 1, mask_size_l(mid,2)
- DO k = 1, mask_size_l(mid,3)
- local_pf(i,j,k) = aerosol_number(9)%conc(mask_k(mid,k), &
- mask_j(mid,j),mask_i(mid,i))
- ENDDO
- ENDDO
- ENDDO
- ELSE
- DO i = 1, mask_size_l(mid,1)
- DO j = 1, mask_size_l(mid,2)
- DO k = 1, mask_size_l(mid,3)
- local_pf(i,j,k) = Nbins_av(mask_k(mid,k), &
- mask_j(mid,j),mask_i(mid,i),9)
- ENDDO
- ENDDO
- ENDDO
- ENDIF
-
- CASE ( 'N_bin10' )
- IF ( av == 0 ) THEN
- DO i = 1, mask_size_l(mid,1)
- DO j = 1, mask_size_l(mid,2)
- DO k = 1, mask_size_l(mid,3)
- local_pf(i,j,k) = aerosol_number(10)%conc(mask_k(mid,k), &
- mask_j(mid,j),mask_i(mid,i))
- ENDDO
- ENDDO
- ENDDO
- ELSE
- DO i = 1, mask_size_l(mid,1)
- DO j = 1, mask_size_l(mid,2)
- DO k = 1, mask_size_l(mid,3)
- local_pf(i,j,k) = Nbins_av(mask_k(mid,k), &
- mask_j(mid,j),mask_i(mid,i),10)
- ENDDO
- ENDDO
- ENDDO
- ENDIF
-
- CASE ( 'N_bin11' )
- IF ( av == 0 ) THEN
- DO i = 1, mask_size_l(mid,1)
- DO j = 1, mask_size_l(mid,2)
- DO k = 1, mask_size_l(mid,3)
- local_pf(i,j,k) = aerosol_number(11)%conc(mask_k(mid,k), &
- mask_j(mid,j),mask_i(mid,i))
- ENDDO
- ENDDO
- ENDDO
- ELSE
- DO i = 1, mask_size_l(mid,1)
- DO j = 1, mask_size_l(mid,2)
- DO k = 1, mask_size_l(mid,3)
- local_pf(i,j,k) = Nbins_av(mask_k(mid,k), &
- mask_j(mid,j),mask_i(mid,i),11)
- ENDDO
- ENDDO
- ENDDO
- ENDIF
-
- CASE ( 'N_bin12' )
- IF ( av == 0 ) THEN
- DO i = 1, mask_size_l(mid,1)
- DO j = 1, mask_size_l(mid,2)
- DO k = 1, mask_size_l(mid,3)
- local_pf(i,j,k) = aerosol_number(12)%conc(mask_k(mid,k), &
- mask_j(mid,j),mask_i(mid,i))
- ENDDO
- ENDDO
- ENDDO
- ELSE
- DO i = 1, mask_size_l(mid,1)
- DO j = 1, mask_size_l(mid,2)
- DO k = 1, mask_size_l(mid,3)
- local_pf(i,j,k) = Nbins_av(mask_k(mid,k), &
- mask_j(mid,j),mask_i(mid,i),12)
- ENDDO
- ENDDO
- ENDDO
- ENDIF
-
- CASE ( 'm_bin1' )
- IF ( av == 0 ) THEN
- DO i = 1, mask_size_l(mid,1)
- DO j = 1, mask_size_l(mid,2)
- DO k = 1, mask_size_l(mid,3)
- temp_bin = 0.0_wp
- DO c = 1, ncc_tot*nbins, nbins
- temp_bin = temp_bin + aerosol_mass(c)%conc( &
- mask_k(mid,k),mask_j(mid,j),mask_i(mid,i))
- ENDDO
- local_pf(i,j,k) = temp_bin
- ENDDO
- ENDDO
- ENDDO
- ELSE
- DO i = 1, mask_size_l(mid,1)
- DO j = 1, mask_size_l(mid,2)
- DO k = 1, mask_size_l(mid,3)
- local_pf(i,j,k) = mbins_av(mask_k(mid,k), &
- mask_j(mid,j),mask_i(mid,i),1)
- ENDDO
- ENDDO
- ENDDO
- ENDIF
-
- CASE ( 'm_bin2' )
- IF ( av == 0 ) THEN
- DO i = 1, mask_size_l(mid,1)
- DO j = 1, mask_size_l(mid,2)
- DO k = 1, mask_size_l(mid,3)
- temp_bin = 0.0_wp
- DO c = 2, ncc_tot*nbins, nbins
- temp_bin = temp_bin + aerosol_mass(c)%conc( &
- mask_k(mid,k),mask_j(mid,j),mask_i(mid,i))
- ENDDO
- local_pf(i,j,k) = temp_bin
- ENDDO
- ENDDO
- ENDDO
- ELSE
- DO i = 1, mask_size_l(mid,1)
- DO j = 1, mask_size_l(mid,2)
- DO k = 1, mask_size_l(mid,3)
- local_pf(i,j,k) = mbins_av(mask_k(mid,k), &
- mask_j(mid,j),mask_i(mid,i),2)
- ENDDO
- ENDDO
- ENDDO
- ENDIF
-
- CASE ( 'm_bin3' )
- IF ( av == 0 ) THEN
- DO i = 1, mask_size_l(mid,1)
- DO j = 1, mask_size_l(mid,2)
- DO k = 1, mask_size_l(mid,3)
- temp_bin = 0.0_wp
- DO c = 3, ncc_tot*nbins, nbins
- temp_bin = temp_bin + aerosol_mass(c)%conc( &
- mask_k(mid,k),mask_j(mid,j),mask_i(mid,i))
- ENDDO
- local_pf(i,j,k) = temp_bin
- ENDDO
- ENDDO
- ENDDO
- ELSE
- DO i = 1, mask_size_l(mid,1)
- DO j = 1, mask_size_l(mid,2)
- DO k = 1, mask_size_l(mid,3)
- local_pf(i,j,k) = mbins_av(mask_k(mid,k), &
- mask_j(mid,j),mask_i(mid,i),3)
- ENDDO
- ENDDO
- ENDDO
- ENDIF
-
- CASE ( 'm_bin4' )
- IF ( av == 0 ) THEN
- DO i = 1, mask_size_l(mid,1)
- DO j = 1, mask_size_l(mid,2)
- DO k = 1, mask_size_l(mid,3)
- temp_bin = 0.0_wp
- DO c = 4, ncc_tot*nbins, nbins
- temp_bin = temp_bin + aerosol_mass(c)%conc( &
- mask_k(mid,k),mask_j(mid,j),mask_i(mid,i))
- ENDDO
- local_pf(i,j,k) = temp_bin
- ENDDO
- ENDDO
- ENDDO
- ELSE
- DO i = 1, mask_size_l(mid,1)
- DO j = 1, mask_size_l(mid,2)
- DO k = 1, mask_size_l(mid,3)
- local_pf(i,j,k) = mbins_av(mask_k(mid,k), &
- mask_j(mid,j),mask_i(mid,i),4)
- ENDDO
- ENDDO
- ENDDO
- ENDIF
-
- CASE ( 'm_bin5' )
- IF ( av == 0 ) THEN
- DO i = 1, mask_size_l(mid,1)
- DO j = 1, mask_size_l(mid,2)
- DO k = 1, mask_size_l(mid,3)
- temp_bin = 0.0_wp
- DO c = 5, ncc_tot*nbins, nbins
- temp_bin = temp_bin + aerosol_mass(c)%conc( &
- mask_k(mid,k),mask_j(mid,j),mask_i(mid,i))
- ENDDO
- local_pf(i,j,k) = temp_bin
- ENDDO
- ENDDO
- ENDDO
- ELSE
- DO i = 1, mask_size_l(mid,1)
- DO j = 1, mask_size_l(mid,2)
- DO k = 1, mask_size_l(mid,3)
- local_pf(i,j,k) = mbins_av(mask_k(mid,k), &
- mask_j(mid,j),mask_i(mid,i),5)
- ENDDO
- ENDDO
- ENDDO
- ENDIF
-
- CASE ( 'm_bin6' )
- IF ( av == 0 ) THEN
- DO i = 1, mask_size_l(mid,1)
- DO j = 1, mask_size_l(mid,2)
- DO k = 1, mask_size_l(mid,3)
- temp_bin = 0.0_wp
- DO c = 6, ncc_tot*nbins, nbins
- temp_bin = temp_bin + aerosol_mass(c)%conc( &
- mask_k(mid,k),mask_j(mid,j),mask_i(mid,i))
- ENDDO
- local_pf(i,j,k) = temp_bin
- ENDDO
- ENDDO
- ENDDO
- ELSE
- DO i = 1, mask_size_l(mid,1)
- DO j = 1, mask_size_l(mid,2)
- DO k = 1, mask_size_l(mid,3)
- local_pf(i,j,k) = mbins_av(mask_k(mid,k), &
- mask_j(mid,j),mask_i(mid,i),6)
- ENDDO
- ENDDO
- ENDDO
- ENDIF
-
- CASE ( 'm_bin7' )
- IF ( av == 0 ) THEN
- DO i = 1, mask_size_l(mid,1)
- DO j = 1, mask_size_l(mid,2)
- DO k = 1, mask_size_l(mid,3)
- temp_bin = 0.0_wp
- DO c = 7, ncc_tot*nbins, nbins
- temp_bin = temp_bin + aerosol_mass(c)%conc( &
- mask_k(mid,k),mask_j(mid,j),mask_i(mid,i))
- ENDDO
- local_pf(i,j,k) = temp_bin
- ENDDO
- ENDDO
- ENDDO
- ELSE
- DO i = 1, mask_size_l(mid,1)
- DO j = 1, mask_size_l(mid,2)
- DO k = 1, mask_size_l(mid,3)
- local_pf(i,j,k) = mbins_av(mask_k(mid,k), &
- mask_j(mid,j),mask_i(mid,i),7)
- ENDDO
- ENDDO
- ENDDO
- ENDIF
-
- CASE ( 'm_bin8' )
- IF ( av == 0 ) THEN
- DO i = 1, mask_size_l(mid,1)
- DO j = 1, mask_size_l(mid,2)
- DO k = 1, mask_size_l(mid,3)
- temp_bin = 0.0_wp
- DO c = 8, ncc_tot*nbins, nbins
- temp_bin = temp_bin + aerosol_mass(c)%conc( &
- mask_k(mid,k),mask_j(mid,j),mask_i(mid,i))
- ENDDO
- local_pf(i,j,k) = temp_bin
- ENDDO
- ENDDO
- ENDDO
- ELSE
- DO i = 1, mask_size_l(mid,1)
- DO j = 1, mask_size_l(mid,2)
- DO k = 1, mask_size_l(mid,3)
- local_pf(i,j,k) = mbins_av(mask_k(mid,k), &
- mask_j(mid,j),mask_i(mid,i),8)
- ENDDO
- ENDDO
- ENDDO
- ENDIF
-
- CASE ( 'm_bin9' )
- IF ( av == 0 ) THEN
- DO i = 1, mask_size_l(mid,1)
- DO j = 1, mask_size_l(mid,2)
- DO k = 1, mask_size_l(mid,3)
- temp_bin = 0.0_wp
- DO c = 9, ncc_tot*nbins, nbins
- temp_bin = temp_bin + aerosol_mass(c)%conc( &
- mask_k(mid,k),mask_j(mid,j),mask_i(mid,i))
- ENDDO
- local_pf(i,j,k) = temp_bin
- ENDDO
- ENDDO
- ENDDO
- ELSE
- DO i = 1, mask_size_l(mid,1)
- DO j = 1, mask_size_l(mid,2)
- DO k = 1, mask_size_l(mid,3)
- local_pf(i,j,k) = mbins_av(mask_k(mid,k), &
- mask_j(mid,j),mask_i(mid,i),9)
- ENDDO
- ENDDO
- ENDDO
- ENDIF
-
- CASE ( 'm_bin10' )
- IF ( av == 0 ) THEN
- DO i = 1, mask_size_l(mid,1)
- DO j = 1, mask_size_l(mid,2)
- DO k = 1, mask_size_l(mid,3)
- temp_bin = 0.0_wp
- DO c = 10, ncc_tot*nbins, nbins
- temp_bin = temp_bin + aerosol_mass(c)%conc( &
- mask_k(mid,k),mask_j(mid,j),mask_i(mid,i))
- ENDDO
- local_pf(i,j,k) = temp_bin
- ENDDO
- ENDDO
- ENDDO
- ELSE
- DO i = 1, mask_size_l(mid,1)
- DO j = 1, mask_size_l(mid,2)
- DO k = 1, mask_size_l(mid,3)
- local_pf(i,j,k) = mbins_av(mask_k(mid,k), &
- mask_j(mid,j),mask_i(mid,i),10)
- ENDDO
- ENDDO
- ENDDO
- ENDIF
-
- CASE ( 'm_bin11' )
- IF ( av == 0 ) THEN
- DO i = 1, mask_size_l(mid,1)
- DO j = 1, mask_size_l(mid,2)
- DO k = 1, mask_size_l(mid,3)
- temp_bin = 0.0_wp
- DO c = 11, ncc_tot*nbins, nbins
- temp_bin = temp_bin + aerosol_mass(c)%conc( &
- mask_k(mid,k),mask_j(mid,j),mask_i(mid,i))
- ENDDO
- local_pf(i,j,k) = temp_bin
- ENDDO
- ENDDO
- ENDDO
- ELSE
- DO i = 1, mask_size_l(mid,1)
- DO j = 1, mask_size_l(mid,2)
- DO k = 1, mask_size_l(mid,3)
- local_pf(i,j,k) = mbins_av(mask_k(mid,k), &
- mask_j(mid,j),mask_i(mid,i),11)
- ENDDO
- ENDDO
- ENDDO
- ENDIF
-
- CASE ( 'm_bin12' )
- IF ( av == 0 ) THEN
- DO i = 1, mask_size_l(mid,1)
- DO j = 1, mask_size_l(mid,2)
- DO k = 1, mask_size_l(mid,3)
- temp_bin = 0.0_wp
- DO c = 12, ncc_tot*nbins, nbins
- temp_bin = temp_bin + aerosol_mass(c)%conc( &
- mask_k(mid,k),mask_j(mid,j),mask_i(mid,i))
- ENDDO
- local_pf(i,j,k) = temp_bin
- ENDDO
- ENDDO
- ENDDO
- ELSE
- DO i = 1, mask_size_l(mid,1)
- DO j = 1, mask_size_l(mid,2)
- DO k = 1, mask_size_l(mid,3)
- local_pf(i,j,k) = mbins_av(mask_k(mid,k), &
- mask_j(mid,j),mask_i(mid,i),12)
- ENDDO
- ENDDO
- ENDDO
+ to_be_resorted => PM10_av
ENDIF
CASE ( 's_BC', 's_DU', 's_NH', 's_NO', 's_OC', 's_SO4', 's_SS' )
- IF ( is_used( prtcl, TRIM( variable(3:) ) ) ) THEN
- icc = get_index( prtcl, TRIM( variable(3:) ) )
- IF ( av == 0 ) THEN
- DO i = 1, mask_size_l(mid,1)
- DO j = 1, mask_size_l(mid,2)
- DO k = 1, mask_size_l(mid,3)
+ IF ( av == 0 ) THEN
+ IF ( is_used( prtcl, TRIM( variable(3:) ) ) ) THEN
+ icc = get_index( prtcl, TRIM( variable(3:) ) )
+ DO i = nxl, nxr
+ DO j = nys, nyn
+ DO k = nzb, nz_do3d
temp_bin = 0.0_wp
DO c = ( icc-1 )*nbins+1, icc*nbins
- temp_bin = temp_bin + aerosol_mass(c)%conc( &
- mask_k(mid,k),mask_j(mid,j),mask_i(mid,i))
+ temp_bin = temp_bin + aerosol_mass(c)%conc(k,j,i)
ENDDO
- local_pf(i,j,k) = temp_bin
+ tend(k,j,i) = temp_bin
ENDDO
ENDDO
ENDDO
ELSE
- IF ( TRIM( variable(3:) ) == 'BC' ) to_be_resorted => s_BC_av
- IF ( TRIM( variable(3:) ) == 'DU' ) to_be_resorted => s_DU_av
- IF ( TRIM( variable(3:) ) == 'NH' ) to_be_resorted => s_NH_av
- IF ( TRIM( variable(3:) ) == 'NO' ) to_be_resorted => s_NO_av
- IF ( TRIM( variable(3:) ) == 'OC' ) to_be_resorted => s_OC_av
- IF ( TRIM( variable(3:) ) == 'SO4' ) to_be_resorted => s_SO4_av
- IF ( TRIM( variable(3:) ) == 'SS' ) to_be_resorted => s_SS_av
+ tend = 0.0_wp
+ ENDIF
+ IF ( .NOT. mask_surface(mid) ) THEN
DO i = 1, mask_size_l(mid,1)
DO j = 1, mask_size_l(mid,2)
- DO k = 1, mask_size_l(mid,3)
- local_pf(i,j,k) = to_be_resorted(mask_k(mid,k), &
- mask_j(mid,j),mask_i(mid,i))
+ DO k = 1, mask_size_l(mid,3)
+ local_pf(i,j,k) = tend( mask_k(mid,k), mask_j(mid,j), &
+ mask_i(mid,i) )
+ ENDDO
+ ENDDO
+ ENDDO
+ ELSE
+ DO i = 1, mask_size_l(mid,1)
+ DO j = 1, mask_size_l(mid,2)
+ topo_top_ind = get_topography_top_index_ji( mask_j(mid,j),&
+ mask_i(mid,i),&
+ grid )
+ DO k = 1, mask_size_l(mid,3)
+ local_pf(i,j,k) = tend( MIN( topo_top_ind+mask_k(mid,k),&
+ nzt+1 ),&
+ mask_j(mid,j), mask_i(mid,i) )
ENDDO
ENDDO
ENDDO
ENDIF
+ resorted = .TRUE.
+ ELSE
+ IF ( TRIM( variable(3:) ) == 'BC' ) to_be_resorted => s_BC_av
+ IF ( TRIM( variable(3:) ) == 'DU' ) to_be_resorted => s_DU_av
+ IF ( TRIM( variable(3:) ) == 'NH' ) to_be_resorted => s_NH_av
+ IF ( TRIM( variable(3:) ) == 'NO' ) to_be_resorted => s_NO_av
+ IF ( TRIM( variable(3:) ) == 'OC' ) to_be_resorted => s_OC_av
+ IF ( TRIM( variable(3:) ) == 'SO4' ) to_be_resorted => s_SO4_av
+ IF ( TRIM( variable(3:) ) == 'SS' ) to_be_resorted => s_SS_av
ENDIF
@@ -11661,4 +10295,38 @@
END SELECT
+
+ IF ( .NOT. resorted ) THEN
+ IF ( .NOT. mask_surface(mid) ) THEN
+!
+!-- Default masked output
+ DO i = 1, mask_size_l(mid,1)
+ DO j = 1, mask_size_l(mid,2)
+ DO k = 1, mask_size_l(mid,3)
+ local_pf(i,j,k) = to_be_resorted( mask_k(mid,k), &
+ mask_j(mid,j),mask_i(mid,i) )
+ ENDDO
+ ENDDO
+ ENDDO
+ ELSE
+!
+!-- Terrain-following masked output
+ DO i = 1, mask_size_l(mid,1)
+ DO j = 1, mask_size_l(mid,2)
+!
+!-- Get k index of highest horizontal surface
+ topo_top_ind = get_topography_top_index_ji( mask_j(mid,j), &
+ mask_i(mid,i), grid )
+!
+!-- Save output array
+ DO k = 1, mask_size_l(mid,3)
+ local_pf(i,j,k) = to_be_resorted( MIN( topo_top_ind+mask_k(mid,k),&
+ nzt+1 ), &
+ mask_j(mid,j), mask_i(mid,i) )
+ ENDDO
+ ENDDO
+ ENDDO
+ ENDIF
+ ENDIF
+
END SUBROUTINE salsa_data_output_mask
Index: palm/trunk/SOURCE/sum_up_3d_data.f90
===================================================================
--- palm/trunk/SOURCE/sum_up_3d_data.f90 (revision 3581)
+++ palm/trunk/SOURCE/sum_up_3d_data.f90 (revision 3582)
@@ -20,5 +20,6 @@
! Current revisions:
! ------------------
-!
+! Move the control parameter "salsa" from salsa_mod to control_parameters
+! (M. Kurppa)
!
! Former revisions:
@@ -122,5 +123,5 @@
! - Workaround for sum-up usm arrays in case of restart runs, to avoid program
! crash (MS)
-!
+!
! 2292 2017-06-20 09:51:42Z schwenkel
! Implementation of new microphysic scheme: cloud_scheme = 'morrison'
@@ -263,5 +264,5 @@
USE control_parameters, &
ONLY: air_chemistry, average_count_3d, biometeorology, doav, doav_n, &
- land_surface, ocean_mode, rho_surface, urban_surface, &
+ land_surface, ocean_mode, rho_surface, salsa, urban_surface, &
varnamelength
@@ -290,5 +291,5 @@
USE salsa_mod, &
- ONLY: salsa, salsa_3d_data_averaging
+ ONLY: salsa_3d_data_averaging
USE surface_mod, &
@@ -552,7 +553,5 @@
CALL radiation_3d_data_averaging( 'allocate', doav(ii) )
ENDIF
-
-!
-!-- SALSA quantity
+
IF ( salsa ) THEN
CALL salsa_3d_data_averaging( 'allocate', doav(ii) )
@@ -1202,7 +1201,5 @@
CALL radiation_3d_data_averaging( 'sum', doav(ii) )
ENDIF
-
-!
-!-- SALSA quantity
+
IF ( salsa ) THEN
CALL salsa_3d_data_averaging( 'sum', doav(ii) )
Index: palm/trunk/SOURCE/swap_timelevel.f90
===================================================================
--- palm/trunk/SOURCE/swap_timelevel.f90 (revision 3581)
+++ palm/trunk/SOURCE/swap_timelevel.f90 (revision 3582)
@@ -20,5 +20,6 @@
! Current revisions:
! -----------------
-!
+! Move the control parameter "salsa" from salsa_mod to control_parameters
+! (M. Kurppa)
!
! Former revisions:
@@ -162,5 +163,5 @@
ONLY: air_chemistry, humidity, land_surface, neutral, ocean_mode, &
passive_scalar, simulated_time, timestep_count, urban_surface, &
- time_since_reference_point
+ time_since_reference_point, salsa
USE gust_mod, &
@@ -182,5 +183,5 @@
USE salsa_mod, &
- ONLY: salsa, salsa_swap_timelevel, skip_time_do_salsa
+ ONLY: salsa_swap_timelevel, skip_time_do_salsa
USE turbulence_closure_mod, &
@@ -295,5 +296,5 @@
IF ( salsa .AND. simulated_time >= time_since_reference_point ) THEN
CALL salsa_swap_timelevel( MOD( timestep_count, 2 ) )
- ENDIF
+ ENDIF
CALL tcm_swap_timelevel( MOD( timestep_count, 2) )
Index: palm/trunk/SOURCE/time_integration.f90
===================================================================
--- palm/trunk/SOURCE/time_integration.f90 (revision 3581)
+++ palm/trunk/SOURCE/time_integration.f90 (revision 3582)
@@ -20,5 +20,6 @@
! Current revisions:
! ------------------
-!
+! Move the control parameter "salsa" from salsa_mod to control_parameters
+! (M. Kurppa)
!
! Former revisions:
@@ -460,5 +461,6 @@
ocean_mode, passive_scalar, pt_reference, &
pt_slope_offset, random_heatflux, rans_mode, &
- rans_tke_e, run_coupled, simulated_time, simulated_time_chr, &
+ rans_tke_e, run_coupled, salsa, &
+ simulated_time, simulated_time_chr, &
skip_time_do2d_xy, skip_time_do2d_xz, skip_time_do2d_yz, &
skip_time_do3d, skip_time_domask, skip_time_dopr, &
@@ -475,5 +477,5 @@
use_single_reference_value, u_gtrans, v_gtrans, &
virtual_flight, virtual_measurement, wind_turbine, &
- ws_scheme_mom, ws_scheme_sca
+ ws_scheme_mom, ws_scheme_sca
USE cpulog, &
@@ -542,4 +544,9 @@
radiation_interaction, radiation_interactions, &
skip_time_do_radiation, time_radiation
+
+ USE salsa_mod, &
+ ONLY: aerosol_number, aerosol_mass, nbins, ncc_tot, ngast, &
+ salsa_boundary_conds, salsa_gas, salsa_gases_from_chem, &
+ skip_time_do_salsa
USE spectra_mod, &
@@ -574,10 +581,5 @@
ONLY: dt_stg_call, dt_stg_adjust, parametrize_inflow_turbulence, &
stg_adjust, stg_main, time_stg_adjust, time_stg_call, &
- use_syn_turb_gen
-
- USE salsa_mod, &
- ONLY: aerosol_number, aerosol_mass, nbins, ncc_tot, ngast, salsa, &
- salsa_boundary_conds, salsa_gas, salsa_gases_from_chem, &
- skip_time_do_salsa
+ use_syn_turb_gen
USE user_actions_mod, &
@@ -916,5 +918,4 @@
CALL cpu_log( log_point_s(91), 'salsa exch-horiz ', 'stop' )
ENDIF
-
CALL cpu_log( log_point(26), 'exchange-horiz-progn', 'stop' )
Index: palm/trunk/SOURCE/write_restart_data_mod.f90
===================================================================
--- palm/trunk/SOURCE/write_restart_data_mod.f90 (revision 3581)
+++ palm/trunk/SOURCE/write_restart_data_mod.f90 (revision 3582)
@@ -20,4 +20,6 @@
! Current revisions:
! -----------------
+! Move the control parameter "salsa" from salsa_mod to control_parameters
+! (M. Kurppa)
!
!
@@ -945,5 +947,5 @@
USE salsa_mod, &
- ONLY: salsa, salsa_wrd_local
+ ONLY: salsa_wrd_local
USE surface_mod, &
@@ -1273,7 +1275,7 @@
IF ( land_surface ) CALL lsm_wrd_local
IF ( ocean_mode ) CALL ocean_wrd_local
- CALL surface_wrd_local
IF ( radiation ) CALL radiation_wrd_local
IF ( salsa ) CALL salsa_wrd_local
+ CALL surface_wrd_local
IF ( urban_surface ) CALL usm_wrd_local
Index: palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_salsa+phstat/chem_gasphase_mod.f90
===================================================================
--- palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_salsa+phstat/chem_gasphase_mod.f90 (revision 3582)
+++ palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_salsa+phstat/chem_gasphase_mod.f90 (revision 3582)
@@ -0,0 +1,2471 @@
+MODULE chem_gasphase_mod
+!
+!------------------------------------------------------------------------------!
+!
+! ******Module chem_gasphase_mod is automatically generated by kpp4palm ******
+!
+! *********Please do NOT change this Code,it will be ovewritten *********
+!
+!------------------------------------------------------------------------------!
+! This file was created by KPP (http://people.cs.vt.edu/asandu/Software/Kpp/)
+! and kpp4palm (created by Klaus Ketelsen)
+!
+! KPP is free software; you can redistribute it and/or modify it under the terms
+! of the General Public Licence as published by the Free Software Foundation;
+! either version 2 of the License,or (at your option) any later version.
+! KPP 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 Licence for more details.
+!
+!------------------------------------------------------------------------------!
+! This file is part of the PALM model system.
+!
+! PALM is free software: you can redistribute it and/or modify it under the
+! terms of the GNU General Public License as published by the Free Software
+! Foundation,either version 3 of the License,or (at your option) any later
+! version.
+!
+! PALM is distributed in the hope that it will be useful,but WITHOUT ANY
+! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
+! A PARTICULAR PURPOSE. See the GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along with
+! PALM. If not,see .
+!
+! Copyright 1997-2018 Leibniz Universitaet Hannover
+!--------------------------------------------------------------------------------!
+!
+! Current revisions:
+! ------------------
+!
+!
+! Former revisions:
+! -----------------
+! $Id: module_header 2460 2017-09-13 14:47:48Z forkel $
+!
+!
+! Variables for photolyis added
+!
+!
+!
+!
+!
+! Nov. 2016: Intial version (Klaus Ketelsen)
+!
+!------------------------------------------------------------------------------!
+!
+
+
+! Set kpp Double Precision to PALM Default Precision
+
+ USE kinds, ONLY: dp=>wp
+
+ USE pegrid, ONLY: myid,threads_per_task
+
+ IMPLICIT NONE
+ PRIVATE
+ !SAVE ! NOTE: OCCURS AGAIN IN AUTOMATICALLY GENERATED CODE ...
+
+! PUBLIC :: IERR_NAMES
+
+! PUBLIC :: SPC_NAMES,EQN_NAMES,EQN_TAGS,REQ_HET,REQ_AEROSOL,REQ_PHOTRAT &
+! ,REQ_MCFCT,IP_MAX,jname
+
+ PUBLIC :: eqn_names, phot_names,spc_names
+ PUBLIC :: nmaxfixsteps
+ PUBLIC :: atol,rtol
+ PUBLIC :: nspec,nreact
+ PUBLIC :: temp
+ PUBLIC :: phot
+ PUBLIC :: rconst
+ PUBLIC :: nvar
+ PUBLIC :: nphot
+
+ PUBLIC :: initialize,integrate,update_rconst
+ PUBLIC :: chem_gasphase_integrate
+ PUBLIC :: initialize_kpp_ctrl
+
+! END OF MODULE HEADER TEMPLATE
+
+! Variables used for vector mode
+
+ LOGICAL, PARAMETER :: l_vector = .FALSE.
+ INTEGER, PARAMETER :: i_lu_di = 0
+ INTEGER, PARAMETER :: vl_dim = 1
+ INTEGER :: vl
+
+ INTEGER :: vl_glo
+ INTEGER :: is,ie
+
+ INTEGER, DIMENSION(vl_dim) :: kacc,krej
+ INTEGER, DIMENSION(vl_dim) :: ierrv
+ LOGICAL :: data_loaded = .false.
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+! Parameter Module File
+!
+! Generated by KPP-2.2.3 symbolic chemistry Kinetics PreProcessor
+! (http://www.cs.vt.edu/~asandu/Software/KPP)
+! KPP is distributed under GPL,the general public licence
+! (http://www.gnu.org/copyleft/gpl.html)
+! (C) 1995-1997,V. Damian & A. Sandu,CGRER,Univ. Iowa
+! (C) 1997-2005,A. Sandu,Michigan Tech,Virginia Tech
+! With important contributions from:
+! M. Damian,Villanova University,USA
+! R. Sander,Max-Planck Institute for Chemistry,Mainz,Germany
+!
+! File : chem_gasphase_mod_Parameters.f90
+! Time : Mon Mar 19 17:08:07 2018
+! Working directory : /home/forkel-r/palmstuff/work/chemistry20180314b/UTIL/chemistry/gasphase_preproc/tmp_kpp4palm
+! Equation file : chem_gasphase_mod.kpp
+! Output root filename : chem_gasphase_mod
+!
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+
+
+
+
+! NSPEC - Number of chemical species
+ INTEGER,PARAMETER :: nspec = 3
+! NVAR - Number of Variable species
+ INTEGER,PARAMETER :: nvar = 3
+! NVARACT - Number of Active species
+ INTEGER,PARAMETER :: nvaract = 3
+! NFIX - Number of Fixed species
+ INTEGER,PARAMETER :: nfix = 1
+! NREACT - Number of reactions
+ INTEGER,PARAMETER :: nreact = 2
+! NVARST - Starting of variables in conc. vect.
+ INTEGER,PARAMETER :: nvarst = 1
+! NFIXST - Starting of fixed in conc. vect.
+ INTEGER,PARAMETER :: nfixst = 4
+! NONZERO - Number of nonzero entries in Jacobian
+ INTEGER,PARAMETER :: nonzero = 9
+! LU_NONZERO - Number of nonzero entries in LU factoriz. of Jacobian
+ INTEGER,PARAMETER :: lu_nonzero = 9
+! CNVAR - (NVAR+1) Number of elements in compressed row format
+ INTEGER,PARAMETER :: cnvar = 4
+! CNEQN - (NREACT+1) Number stoicm elements in compressed col format
+ INTEGER,PARAMETER :: cneqn = 3
+! NHESS - Length of Sparse Hessian
+ INTEGER,PARAMETER :: nhess = 3
+! NLOOKAT - Number of species to look at
+ INTEGER,PARAMETER :: nlookat = 0
+! NMONITOR - Number of species to monitor
+ INTEGER,PARAMETER :: nmonitor = 0
+! NMASS - Number of atoms to check mass balance
+ INTEGER,PARAMETER :: nmass = 1
+
+! Index declaration for variable species in C and VAR
+! VAR(ind_spc) = C(ind_spc)
+
+ INTEGER,PARAMETER,PUBLIC :: ind_o3 = 1
+ INTEGER,PARAMETER,PUBLIC :: ind_no = 2
+ INTEGER,PARAMETER,PUBLIC :: ind_no2 = 3
+
+! Index declaration for fixed species in C
+! C(ind_spc)
+
+
+! Index declaration for fixed species in FIX
+! FIX(indf_spc) = C(ind_spc) = C(NVAR+indf_spc)
+
+
+! NJVRP - Length of sparse Jacobian JVRP
+ INTEGER,PARAMETER :: njvrp = 3
+
+! NSTOICM - Length of Sparse Stoichiometric Matrix
+ INTEGER,PARAMETER :: nstoicm = 6
+
+
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+! Global Data Module File
+!
+! Generated by KPP-2.2.3 symbolic chemistry Kinetics PreProcessor
+! (http://www.cs.vt.edu/~asandu/Software/KPP)
+! KPP is distributed under GPL,the general public licence
+! (http://www.gnu.org/copyleft/gpl.html)
+! (C) 1995-1997,V. Damian & A. Sandu,CGRER,Univ. Iowa
+! (C) 1997-2005,A. Sandu,Michigan Tech,Virginia Tech
+! With important contributions from:
+! M. Damian,Villanova University,USA
+! R. Sander,Max-Planck Institute for Chemistry,Mainz,Germany
+!
+! File : chem_gasphase_mod_Global.f90
+! Time : Mon Mar 19 17:08:07 2018
+! Working directory : /home/forkel-r/palmstuff/work/chemistry20180314b/UTIL/chemistry/gasphase_preproc/tmp_kpp4palm
+! Equation file : chem_gasphase_mod.kpp
+! Output root filename : chem_gasphase_mod
+!
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+
+
+
+
+! Declaration of global variables
+
+! C - Concentration of all species
+ REAL(kind=dp):: c(nspec)
+! VAR - Concentrations of variable species (global)
+ REAL(kind=dp):: var(nvar)
+! FIX - Concentrations of fixed species (global)
+ REAL(kind=dp):: fix(nfix)
+! VAR,FIX are chunks of array C
+ equivalence( c(1),var(1))
+! RCONST - Rate constants (global)
+ REAL(kind=dp):: rconst(nreact)
+! TIME - Current integration time
+ REAL(kind=dp):: time
+! SUN - Sunlight intensity between [0,1]
+ REAL(kind=dp):: sun
+! TEMP - Temperature
+ REAL(dp),dimension(:),allocatable :: temp
+! RTOLS - (scalar) Relative tolerance
+ REAL(kind=dp):: rtols
+! TSTART - Integration start time
+ REAL(kind=dp):: tstart
+! TEND - Integration end time
+ REAL(kind=dp):: tend
+! DT - Integration step
+ REAL(kind=dp):: dt
+! ATOL - Absolute tolerance
+ REAL(kind=dp):: atol(nvar)
+! RTOL - Relative tolerance
+ REAL(kind=dp):: rtol(nvar)
+! STEPMIN - Lower bound for integration step
+ REAL(kind=dp):: stepmin
+! STEPMAX - Upper bound for integration step
+ REAL(kind=dp):: stepmax
+! CFACTOR - Conversion factor for concentration units
+ REAL(kind=dp):: cfactor
+! DDMTYPE - DDM sensitivity w.r.t.: 0=init.val.,1=params
+ INTEGER :: ddmtype
+
+! INLINED global variable declarations
+
+ ! declaration of global variable declarations for photolysis will come from
+
+! INLINED global variable declarations
+
+
+
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+! Sparse Jacobian Data Structures File
+!
+! Generated by KPP-2.2.3 symbolic chemistry Kinetics PreProcessor
+! (http://www.cs.vt.edu/~asandu/Software/KPP)
+! KPP is distributed under GPL,the general public licence
+! (http://www.gnu.org/copyleft/gpl.html)
+! (C) 1995-1997,V. Damian & A. Sandu,CGRER,Univ. Iowa
+! (C) 1997-2005,A. Sandu,Michigan Tech,Virginia Tech
+! With important contributions from:
+! M. Damian,Villanova University,USA
+! R. Sander,Max-Planck Institute for Chemistry,Mainz,Germany
+!
+! File : chem_gasphase_mod_JacobianSP.f90
+! Time : Mon Mar 19 17:08:07 2018
+! Working directory : /home/forkel-r/palmstuff/work/chemistry20180314b/UTIL/chemistry/gasphase_preproc/tmp_kpp4palm
+! Equation file : chem_gasphase_mod.kpp
+! Output root filename : chem_gasphase_mod
+!
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+
+
+
+
+! Sparse Jacobian Data
+
+
+ INTEGER,PARAMETER,DIMENSION(9):: lu_irow = (/ &
+ 1, 1, 1, 2, 2, 2, 3, 3, 3 /)
+
+ INTEGER,PARAMETER,DIMENSION(9):: lu_icol = (/ &
+ 1, 2, 3, 1, 2, 3, 1, 2, 3 /)
+
+ INTEGER,PARAMETER,DIMENSION(4):: lu_crow = (/ &
+ 1, 4, 7,10 /)
+
+ INTEGER,PARAMETER,DIMENSION(4):: lu_diag = (/ &
+ 1, 5, 9,10 /)
+
+
+
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+! Utility Data Module File
+!
+! Generated by KPP-2.2.3 symbolic chemistry Kinetics PreProcessor
+! (http://www.cs.vt.edu/~asandu/Software/KPP)
+! KPP is distributed under GPL,the general public licence
+! (http://www.gnu.org/copyleft/gpl.html)
+! (C) 1995-1997,V. Damian & A. Sandu,CGRER,Univ. Iowa
+! (C) 1997-2005,A. Sandu,Michigan Tech,Virginia Tech
+! With important contributions from:
+! M. Damian,Villanova University,USA
+! R. Sander,Max-Planck Institute for Chemistry,Mainz,Germany
+!
+! File : chem_gasphase_mod_Monitor.f90
+! Time : Mon Mar 19 17:08:07 2018
+! Working directory : /home/forkel-r/palmstuff/work/chemistry20180314b/UTIL/chemistry/gasphase_preproc/tmp_kpp4palm
+! Equation file : chem_gasphase_mod.kpp
+! Output root filename : chem_gasphase_mod
+!
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+
+
+
+ CHARACTER(len=15),PARAMETER,DIMENSION(3):: spc_names = (/ &
+ 'O3 ','NO ','NO2 ' /)
+
+ INTEGER,DIMENSION(1):: lookat
+ INTEGER,DIMENSION(1):: monitor
+ CHARACTER(len=15),DIMENSION(1):: smass
+ CHARACTER(len=100),PARAMETER,DIMENSION(2):: eqn_names = (/ &
+ ' NO2 --> O3 + NO ',&
+ 'O3 + NO --> NO2 ' /)
+
+! INLINED global variables
+
+ ! inline f90_data: declaration of global variables for photolysis
+ ! REAL(kind=dp):: phot(nphot)must eventually be moved to global later for
+ INTEGER,PARAMETER :: nphot = 1
+ ! phot photolysis frequencies
+ REAL(kind=dp):: phot(nphot)
+
+ INTEGER,PARAMETER,PUBLIC :: j_no2 = 1
+
+ CHARACTER(len=15),PARAMETER,DIMENSION(nphot):: phot_names = (/ &
+ 'J_NO2 '/)
+
+! End INLINED global variables
+
+
+! Automatic generated PUBLIC Statements for ip_ and ihs_ variables
+
+! Automatic generated PUBLIC Statements for ip_ and ihs_ variables
+
+! Automatic generated PUBLIC Statements for ip_ and ihs_ variables
+
+! Automatic generated PUBLIC Statements for ip_ and ihs_ variables
+
+
+! variable definations from individual module headers
+
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+! Initialization File
+!
+! Generated by KPP-2.2.3 symbolic chemistry Kinetics PreProcessor
+! (http://www.cs.vt.edu/~asandu/Software/KPP)
+! KPP is distributed under GPL,the general public licence
+! (http://www.gnu.org/copyleft/gpl.html)
+! (C) 1995-1997,V. Damian & A. Sandu,CGRER,Univ. Iowa
+! (C) 1997-2005,A. Sandu,Michigan Tech,Virginia Tech
+! With important contributions from:
+! M. Damian,Villanova University,USA
+! R. Sander,Max-Planck Institute for Chemistry,Mainz,Germany
+!
+! File : chem_gasphase_mod_Initialize.f90
+! Time : Mon Mar 19 17:08:07 2018
+! Working directory : /home/forkel-r/palmstuff/work/chemistry20180314b/UTIL/chemistry/gasphase_preproc/tmp_kpp4palm
+! Equation file : chem_gasphase_mod.kpp
+! Output root filename : chem_gasphase_mod
+!
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+
+
+
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+! Numerical Integrator (Time-Stepping) File
+!
+! Generated by KPP-2.2.3 symbolic chemistry Kinetics PreProcessor
+! (http://www.cs.vt.edu/~asandu/Software/KPP)
+! KPP is distributed under GPL,the general public licence
+! (http://www.gnu.org/copyleft/gpl.html)
+! (C) 1995-1997,V. Damian & A. Sandu,CGRER,Univ. Iowa
+! (C) 1997-2005,A. Sandu,Michigan Tech,Virginia Tech
+! With important contributions from:
+! M. Damian,Villanova University,USA
+! R. Sander,Max-Planck Institute for Chemistry,Mainz,Germany
+!
+! File : chem_gasphase_mod_Integrator.f90
+! Time : Mon Mar 19 17:08:07 2018
+! Working directory : /home/forkel-r/palmstuff/work/chemistry20180314b/UTIL/chemistry/gasphase_preproc/tmp_kpp4palm
+! Equation file : chem_gasphase_mod.kpp
+! Output root filename : chem_gasphase_mod
+!
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+! INTEGRATE - Integrator routine
+! Arguments :
+! TIN - Start Time for Integration
+! TOUT - End Time for Integration
+!
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~!
+! Rosenbrock - Implementation of several Rosenbrock methods: !
+! *Ros2 !
+! *Ros3 !
+! *Ros4 !
+! *Rodas3 !
+! *Rodas4 !
+! By default the code employs the KPP sparse linear algebra routines !
+! Compile with -DFULL_ALGEBRA to use full linear algebra (LAPACK) !
+! !
+! (C) Adrian Sandu,August 2004 !
+! Virginia Polytechnic Institute and State University !
+! Contact: sandu@cs.vt.edu !
+! Revised by Philipp Miehe and Adrian Sandu,May 2006 ! !
+! This implementation is part of KPP - the Kinetic PreProcessor !
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~!
+
+
+ SAVE
+
+!~~~> statistics on the work performed by the rosenbrock method
+ INTEGER,PARAMETER :: nfun=1,njac=2,nstp=3,nacc=4,&
+ nrej=5,ndec=6,nsol=7,nsng=8,&
+ ntexit=1,nhexit=2,nhnew = 3
+
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+! Linear Algebra Data and Routines File
+!
+! Generated by KPP-2.2.3 symbolic chemistry Kinetics PreProcessor
+! (http://www.cs.vt.edu/~asandu/Software/KPP)
+! KPP is distributed under GPL,the general public licence
+! (http://www.gnu.org/copyleft/gpl.html)
+! (C) 1995-1997,V. Damian & A. Sandu,CGRER,Univ. Iowa
+! (C) 1997-2005,A. Sandu,Michigan Tech,Virginia Tech
+! With important contributions from:
+! M. Damian,Villanova University,USA
+! R. Sander,Max-Planck Institute for Chemistry,Mainz,Germany
+!
+! File : chem_gasphase_mod_LinearAlgebra.f90
+! Time : Mon Mar 19 17:08:07 2018
+! Working directory : /home/forkel-r/palmstuff/work/chemistry20180314b/UTIL/chemistry/gasphase_preproc/tmp_kpp4palm
+! Equation file : chem_gasphase_mod.kpp
+! Output root filename : chem_gasphase_mod
+!
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+
+
+
+
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+! The ODE Jacobian of Chemical Model File
+!
+! Generated by KPP-2.2.3 symbolic chemistry Kinetics PreProcessor
+! (http://www.cs.vt.edu/~asandu/Software/KPP)
+! KPP is distributed under GPL,the general public licence
+! (http://www.gnu.org/copyleft/gpl.html)
+! (C) 1995-1997,V. Damian & A. Sandu,CGRER,Univ. Iowa
+! (C) 1997-2005,A. Sandu,Michigan Tech,Virginia Tech
+! With important contributions from:
+! M. Damian,Villanova University,USA
+! R. Sander,Max-Planck Institute for Chemistry,Mainz,Germany
+!
+! File : chem_gasphase_mod_Jacobian.f90
+! Time : Mon Mar 19 17:08:07 2018
+! Working directory : /home/forkel-r/palmstuff/work/chemistry20180314b/UTIL/chemistry/gasphase_preproc/tmp_kpp4palm
+! Equation file : chem_gasphase_mod.kpp
+! Output root filename : chem_gasphase_mod
+!
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+
+
+
+
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+! The ODE Function of Chemical Model File
+!
+! Generated by KPP-2.2.3 symbolic chemistry Kinetics PreProcessor
+! (http://www.cs.vt.edu/~asandu/Software/KPP)
+! KPP is distributed under GPL,the general public licence
+! (http://www.gnu.org/copyleft/gpl.html)
+! (C) 1995-1997,V. Damian & A. Sandu,CGRER,Univ. Iowa
+! (C) 1997-2005,A. Sandu,Michigan Tech,Virginia Tech
+! With important contributions from:
+! M. Damian,Villanova University,USA
+! R. Sander,Max-Planck Institute for Chemistry,Mainz,Germany
+!
+! File : chem_gasphase_mod_Function.f90
+! Time : Mon Mar 19 17:08:07 2018
+! Working directory : /home/forkel-r/palmstuff/work/chemistry20180314b/UTIL/chemistry/gasphase_preproc/tmp_kpp4palm
+! Equation file : chem_gasphase_mod.kpp
+! Output root filename : chem_gasphase_mod
+!
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+
+
+
+! A - Rate for each equation
+ REAL(kind=dp):: a(nreact)
+
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+! The Reaction Rates File
+!
+! Generated by KPP-2.2.3 symbolic chemistry Kinetics PreProcessor
+! (http://www.cs.vt.edu/~asandu/Software/KPP)
+! KPP is distributed under GPL,the general public licence
+! (http://www.gnu.org/copyleft/gpl.html)
+! (C) 1995-1997,V. Damian & A. Sandu,CGRER,Univ. Iowa
+! (C) 1997-2005,A. Sandu,Michigan Tech,Virginia Tech
+! With important contributions from:
+! M. Damian,Villanova University,USA
+! R. Sander,Max-Planck Institute for Chemistry,Mainz,Germany
+!
+! File : chem_gasphase_mod_Rates.f90
+! Time : Mon Mar 19 17:08:07 2018
+! Working directory : /home/forkel-r/palmstuff/work/chemistry20180314b/UTIL/chemistry/gasphase_preproc/tmp_kpp4palm
+! Equation file : chem_gasphase_mod.kpp
+! Output root filename : chem_gasphase_mod
+!
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+
+
+
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+! Auxiliary Routines File
+!
+! Generated by KPP-2.2.3 symbolic chemistry Kinetics PreProcessor
+! (http://www.cs.vt.edu/~asandu/Software/KPP)
+! KPP is distributed under GPL,the general public licence
+! (http://www.gnu.org/copyleft/gpl.html)
+! (C) 1995-1997,V. Damian & A. Sandu,CGRER,Univ. Iowa
+! (C) 1997-2005,A. Sandu,Michigan Tech,Virginia Tech
+! With important contributions from:
+! M. Damian,Villanova University,USA
+! R. Sander,Max-Planck Institute for Chemistry,Mainz,Germany
+!
+! File : chem_gasphase_mod_Util.f90
+! Time : Mon Mar 19 17:08:07 2018
+! Working directory : /home/forkel-r/palmstuff/work/chemistry20180314b/UTIL/chemistry/gasphase_preproc/tmp_kpp4palm
+! Equation file : chem_gasphase_mod.kpp
+! Output root filename : chem_gasphase_mod
+!
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+
+
+
+
+ ! header MODULE initialize_kpp_ctrl_template
+
+ ! notes:
+ ! - l_vector is automatically defined by kp4
+ ! - vl_dim is automatically defined by kp4
+ ! - i_lu_di is automatically defined by kp4
+ ! - wanted is automatically defined by xmecca
+ ! - icntrl rcntrl are automatically defined by kpp
+ ! - "USE messy_main_tools" is in MODULE_header of messy_mecca_kpp.f90
+ ! - SAVE will be automatically added by kp4
+
+ !SAVE
+
+ ! for fixed time step control
+ ! ... max. number of fixed time steps (sum must be 1)
+ INTEGER,PARAMETER :: nmaxfixsteps = 50
+ ! ... switch for fixed time stepping
+ LOGICAL,PUBLIC :: l_fixed_step = .false.
+ INTEGER,PUBLIC :: nfsteps = 1
+ ! ... number of kpp control PARAMETERs
+ INTEGER,PARAMETER,PUBLIC :: nkppctrl = 20
+ !
+ INTEGER, DIMENSION(nkppctrl),PUBLIC :: icntrl = 0
+ REAL(dp),DIMENSION(nkppctrl),PUBLIC :: rcntrl = 0.0_dp
+ REAL(dp),DIMENSION(nmaxfixsteps),PUBLIC :: t_steps = 0.0_dp
+
+ ! END header MODULE initialize_kpp_ctrl_template
+
+
+! Interface Block
+
+ INTERFACE initialize
+ MODULE PROCEDURE initialize
+ END INTERFACE initialize
+
+ INTERFACE integrate
+ MODULE PROCEDURE integrate
+ END INTERFACE integrate
+
+ INTERFACE fun
+ MODULE PROCEDURE fun
+ END INTERFACE fun
+
+ INTERFACE kppsolve
+ MODULE PROCEDURE kppsolve
+ END INTERFACE kppsolve
+
+ INTERFACE kppdecomp
+ MODULE PROCEDURE kppdecomp
+ END INTERFACE kppdecomp
+
+ INTERFACE wlamch
+ MODULE PROCEDURE wlamch
+ END INTERFACE wlamch
+
+ INTERFACE wlamch_add
+ MODULE PROCEDURE wlamch_add
+ END INTERFACE wlamch_add
+
+ INTERFACE jac_sp
+ MODULE PROCEDURE jac_sp
+ END INTERFACE jac_sp
+
+ INTERFACE k_arr
+ MODULE PROCEDURE k_arr
+ END INTERFACE k_arr
+
+ INTERFACE update_rconst
+ MODULE PROCEDURE update_rconst
+ END INTERFACE update_rconst
+
+ INTERFACE arr2
+ MODULE PROCEDURE arr2
+ END INTERFACE arr2
+
+ INTERFACE initialize_kpp_ctrl
+ MODULE PROCEDURE initialize_kpp_ctrl
+ END INTERFACE initialize_kpp_ctrl
+
+ INTERFACE error_output
+ MODULE PROCEDURE error_output
+ END INTERFACE error_output
+
+!interface not working INTERFACE wcopy
+!interface not working MODULE PROCEDURE wcopy
+!interface not working END INTERFACE wcopy
+
+ INTERFACE wscal
+ MODULE PROCEDURE wscal
+ END INTERFACE wscal
+
+!interface not working INTERFACE waxpy
+!interface not working MODULE PROCEDURE waxpy
+!interface not working END INTERFACE waxpy
+
+ INTERFACE rosenbrock
+ MODULE PROCEDURE rosenbrock
+ END INTERFACE rosenbrock
+
+ INTERFACE funtemplate
+ MODULE PROCEDURE funtemplate
+ END INTERFACE funtemplate
+
+ INTERFACE jactemplate
+ MODULE PROCEDURE jactemplate
+ END INTERFACE jactemplate
+
+ INTERFACE chem_gasphase_integrate
+ MODULE PROCEDURE chem_gasphase_integrate
+ END INTERFACE chem_gasphase_integrate
+
+ INTERFACE fill_temp
+ MODULE PROCEDURE fill_temp
+ END INTERFACE fill_temp
+ PUBLIC fill_temp
+
+
+ CONTAINS
+
+SUBROUTINE initialize()
+
+
+
+ INTEGER :: i
+ REAL(kind=dp):: x
+
+ cfactor = 1.000000e+00_dp
+
+ x = (0.)*cfactor
+ DO i = 1,nvar
+ var(i) = x
+ ENDDO
+
+ x = (0.)*cfactor
+ DO i = 1,nfix
+ fix(i) = x
+ ENDDO
+
+! constant rate coefficients
+! END constant rate coefficients
+
+! INLINED initializations
+
+! End INLINED initializations
+
+
+END SUBROUTINE initialize
+
+SUBROUTINE integrate( tin,tout,&
+ icntrl_u,rcntrl_u,istatus_u,rstatus_u,ierr_u)
+
+
+ REAL(kind=dp),INTENT(in):: tin ! start time
+ REAL(kind=dp),INTENT(in):: tout ! END time
+ ! OPTIONAL input PARAMETERs and statistics
+ INTEGER, INTENT(in), OPTIONAL :: icntrl_u(20)
+ REAL(kind=dp),INTENT(in), OPTIONAL :: rcntrl_u(20)
+ INTEGER, INTENT(out),OPTIONAL :: istatus_u(20)
+ REAL(kind=dp),INTENT(out),OPTIONAL :: rstatus_u(20)
+ INTEGER, INTENT(out),OPTIONAL :: ierr_u
+
+ REAL(kind=dp):: rcntrl(20),rstatus(20)
+ INTEGER :: icntrl(20),istatus(20),ierr
+
+ INTEGER,SAVE :: ntotal = 0
+
+ icntrl(:) = 0
+ rcntrl(:) = 0.0_dp
+ istatus(:) = 0
+ rstatus(:) = 0.0_dp
+
+ !~~~> fine-tune the integrator:
+ icntrl(1) = 0 ! 0 - non- autonomous,1 - autonomous
+ icntrl(2) = 0 ! 0 - vector tolerances,1 - scalars
+
+ ! IF OPTIONAL PARAMETERs are given,and IF they are >0,
+ ! THEN they overwrite default settings.
+ IF (present(icntrl_u))THEN
+ where(icntrl_u(:)> 0)icntrl(:) = icntrl_u(:)
+ ENDIF
+ IF (present(rcntrl_u))THEN
+ where(rcntrl_u(:)> 0)rcntrl(:) = rcntrl_u(:)
+ ENDIF
+
+
+ CALL rosenbrock(nvar,var,tin,tout, &
+ atol,rtol, &
+ rcntrl,icntrl,rstatus,istatus,ierr)
+
+ !~~~> debug option: show no of steps
+ ! ntotal = ntotal + istatus(nstp)
+ ! PRINT*,'NSTEPS=',ISTATUS(Nstp),' (',Ntotal,')',' O3=',VAR(ind_O3)
+
+ stepmin = rstatus(nhexit)
+ ! IF OPTIONAL PARAMETERs are given for output they
+ ! are updated with the RETURN information
+ IF (present(istatus_u))istatus_u(:) = istatus(:)
+ IF (present(rstatus_u))rstatus_u(:) = rstatus(:)
+ IF (present(ierr_u)) ierr_u = ierr
+
+END SUBROUTINE integrate
+
+SUBROUTINE fun(v,f,rct,vdot)
+
+! V - Concentrations of variable species (local)
+ REAL(kind=dp):: v(nvar)
+! F - Concentrations of fixed species (local)
+ REAL(kind=dp):: f(nfix)
+! RCT - Rate constants (local)
+ REAL(kind=dp):: rct(nreact)
+! Vdot - Time derivative of variable species concentrations
+ REAL(kind=dp):: vdot(nvar)
+
+
+! Computation of equation rates
+ a(1) = rct(1)*v(3)
+ a(2) = rct(2)*v(1)*v(2)
+
+! Aggregate function
+ vdot(1) = a(1)- a(2)
+ vdot(2) = a(1)- a(2)
+ vdot(3) = - a(1)+ a(2)
+
+END SUBROUTINE fun
+
+SUBROUTINE kppsolve(jvs,x)
+
+! JVS - sparse Jacobian of variables
+ REAL(kind=dp):: jvs(lu_nonzero)
+! X - Vector for variables
+ REAL(kind=dp):: x(nvar)
+
+ x(2) = x(2)- jvs(4)*x(1)
+ x(3) = x(3)- jvs(7)*x(1)- jvs(8)*x(2)
+ x(3) = x(3)/ jvs(9)
+ x(2) = (x(2)- jvs(6)*x(3))/(jvs(5))
+ x(1) = (x(1)- jvs(2)*x(2)- jvs(3)*x(3))/(jvs(1))
+
+END SUBROUTINE kppsolve
+
+SUBROUTINE kppdecomp( jvs,ier)
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+! Sparse LU factorization
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+ INTEGER :: ier
+ REAL(kind=dp):: jvs(lu_nonzero),w(nvar),a
+ INTEGER :: k,kk,j,jj
+
+ a = 0. ! mz_rs_20050606
+ ier = 0
+ DO k=1,nvar
+ ! mz_rs_20050606: don't check if real value == 0
+ ! IF(jvs( lu_diag(k)).eq. 0.)THEN
+ IF(abs(jvs(lu_diag(k)))< tiny(a))THEN
+ ier = k
+ RETURN
+ ENDIF
+ DO kk = lu_crow(k),lu_crow(k+ 1)- 1
+ w( lu_icol(kk)) = jvs(kk)
+ ENDDO
+ DO kk = lu_crow(k),lu_diag(k)- 1
+ j = lu_icol(kk)
+ a = - w(j)/ jvs( lu_diag(j))
+ w(j) = - a
+ DO jj = lu_diag(j)+ 1,lu_crow(j+ 1)- 1
+ w( lu_icol(jj)) = w( lu_icol(jj))+ a*jvs(jj)
+ ENDDO
+ ENDDO
+ DO kk = lu_crow(k),lu_crow(k+ 1)- 1
+ jvs(kk) = w( lu_icol(kk))
+ ENDDO
+ ENDDO
+
+END SUBROUTINE kppdecomp
+
+ REAL(kind=dp)FUNCTION wlamch( c)
+!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+! returns epsilon machine
+! after LAPACK
+! replace this by the function from the optimized LAPACK implementation:
+! CALL SLAMCH('E') or CALL DLAMCH('E')
+!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+! USE chem_gasphase_mod_Precision
+
+ CHARACTER :: c
+ INTEGER :: i
+ REAL(kind=dp),SAVE :: eps
+ REAL(kind=dp) :: suma
+ REAL(kind=dp),PARAMETER :: one=1.0_dp, half=0.5_dp
+ LOGICAL,SAVE :: first=.true.
+
+ IF (first)THEN
+ first = .false.
+ eps = half**(16)
+ DO i = 17,80
+ eps = eps*half
+ CALL wlamch_add(one,eps,suma)
+ IF (suma.le.one)goto 10
+ ENDDO
+ PRINT*,'ERROR IN WLAMCH. EPS < ',Eps
+ RETURN
+10 eps = eps*2
+ i = i- 1
+ ENDIF
+
+ wlamch = eps
+
+ END FUNCTION wlamch
+
+ SUBROUTINE wlamch_add( a,b,suma)
+! USE chem_gasphase_mod_Precision
+
+ REAL(kind=dp)a,b,suma
+ suma = a + b
+
+ END SUBROUTINE wlamch_add
+
+SUBROUTINE jac_sp(v,f,rct,jvs)
+
+! V - Concentrations of variable species (local)
+ REAL(kind=dp):: v(nvar)
+! F - Concentrations of fixed species (local)
+ REAL(kind=dp):: f(nfix)
+! RCT - Rate constants (local)
+ REAL(kind=dp):: rct(nreact)
+! JVS - sparse Jacobian of variables
+ REAL(kind=dp):: jvs(lu_nonzero)
+
+
+! Local variables
+! B - Temporary array
+ REAL(kind=dp):: b(3)
+
+! B(1) = dA(1)/dV(3)
+ b(1) = rct(1)
+! B(2) = dA(2)/dV(1)
+ b(2) = rct(2)*v(2)
+! B(3) = dA(2)/dV(2)
+ b(3) = rct(2)*v(1)
+
+! Construct the Jacobian terms from B's
+! JVS(1) = Jac_FULL(1,1)
+ jvs(1) = - b(2)
+! JVS(2) = Jac_FULL(1,2)
+ jvs(2) = - b(3)
+! JVS(3) = Jac_FULL(1,3)
+ jvs(3) = b(1)
+! JVS(4) = Jac_FULL(2,1)
+ jvs(4) = - b(2)
+! JVS(5) = Jac_FULL(2,2)
+ jvs(5) = - b(3)
+! JVS(6) = Jac_FULL(2,3)
+ jvs(6) = b(1)
+! JVS(7) = Jac_FULL(3,1)
+ jvs(7) = b(2)
+! JVS(8) = Jac_FULL(3,2)
+ jvs(8) = b(3)
+! JVS(9) = Jac_FULL(3,3)
+ jvs(9) = - b(1)
+
+END SUBROUTINE jac_sp
+
+ elemental REAL(kind=dp)FUNCTION k_arr (k_298,tdep,temp)
+ ! arrhenius FUNCTION
+
+ REAL, INTENT(in):: k_298 ! k at t = 298.15k
+ REAL, INTENT(in):: tdep ! temperature dependence
+ REAL(kind=dp),INTENT(in):: temp ! temperature
+
+ intrinsic exp
+
+ k_arr = k_298 *exp(tdep*(1._dp/temp- 3.3540e-3_dp))! 1/298.15=3.3540e-3
+
+ END FUNCTION k_arr
+
+SUBROUTINE update_rconst()
+ INTEGER :: j,k
+
+ k = is
+
+! Begin INLINED RCONST
+
+
+! End INLINED RCONST
+
+ rconst(1) = (phot(j_no2))
+ rconst(2) = (arr2(1.8e-12_dp , 1370.0_dp , temp(k)))
+
+END SUBROUTINE update_rconst
+
+REAL(kind=dp)FUNCTION arr2( a0,b0,temp)
+ REAL(kind=dp):: temp
+ REAL(kind=dp):: a0,b0
+ arr2 = a0 *exp( - b0 / temp)
+END FUNCTION arr2
+
+SUBROUTINE initialize_kpp_ctrl(status,iou,modstr)
+
+
+ ! i/o
+ INTEGER, INTENT(out):: status
+ INTEGER, INTENT(in) :: iou ! LOGICAL i/o unit
+ CHARACTER(len=*),INTENT(in) :: modstr ! read .nml
+
+ ! local
+ REAL(dp):: tsum
+ INTEGER :: i
+
+ ! check fixed time steps
+ tsum = 0.0_dp
+ DO i=1,nmaxfixsteps
+ IF (t_steps(i)< tiny(0.0_dp))exit
+ tsum = tsum + t_steps(i)
+ ENDDO
+
+ nfsteps = i- 1
+
+ l_fixed_step = (nfsteps > 0).and.((tsum - 1.0)< tiny(0.0_dp))
+
+ IF (l_vector)THEN
+ WRITE(*,*) ' MODE : VECTOR (LENGTH=',VL_DIM,')'
+ ELSE
+ WRITE(*,*) ' MODE : SCALAR'
+ ENDIF
+ !
+ WRITE(*,*) ' DE-INDEXING MODE :',I_LU_DI
+ !
+ WRITE(*,*) ' ICNTRL : ',icntrl
+ WRITE(*,*) ' RCNTRL : ',rcntrl
+ !
+ ! note: this is only meaningful for vectorized (kp4)rosenbrock- methods
+ IF (l_vector)THEN
+ IF (l_fixed_step)THEN
+ WRITE(*,*) ' TIME STEPS : FIXED (',t_steps(1:nfsteps),')'
+ ELSE
+ WRITE(*,*) ' TIME STEPS : AUTOMATIC'
+ ENDIF
+ ELSE
+ WRITE(*,*) ' TIME STEPS : AUTOMATIC '//&
+ &'(t_steps (CTRL_KPP) ignored in SCALAR MODE)'
+ ENDIF
+ ! mz_pj_20070531-
+
+ status = 0
+
+
+END SUBROUTINE initialize_kpp_ctrl
+
+SUBROUTINE error_output(c,ierr,pe)
+
+
+ INTEGER,INTENT(in):: ierr
+ INTEGER,INTENT(in):: pe
+ REAL(dp),DIMENSION(:),INTENT(in):: c
+
+ write(6,*) 'ERROR in chem_gasphase_mod ',ierr,C(1)
+
+
+END SUBROUTINE error_output
+
+ SUBROUTINE wcopy(n,x,incx,y,incy)
+!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+! copies a vector,x,to a vector,y: y <- x
+! only for incX=incY=1
+! after BLAS
+! replace this by the function from the optimized BLAS implementation:
+! CALL SCOPY(N,X,1,Y,1) or CALL DCOPY(N,X,1,Y,1)
+!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+! USE chem_gasphase_mod_Precision
+
+ INTEGER :: i,incx,incy,m,mp1,n
+ REAL(kind=dp):: x(n),y(n)
+
+ IF (n.le.0)RETURN
+
+ m = mod(n,8)
+ IF( m .ne. 0)THEN
+ DO i = 1,m
+ y(i) = x(i)
+ ENDDO
+ IF( n .lt. 8)RETURN
+ ENDIF
+ mp1 = m+ 1
+ DO i = mp1,n,8
+ y(i) = x(i)
+ y(i + 1) = x(i + 1)
+ y(i + 2) = x(i + 2)
+ y(i + 3) = x(i + 3)
+ y(i + 4) = x(i + 4)
+ y(i + 5) = x(i + 5)
+ y(i + 6) = x(i + 6)
+ y(i + 7) = x(i + 7)
+ ENDDO
+
+ END SUBROUTINE wcopy
+
+ SUBROUTINE wscal(n,alpha,x,incx)
+!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+! constant times a vector: x(1:N) <- Alpha*x(1:N)
+! only for incX=incY=1
+! after BLAS
+! replace this by the function from the optimized BLAS implementation:
+! CALL SSCAL(N,Alpha,X,1) or CALL DSCAL(N,Alpha,X,1)
+!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+ INTEGER :: i,incx,m,mp1,n
+ REAL(kind=dp) :: x(n),alpha
+ REAL(kind=dp),PARAMETER :: zero=0.0_dp, one=1.0_dp
+
+ IF (alpha .eq. one)RETURN
+ IF (n .le. 0)RETURN
+
+ m = mod(n,5)
+ IF( m .ne. 0)THEN
+ IF (alpha .eq. (- one))THEN
+ DO i = 1,m
+ x(i) = - x(i)
+ ENDDO
+ ELSEIF (alpha .eq. zero)THEN
+ DO i = 1,m
+ x(i) = zero
+ ENDDO
+ ELSE
+ DO i = 1,m
+ x(i) = alpha*x(i)
+ ENDDO
+ ENDIF
+ IF( n .lt. 5)RETURN
+ ENDIF
+ mp1 = m + 1
+ IF (alpha .eq. (- one))THEN
+ DO i = mp1,n,5
+ x(i) = - x(i)
+ x(i + 1) = - x(i + 1)
+ x(i + 2) = - x(i + 2)
+ x(i + 3) = - x(i + 3)
+ x(i + 4) = - x(i + 4)
+ ENDDO
+ ELSEIF (alpha .eq. zero)THEN
+ DO i = mp1,n,5
+ x(i) = zero
+ x(i + 1) = zero
+ x(i + 2) = zero
+ x(i + 3) = zero
+ x(i + 4) = zero
+ ENDDO
+ ELSE
+ DO i = mp1,n,5
+ x(i) = alpha*x(i)
+ x(i + 1) = alpha*x(i + 1)
+ x(i + 2) = alpha*x(i + 2)
+ x(i + 3) = alpha*x(i + 3)
+ x(i + 4) = alpha*x(i + 4)
+ ENDDO
+ ENDIF
+
+ END SUBROUTINE wscal
+
+ SUBROUTINE waxpy(n,alpha,x,incx,y,incy)
+!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+! constant times a vector plus a vector: y <- y + Alpha*x
+! only for incX=incY=1
+! after BLAS
+! replace this by the function from the optimized BLAS implementation:
+! CALL SAXPY(N,Alpha,X,1,Y,1) or CALL DAXPY(N,Alpha,X,1,Y,1)
+!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+ INTEGER :: i,incx,incy,m,mp1,n
+ REAL(kind=dp):: x(n),y(n),alpha
+ REAL(kind=dp),PARAMETER :: zero = 0.0_dp
+
+ IF (alpha .eq. zero)RETURN
+ IF (n .le. 0)RETURN
+
+ m = mod(n,4)
+ IF( m .ne. 0)THEN
+ DO i = 1,m
+ y(i) = y(i)+ alpha*x(i)
+ ENDDO
+ IF( n .lt. 4)RETURN
+ ENDIF
+ mp1 = m + 1
+ DO i = mp1,n,4
+ y(i) = y(i)+ alpha*x(i)
+ y(i + 1) = y(i + 1)+ alpha*x(i + 1)
+ y(i + 2) = y(i + 2)+ alpha*x(i + 2)
+ y(i + 3) = y(i + 3)+ alpha*x(i + 3)
+ ENDDO
+
+ END SUBROUTINE waxpy
+
+SUBROUTINE rosenbrock(n,y,tstart,tend,&
+ abstol,reltol, &
+ rcntrl,icntrl,rstatus,istatus,ierr)
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+! Solves the system y'=F(t,y) using a Rosenbrock method defined by:
+!
+! G = 1/(H*gamma(1)) - Jac(t0,Y0)
+! T_i = t0 + Alpha(i)*H
+! Y_i = Y0 + \sum_{j=1}^{i-1} A(i,j)*K_j
+! G *K_i = Fun( T_i,Y_i)+ \sum_{j=1}^S C(i,j)/H *K_j +
+! gamma(i)*dF/dT(t0,Y0)
+! Y1 = Y0 + \sum_{j=1}^S M(j)*K_j
+!
+! For details on Rosenbrock methods and their implementation consult:
+! E. Hairer and G. Wanner
+! "Solving ODEs II. Stiff and differential-algebraic problems".
+! Springer series in computational mathematics,Springer-Verlag,1996.
+! The codes contained in the book inspired this implementation.
+!
+! (C) Adrian Sandu,August 2004
+! Virginia Polytechnic Institute and State University
+! Contact: sandu@cs.vt.edu
+! Revised by Philipp Miehe and Adrian Sandu,May 2006
+! This implementation is part of KPP - the Kinetic PreProcessor
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+!~~~> input arguments:
+!
+!- y(n) = vector of initial conditions (at t=tstart)
+!- [tstart,tend] = time range of integration
+! (if Tstart>Tend the integration is performed backwards in time)
+!- reltol,abstol = user precribed accuracy
+!- SUBROUTINE fun( t,y,ydot) = ode FUNCTION,
+! returns Ydot = Y' = F(T,Y)
+!- SUBROUTINE jac( t,y,jcb) = jacobian of the ode FUNCTION,
+! returns Jcb = dFun/dY
+!- icntrl(1:20) = INTEGER inputs PARAMETERs
+!- rcntrl(1:20) = REAL inputs PARAMETERs
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+!~~~> output arguments:
+!
+!- y(n) - > vector of final states (at t- >tEND)
+!- istatus(1:20) - > INTEGER output PARAMETERs
+!- rstatus(1:20) - > REAL output PARAMETERs
+!- ierr - > job status upon RETURN
+! success (positive value) or
+! failure (negative value)
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+!~~~> input PARAMETERs:
+!
+! Note: For input parameters equal to zero the default values of the
+! corresponding variables are used.
+!
+! ICNTRL(1) = 1: F = F(y) Independent of T (AUTONOMOUS)
+! = 0: F = F(t,y) Depends on T (NON-AUTONOMOUS)
+!
+! ICNTRL(2) = 0: AbsTol,RelTol are N-dimensional vectors
+! = 1: AbsTol,RelTol are scalars
+!
+! ICNTRL(3) -> selection of a particular Rosenbrock method
+! = 0 : Rodas3 (default)
+! = 1 : Ros2
+! = 2 : Ros3
+! = 3 : Ros4
+! = 4 : Rodas3
+! = 5 : Rodas4
+!
+! ICNTRL(4) -> maximum number of integration steps
+! For ICNTRL(4) =0) the default value of 100000 is used
+!
+! RCNTRL(1) -> Hmin,lower bound for the integration step size
+! It is strongly recommended to keep Hmin = ZERO
+! RCNTRL(2) -> Hmax,upper bound for the integration step size
+! RCNTRL(3) -> Hstart,starting value for the integration step size
+!
+! RCNTRL(4) -> FacMin,lower bound on step decrease factor (default=0.2)
+! RCNTRL(5) -> FacMax,upper bound on step increase factor (default=6)
+! RCNTRL(6) -> FacRej,step decrease factor after multiple rejections
+! (default=0.1)
+! RCNTRL(7) -> FacSafe,by which the new step is slightly smaller
+! than the predicted value (default=0.9)
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+!
+! OUTPUT ARGUMENTS:
+! -----------------
+!
+! T -> T value for which the solution has been computed
+! (after successful return T=Tend).
+!
+! Y(N) -> Numerical solution at T
+!
+! IDID -> Reports on successfulness upon return:
+! = 1 for success
+! < 0 for error (value equals error code)
+!
+! ISTATUS(1) -> No. of function calls
+! ISTATUS(2) -> No. of jacobian calls
+! ISTATUS(3) -> No. of steps
+! ISTATUS(4) -> No. of accepted steps
+! ISTATUS(5) -> No. of rejected steps (except at very beginning)
+! ISTATUS(6) -> No. of LU decompositions
+! ISTATUS(7) -> No. of forward/backward substitutions
+! ISTATUS(8) -> No. of singular matrix decompositions
+!
+! RSTATUS(1) -> Texit,the time corresponding to the
+! computed Y upon return
+! RSTATUS(2) -> Hexit,last accepted step before exit
+! RSTATUS(3) -> Hnew,last predicted step (not yet taken)
+! For multiple restarts,use Hnew as Hstart
+! in the subsequent run
+!
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+!~~~> arguments
+ INTEGER, INTENT(in) :: n
+ REAL(kind=dp),INTENT(inout):: y(n)
+ REAL(kind=dp),INTENT(in) :: tstart,tend
+ REAL(kind=dp),INTENT(in) :: abstol(n),reltol(n)
+ INTEGER, INTENT(in) :: icntrl(20)
+ REAL(kind=dp),INTENT(in) :: rcntrl(20)
+ INTEGER, INTENT(inout):: istatus(20)
+ REAL(kind=dp),INTENT(inout):: rstatus(20)
+ INTEGER,INTENT(out) :: ierr
+!~~~> PARAMETERs of the rosenbrock method,up to 6 stages
+ INTEGER :: ros_s,rosmethod
+ INTEGER,PARAMETER :: rs2=1,rs3=2,rs4=3,rd3=4,rd4=5,rg3=6
+ REAL(kind=dp):: ros_a(15),ros_c(15),ros_m(6),ros_e(6),&
+ ros_alpha(6),ros_gamma(6),ros_elo
+ LOGICAL :: ros_newf(6)
+ CHARACTER(len=12):: ros_name
+!~~~> local variables
+ REAL(kind=dp):: roundoff,facmin,facmax,facrej,facsafe
+ REAL(kind=dp):: hmin,hmax,hstart
+ REAL(kind=dp):: texit
+ INTEGER :: i,uplimtol,max_no_steps
+ LOGICAL :: autonomous,vectortol
+!~~~> PARAMETERs
+ REAL(kind=dp),PARAMETER :: zero = 0.0_dp, one = 1.0_dp
+ REAL(kind=dp),PARAMETER :: deltamin = 1.0e-5_dp
+
+!~~~> initialize statistics
+ istatus(1:8) = 0
+ rstatus(1:3) = zero
+
+!~~~> autonomous or time dependent ode. default is time dependent.
+ autonomous = .not.(icntrl(1) == 0)
+
+!~~~> for scalar tolerances (icntrl(2).ne.0) the code uses abstol(1)and reltol(1)
+! For Vector tolerances (ICNTRL(2) == 0) the code uses AbsTol(1:N) and RelTol(1:N)
+ IF (icntrl(2) == 0)THEN
+ vectortol = .true.
+ uplimtol = n
+ ELSE
+ vectortol = .false.
+ uplimtol = 1
+ ENDIF
+
+!~~~> initialize the particular rosenbrock method selected
+ select CASE (icntrl(3))
+ CASE (1)
+ CALL ros2
+ CASE (2)
+ CALL ros3
+ CASE (3)
+ CALL ros4
+ CASE (0,4)
+ CALL rodas3
+ CASE (5)
+ CALL rodas4
+ CASE (6)
+ CALL rang3
+ CASE default
+ PRINT *,'Unknown Rosenbrock method: ICNTRL(3) =',ICNTRL(3)
+ CALL ros_errormsg(- 2,tstart,zero,ierr)
+ RETURN
+ END select
+
+!~~~> the maximum number of steps admitted
+ IF (icntrl(4) == 0)THEN
+ max_no_steps = 200000
+ ELSEIF (icntrl(4)> 0)THEN
+ max_no_steps=icntrl(4)
+ ELSE
+ PRINT *,'User-selected max no. of steps: ICNTRL(4) =',ICNTRL(4)
+ CALL ros_errormsg(- 1,tstart,zero,ierr)
+ RETURN
+ ENDIF
+
+!~~~> unit roundoff (1+ roundoff>1)
+ Roundoff = WLAMCH('E')
+
+!~~~> lower bound on the step size: (positive value)
+ IF (rcntrl(1) == zero)THEN
+ hmin = zero
+ ELSEIF (rcntrl(1)> zero)THEN
+ hmin = rcntrl(1)
+ ELSE
+ PRINT *,'User-selected Hmin: RCNTRL(1) =',RCNTRL(1)
+ CALL ros_errormsg(- 3,tstart,zero,ierr)
+ RETURN
+ ENDIF
+!~~~> upper bound on the step size: (positive value)
+ IF (rcntrl(2) == zero)THEN
+ hmax = abs(tend-tstart)
+ ELSEIF (rcntrl(2)> zero)THEN
+ hmax = min(abs(rcntrl(2)),abs(tend-tstart))
+ ELSE
+ PRINT *,'User-selected Hmax: RCNTRL(2) =',RCNTRL(2)
+ CALL ros_errormsg(- 3,tstart,zero,ierr)
+ RETURN
+ ENDIF
+!~~~> starting step size: (positive value)
+ IF (rcntrl(3) == zero)THEN
+ hstart = max(hmin,deltamin)
+ ELSEIF (rcntrl(3)> zero)THEN
+ hstart = min(abs(rcntrl(3)),abs(tend-tstart))
+ ELSE
+ PRINT *,'User-selected Hstart: RCNTRL(3) =',RCNTRL(3)
+ CALL ros_errormsg(- 3,tstart,zero,ierr)
+ RETURN
+ ENDIF
+!~~~> step size can be changed s.t. facmin < hnew/hold < facmax
+ IF (rcntrl(4) == zero)THEN
+ facmin = 0.2_dp
+ ELSEIF (rcntrl(4)> zero)THEN
+ facmin = rcntrl(4)
+ ELSE
+ PRINT *,'User-selected FacMin: RCNTRL(4) =',RCNTRL(4)
+ CALL ros_errormsg(- 4,tstart,zero,ierr)
+ RETURN
+ ENDIF
+ IF (rcntrl(5) == zero)THEN
+ facmax = 6.0_dp
+ ELSEIF (rcntrl(5)> zero)THEN
+ facmax = rcntrl(5)
+ ELSE
+ PRINT *,'User-selected FacMax: RCNTRL(5) =',RCNTRL(5)
+ CALL ros_errormsg(- 4,tstart,zero,ierr)
+ RETURN
+ ENDIF
+!~~~> facrej: factor to decrease step after 2 succesive rejections
+ IF (rcntrl(6) == zero)THEN
+ facrej = 0.1_dp
+ ELSEIF (rcntrl(6)> zero)THEN
+ facrej = rcntrl(6)
+ ELSE
+ PRINT *,'User-selected FacRej: RCNTRL(6) =',RCNTRL(6)
+ CALL ros_errormsg(- 4,tstart,zero,ierr)
+ RETURN
+ ENDIF
+!~~~> facsafe: safety factor in the computation of new step size
+ IF (rcntrl(7) == zero)THEN
+ facsafe = 0.9_dp
+ ELSEIF (rcntrl(7)> zero)THEN
+ facsafe = rcntrl(7)
+ ELSE
+ PRINT *,'User-selected FacSafe: RCNTRL(7) =',RCNTRL(7)
+ CALL ros_errormsg(- 4,tstart,zero,ierr)
+ RETURN
+ ENDIF
+!~~~> check IF tolerances are reasonable
+ DO i=1,uplimtol
+ IF((abstol(i)<= zero).or. (reltol(i)<= 10.0_dp*roundoff)&
+ .or. (reltol(i)>= 1.0_dp))THEN
+ PRINT *,' AbsTol(',i,') = ',AbsTol(i)
+ PRINT *,' RelTol(',i,') = ',RelTol(i)
+ CALL ros_errormsg(- 5,tstart,zero,ierr)
+ RETURN
+ ENDIF
+ ENDDO
+
+
+!~~~> CALL rosenbrock method
+ CALL ros_integrator(y,tstart,tend,texit, &
+ abstol,reltol, &
+! Integration parameters
+ autonomous,vectortol,max_no_steps, &
+ roundoff,hmin,hmax,hstart, &
+ facmin,facmax,facrej,facsafe, &
+! Error indicator
+ ierr)
+
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+CONTAINS ! SUBROUTINEs internal to rosenbrock
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ SUBROUTINE ros_errormsg(code,t,h,ierr)
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+! Handles all error messages
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+ REAL(kind=dp),INTENT(in):: t,h
+ INTEGER,INTENT(in) :: code
+ INTEGER,INTENT(out):: ierr
+
+ ierr = code
+ print *,&
+ 'Forced exit from Rosenbrock due to the following error:'
+
+ select CASE (code)
+ CASE (- 1)
+ PRINT *,'--> Improper value for maximal no of steps'
+ CASE (- 2)
+ PRINT *,'--> Selected Rosenbrock method not implemented'
+ CASE (- 3)
+ PRINT *,'--> Hmin/Hmax/Hstart must be positive'
+ CASE (- 4)
+ PRINT *,'--> FacMin/FacMax/FacRej must be positive'
+ CASE (- 5)
+ PRINT *,'--> Improper tolerance values'
+ CASE (- 6)
+ PRINT *,'--> No of steps exceeds maximum bound'
+ CASE (- 7)
+ PRINT *,'--> Step size too small: T + 10*H = T',&
+ ' or H < Roundoff'
+ CASE (- 8)
+ PRINT *,'--> Matrix is repeatedly singular'
+ CASE default
+ PRINT *,'Unknown Error code: ',Code
+ END select
+
+ print *,"t=",t,"and h=",h
+
+ END SUBROUTINE ros_errormsg
+
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ SUBROUTINE ros_integrator (y,tstart,tend,t, &
+ abstol,reltol, &
+!~~~> integration PARAMETERs
+ autonomous,vectortol,max_no_steps, &
+ roundoff,hmin,hmax,hstart, &
+ facmin,facmax,facrej,facsafe, &
+!~~~> error indicator
+ ierr)
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+! Template for the implementation of a generic Rosenbrock method
+! defined by ros_S (no of stages)
+! and its coefficients ros_{A,C,M,E,Alpha,Gamma}
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+!~~~> input: the initial condition at tstart; output: the solution at t
+ REAL(kind=dp),INTENT(inout):: y(n)
+!~~~> input: integration interval
+ REAL(kind=dp),INTENT(in):: tstart,tend
+!~~~> output: time at which the solution is RETURNed (t=tENDIF success)
+ REAL(kind=dp),INTENT(out):: t
+!~~~> input: tolerances
+ REAL(kind=dp),INTENT(in):: abstol(n),reltol(n)
+!~~~> input: integration PARAMETERs
+ LOGICAL,INTENT(in):: autonomous,vectortol
+ REAL(kind=dp),INTENT(in):: hstart,hmin,hmax
+ INTEGER,INTENT(in):: max_no_steps
+ REAL(kind=dp),INTENT(in):: roundoff,facmin,facmax,facrej,facsafe
+!~~~> output: error indicator
+ INTEGER,INTENT(out):: ierr
+! ~~~~ Local variables
+ REAL(kind=dp):: ynew(n),fcn0(n),fcn(n)
+ REAL(kind=dp):: k(n*ros_s),dfdt(n)
+#ifdef full_algebra
+ REAL(kind=dp):: jac0(n,n),ghimj(n,n)
+#else
+ REAL(kind=dp):: jac0(lu_nonzero),ghimj(lu_nonzero)
+#endif
+ REAL(kind=dp):: h,hnew,hc,hg,fac,tau
+ REAL(kind=dp):: err,yerr(n)
+ INTEGER :: pivot(n),direction,ioffset,j,istage
+ LOGICAL :: rejectlasth,rejectmoreh,singular
+!~~~> local PARAMETERs
+ REAL(kind=dp),PARAMETER :: zero = 0.0_dp, one = 1.0_dp
+ REAL(kind=dp),PARAMETER :: deltamin = 1.0e-5_dp
+!~~~> locally called FUNCTIONs
+! REAL(kind=dp) WLAMCH
+! EXTERNAL WLAMCH
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+!~~~> initial preparations
+ t = tstart
+ rstatus(nhexit) = zero
+ h = min( max(abs(hmin),abs(hstart)),abs(hmax))
+ IF (abs(h)<= 10.0_dp*roundoff)h = deltamin
+
+ IF (tEND >= tstart)THEN
+ direction = + 1
+ ELSE
+ direction = - 1
+ ENDIF
+ h = direction*h
+
+ rejectlasth=.false.
+ rejectmoreh=.false.
+
+!~~~> time loop begins below
+
+timeloop: DO WHILE((direction > 0).and.((t- tEND)+ roundoff <= zero)&
+ .or. (direction < 0).and.((tend-t)+ roundoff <= zero))
+
+ IF(istatus(nstp)> max_no_steps)THEN ! too many steps
+ CALL ros_errormsg(- 6,t,h,ierr)
+ RETURN
+ ENDIF
+ IF(((t+ 0.1_dp*h) == t).or.(h <= roundoff))THEN ! step size too small
+ CALL ros_errormsg(- 7,t,h,ierr)
+ RETURN
+ ENDIF
+
+!~~~> limit h IF necessary to avoid going beyond tend
+ h = min(h,abs(tend-t))
+
+!~~~> compute the FUNCTION at current time
+ CALL funtemplate(t,y,fcn0)
+ istatus(nfun) = istatus(nfun)+ 1
+
+!~~~> compute the FUNCTION derivative with respect to t
+ IF (.not.autonomous)THEN
+ CALL ros_funtimederivative(t,roundoff,y,&
+ fcn0,dfdt)
+ ENDIF
+
+!~~~> compute the jacobian at current time
+ CALL jactemplate(t,y,jac0)
+ istatus(njac) = istatus(njac)+ 1
+
+!~~~> repeat step calculation until current step accepted
+untilaccepted: do
+
+ CALL ros_preparematrix(h,direction,ros_gamma(1),&
+ jac0,ghimj,pivot,singular)
+ IF (singular)THEN ! more than 5 consecutive failed decompositions
+ CALL ros_errormsg(- 8,t,h,ierr)
+ RETURN
+ ENDIF
+
+!~~~> compute the stages
+stage: DO istage = 1,ros_s
+
+ ! current istage offset. current istage vector is k(ioffset+ 1:ioffset+ n)
+ ioffset = n*(istage-1)
+
+ ! for the 1st istage the FUNCTION has been computed previously
+ IF(istage == 1)THEN
+ !slim: CALL wcopy(n,fcn0,1,fcn,1)
+ fcn(1:n) = fcn0(1:n)
+ ! istage>1 and a new FUNCTION evaluation is needed at the current istage
+ ELSEIF(ros_newf(istage))THEN
+ !slim: CALL wcopy(n,y,1,ynew,1)
+ ynew(1:n) = y(1:n)
+ DO j = 1,istage-1
+ CALL waxpy(n,ros_a((istage-1)*(istage-2)/2+ j),&
+ k(n*(j- 1)+ 1),1,ynew,1)
+ ENDDO
+ tau = t + ros_alpha(istage)*direction*h
+ CALL funtemplate(tau,ynew,fcn)
+ istatus(nfun) = istatus(nfun)+ 1
+ ENDIF ! IF istage == 1 ELSEIF ros_newf(istage)
+ !slim: CALL wcopy(n,fcn,1,k(ioffset+ 1),1)
+ k(ioffset+ 1:ioffset+ n) = fcn(1:n)
+ DO j = 1,istage-1
+ hc = ros_c((istage-1)*(istage-2)/2+ j)/(direction*h)
+ CALL waxpy(n,hc,k(n*(j- 1)+ 1),1,k(ioffset+ 1),1)
+ ENDDO
+ IF ((.not. autonomous).and.(ros_gamma(istage).ne.zero))THEN
+ hg = direction*h*ros_gamma(istage)
+ CALL waxpy(n,hg,dfdt,1,k(ioffset+ 1),1)
+ ENDIF
+ CALL ros_solve(ghimj,pivot,k(ioffset+ 1))
+
+ END DO stage
+
+
+!~~~> compute the new solution
+ !slim: CALL wcopy(n,y,1,ynew,1)
+ ynew(1:n) = y(1:n)
+ DO j=1,ros_s
+ CALL waxpy(n,ros_m(j),k(n*(j- 1)+ 1),1,ynew,1)
+ ENDDO
+
+!~~~> compute the error estimation
+ !slim: CALL wscal(n,zero,yerr,1)
+ yerr(1:n) = zero
+ DO j=1,ros_s
+ CALL waxpy(n,ros_e(j),k(n*(j- 1)+ 1),1,yerr,1)
+ ENDDO
+ err = ros_errornorm(y,ynew,yerr,abstol,reltol,vectortol)
+
+!~~~> new step size is bounded by facmin <= hnew/h <= facmax
+ fac = min(facmax,max(facmin,facsafe/err**(one/ros_elo)))
+ hnew = h*fac
+
+!~~~> check the error magnitude and adjust step size
+ istatus(nstp) = istatus(nstp)+ 1
+ IF((err <= one).or.(h <= hmin))THEN !~~~> accept step
+ istatus(nacc) = istatus(nacc)+ 1
+ !slim: CALL wcopy(n,ynew,1,y,1)
+ y(1:n) = ynew(1:n)
+ t = t + direction*h
+ hnew = max(hmin,min(hnew,hmax))
+ IF (rejectlasth)THEN ! no step size increase after a rejected step
+ hnew = min(hnew,h)
+ ENDIF
+ rstatus(nhexit) = h
+ rstatus(nhnew) = hnew
+ rstatus(ntexit) = t
+ rejectlasth = .false.
+ rejectmoreh = .false.
+ h = hnew
+ exit untilaccepted ! exit the loop: WHILE step not accepted
+ ELSE !~~~> reject step
+ IF (rejectmoreh)THEN
+ hnew = h*facrej
+ ENDIF
+ rejectmoreh = rejectlasth
+ rejectlasth = .true.
+ h = hnew
+ IF (istatus(nacc)>= 1) istatus(nrej) = istatus(nrej)+ 1
+ ENDIF ! err <= 1
+
+ END DO untilaccepted
+
+ END DO timeloop
+
+!~~~> succesful exit
+ ierr = 1 !~~~> the integration was successful
+
+ END SUBROUTINE ros_integrator
+
+
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ REAL(kind=dp)FUNCTION ros_errornorm(y,ynew,yerr,&
+ abstol,reltol,vectortol)
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!~~~> computes the "scaled norm" of the error vector yerr
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+! Input arguments
+ REAL(kind=dp),INTENT(in):: y(n),ynew(n),&
+ yerr(n),abstol(n),reltol(n)
+ LOGICAL,INTENT(in):: vectortol
+! Local variables
+ REAL(kind=dp):: err,scale,ymax
+ INTEGER :: i
+ REAL(kind=dp),PARAMETER :: zero = 0.0_dp
+
+ err = zero
+ DO i=1,n
+ ymax = max(abs(y(i)),abs(ynew(i)))
+ IF (vectortol)THEN
+ scale = abstol(i)+ reltol(i)*ymax
+ ELSE
+ scale = abstol(1)+ reltol(1)*ymax
+ ENDIF
+ err = err+(yerr(i)/scale)**2
+ ENDDO
+ err = sqrt(err/n)
+
+ ros_errornorm = max(err,1.0d-10)
+
+ END FUNCTION ros_errornorm
+
+
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ SUBROUTINE ros_funtimederivative(t,roundoff,y,&
+ fcn0,dfdt)
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!~~~> the time partial derivative of the FUNCTION by finite differences
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+!~~~> input arguments
+ REAL(kind=dp),INTENT(in):: t,roundoff,y(n),fcn0(n)
+!~~~> output arguments
+ REAL(kind=dp),INTENT(out):: dfdt(n)
+!~~~> local variables
+ REAL(kind=dp):: delta
+ REAL(kind=dp),PARAMETER :: one = 1.0_dp, deltamin = 1.0e-6_dp
+
+ delta = sqrt(roundoff)*max(deltamin,abs(t))
+ CALL funtemplate(t+ delta,y,dfdt)
+ istatus(nfun) = istatus(nfun)+ 1
+ CALL waxpy(n,(- one),fcn0,1,dfdt,1)
+ CALL wscal(n,(one/delta),dfdt,1)
+
+ END SUBROUTINE ros_funtimederivative
+
+
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ SUBROUTINE ros_preparematrix(h,direction,gam,&
+ jac0,ghimj,pivot,singular)
+! --- --- --- --- --- --- --- --- --- --- --- --- ---
+! Prepares the LHS matrix for stage calculations
+! 1. Construct Ghimj = 1/(H*ham) - Jac0
+! "(Gamma H) Inverse Minus Jacobian"
+! 2. Repeat LU decomposition of Ghimj until successful.
+! -half the step size if LU decomposition fails and retry
+! -exit after 5 consecutive fails
+! --- --- --- --- --- --- --- --- --- --- --- --- ---
+
+!~~~> input arguments
+#ifdef full_algebra
+ REAL(kind=dp),INTENT(in):: jac0(n,n)
+#else
+ REAL(kind=dp),INTENT(in):: jac0(lu_nonzero)
+#endif
+ REAL(kind=dp),INTENT(in):: gam
+ INTEGER,INTENT(in):: direction
+!~~~> output arguments
+#ifdef full_algebra
+ REAL(kind=dp),INTENT(out):: ghimj(n,n)
+#else
+ REAL(kind=dp),INTENT(out):: ghimj(lu_nonzero)
+#endif
+ LOGICAL,INTENT(out):: singular
+ INTEGER,INTENT(out):: pivot(n)
+!~~~> inout arguments
+ REAL(kind=dp),INTENT(inout):: h ! step size is decreased when lu fails
+!~~~> local variables
+ INTEGER :: i,ising,nconsecutive
+ REAL(kind=dp):: ghinv
+ REAL(kind=dp),PARAMETER :: one = 1.0_dp, half = 0.5_dp
+
+ nconsecutive = 0
+ singular = .true.
+
+ DO WHILE (singular)
+
+!~~~> construct ghimj = 1/(h*gam)- jac0
+#ifdef full_algebra
+ !slim: CALL wcopy(n*n,jac0,1,ghimj,1)
+ !slim: CALL wscal(n*n,(- one),ghimj,1)
+ ghimj = - jac0
+ ghinv = one/(direction*h*gam)
+ DO i=1,n
+ ghimj(i,i) = ghimj(i,i)+ ghinv
+ ENDDO
+#else
+ !slim: CALL wcopy(lu_nonzero,jac0,1,ghimj,1)
+ !slim: CALL wscal(lu_nonzero,(- one),ghimj,1)
+ ghimj(1:lu_nonzero) = - jac0(1:lu_nonzero)
+ ghinv = one/(direction*h*gam)
+ DO i=1,n
+ ghimj(lu_diag(i)) = ghimj(lu_diag(i))+ ghinv
+ ENDDO
+#endif
+!~~~> compute lu decomposition
+ CALL ros_decomp( ghimj,pivot,ising)
+ IF (ising == 0)THEN
+!~~~> IF successful done
+ singular = .false.
+ ELSE ! ising .ne. 0
+!~~~> IF unsuccessful half the step size; IF 5 consecutive fails THEN RETURN
+ istatus(nsng) = istatus(nsng)+ 1
+ nconsecutive = nconsecutive+1
+ singular = .true.
+ PRINT*,'Warning: LU Decomposition returned ISING = ',ISING
+ IF (nconsecutive <= 5)THEN ! less than 5 consecutive failed decompositions
+ h = h*half
+ ELSE ! more than 5 consecutive failed decompositions
+ RETURN
+ ENDIF ! nconsecutive
+ ENDIF ! ising
+
+ END DO ! WHILE singular
+
+ END SUBROUTINE ros_preparematrix
+
+
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ SUBROUTINE ros_decomp( a,pivot,ising)
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+! Template for the LU decomposition
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!~~~> inout variables
+#ifdef full_algebra
+ REAL(kind=dp),INTENT(inout):: a(n,n)
+#else
+ REAL(kind=dp),INTENT(inout):: a(lu_nonzero)
+#endif
+!~~~> output variables
+ INTEGER,INTENT(out):: pivot(n),ising
+
+#ifdef full_algebra
+ CALL dgetrf( n,n,a,n,pivot,ising)
+#else
+ CALL kppdecomp(a,ising)
+ pivot(1) = 1
+#endif
+ istatus(ndec) = istatus(ndec)+ 1
+
+ END SUBROUTINE ros_decomp
+
+
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ SUBROUTINE ros_solve( a,pivot,b)
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+! Template for the forward/backward substitution (using pre-computed LU decomposition)
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!~~~> input variables
+#ifdef full_algebra
+ REAL(kind=dp),INTENT(in):: a(n,n)
+ INTEGER :: ising
+#else
+ REAL(kind=dp),INTENT(in):: a(lu_nonzero)
+#endif
+ INTEGER,INTENT(in):: pivot(n)
+!~~~> inout variables
+ REAL(kind=dp),INTENT(inout):: b(n)
+
+#ifdef full_algebra
+ CALL DGETRS( 'N',N ,1,A,N,Pivot,b,N,ISING)
+ IF(info < 0)THEN
+ print*,"error in dgetrs. ising=",ising
+ ENDIF
+#else
+ CALL kppsolve( a,b)
+#endif
+
+ istatus(nsol) = istatus(nsol)+ 1
+
+ END SUBROUTINE ros_solve
+
+
+
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ SUBROUTINE ros2
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+! --- AN L-STABLE METHOD,2 stages,order 2
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+ double precision g
+
+ g = 1.0_dp + 1.0_dp/sqrt(2.0_dp)
+ rosmethod = rs2
+!~~~> name of the method
+ ros_Name = 'ROS-2'
+!~~~> number of stages
+ ros_s = 2
+
+!~~~> the coefficient matrices a and c are strictly lower triangular.
+! The lower triangular (subdiagonal) elements are stored in row-wise order:
+! A(2,1) = ros_A(1),A(3,1) =ros_A(2),A(3,2) =ros_A(3),etc.
+! The general mapping formula is:
+! A(i,j) = ros_A( (i-1)*(i-2)/2 + j)
+! C(i,j) = ros_C( (i-1)*(i-2)/2 + j)
+
+ ros_a(1) = (1.0_dp)/g
+ ros_c(1) = (- 2.0_dp)/g
+!~~~> does the stage i require a new FUNCTION evaluation (ros_newf(i) =true)
+! or does it re-use the function evaluation from stage i-1 (ros_NewF(i) =FALSE)
+ ros_newf(1) = .true.
+ ros_newf(2) = .true.
+!~~~> m_i = coefficients for new step solution
+ ros_m(1) = (3.0_dp)/(2.0_dp*g)
+ ros_m(2) = (1.0_dp)/(2.0_dp*g)
+! E_i = Coefficients for error estimator
+ ros_e(1) = 1.0_dp/(2.0_dp*g)
+ ros_e(2) = 1.0_dp/(2.0_dp*g)
+!~~~> ros_elo = estimator of local order - the minimum between the
+! main and the embedded scheme orders plus one
+ ros_elo = 2.0_dp
+!~~~> y_stage_i ~ y( t + h*alpha_i)
+ ros_alpha(1) = 0.0_dp
+ ros_alpha(2) = 1.0_dp
+!~~~> gamma_i = \sum_j gamma_{i,j}
+ ros_gamma(1) = g
+ ros_gamma(2) =- g
+
+ END SUBROUTINE ros2
+
+
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ SUBROUTINE ros3
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+! --- AN L-STABLE METHOD,3 stages,order 3,2 function evaluations
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+ rosmethod = rs3
+!~~~> name of the method
+ ros_Name = 'ROS-3'
+!~~~> number of stages
+ ros_s = 3
+
+!~~~> the coefficient matrices a and c are strictly lower triangular.
+! The lower triangular (subdiagonal) elements are stored in row-wise order:
+! A(2,1) = ros_A(1),A(3,1) =ros_A(2),A(3,2) =ros_A(3),etc.
+! The general mapping formula is:
+! A(i,j) = ros_A( (i-1)*(i-2)/2 + j)
+! C(i,j) = ros_C( (i-1)*(i-2)/2 + j)
+
+ ros_a(1) = 1.0_dp
+ ros_a(2) = 1.0_dp
+ ros_a(3) = 0.0_dp
+
+ ros_c(1) = - 0.10156171083877702091975600115545e+01_dp
+ ros_c(2) = 0.40759956452537699824805835358067e+01_dp
+ ros_c(3) = 0.92076794298330791242156818474003e+01_dp
+!~~~> does the stage i require a new FUNCTION evaluation (ros_newf(i) =true)
+! or does it re-use the function evaluation from stage i-1 (ros_NewF(i) =FALSE)
+ ros_newf(1) = .true.
+ ros_newf(2) = .true.
+ ros_newf(3) = .false.
+!~~~> m_i = coefficients for new step solution
+ ros_m(1) = 0.1e+01_dp
+ ros_m(2) = 0.61697947043828245592553615689730e+01_dp
+ ros_m(3) = - 0.42772256543218573326238373806514_dp
+! E_i = Coefficients for error estimator
+ ros_e(1) = 0.5_dp
+ ros_e(2) = - 0.29079558716805469821718236208017e+01_dp
+ ros_e(3) = 0.22354069897811569627360909276199_dp
+!~~~> ros_elo = estimator of local order - the minimum between the
+! main and the embedded scheme orders plus 1
+ ros_elo = 3.0_dp
+!~~~> y_stage_i ~ y( t + h*alpha_i)
+ ros_alpha(1) = 0.0_dp
+ ros_alpha(2) = 0.43586652150845899941601945119356_dp
+ ros_alpha(3) = 0.43586652150845899941601945119356_dp
+!~~~> gamma_i = \sum_j gamma_{i,j}
+ ros_gamma(1) = 0.43586652150845899941601945119356_dp
+ ros_gamma(2) = 0.24291996454816804366592249683314_dp
+ ros_gamma(3) = 0.21851380027664058511513169485832e+01_dp
+
+ END SUBROUTINE ros3
+
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ SUBROUTINE ros4
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+! L-STABLE ROSENBROCK METHOD OF ORDER 4,WITH 4 STAGES
+! L-STABLE EMBEDDED ROSENBROCK METHOD OF ORDER 3
+!
+! E. HAIRER AND G. WANNER,SOLVING ORDINARY DIFFERENTIAL
+! EQUATIONS II. STIFF AND DIFFERENTIAL-ALGEBRAIC PROBLEMS.
+! SPRINGER SERIES IN COMPUTATIONAL MATHEMATICS,
+! SPRINGER-VERLAG (1990)
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+ rosmethod = rs4
+!~~~> name of the method
+ ros_Name = 'ROS-4'
+!~~~> number of stages
+ ros_s = 4
+
+!~~~> the coefficient matrices a and c are strictly lower triangular.
+! The lower triangular (subdiagonal) elements are stored in row-wise order:
+! A(2,1) = ros_A(1),A(3,1) =ros_A(2),A(3,2) =ros_A(3),etc.
+! The general mapping formula is:
+! A(i,j) = ros_A( (i-1)*(i-2)/2 + j)
+! C(i,j) = ros_C( (i-1)*(i-2)/2 + j)
+
+ ros_a(1) = 0.2000000000000000e+01_dp
+ ros_a(2) = 0.1867943637803922e+01_dp
+ ros_a(3) = 0.2344449711399156_dp
+ ros_a(4) = ros_a(2)
+ ros_a(5) = ros_a(3)
+ ros_a(6) = 0.0_dp
+
+ ros_c(1) =- 0.7137615036412310e+01_dp
+ ros_c(2) = 0.2580708087951457e+01_dp
+ ros_c(3) = 0.6515950076447975_dp
+ ros_c(4) =- 0.2137148994382534e+01_dp
+ ros_c(5) =- 0.3214669691237626_dp
+ ros_c(6) =- 0.6949742501781779_dp
+!~~~> does the stage i require a new FUNCTION evaluation (ros_newf(i) =true)
+! or does it re-use the function evaluation from stage i-1 (ros_NewF(i) =FALSE)
+ ros_newf(1) = .true.
+ ros_newf(2) = .true.
+ ros_newf(3) = .true.
+ ros_newf(4) = .false.
+!~~~> m_i = coefficients for new step solution
+ ros_m(1) = 0.2255570073418735e+01_dp
+ ros_m(2) = 0.2870493262186792_dp
+ ros_m(3) = 0.4353179431840180_dp
+ ros_m(4) = 0.1093502252409163e+01_dp
+!~~~> e_i = coefficients for error estimator
+ ros_e(1) =- 0.2815431932141155_dp
+ ros_e(2) =- 0.7276199124938920e-01_dp
+ ros_e(3) =- 0.1082196201495311_dp
+ ros_e(4) =- 0.1093502252409163e+01_dp
+!~~~> ros_elo = estimator of local order - the minimum between the
+! main and the embedded scheme orders plus 1
+ ros_elo = 4.0_dp
+!~~~> y_stage_i ~ y( t + h*alpha_i)
+ ros_alpha(1) = 0.0_dp
+ ros_alpha(2) = 0.1145640000000000e+01_dp
+ ros_alpha(3) = 0.6552168638155900_dp
+ ros_alpha(4) = ros_alpha(3)
+!~~~> gamma_i = \sum_j gamma_{i,j}
+ ros_gamma(1) = 0.5728200000000000_dp
+ ros_gamma(2) =- 0.1769193891319233e+01_dp
+ ros_gamma(3) = 0.7592633437920482_dp
+ ros_gamma(4) =- 0.1049021087100450_dp
+
+ END SUBROUTINE ros4
+
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ SUBROUTINE rodas3
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+! --- A STIFFLY-STABLE METHOD,4 stages,order 3
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+ rosmethod = rd3
+!~~~> name of the method
+ ros_Name = 'RODAS-3'
+!~~~> number of stages
+ ros_s = 4
+
+!~~~> the coefficient matrices a and c are strictly lower triangular.
+! The lower triangular (subdiagonal) elements are stored in row-wise order:
+! A(2,1) = ros_A(1),A(3,1) =ros_A(2),A(3,2) =ros_A(3),etc.
+! The general mapping formula is:
+! A(i,j) = ros_A( (i-1)*(i-2)/2 + j)
+! C(i,j) = ros_C( (i-1)*(i-2)/2 + j)
+
+ ros_a(1) = 0.0_dp
+ ros_a(2) = 2.0_dp
+ ros_a(3) = 0.0_dp
+ ros_a(4) = 2.0_dp
+ ros_a(5) = 0.0_dp
+ ros_a(6) = 1.0_dp
+
+ ros_c(1) = 4.0_dp
+ ros_c(2) = 1.0_dp
+ ros_c(3) =- 1.0_dp
+ ros_c(4) = 1.0_dp
+ ros_c(5) =- 1.0_dp
+ ros_c(6) =- (8.0_dp/3.0_dp)
+
+!~~~> does the stage i require a new FUNCTION evaluation (ros_newf(i) =true)
+! or does it re-use the function evaluation from stage i-1 (ros_NewF(i) =FALSE)
+ ros_newf(1) = .true.
+ ros_newf(2) = .false.
+ ros_newf(3) = .true.
+ ros_newf(4) = .true.
+!~~~> m_i = coefficients for new step solution
+ ros_m(1) = 2.0_dp
+ ros_m(2) = 0.0_dp
+ ros_m(3) = 1.0_dp
+ ros_m(4) = 1.0_dp
+!~~~> e_i = coefficients for error estimator
+ ros_e(1) = 0.0_dp
+ ros_e(2) = 0.0_dp
+ ros_e(3) = 0.0_dp
+ ros_e(4) = 1.0_dp
+!~~~> ros_elo = estimator of local order - the minimum between the
+! main and the embedded scheme orders plus 1
+ ros_elo = 3.0_dp
+!~~~> y_stage_i ~ y( t + h*alpha_i)
+ ros_alpha(1) = 0.0_dp
+ ros_alpha(2) = 0.0_dp
+ ros_alpha(3) = 1.0_dp
+ ros_alpha(4) = 1.0_dp
+!~~~> gamma_i = \sum_j gamma_{i,j}
+ ros_gamma(1) = 0.5_dp
+ ros_gamma(2) = 1.5_dp
+ ros_gamma(3) = 0.0_dp
+ ros_gamma(4) = 0.0_dp
+
+ END SUBROUTINE rodas3
+
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ SUBROUTINE rodas4
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+! STIFFLY-STABLE ROSENBROCK METHOD OF ORDER 4,WITH 6 STAGES
+!
+! E. HAIRER AND G. WANNER,SOLVING ORDINARY DIFFERENTIAL
+! EQUATIONS II. STIFF AND DIFFERENTIAL-ALGEBRAIC PROBLEMS.
+! SPRINGER SERIES IN COMPUTATIONAL MATHEMATICS,
+! SPRINGER-VERLAG (1996)
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+ rosmethod = rd4
+!~~~> name of the method
+ ros_Name = 'RODAS-4'
+!~~~> number of stages
+ ros_s = 6
+
+!~~~> y_stage_i ~ y( t + h*alpha_i)
+ ros_alpha(1) = 0.000_dp
+ ros_alpha(2) = 0.386_dp
+ ros_alpha(3) = 0.210_dp
+ ros_alpha(4) = 0.630_dp
+ ros_alpha(5) = 1.000_dp
+ ros_alpha(6) = 1.000_dp
+
+!~~~> gamma_i = \sum_j gamma_{i,j}
+ ros_gamma(1) = 0.2500000000000000_dp
+ ros_gamma(2) =- 0.1043000000000000_dp
+ ros_gamma(3) = 0.1035000000000000_dp
+ ros_gamma(4) =- 0.3620000000000023e-01_dp
+ ros_gamma(5) = 0.0_dp
+ ros_gamma(6) = 0.0_dp
+
+!~~~> the coefficient matrices a and c are strictly lower triangular.
+! The lower triangular (subdiagonal) elements are stored in row-wise order:
+! A(2,1) = ros_A(1),A(3,1) =ros_A(2),A(3,2) =ros_A(3),etc.
+! The general mapping formula is: A(i,j) = ros_A( (i-1)*(i-2)/2 + j)
+! C(i,j) = ros_C( (i-1)*(i-2)/2 + j)
+
+ ros_a(1) = 0.1544000000000000e+01_dp
+ ros_a(2) = 0.9466785280815826_dp
+ ros_a(3) = 0.2557011698983284_dp
+ ros_a(4) = 0.3314825187068521e+01_dp
+ ros_a(5) = 0.2896124015972201e+01_dp
+ ros_a(6) = 0.9986419139977817_dp
+ ros_a(7) = 0.1221224509226641e+01_dp
+ ros_a(8) = 0.6019134481288629e+01_dp
+ ros_a(9) = 0.1253708332932087e+02_dp
+ ros_a(10) =- 0.6878860361058950_dp
+ ros_a(11) = ros_a(7)
+ ros_a(12) = ros_a(8)
+ ros_a(13) = ros_a(9)
+ ros_a(14) = ros_a(10)
+ ros_a(15) = 1.0_dp
+
+ ros_c(1) =- 0.5668800000000000e+01_dp
+ ros_c(2) =- 0.2430093356833875e+01_dp
+ ros_c(3) =- 0.2063599157091915_dp
+ ros_c(4) =- 0.1073529058151375_dp
+ ros_c(5) =- 0.9594562251023355e+01_dp
+ ros_c(6) =- 0.2047028614809616e+02_dp
+ ros_c(7) = 0.7496443313967647e+01_dp
+ ros_c(8) =- 0.1024680431464352e+02_dp
+ ros_c(9) =- 0.3399990352819905e+02_dp
+ ros_c(10) = 0.1170890893206160e+02_dp
+ ros_c(11) = 0.8083246795921522e+01_dp
+ ros_c(12) =- 0.7981132988064893e+01_dp
+ ros_c(13) =- 0.3152159432874371e+02_dp
+ ros_c(14) = 0.1631930543123136e+02_dp
+ ros_c(15) =- 0.6058818238834054e+01_dp
+
+!~~~> m_i = coefficients for new step solution
+ ros_m(1) = ros_a(7)
+ ros_m(2) = ros_a(8)
+ ros_m(3) = ros_a(9)
+ ros_m(4) = ros_a(10)
+ ros_m(5) = 1.0_dp
+ ros_m(6) = 1.0_dp
+
+!~~~> e_i = coefficients for error estimator
+ ros_e(1) = 0.0_dp
+ ros_e(2) = 0.0_dp
+ ros_e(3) = 0.0_dp
+ ros_e(4) = 0.0_dp
+ ros_e(5) = 0.0_dp
+ ros_e(6) = 1.0_dp
+
+!~~~> does the stage i require a new FUNCTION evaluation (ros_newf(i) =true)
+! or does it re-use the function evaluation from stage i-1 (ros_NewF(i) =FALSE)
+ ros_newf(1) = .true.
+ ros_newf(2) = .true.
+ ros_newf(3) = .true.
+ ros_newf(4) = .true.
+ ros_newf(5) = .true.
+ ros_newf(6) = .true.
+
+!~~~> ros_elo = estimator of local order - the minimum between the
+! main and the embedded scheme orders plus 1
+ ros_elo = 4.0_dp
+
+ END SUBROUTINE rodas4
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ SUBROUTINE rang3
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+! STIFFLY-STABLE W METHOD OF ORDER 3,WITH 4 STAGES
+!
+! J. RANG and L. ANGERMANN
+! NEW ROSENBROCK W-METHODS OF ORDER 3
+! FOR PARTIAL DIFFERENTIAL ALGEBRAIC
+! EQUATIONS OF INDEX 1
+! BIT Numerical Mathematics (2005) 45: 761-787
+! DOI: 10.1007/s10543-005-0035-y
+! Table 4.1-4.2
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+ rosmethod = rg3
+!~~~> name of the method
+ ros_Name = 'RANG-3'
+!~~~> number of stages
+ ros_s = 4
+
+ ros_a(1) = 5.09052051067020d+00;
+ ros_a(2) = 5.09052051067020d+00;
+ ros_a(3) = 0.0d0;
+ ros_a(4) = 4.97628111010787d+00;
+ ros_a(5) = 2.77268164715849d-02;
+ ros_a(6) = 2.29428036027904d-01;
+
+ ros_c(1) = - 1.16790812312283d+01;
+ ros_c(2) = - 1.64057326467367d+01;
+ ros_c(3) = - 2.77268164715850d-01;
+ ros_c(4) = - 8.38103960500476d+00;
+ ros_c(5) = - 8.48328409199343d-01;
+ ros_c(6) = 2.87009860433106d-01;
+
+ ros_m(1) = 5.22582761233094d+00;
+ ros_m(2) = - 5.56971148154165d-01;
+ ros_m(3) = 3.57979469353645d-01;
+ ros_m(4) = 1.72337398521064d+00;
+
+ ros_e(1) = - 5.16845212784040d+00;
+ ros_e(2) = - 1.26351942603842d+00;
+ ros_e(3) = - 1.11022302462516d-16;
+ ros_e(4) = 2.22044604925031d-16;
+
+ ros_alpha(1) = 0.0d00;
+ ros_alpha(2) = 2.21878746765329d+00;
+ ros_alpha(3) = 2.21878746765329d+00;
+ ros_alpha(4) = 1.55392337535788d+00;
+
+ ros_gamma(1) = 4.35866521508459d-01;
+ ros_gamma(2) = - 1.78292094614483d+00;
+ ros_gamma(3) = - 2.46541900496934d+00;
+ ros_gamma(4) = - 8.05529997906370d-01;
+
+
+!~~~> does the stage i require a new FUNCTION evaluation (ros_newf(i) =true)
+! or does it re-use the function evaluation from stage i-1 (ros_NewF(i) =FALSE)
+ ros_newf(1) = .true.
+ ros_newf(2) = .true.
+ ros_newf(3) = .true.
+ ros_newf(4) = .true.
+
+!~~~> ros_elo = estimator of local order - the minimum between the
+! main and the embedded scheme orders plus 1
+ ros_elo = 3.0_dp
+
+ END SUBROUTINE rang3
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+! End of the set of internal Rosenbrock subroutines
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+END SUBROUTINE rosenbrock
+
+SUBROUTINE funtemplate( t,y,ydot)
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+! Template for the ODE function call.
+! Updates the rate coefficients (and possibly the fixed species) at each call
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!~~~> input variables
+ REAL(kind=dp):: t,y(nvar)
+!~~~> output variables
+ REAL(kind=dp):: ydot(nvar)
+!~~~> local variables
+ REAL(kind=dp):: told
+
+ told = time
+ time = t
+ CALL fun( y,fix,rconst,ydot)
+ time = told
+
+END SUBROUTINE funtemplate
+
+SUBROUTINE jactemplate( t,y,jcb)
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+! Template for the ODE Jacobian call.
+! Updates the rate coefficients (and possibly the fixed species) at each call
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!~~~> input variables
+ REAL(kind=dp):: t,y(nvar)
+!~~~> output variables
+#ifdef full_algebra
+ REAL(kind=dp):: jv(lu_nonzero),jcb(nvar,nvar)
+#else
+ REAL(kind=dp):: jcb(lu_nonzero)
+#endif
+!~~~> local variables
+ REAL(kind=dp):: told
+#ifdef full_algebra
+ INTEGER :: i,j
+#endif
+
+ told = time
+ time = t
+#ifdef full_algebra
+ CALL jac_sp(y,fix,rconst,jv)
+ DO j=1,nvar
+ DO i=1,nvar
+ jcb(i,j) = 0.0_dp
+ ENDDO
+ ENDDO
+ DO i=1,lu_nonzero
+ jcb(lu_irow(i),lu_icol(i)) = jv(i)
+ ENDDO
+#else
+ CALL jac_sp( y,fix,rconst,jcb)
+#endif
+ time = told
+
+END SUBROUTINE jactemplate
+
+SUBROUTINE chem_gasphase_integrate (time_step_len,conc,tempk,photo,ierrf,xnacc,xnrej,istatus,l_debug,pe)
+
+ IMPLICIT NONE
+
+ REAL(dp), INTENT(IN) :: time_step_len
+ REAL(dp), DIMENSION(:,:), INTENT(INOUT) :: conc
+ REAL(dp), DIMENSION(:,:), INTENT(INOUT) :: photo
+ REAL(dp), DIMENSION(:), INTENT(IN) :: tempk
+ INTEGER, INTENT(OUT), OPTIONAL :: ierrf(:)
+ INTEGER, INTENT(OUT), OPTIONAL :: xnacc(:)
+ INTEGER, INTENT(OUT), OPTIONAL :: xnrej(:)
+ INTEGER, INTENT(INOUT), OPTIONAL :: istatus(:)
+ INTEGER, INTENT(IN), OPTIONAL :: pe
+ LOGICAL, INTENT(IN), OPTIONAL :: l_debug
+
+ INTEGER :: k ! loop variable
+ REAL(dp) :: dt
+ INTEGER, DIMENSION(20) :: istatus_u
+ INTEGER :: ierr_u
+
+
+ if (present (istatus)) istatus = 0
+
+ DO k=1,vl_glo,vl_dim
+ is = k
+ ie = min(k+vl_dim-1,vl_glo)
+ vl = ie-is+1
+
+ c(:) = conc(is,:)
+
+ temp = tempk(is)
+
+ phot(:) = photo(is,:)
+
+ CALL update_rconst
+
+ dt = time_step_len
+
+ ! integrate from t=0 to t=dt
+ CALL integrate(0._dp, dt,icntrl,rcntrl,istatus_u = istatus_u,ierr_u=ierr_u)
+
+
+ IF (PRESENT(l_debug) .AND. PRESENT(pe)) THEN
+ IF (l_debug) CALL error_output(conc(is,:),ierr_u,pe)
+ ENDIF
+ conc(is,:) = c(:)
+
+ ! Return Diagnostic Information
+
+ if(PRESENT(ierrf)) ierrf(is) = ierr_u
+ if(PRESENT(xnacc)) xnacc(is) = istatus_u(4)
+ if(PRESENT(xnrej)) xnrej(is) = istatus_u(5)
+
+ if (PRESENT (istatus)) then
+ istatus(1:8) = istatus(1:8) + istatus_u(1:8)
+ ENDIF
+
+ END DO
+
+
+! Deallocate input arrays
+
+ if (ALLOCATED(temp)) DEALLOCATE(temp)
+
+ data_loaded = .false.
+
+ RETURN
+END SUBROUTINE chem_gasphase_integrate
+
+ SUBROUTINE fill_temp(status,array)
+
+ INTEGER, INTENT(OUT) :: status
+ REAL(dp), INTENT(IN), DIMENSION(:) :: array
+
+ status = 0
+ IF (.not. ALLOCATED(temp)) &
+ ALLOCATE(temp(size(array)))
+
+ IF (data_loaded .AND. (vl_glo /= size(array,1))) THEN
+ status = 1
+ RETURN
+ END IF
+
+ vl_glo = size(array,1)
+ temp = array
+ data_loaded = .TRUE.
+
+ RETURN
+
+ END SUBROUTINE fill_temp
+
+END MODULE chem_gasphase_mod
+
Index: palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_salsa+phstat/chem_gasphase_mod.kpp
===================================================================
--- palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_salsa+phstat/chem_gasphase_mod.kpp (revision 3582)
+++ palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_salsa+phstat/chem_gasphase_mod.kpp (revision 3582)
@@ -0,0 +1,42 @@
+//chem_gasphase_mod.kpp
+//
+//Former revisions
+//----------------
+// $Id: chem_gasphase_mod.kpp 2459 2017-09-13 14:10:33Z forkel $
+//
+#include phstat.spc
+#include phstat.eqn
+#INTEGRATOR rosenbrock
+#LANGUAGE Fortran90
+#HESSIAN on
+#STOICMAT on
+#INLINE F90_GLOBAL
+! QVAP - Water vapor
+! REAL(dp),dimension(:),allocatable :: qvap
+ REAL(dp) :: qvap
+! FAKT - Conversion factor
+! REAL(dp),dimension(:),allocatable :: fakt
+ REAL(dp) :: fakt
+
+ ! Declaration of global variable declarations for photolysis will come from INLINE F90_DATA
+#ENDINLINE
+//
+// *******************************************************************************************
+// *** adapt the lines below occurding to the photolysis reactions of your mechanism *
+// *** adapt the number of photolysis frequencies NPHO *
+// *** adapt/extend the indices in the INTEGER, PARAMETER,PUBLIC statement below *
+// *** adapt/extend PHOT_NAMES: Note that the order of PHOT_NAMES and the indices must match *
+// *******************************************************************************************
+//
+#INLINE F90_DATA
+ ! INLINE F90_DATA: Declaration of global variables for photolysis
+ ! REAL(kind=dp) :: phot(nphot) must eventually be moved to GLOBAL later for vector version
+ INTEGER, PARAMETER :: nphot = 1
+ ! phot Photolysis frequencies
+ REAL(kind=dp) :: phot(nphot)
+
+ INTEGER, PARAMETER,PUBLIC :: j_no2 = 1
+
+ CHARACTER(LEN=15), PARAMETER, DIMENSION(NPHOT) :: phot_names = (/ &
+ 'J_NO2 '/)
+#ENDINLINE
Index: palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_salsa+phstat/phstat.eqn
===================================================================
--- palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_salsa+phstat/phstat.eqn (revision 3582)
+++ palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_salsa+phstat/phstat.eqn (revision 3582)
@@ -0,0 +1,9 @@
+{phstat.eqn
+Current revision
+----------------
+ 20180319 Photostationary O3-NO-NO2-equilibrium forkel
+}
+#EQUATIONS
+
+ { 1.} NO2 + hv = NO + O3 : phot(j_no2) ;
+ { 3.} NO + O3 = NO2 : arr2(1.8E-12_dp, 1370.0_dp, temp) ;
Index: palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_salsa+phstat/phstat.spc
===================================================================
--- palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_salsa+phstat/phstat.spc (revision 3582)
+++ palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_salsa+phstat/phstat.spc (revision 3582)
@@ -0,0 +1,19 @@
+{phstat.spc
+Former revisions
+----------------
+ $Id: smog.spc 2459 2017-09-13 14:10:33Z forkel $
+}
+#include atoms
+
+ #DEFVAR
+ O = O ; {oxygen atomic ground state (3P)}
+ O3 = 3O ; {ozone}
+ NO = N + O ; {nitric oxide}
+ NO2 = N + 2O ; {nitrogen dioxide}
+
+#DEFFIX
+ H2O = H + 2O ; {water}
+ H2 = 2H ; {molecular hydrogen}
+ O2 = 2O ; {molecular oxygen}
+ N2 = 2N ; {molecular nitrogen}
+
Index: palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_salsa+simple/chem_gasphase_mod.f90
===================================================================
--- palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_salsa+simple/chem_gasphase_mod.f90 (revision 3582)
+++ palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_salsa+simple/chem_gasphase_mod.f90 (revision 3582)
@@ -0,0 +1,2628 @@
+MODULE chem_gasphase_mod
+
+!------------------------------------------------------------------------------!
+!
+! ******Module chem_gasphase_mod is automatically generated by kpp4palm ******
+!
+! *********Please do NOT change this Code *********
+!
+!------------------------------------------------------------------------------!
+! This file is part of the PALM model system.
+!
+! PALM is free software: you can redistribute it and/or modify it under the
+! terms of the GNU General Public License as published by the Free Software
+! Foundation,either version 3 of the License,or (at your option) any later
+! version.
+!
+! PALM is distributed in the hope that it will be useful,but WITHOUT ANY
+! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
+! A PARTICULAR PURPOSE. See the GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along with
+! PALM. If not,see .
+!
+! Copyright 1997-2018 Leibniz Universitaet Hannover
+!--------------------------------------------------------------------------------!
+!
+! Current revisions:
+! ------------------
+!
+!
+! Former revisions:
+! -----------------
+! $Id: module_header 2460 2017-09-13 14:47:48Z forkel $
+!
+!
+! Variables for photolyis added
+!
+!
+!
+!
+!
+! Nov. 2016: Intial version (Klaus Ketelsen)
+!
+!------------------------------------------------------------------------------!
+!
+
+
+! Set kpp Double Precision to PALM Default Precision
+
+ USE kinds, ONLY: dp=>wp
+
+ USE pegrid, ONLY: myid,threads_per_task
+
+ IMPLICIT NONE
+ PRIVATE
+ !SAVE ! NOTE: OCCURS AGAIN IN AUTOMATICALLY GENERATED CODE ...
+
+! PUBLIC :: IERR_NAMES
+
+! PUBLIC :: SPC_NAMES,EQN_NAMES,EQN_TAGS,REQ_HET,REQ_AEROSOL,REQ_PHOTRAT &
+! ,REQ_MCFCT,IP_MAX,jname
+
+ PUBLIC :: eqn_names, phot_names,spc_names
+ PUBLIC :: nmaxfixsteps
+ PUBLIC :: atol,rtol
+ PUBLIC :: nspec,nreact
+ PUBLIC :: temp
+ PUBLIC :: phot
+ PUBLIC :: rconst
+ PUBLIC :: nvar
+ PUBLIC :: nphot
+
+ PUBLIC :: initialize,integrate,update_rconst
+ PUBLIC :: chem_gasphase_integrate
+ PUBLIC :: initialize_kpp_ctrl
+
+! END OF MODULE HEADER TEMPLATE
+
+! Variables used for vector mode
+
+ LOGICAL, PARAMETER :: l_vector = .FALSE.
+ INTEGER, PARAMETER :: i_lu_di = 0
+ INTEGER, PARAMETER :: vl_dim = 1
+ INTEGER :: vl
+
+ INTEGER :: vl_glo
+ INTEGER :: is,ie
+
+ INTEGER, DIMENSION(vl_dim) :: kacc,krej
+ INTEGER, DIMENSION(vl_dim) :: ierrv
+ LOGICAL :: data_loaded = .false.
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+! Parameter Module File
+!
+! Generated by KPP-2.2.3 symbolic chemistry Kinetics PreProcessor
+! (http://www.cs.vt.edu/~asandu/Software/KPP)
+! KPP is distributed under GPL,the general public licence
+! (http://www.gnu.org/copyleft/gpl.html)
+! (C) 1995-1997,V. Damian & A. Sandu,CGRER,Univ. Iowa
+! (C) 1997-2005,A. Sandu,Michigan Tech,Virginia Tech
+! With important contributions from:
+! M. Damian,Villanova University,USA
+! R. Sander,Max-Planck Institute for Chemistry,Mainz,Germany
+!
+! File : chem_gasphase_mod_Parameters.f90
+! Time : Mon Sep 3 10:04:24 2018
+! Working directory : /home/monakurp/palm/branches/salsa/UTIL/chemistry/gasphase_preproc/tmp_kpp4palm
+! Equation file : chem_gasphase_mod.kpp
+! Output root filename : chem_gasphase_mod
+!
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+
+
+
+
+! NSPEC - Number of chemical species
+ INTEGER,PARAMETER :: nspec = 15
+! NVAR - Number of Variable species
+ INTEGER,PARAMETER :: nvar = 13
+! NVARACT - Number of Active species
+ INTEGER,PARAMETER :: nvaract = 11
+! NFIX - Number of Fixed species
+ INTEGER,PARAMETER :: nfix = 2
+! NREACT - Number of reactions
+ INTEGER,PARAMETER :: nreact = 11
+! NVARST - Starting of variables in conc. vect.
+ INTEGER,PARAMETER :: nvarst = 1
+! NFIXST - Starting of fixed in conc. vect.
+ INTEGER,PARAMETER :: nfixst = 14
+! NONZERO - Number of nonzero entries in Jacobian
+ INTEGER,PARAMETER :: nonzero = 39
+! LU_NONZERO - Number of nonzero entries in LU factoriz. of Jacobian
+ INTEGER,PARAMETER :: lu_nonzero = 41
+! CNVAR - (NVAR+1) Number of elements in compressed row format
+ INTEGER,PARAMETER :: cnvar = 14
+! CNEQN - (NREACT+1) Number stoicm elements in compressed col format
+ INTEGER,PARAMETER :: cneqn = 12
+! NHESS - Length of Sparse Hessian
+ INTEGER,PARAMETER :: nhess = 18
+! NLOOKAT - Number of species to look at
+ INTEGER,PARAMETER :: nlookat = 0
+! NMONITOR - Number of species to monitor
+ INTEGER,PARAMETER :: nmonitor = 0
+! NMASS - Number of atoms to check mass balance
+ INTEGER,PARAMETER :: nmass = 1
+
+! Index declaration for variable species in C and VAR
+! VAR(ind_spc) = C(ind_spc)
+
+ INTEGER,PARAMETER,PUBLIC :: ind_h2so4 = 1
+ INTEGER,PARAMETER,PUBLIC :: ind_nh3 = 2
+ INTEGER,PARAMETER,PUBLIC :: ind_ocnv = 3
+ INTEGER,PARAMETER,PUBLIC :: ind_ocsv = 4
+ INTEGER,PARAMETER,PUBLIC :: ind_hno3 = 5
+ INTEGER,PARAMETER,PUBLIC :: ind_rcho = 6
+ INTEGER,PARAMETER,PUBLIC :: ind_rh = 7
+ INTEGER,PARAMETER,PUBLIC :: ind_o3 = 8
+ INTEGER,PARAMETER,PUBLIC :: ind_oh = 9
+ INTEGER,PARAMETER,PUBLIC :: ind_no2 = 10
+ INTEGER,PARAMETER,PUBLIC :: ind_no = 11
+ INTEGER,PARAMETER,PUBLIC :: ind_ho2 = 12
+ INTEGER,PARAMETER,PUBLIC :: ind_ro2 = 13
+
+! Index declaration for fixed species in C
+! C(ind_spc)
+
+ INTEGER,PARAMETER,PUBLIC :: ind_h2o = 14
+ INTEGER,PARAMETER,PUBLIC :: ind_o2 = 15
+
+! Index declaration for fixed species in FIX
+! FIX(indf_spc) = C(ind_spc) = C(NVAR+indf_spc)
+
+ INTEGER,PARAMETER :: indf_h2o = 1
+ INTEGER,PARAMETER :: indf_o2 = 2
+
+! NJVRP - Length of sparse Jacobian JVRP
+ INTEGER,PARAMETER :: njvrp = 16
+
+! NSTOICM - Length of Sparse Stoichiometric Matrix
+ INTEGER,PARAMETER :: nstoicm = 23
+
+
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+! Global Data Module File
+!
+! Generated by KPP-2.2.3 symbolic chemistry Kinetics PreProcessor
+! (http://www.cs.vt.edu/~asandu/Software/KPP)
+! KPP is distributed under GPL,the general public licence
+! (http://www.gnu.org/copyleft/gpl.html)
+! (C) 1995-1997,V. Damian & A. Sandu,CGRER,Univ. Iowa
+! (C) 1997-2005,A. Sandu,Michigan Tech,Virginia Tech
+! With important contributions from:
+! M. Damian,Villanova University,USA
+! R. Sander,Max-Planck Institute for Chemistry,Mainz,Germany
+!
+! File : chem_gasphase_mod_Global.f90
+! Time : Mon Sep 3 10:04:24 2018
+! Working directory : /home/monakurp/palm/branches/salsa/UTIL/chemistry/gasphase_preproc/tmp_kpp4palm
+! Equation file : chem_gasphase_mod.kpp
+! Output root filename : chem_gasphase_mod
+!
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+
+
+
+
+! Declaration of global variables
+
+! C - Concentration of all species
+ REAL(kind=dp):: c(nspec)
+! VAR - Concentrations of variable species (global)
+ REAL(kind=dp):: var(nvar)
+! FIX - Concentrations of fixed species (global)
+ REAL(kind=dp):: fix(nfix)
+! VAR,FIX are chunks of array C
+ equivalence( c(1),var(1))
+ equivalence( c(14),fix(1))
+! RCONST - Rate constants (global)
+ REAL(kind=dp):: rconst(nreact)
+! TIME - Current integration time
+ REAL(kind=dp):: time
+! SUN - Sunlight intensity between [0,1]
+ REAL(kind=dp):: sun
+! TEMP - Temperature
+ REAL(dp),dimension(:),allocatable :: temp
+! RTOLS - (scalar) Relative tolerance
+ REAL(kind=dp):: rtols
+! TSTART - Integration start time
+ REAL(kind=dp):: tstart
+! TEND - Integration end time
+ REAL(kind=dp):: tend
+! DT - Integration step
+ REAL(kind=dp):: dt
+! ATOL - Absolute tolerance
+ REAL(kind=dp):: atol(nvar)
+! RTOL - Relative tolerance
+ REAL(kind=dp):: rtol(nvar)
+! STEPMIN - Lower bound for integration step
+ REAL(kind=dp):: stepmin
+! STEPMAX - Upper bound for integration step
+ REAL(kind=dp):: stepmax
+! CFACTOR - Conversion factor for concentration units
+ REAL(kind=dp):: cfactor
+! DDMTYPE - DDM sensitivity w.r.t.: 0=init.val.,1=params
+ INTEGER :: ddmtype
+
+! INLINED global variable declarations
+
+! QVAP - Water vapor
+ REAL(dp) :: qvap
+! FAKT - Conversion factor
+ REAL(dp) :: fakt
+! Declaration of global variable declarations for photolysis will come from IN
+
+! INLINED global variable declarations
+
+
+
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+! Sparse Jacobian Data Structures File
+!
+! Generated by KPP-2.2.3 symbolic chemistry Kinetics PreProcessor
+! (http://www.cs.vt.edu/~asandu/Software/KPP)
+! KPP is distributed under GPL,the general public licence
+! (http://www.gnu.org/copyleft/gpl.html)
+! (C) 1995-1997,V. Damian & A. Sandu,CGRER,Univ. Iowa
+! (C) 1997-2005,A. Sandu,Michigan Tech,Virginia Tech
+! With important contributions from:
+! M. Damian,Villanova University,USA
+! R. Sander,Max-Planck Institute for Chemistry,Mainz,Germany
+!
+! File : chem_gasphase_mod_JacobianSP.f90
+! Time : Mon Sep 3 10:04:24 2018
+! Working directory : /home/monakurp/palm/branches/salsa/UTIL/chemistry/gasphase_preproc/tmp_kpp4palm
+! Equation file : chem_gasphase_mod.kpp
+! Output root filename : chem_gasphase_mod
+!
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+
+
+
+
+! Sparse Jacobian Data
+
+
+ INTEGER,PARAMETER,DIMENSION(41):: lu_irow = (/ &
+ 1, 2, 3, 4, 5, 5, 5, 6, 6, 6, 7, 7,&
+ 8, 8, 8, 9, 9, 9, 9, 9, 9,10,10,10,&
+ 10,10,10,11,11,11,11,11,12,12,12,13,&
+ 13,13,13,13,13 /)
+
+ INTEGER,PARAMETER,DIMENSION(41):: lu_icol = (/ &
+ 1, 2, 3, 4, 5, 9,10, 6,11,13, 7, 9,&
+ 8,10,11, 7, 8, 9,10,11,12, 8, 9,10,&
+ 11,12,13, 8,10,11,12,13,11,12,13, 7,&
+ 9,10,11,12,13 /)
+
+ INTEGER,PARAMETER,DIMENSION(14):: lu_crow = (/ &
+ 1, 2, 3, 4, 5, 8,11,13,16,22,28,33,&
+ 36,42 /)
+
+ INTEGER,PARAMETER,DIMENSION(14):: lu_diag = (/ &
+ 1, 2, 3, 4, 5, 8,11,13,18,24,30,34,&
+ 41,42 /)
+
+
+
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+! Utility Data Module File
+!
+! Generated by KPP-2.2.3 symbolic chemistry Kinetics PreProcessor
+! (http://www.cs.vt.edu/~asandu/Software/KPP)
+! KPP is distributed under GPL,the general public licence
+! (http://www.gnu.org/copyleft/gpl.html)
+! (C) 1995-1997,V. Damian & A. Sandu,CGRER,Univ. Iowa
+! (C) 1997-2005,A. Sandu,Michigan Tech,Virginia Tech
+! With important contributions from:
+! M. Damian,Villanova University,USA
+! R. Sander,Max-Planck Institute for Chemistry,Mainz,Germany
+!
+! File : chem_gasphase_mod_Monitor.f90
+! Time : Mon Sep 3 10:04:24 2018
+! Working directory : /home/monakurp/palm/branches/salsa/UTIL/chemistry/gasphase_preproc/tmp_kpp4palm
+! Equation file : chem_gasphase_mod.kpp
+! Output root filename : chem_gasphase_mod
+!
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+
+
+
+ CHARACTER(len=15),PARAMETER,DIMENSION(15):: spc_names = (/ &
+ 'H2SO4 ','NH3 ','OCNV ',&
+ 'OCSV ','HNO3 ','RCHO ',&
+ 'RH ','O3 ','OH ',&
+ 'NO2 ','NO ','HO2 ',&
+ 'RO2 ','H2O ','O2 ' /)
+
+ INTEGER,DIMENSION(1):: lookat
+ INTEGER,DIMENSION(1):: monitor
+ CHARACTER(len=15),DIMENSION(1):: smass
+ CHARACTER(len=100),PARAMETER,DIMENSION(11):: eqn_names = (/ &
+ ' NO2 --> O3 + NO ',&
+ ' O3 --> 2 OH + O2 ',&
+ ' O3 + NO --> NO2 ',&
+ ' RH + OH --> RO2 + H2O ',&
+ 'NO + RO2 --> RCHO + NO2 + HO2 ',&
+ 'NO + HO2 --> OH + NO2 ',&
+ 'OH + NO2 --> HNO3 ',&
+ ' H2SO4 --> H2SO4 ',&
+ ' NH3 --> NH3 ',&
+ ' OCNV --> OCNV ',&
+ ' OCSV --> OCSV ' /)
+
+! INLINED global variables
+
+ ! inline f90_data: declaration of global variables for photolysis
+ ! REAL(kind=dp):: phot(nphot)must eventually be moved to global later for
+ INTEGER,PARAMETER :: nphot = 2
+ ! phot photolysis frequencies
+ REAL(kind=dp):: phot(nphot)
+
+ INTEGER,PARAMETER,PUBLIC :: j_no2 = 1
+ INTEGER,PARAMETER,PUBLIC :: j_o31d = 2
+
+ CHARACTER(len=15),PARAMETER,DIMENSION(nphot):: phot_names = (/ &
+ 'J_NO2 ','J_O31D '/)
+
+! End INLINED global variables
+
+
+! Automatic generated PUBLIC Statements for ip_ and ihs_ variables
+
+! Automatic generated PUBLIC Statements for ip_ and ihs_ variables
+
+! Automatic generated PUBLIC Statements for ip_ and ihs_ variables
+
+! Automatic generated PUBLIC Statements for ip_ and ihs_ variables
+
+
+! variable definations from individual module headers
+
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+! Initialization File
+!
+! Generated by KPP-2.2.3 symbolic chemistry Kinetics PreProcessor
+! (http://www.cs.vt.edu/~asandu/Software/KPP)
+! KPP is distributed under GPL,the general public licence
+! (http://www.gnu.org/copyleft/gpl.html)
+! (C) 1995-1997,V. Damian & A. Sandu,CGRER,Univ. Iowa
+! (C) 1997-2005,A. Sandu,Michigan Tech,Virginia Tech
+! With important contributions from:
+! M. Damian,Villanova University,USA
+! R. Sander,Max-Planck Institute for Chemistry,Mainz,Germany
+!
+! File : chem_gasphase_mod_Initialize.f90
+! Time : Mon Sep 3 10:04:24 2018
+! Working directory : /home/monakurp/palm/branches/salsa/UTIL/chemistry/gasphase_preproc/tmp_kpp4palm
+! Equation file : chem_gasphase_mod.kpp
+! Output root filename : chem_gasphase_mod
+!
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+
+
+
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+! Numerical Integrator (Time-Stepping) File
+!
+! Generated by KPP-2.2.3 symbolic chemistry Kinetics PreProcessor
+! (http://www.cs.vt.edu/~asandu/Software/KPP)
+! KPP is distributed under GPL,the general public licence
+! (http://www.gnu.org/copyleft/gpl.html)
+! (C) 1995-1997,V. Damian & A. Sandu,CGRER,Univ. Iowa
+! (C) 1997-2005,A. Sandu,Michigan Tech,Virginia Tech
+! With important contributions from:
+! M. Damian,Villanova University,USA
+! R. Sander,Max-Planck Institute for Chemistry,Mainz,Germany
+!
+! File : chem_gasphase_mod_Integrator.f90
+! Time : Mon Sep 3 10:04:24 2018
+! Working directory : /home/monakurp/palm/branches/salsa/UTIL/chemistry/gasphase_preproc/tmp_kpp4palm
+! Equation file : chem_gasphase_mod.kpp
+! Output root filename : chem_gasphase_mod
+!
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+! INTEGRATE - Integrator routine
+! Arguments :
+! TIN - Start Time for Integration
+! TOUT - End Time for Integration
+!
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~!
+! Rosenbrock - Implementation of several Rosenbrock methods: !
+! *Ros2 !
+! *Ros3 !
+! *Ros4 !
+! *Rodas3 !
+! *Rodas4 !
+! By default the code employs the KPP sparse linear algebra routines !
+! Compile with -DFULL_ALGEBRA to use full linear algebra (LAPACK) !
+! !
+! (C) Adrian Sandu,August 2004 !
+! Virginia Polytechnic Institute and State University !
+! Contact: sandu@cs.vt.edu !
+! Revised by Philipp Miehe and Adrian Sandu,May 2006 ! !
+! This implementation is part of KPP - the Kinetic PreProcessor !
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~!
+
+
+ SAVE
+
+!~~~> statistics on the work performed by the rosenbrock method
+ INTEGER,PARAMETER :: nfun=1,njac=2,nstp=3,nacc=4,&
+ nrej=5,ndec=6,nsol=7,nsng=8,&
+ ntexit=1,nhexit=2,nhnew = 3
+
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+! Linear Algebra Data and Routines File
+!
+! Generated by KPP-2.2.3 symbolic chemistry Kinetics PreProcessor
+! (http://www.cs.vt.edu/~asandu/Software/KPP)
+! KPP is distributed under GPL,the general public licence
+! (http://www.gnu.org/copyleft/gpl.html)
+! (C) 1995-1997,V. Damian & A. Sandu,CGRER,Univ. Iowa
+! (C) 1997-2005,A. Sandu,Michigan Tech,Virginia Tech
+! With important contributions from:
+! M. Damian,Villanova University,USA
+! R. Sander,Max-Planck Institute for Chemistry,Mainz,Germany
+!
+! File : chem_gasphase_mod_LinearAlgebra.f90
+! Time : Mon Sep 3 10:04:24 2018
+! Working directory : /home/monakurp/palm/branches/salsa/UTIL/chemistry/gasphase_preproc/tmp_kpp4palm
+! Equation file : chem_gasphase_mod.kpp
+! Output root filename : chem_gasphase_mod
+!
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+
+
+
+
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+! The ODE Jacobian of Chemical Model File
+!
+! Generated by KPP-2.2.3 symbolic chemistry Kinetics PreProcessor
+! (http://www.cs.vt.edu/~asandu/Software/KPP)
+! KPP is distributed under GPL,the general public licence
+! (http://www.gnu.org/copyleft/gpl.html)
+! (C) 1995-1997,V. Damian & A. Sandu,CGRER,Univ. Iowa
+! (C) 1997-2005,A. Sandu,Michigan Tech,Virginia Tech
+! With important contributions from:
+! M. Damian,Villanova University,USA
+! R. Sander,Max-Planck Institute for Chemistry,Mainz,Germany
+!
+! File : chem_gasphase_mod_Jacobian.f90
+! Time : Mon Sep 3 10:04:24 2018
+! Working directory : /home/monakurp/palm/branches/salsa/UTIL/chemistry/gasphase_preproc/tmp_kpp4palm
+! Equation file : chem_gasphase_mod.kpp
+! Output root filename : chem_gasphase_mod
+!
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+
+
+
+
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+! The ODE Function of Chemical Model File
+!
+! Generated by KPP-2.2.3 symbolic chemistry Kinetics PreProcessor
+! (http://www.cs.vt.edu/~asandu/Software/KPP)
+! KPP is distributed under GPL,the general public licence
+! (http://www.gnu.org/copyleft/gpl.html)
+! (C) 1995-1997,V. Damian & A. Sandu,CGRER,Univ. Iowa
+! (C) 1997-2005,A. Sandu,Michigan Tech,Virginia Tech
+! With important contributions from:
+! M. Damian,Villanova University,USA
+! R. Sander,Max-Planck Institute for Chemistry,Mainz,Germany
+!
+! File : chem_gasphase_mod_Function.f90
+! Time : Mon Sep 3 10:04:24 2018
+! Working directory : /home/monakurp/palm/branches/salsa/UTIL/chemistry/gasphase_preproc/tmp_kpp4palm
+! Equation file : chem_gasphase_mod.kpp
+! Output root filename : chem_gasphase_mod
+!
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+
+
+
+! A - Rate for each equation
+ REAL(kind=dp):: a(nreact)
+
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+! The Reaction Rates File
+!
+! Generated by KPP-2.2.3 symbolic chemistry Kinetics PreProcessor
+! (http://www.cs.vt.edu/~asandu/Software/KPP)
+! KPP is distributed under GPL,the general public licence
+! (http://www.gnu.org/copyleft/gpl.html)
+! (C) 1995-1997,V. Damian & A. Sandu,CGRER,Univ. Iowa
+! (C) 1997-2005,A. Sandu,Michigan Tech,Virginia Tech
+! With important contributions from:
+! M. Damian,Villanova University,USA
+! R. Sander,Max-Planck Institute for Chemistry,Mainz,Germany
+!
+! File : chem_gasphase_mod_Rates.f90
+! Time : Mon Sep 3 10:04:24 2018
+! Working directory : /home/monakurp/palm/branches/salsa/UTIL/chemistry/gasphase_preproc/tmp_kpp4palm
+! Equation file : chem_gasphase_mod.kpp
+! Output root filename : chem_gasphase_mod
+!
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+
+
+
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+! Auxiliary Routines File
+!
+! Generated by KPP-2.2.3 symbolic chemistry Kinetics PreProcessor
+! (http://www.cs.vt.edu/~asandu/Software/KPP)
+! KPP is distributed under GPL,the general public licence
+! (http://www.gnu.org/copyleft/gpl.html)
+! (C) 1995-1997,V. Damian & A. Sandu,CGRER,Univ. Iowa
+! (C) 1997-2005,A. Sandu,Michigan Tech,Virginia Tech
+! With important contributions from:
+! M. Damian,Villanova University,USA
+! R. Sander,Max-Planck Institute for Chemistry,Mainz,Germany
+!
+! File : chem_gasphase_mod_Util.f90
+! Time : Mon Sep 3 10:04:24 2018
+! Working directory : /home/monakurp/palm/branches/salsa/UTIL/chemistry/gasphase_preproc/tmp_kpp4palm
+! Equation file : chem_gasphase_mod.kpp
+! Output root filename : chem_gasphase_mod
+!
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+
+
+
+
+ ! header MODULE initialize_kpp_ctrl_template
+
+ ! notes:
+ ! - l_vector is automatically defined by kp4
+ ! - vl_dim is automatically defined by kp4
+ ! - i_lu_di is automatically defined by kp4
+ ! - wanted is automatically defined by xmecca
+ ! - icntrl rcntrl are automatically defined by kpp
+ ! - "USE messy_main_tools" is in MODULE_header of messy_mecca_kpp.f90
+ ! - SAVE will be automatically added by kp4
+
+ !SAVE
+
+ ! for fixed time step control
+ ! ... max. number of fixed time steps (sum must be 1)
+ INTEGER,PARAMETER :: nmaxfixsteps = 50
+ ! ... switch for fixed time stepping
+ LOGICAL,PUBLIC :: l_fixed_step = .false.
+ INTEGER,PUBLIC :: nfsteps = 1
+ ! ... number of kpp control PARAMETERs
+ INTEGER,PARAMETER,PUBLIC :: nkppctrl = 20
+ !
+ INTEGER, DIMENSION(nkppctrl),PUBLIC :: icntrl = 0
+ REAL(dp),DIMENSION(nkppctrl),PUBLIC :: rcntrl = 0.0_dp
+ REAL(dp),DIMENSION(nmaxfixsteps),PUBLIC :: t_steps = 0.0_dp
+
+ ! END header MODULE initialize_kpp_ctrl_template
+
+
+! Interface Block
+
+ INTERFACE initialize
+ MODULE PROCEDURE initialize
+ END INTERFACE initialize
+
+ INTERFACE integrate
+ MODULE PROCEDURE integrate
+ END INTERFACE integrate
+
+ INTERFACE fun
+ MODULE PROCEDURE fun
+ END INTERFACE fun
+
+ INTERFACE kppsolve
+ MODULE PROCEDURE kppsolve
+ END INTERFACE kppsolve
+
+ INTERFACE kppdecomp
+ MODULE PROCEDURE kppdecomp
+ END INTERFACE kppdecomp
+
+ INTERFACE wlamch
+ MODULE PROCEDURE wlamch
+ END INTERFACE wlamch
+
+ INTERFACE wlamch_add
+ MODULE PROCEDURE wlamch_add
+ END INTERFACE wlamch_add
+
+ INTERFACE jac_sp
+ MODULE PROCEDURE jac_sp
+ END INTERFACE jac_sp
+
+ INTERFACE k_arr
+ MODULE PROCEDURE k_arr
+ END INTERFACE k_arr
+
+ INTERFACE update_rconst
+ MODULE PROCEDURE update_rconst
+ END INTERFACE update_rconst
+
+ INTERFACE arr2
+ MODULE PROCEDURE arr2
+ END INTERFACE arr2
+
+ INTERFACE initialize_kpp_ctrl
+ MODULE PROCEDURE initialize_kpp_ctrl
+ END INTERFACE initialize_kpp_ctrl
+
+ INTERFACE error_output
+ MODULE PROCEDURE error_output
+ END INTERFACE error_output
+
+!interface not working INTERFACE wcopy
+!interface not working MODULE PROCEDURE wcopy
+!interface not working END INTERFACE wcopy
+
+ INTERFACE wscal
+ MODULE PROCEDURE wscal
+ END INTERFACE wscal
+
+!interface not working INTERFACE waxpy
+!interface not working MODULE PROCEDURE waxpy
+!interface not working END INTERFACE waxpy
+
+ INTERFACE rosenbrock
+ MODULE PROCEDURE rosenbrock
+ END INTERFACE rosenbrock
+
+ INTERFACE funtemplate
+ MODULE PROCEDURE funtemplate
+ END INTERFACE funtemplate
+
+ INTERFACE jactemplate
+ MODULE PROCEDURE jactemplate
+ END INTERFACE jactemplate
+
+ INTERFACE chem_gasphase_integrate
+ MODULE PROCEDURE chem_gasphase_integrate
+ END INTERFACE chem_gasphase_integrate
+
+ INTERFACE fill_temp
+ MODULE PROCEDURE fill_temp
+ END INTERFACE fill_temp
+ PUBLIC fill_temp
+
+
+ CONTAINS
+
+SUBROUTINE initialize()
+
+
+
+ INTEGER :: i
+ REAL(kind=dp):: x
+
+ cfactor = 1.000000e+00_dp
+
+ x = (0.)*cfactor
+ DO i = 1,nvar
+ var(i) = x
+ ENDDO
+
+ x = (0.)*cfactor
+ DO i = 1,nfix
+ fix(i) = x
+ ENDDO
+
+! constant rate coefficients
+! END constant rate coefficients
+
+! INLINED initializations
+
+! End INLINED initializations
+
+
+END SUBROUTINE initialize
+
+SUBROUTINE integrate( tin,tout,&
+ icntrl_u,rcntrl_u,istatus_u,rstatus_u,ierr_u)
+
+
+ REAL(kind=dp),INTENT(in):: tin ! start time
+ REAL(kind=dp),INTENT(in):: tout ! END time
+ ! OPTIONAL input PARAMETERs and statistics
+ INTEGER, INTENT(in), OPTIONAL :: icntrl_u(20)
+ REAL(kind=dp),INTENT(in), OPTIONAL :: rcntrl_u(20)
+ INTEGER, INTENT(out),OPTIONAL :: istatus_u(20)
+ REAL(kind=dp),INTENT(out),OPTIONAL :: rstatus_u(20)
+ INTEGER, INTENT(out),OPTIONAL :: ierr_u
+
+ REAL(kind=dp):: rcntrl(20),rstatus(20)
+ INTEGER :: icntrl(20),istatus(20),ierr
+
+ INTEGER,SAVE :: ntotal = 0
+
+ icntrl(:) = 0
+ rcntrl(:) = 0.0_dp
+ istatus(:) = 0
+ rstatus(:) = 0.0_dp
+
+ !~~~> fine-tune the integrator:
+ icntrl(1) = 0 ! 0 - non- autonomous,1 - autonomous
+ icntrl(2) = 0 ! 0 - vector tolerances,1 - scalars
+
+ ! IF OPTIONAL PARAMETERs are given,and IF they are >0,
+ ! THEN they overwrite default settings.
+ IF (present(icntrl_u))THEN
+ where(icntrl_u(:)> 0)icntrl(:) = icntrl_u(:)
+ ENDIF
+ IF (present(rcntrl_u))THEN
+ where(rcntrl_u(:)> 0)rcntrl(:) = rcntrl_u(:)
+ ENDIF
+
+
+ CALL rosenbrock(nvar,var,tin,tout, &
+ atol,rtol, &
+ rcntrl,icntrl,rstatus,istatus,ierr)
+
+ !~~~> debug option: show no of steps
+ ! ntotal = ntotal + istatus(nstp)
+ ! PRINT*,'NSTEPS=',ISTATUS(Nstp),' (',Ntotal,')',' O3=',VAR(ind_O3)
+
+ stepmin = rstatus(nhexit)
+ ! IF OPTIONAL PARAMETERs are given for output they
+ ! are updated with the RETURN information
+ IF (present(istatus_u))istatus_u(:) = istatus(:)
+ IF (present(rstatus_u))rstatus_u(:) = rstatus(:)
+ IF (present(ierr_u)) ierr_u = ierr
+
+END SUBROUTINE integrate
+
+SUBROUTINE fun(v,f,rct,vdot)
+
+! V - Concentrations of variable species (local)
+ REAL(kind=dp):: v(nvar)
+! F - Concentrations of fixed species (local)
+ REAL(kind=dp):: f(nfix)
+! RCT - Rate constants (local)
+ REAL(kind=dp):: rct(nreact)
+! Vdot - Time derivative of variable species concentrations
+ REAL(kind=dp):: vdot(nvar)
+
+
+! Computation of equation rates
+ a(1) = rct(1)*v(10)
+ a(2) = rct(2)*v(8)
+ a(3) = rct(3)*v(8)*v(11)
+ a(4) = rct(4)*v(7)*v(9)
+ a(5) = rct(5)*v(11)*v(13)
+ a(6) = rct(6)*v(11)*v(12)
+ a(7) = rct(7)*v(9)*v(10)
+
+! Aggregate function
+ vdot(1) = 0
+ vdot(2) = 0
+ vdot(3) = 0
+ vdot(4) = 0
+ vdot(5) = a(7)
+ vdot(6) = a(5)
+ vdot(7) = - a(4)
+ vdot(8) = a(1)- a(2)- a(3)
+ vdot(9) = 2*a(2)- a(4)+ a(6)- a(7)
+ vdot(10) = - a(1)+ a(3)+ a(5)+ a(6)- a(7)
+ vdot(11) = a(1)- a(3)- a(5)- a(6)
+ vdot(12) = a(5)- a(6)
+ vdot(13) = a(4)- a(5)
+
+END SUBROUTINE fun
+
+SUBROUTINE kppsolve(jvs,x)
+
+! JVS - sparse Jacobian of variables
+ REAL(kind=dp):: jvs(lu_nonzero)
+! X - Vector for variables
+ REAL(kind=dp):: x(nvar)
+
+ x(9) = x(9)- jvs(16)*x(7)- jvs(17)*x(8)
+ x(10) = x(10)- jvs(22)*x(8)- jvs(23)*x(9)
+ x(11) = x(11)- jvs(28)*x(8)- jvs(29)*x(10)
+ x(12) = x(12)- jvs(33)*x(11)
+ x(13) = x(13)- jvs(36)*x(7)- jvs(37)*x(9)- jvs(38)*x(10)- jvs(39)*x(11)- jvs(40)*x(12)
+ x(13) = x(13)/ jvs(41)
+ x(12) = (x(12)- jvs(35)*x(13))/(jvs(34))
+ x(11) = (x(11)- jvs(31)*x(12)- jvs(32)*x(13))/(jvs(30))
+ x(10) = (x(10)- jvs(25)*x(11)- jvs(26)*x(12)- jvs(27)*x(13))/(jvs(24))
+ x(9) = (x(9)- jvs(19)*x(10)- jvs(20)*x(11)- jvs(21)*x(12))/(jvs(18))
+ x(8) = (x(8)- jvs(14)*x(10)- jvs(15)*x(11))/(jvs(13))
+ x(7) = (x(7)- jvs(12)*x(9))/(jvs(11))
+ x(6) = (x(6)- jvs(9)*x(11)- jvs(10)*x(13))/(jvs(8))
+ x(5) = (x(5)- jvs(6)*x(9)- jvs(7)*x(10))/(jvs(5))
+ x(4) = x(4)/ jvs(4)
+ x(3) = x(3)/ jvs(3)
+ x(2) = x(2)/ jvs(2)
+ x(1) = x(1)/ jvs(1)
+
+END SUBROUTINE kppsolve
+
+SUBROUTINE kppdecomp( jvs,ier)
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+! Sparse LU factorization
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+ INTEGER :: ier
+ REAL(kind=dp):: jvs(lu_nonzero),w(nvar),a
+ INTEGER :: k,kk,j,jj
+
+ a = 0. ! mz_rs_20050606
+ ier = 0
+ DO k=1,nvar
+ ! mz_rs_20050606: don't check if real value == 0
+ ! IF(jvs( lu_diag(k)).eq. 0.)THEN
+ IF(abs(jvs(lu_diag(k)))< tiny(a))THEN
+ ier = k
+ RETURN
+ ENDIF
+ DO kk = lu_crow(k),lu_crow(k+ 1)- 1
+ w( lu_icol(kk)) = jvs(kk)
+ ENDDO
+ DO kk = lu_crow(k),lu_diag(k)- 1
+ j = lu_icol(kk)
+ a = - w(j)/ jvs( lu_diag(j))
+ w(j) = - a
+ DO jj = lu_diag(j)+ 1,lu_crow(j+ 1)- 1
+ w( lu_icol(jj)) = w( lu_icol(jj))+ a*jvs(jj)
+ ENDDO
+ ENDDO
+ DO kk = lu_crow(k),lu_crow(k+ 1)- 1
+ jvs(kk) = w( lu_icol(kk))
+ ENDDO
+ ENDDO
+
+END SUBROUTINE kppdecomp
+
+ REAL(kind=dp)FUNCTION wlamch( c)
+!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+! returns epsilon machine
+! after LAPACK
+! replace this by the function from the optimized LAPACK implementation:
+! CALL SLAMCH('E') or CALL DLAMCH('E')
+!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+! USE chem_gasphase_mod_Precision
+
+ CHARACTER :: c
+ INTEGER :: i
+ REAL(kind=dp),SAVE :: eps
+ REAL(kind=dp) :: suma
+ REAL(kind=dp),PARAMETER :: one=1.0_dp, half=0.5_dp
+ LOGICAL,SAVE :: first=.true.
+
+ IF (first)THEN
+ first = .false.
+ eps = half**(16)
+ DO i = 17,80
+ eps = eps*half
+ CALL wlamch_add(one,eps,suma)
+ IF (suma.le.one)goto 10
+ ENDDO
+ PRINT*,'ERROR IN WLAMCH. EPS < ',Eps
+ RETURN
+10 eps = eps*2
+ i = i- 1
+ ENDIF
+
+ wlamch = eps
+
+ END FUNCTION wlamch
+
+ SUBROUTINE wlamch_add( a,b,suma)
+! USE chem_gasphase_mod_Precision
+
+ REAL(kind=dp)a,b,suma
+ suma = a + b
+
+ END SUBROUTINE wlamch_add
+
+SUBROUTINE jac_sp(v,f,rct,jvs)
+
+! V - Concentrations of variable species (local)
+ REAL(kind=dp):: v(nvar)
+! F - Concentrations of fixed species (local)
+ REAL(kind=dp):: f(nfix)
+! RCT - Rate constants (local)
+ REAL(kind=dp):: rct(nreact)
+! JVS - sparse Jacobian of variables
+ REAL(kind=dp):: jvs(lu_nonzero)
+
+
+! Local variables
+! B - Temporary array
+ REAL(kind=dp):: b(16)
+
+! B(1) = dA(1)/dV(10)
+ b(1) = rct(1)
+! B(2) = dA(2)/dV(8)
+ b(2) = rct(2)
+! B(3) = dA(3)/dV(8)
+ b(3) = rct(3)*v(11)
+! B(4) = dA(3)/dV(11)
+ b(4) = rct(3)*v(8)
+! B(5) = dA(4)/dV(7)
+ b(5) = rct(4)*v(9)
+! B(6) = dA(4)/dV(9)
+ b(6) = rct(4)*v(7)
+! B(7) = dA(5)/dV(11)
+ b(7) = rct(5)*v(13)
+! B(8) = dA(5)/dV(13)
+ b(8) = rct(5)*v(11)
+! B(9) = dA(6)/dV(11)
+ b(9) = rct(6)*v(12)
+! B(10) = dA(6)/dV(12)
+ b(10) = rct(6)*v(11)
+! B(11) = dA(7)/dV(9)
+ b(11) = rct(7)*v(10)
+! B(12) = dA(7)/dV(10)
+ b(12) = rct(7)*v(9)
+! B(13) = dA(8)/dV(1)
+ b(13) = rct(8)
+! B(14) = dA(9)/dV(2)
+ b(14) = rct(9)
+! B(15) = dA(10)/dV(3)
+ b(15) = rct(10)
+! B(16) = dA(11)/dV(4)
+ b(16) = rct(11)
+
+! Construct the Jacobian terms from B's
+! JVS(1) = Jac_FULL(1,1)
+ jvs(1) = 0
+! JVS(2) = Jac_FULL(2,2)
+ jvs(2) = 0
+! JVS(3) = Jac_FULL(3,3)
+ jvs(3) = 0
+! JVS(4) = Jac_FULL(4,4)
+ jvs(4) = 0
+! JVS(5) = Jac_FULL(5,5)
+ jvs(5) = 0
+! JVS(6) = Jac_FULL(5,9)
+ jvs(6) = b(11)
+! JVS(7) = Jac_FULL(5,10)
+ jvs(7) = b(12)
+! JVS(8) = Jac_FULL(6,6)
+ jvs(8) = 0
+! JVS(9) = Jac_FULL(6,11)
+ jvs(9) = b(7)
+! JVS(10) = Jac_FULL(6,13)
+ jvs(10) = b(8)
+! JVS(11) = Jac_FULL(7,7)
+ jvs(11) = - b(5)
+! JVS(12) = Jac_FULL(7,9)
+ jvs(12) = - b(6)
+! JVS(13) = Jac_FULL(8,8)
+ jvs(13) = - b(2)- b(3)
+! JVS(14) = Jac_FULL(8,10)
+ jvs(14) = b(1)
+! JVS(15) = Jac_FULL(8,11)
+ jvs(15) = - b(4)
+! JVS(16) = Jac_FULL(9,7)
+ jvs(16) = - b(5)
+! JVS(17) = Jac_FULL(9,8)
+ jvs(17) = 2*b(2)
+! JVS(18) = Jac_FULL(9,9)
+ jvs(18) = - b(6)- b(11)
+! JVS(19) = Jac_FULL(9,10)
+ jvs(19) = - b(12)
+! JVS(20) = Jac_FULL(9,11)
+ jvs(20) = b(9)
+! JVS(21) = Jac_FULL(9,12)
+ jvs(21) = b(10)
+! JVS(22) = Jac_FULL(10,8)
+ jvs(22) = b(3)
+! JVS(23) = Jac_FULL(10,9)
+ jvs(23) = - b(11)
+! JVS(24) = Jac_FULL(10,10)
+ jvs(24) = - b(1)- b(12)
+! JVS(25) = Jac_FULL(10,11)
+ jvs(25) = b(4)+ b(7)+ b(9)
+! JVS(26) = Jac_FULL(10,12)
+ jvs(26) = b(10)
+! JVS(27) = Jac_FULL(10,13)
+ jvs(27) = b(8)
+! JVS(28) = Jac_FULL(11,8)
+ jvs(28) = - b(3)
+! JVS(29) = Jac_FULL(11,10)
+ jvs(29) = b(1)
+! JVS(30) = Jac_FULL(11,11)
+ jvs(30) = - b(4)- b(7)- b(9)
+! JVS(31) = Jac_FULL(11,12)
+ jvs(31) = - b(10)
+! JVS(32) = Jac_FULL(11,13)
+ jvs(32) = - b(8)
+! JVS(33) = Jac_FULL(12,11)
+ jvs(33) = b(7)- b(9)
+! JVS(34) = Jac_FULL(12,12)
+ jvs(34) = - b(10)
+! JVS(35) = Jac_FULL(12,13)
+ jvs(35) = b(8)
+! JVS(36) = Jac_FULL(13,7)
+ jvs(36) = b(5)
+! JVS(37) = Jac_FULL(13,9)
+ jvs(37) = b(6)
+! JVS(38) = Jac_FULL(13,10)
+ jvs(38) = 0
+! JVS(39) = Jac_FULL(13,11)
+ jvs(39) = - b(7)
+! JVS(40) = Jac_FULL(13,12)
+ jvs(40) = 0
+! JVS(41) = Jac_FULL(13,13)
+ jvs(41) = - b(8)
+
+END SUBROUTINE jac_sp
+
+ elemental REAL(kind=dp)FUNCTION k_arr (k_298,tdep,temp)
+ ! arrhenius FUNCTION
+
+ REAL, INTENT(in):: k_298 ! k at t = 298.15k
+ REAL, INTENT(in):: tdep ! temperature dependence
+ REAL(kind=dp),INTENT(in):: temp ! temperature
+
+ intrinsic exp
+
+ k_arr = k_298 *exp(tdep*(1._dp/temp- 3.3540e-3_dp))! 1/298.15=3.3540e-3
+
+ END FUNCTION k_arr
+
+SUBROUTINE update_rconst()
+ INTEGER :: j,k
+
+ k = is
+
+! Begin INLINED RCONST
+
+
+! End INLINED RCONST
+
+ rconst(1) = (phot(j_no2))
+ rconst(2) = (phot(j_o31d))
+ rconst(3) = (arr2(1.80e-12_dp , 1370.0_dp , temp(k)))
+ rconst(4) = (arr2(2.00e-11_dp , 500.0_dp , temp(k)))
+ rconst(5) = (arr2(4.20e-12_dp , -180.0_dp , temp(k)))
+ rconst(6) = (arr2(3.70e-12_dp , -240.0_dp , temp(k)))
+ rconst(7) = (arr2(1.15e-11_dp , 0.0_dp , temp(k)))
+ rconst(8) = (1.0_dp)
+ rconst(9) = (1.0_dp)
+ rconst(10) = (1.0_dp)
+ rconst(11) = (1.0_dp)
+
+END SUBROUTINE update_rconst
+
+REAL(kind=dp)FUNCTION arr2( a0,b0,temp)
+ REAL(kind=dp):: temp
+ REAL(kind=dp):: a0,b0
+ arr2 = a0 *exp( - b0 / temp)
+END FUNCTION arr2
+
+SUBROUTINE initialize_kpp_ctrl(status,iou,modstr)
+
+
+ ! i/o
+ INTEGER, INTENT(out):: status
+ INTEGER, INTENT(in) :: iou ! LOGICAL i/o unit
+ CHARACTER(len=*),INTENT(in) :: modstr ! read .nml
+
+ ! local
+ REAL(dp):: tsum
+ INTEGER :: i
+
+ ! check fixed time steps
+ tsum = 0.0_dp
+ DO i=1,nmaxfixsteps
+ IF (t_steps(i)< tiny(0.0_dp))exit
+ tsum = tsum + t_steps(i)
+ ENDDO
+
+ nfsteps = i- 1
+
+ l_fixed_step = (nfsteps > 0).and.((tsum - 1.0)< tiny(0.0_dp))
+
+ IF (l_vector)THEN
+ WRITE(*,*) ' MODE : VECTOR (LENGTH=',VL_DIM,')'
+ ELSE
+ WRITE(*,*) ' MODE : SCALAR'
+ ENDIF
+ !
+ WRITE(*,*) ' DE-INDEXING MODE :',I_LU_DI
+ !
+ WRITE(*,*) ' ICNTRL : ',icntrl
+ WRITE(*,*) ' RCNTRL : ',rcntrl
+ !
+ ! note: this is only meaningful for vectorized (kp4)rosenbrock- methods
+ IF (l_vector)THEN
+ IF (l_fixed_step)THEN
+ WRITE(*,*) ' TIME STEPS : FIXED (',t_steps(1:nfsteps),')'
+ ELSE
+ WRITE(*,*) ' TIME STEPS : AUTOMATIC'
+ ENDIF
+ ELSE
+ WRITE(*,*) ' TIME STEPS : AUTOMATIC '//&
+ &'(t_steps (CTRL_KPP) ignored in SCALAR MODE)'
+ ENDIF
+ ! mz_pj_20070531-
+
+ status = 0
+
+
+END SUBROUTINE initialize_kpp_ctrl
+
+SUBROUTINE error_output(c,ierr,pe)
+
+
+ INTEGER,INTENT(in):: ierr
+ INTEGER,INTENT(in):: pe
+ REAL(dp),DIMENSION(:),INTENT(in):: c
+
+ write(6,*) 'ERROR in chem_gasphase_mod ',ierr,C(1)
+
+
+END SUBROUTINE error_output
+
+ SUBROUTINE wcopy(n,x,incx,y,incy)
+!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+! copies a vector,x,to a vector,y: y <- x
+! only for incX=incY=1
+! after BLAS
+! replace this by the function from the optimized BLAS implementation:
+! CALL SCOPY(N,X,1,Y,1) or CALL DCOPY(N,X,1,Y,1)
+!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+! USE chem_gasphase_mod_Precision
+
+ INTEGER :: i,incx,incy,m,mp1,n
+ REAL(kind=dp):: x(n),y(n)
+
+ IF (n.le.0)RETURN
+
+ m = mod(n,8)
+ IF( m .ne. 0)THEN
+ DO i = 1,m
+ y(i) = x(i)
+ ENDDO
+ IF( n .lt. 8)RETURN
+ ENDIF
+ mp1 = m+ 1
+ DO i = mp1,n,8
+ y(i) = x(i)
+ y(i + 1) = x(i + 1)
+ y(i + 2) = x(i + 2)
+ y(i + 3) = x(i + 3)
+ y(i + 4) = x(i + 4)
+ y(i + 5) = x(i + 5)
+ y(i + 6) = x(i + 6)
+ y(i + 7) = x(i + 7)
+ ENDDO
+
+ END SUBROUTINE wcopy
+
+ SUBROUTINE wscal(n,alpha,x,incx)
+!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+! constant times a vector: x(1:N) <- Alpha*x(1:N)
+! only for incX=incY=1
+! after BLAS
+! replace this by the function from the optimized BLAS implementation:
+! CALL SSCAL(N,Alpha,X,1) or CALL DSCAL(N,Alpha,X,1)
+!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+ INTEGER :: i,incx,m,mp1,n
+ REAL(kind=dp) :: x(n),alpha
+ REAL(kind=dp),PARAMETER :: zero=0.0_dp, one=1.0_dp
+
+ IF (alpha .eq. one)RETURN
+ IF (n .le. 0)RETURN
+
+ m = mod(n,5)
+ IF( m .ne. 0)THEN
+ IF (alpha .eq. (- one))THEN
+ DO i = 1,m
+ x(i) = - x(i)
+ ENDDO
+ ELSEIF (alpha .eq. zero)THEN
+ DO i = 1,m
+ x(i) = zero
+ ENDDO
+ ELSE
+ DO i = 1,m
+ x(i) = alpha*x(i)
+ ENDDO
+ ENDIF
+ IF( n .lt. 5)RETURN
+ ENDIF
+ mp1 = m + 1
+ IF (alpha .eq. (- one))THEN
+ DO i = mp1,n,5
+ x(i) = - x(i)
+ x(i + 1) = - x(i + 1)
+ x(i + 2) = - x(i + 2)
+ x(i + 3) = - x(i + 3)
+ x(i + 4) = - x(i + 4)
+ ENDDO
+ ELSEIF (alpha .eq. zero)THEN
+ DO i = mp1,n,5
+ x(i) = zero
+ x(i + 1) = zero
+ x(i + 2) = zero
+ x(i + 3) = zero
+ x(i + 4) = zero
+ ENDDO
+ ELSE
+ DO i = mp1,n,5
+ x(i) = alpha*x(i)
+ x(i + 1) = alpha*x(i + 1)
+ x(i + 2) = alpha*x(i + 2)
+ x(i + 3) = alpha*x(i + 3)
+ x(i + 4) = alpha*x(i + 4)
+ ENDDO
+ ENDIF
+
+ END SUBROUTINE wscal
+
+ SUBROUTINE waxpy(n,alpha,x,incx,y,incy)
+!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+! constant times a vector plus a vector: y <- y + Alpha*x
+! only for incX=incY=1
+! after BLAS
+! replace this by the function from the optimized BLAS implementation:
+! CALL SAXPY(N,Alpha,X,1,Y,1) or CALL DAXPY(N,Alpha,X,1,Y,1)
+!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+ INTEGER :: i,incx,incy,m,mp1,n
+ REAL(kind=dp):: x(n),y(n),alpha
+ REAL(kind=dp),PARAMETER :: zero = 0.0_dp
+
+ IF (alpha .eq. zero)RETURN
+ IF (n .le. 0)RETURN
+
+ m = mod(n,4)
+ IF( m .ne. 0)THEN
+ DO i = 1,m
+ y(i) = y(i)+ alpha*x(i)
+ ENDDO
+ IF( n .lt. 4)RETURN
+ ENDIF
+ mp1 = m + 1
+ DO i = mp1,n,4
+ y(i) = y(i)+ alpha*x(i)
+ y(i + 1) = y(i + 1)+ alpha*x(i + 1)
+ y(i + 2) = y(i + 2)+ alpha*x(i + 2)
+ y(i + 3) = y(i + 3)+ alpha*x(i + 3)
+ ENDDO
+
+ END SUBROUTINE waxpy
+
+SUBROUTINE rosenbrock(n,y,tstart,tend,&
+ abstol,reltol, &
+ rcntrl,icntrl,rstatus,istatus,ierr)
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+! Solves the system y'=F(t,y) using a Rosenbrock method defined by:
+!
+! G = 1/(H*gamma(1)) - Jac(t0,Y0)
+! T_i = t0 + Alpha(i)*H
+! Y_i = Y0 + \sum_{j=1}^{i-1} A(i,j)*K_j
+! G *K_i = Fun( T_i,Y_i)+ \sum_{j=1}^S C(i,j)/H *K_j +
+! gamma(i)*dF/dT(t0,Y0)
+! Y1 = Y0 + \sum_{j=1}^S M(j)*K_j
+!
+! For details on Rosenbrock methods and their implementation consult:
+! E. Hairer and G. Wanner
+! "Solving ODEs II. Stiff and differential-algebraic problems".
+! Springer series in computational mathematics,Springer-Verlag,1996.
+! The codes contained in the book inspired this implementation.
+!
+! (C) Adrian Sandu,August 2004
+! Virginia Polytechnic Institute and State University
+! Contact: sandu@cs.vt.edu
+! Revised by Philipp Miehe and Adrian Sandu,May 2006
+! This implementation is part of KPP - the Kinetic PreProcessor
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+!~~~> input arguments:
+!
+!- y(n) = vector of initial conditions (at t=tstart)
+!- [tstart,tend] = time range of integration
+! (if Tstart>Tend the integration is performed backwards in time)
+!- reltol,abstol = user precribed accuracy
+!- SUBROUTINE fun( t,y,ydot) = ode FUNCTION,
+! returns Ydot = Y' = F(T,Y)
+!- SUBROUTINE jac( t,y,jcb) = jacobian of the ode FUNCTION,
+! returns Jcb = dFun/dY
+!- icntrl(1:20) = INTEGER inputs PARAMETERs
+!- rcntrl(1:20) = REAL inputs PARAMETERs
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+!~~~> output arguments:
+!
+!- y(n) - > vector of final states (at t- >tEND)
+!- istatus(1:20) - > INTEGER output PARAMETERs
+!- rstatus(1:20) - > REAL output PARAMETERs
+!- ierr - > job status upon RETURN
+! success (positive value) or
+! failure (negative value)
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+!~~~> input PARAMETERs:
+!
+! Note: For input parameters equal to zero the default values of the
+! corresponding variables are used.
+!
+! ICNTRL(1) = 1: F = F(y) Independent of T (AUTONOMOUS)
+! = 0: F = F(t,y) Depends on T (NON-AUTONOMOUS)
+!
+! ICNTRL(2) = 0: AbsTol,RelTol are N-dimensional vectors
+! = 1: AbsTol,RelTol are scalars
+!
+! ICNTRL(3) -> selection of a particular Rosenbrock method
+! = 0 : Rodas3 (default)
+! = 1 : Ros2
+! = 2 : Ros3
+! = 3 : Ros4
+! = 4 : Rodas3
+! = 5 : Rodas4
+!
+! ICNTRL(4) -> maximum number of integration steps
+! For ICNTRL(4) =0) the default value of 100000 is used
+!
+! RCNTRL(1) -> Hmin,lower bound for the integration step size
+! It is strongly recommended to keep Hmin = ZERO
+! RCNTRL(2) -> Hmax,upper bound for the integration step size
+! RCNTRL(3) -> Hstart,starting value for the integration step size
+!
+! RCNTRL(4) -> FacMin,lower bound on step decrease factor (default=0.2)
+! RCNTRL(5) -> FacMax,upper bound on step increase factor (default=6)
+! RCNTRL(6) -> FacRej,step decrease factor after multiple rejections
+! (default=0.1)
+! RCNTRL(7) -> FacSafe,by which the new step is slightly smaller
+! than the predicted value (default=0.9)
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+!
+! OUTPUT ARGUMENTS:
+! -----------------
+!
+! T -> T value for which the solution has been computed
+! (after successful return T=Tend).
+!
+! Y(N) -> Numerical solution at T
+!
+! IDID -> Reports on successfulness upon return:
+! = 1 for success
+! < 0 for error (value equals error code)
+!
+! ISTATUS(1) -> No. of function calls
+! ISTATUS(2) -> No. of jacobian calls
+! ISTATUS(3) -> No. of steps
+! ISTATUS(4) -> No. of accepted steps
+! ISTATUS(5) -> No. of rejected steps (except at very beginning)
+! ISTATUS(6) -> No. of LU decompositions
+! ISTATUS(7) -> No. of forward/backward substitutions
+! ISTATUS(8) -> No. of singular matrix decompositions
+!
+! RSTATUS(1) -> Texit,the time corresponding to the
+! computed Y upon return
+! RSTATUS(2) -> Hexit,last accepted step before exit
+! RSTATUS(3) -> Hnew,last predicted step (not yet taken)
+! For multiple restarts,use Hnew as Hstart
+! in the subsequent run
+!
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+!~~~> arguments
+ INTEGER, INTENT(in) :: n
+ REAL(kind=dp),INTENT(inout):: y(n)
+ REAL(kind=dp),INTENT(in) :: tstart,tend
+ REAL(kind=dp),INTENT(in) :: abstol(n),reltol(n)
+ INTEGER, INTENT(in) :: icntrl(20)
+ REAL(kind=dp),INTENT(in) :: rcntrl(20)
+ INTEGER, INTENT(inout):: istatus(20)
+ REAL(kind=dp),INTENT(inout):: rstatus(20)
+ INTEGER,INTENT(out) :: ierr
+!~~~> PARAMETERs of the rosenbrock method,up to 6 stages
+ INTEGER :: ros_s,rosmethod
+ INTEGER,PARAMETER :: rs2=1,rs3=2,rs4=3,rd3=4,rd4=5,rg3=6
+ REAL(kind=dp):: ros_a(15),ros_c(15),ros_m(6),ros_e(6),&
+ ros_alpha(6),ros_gamma(6),ros_elo
+ LOGICAL :: ros_newf(6)
+ CHARACTER(len=12):: ros_name
+!~~~> local variables
+ REAL(kind=dp):: roundoff,facmin,facmax,facrej,facsafe
+ REAL(kind=dp):: hmin,hmax,hstart
+ REAL(kind=dp):: texit
+ INTEGER :: i,uplimtol,max_no_steps
+ LOGICAL :: autonomous,vectortol
+!~~~> PARAMETERs
+ REAL(kind=dp),PARAMETER :: zero = 0.0_dp, one = 1.0_dp
+ REAL(kind=dp),PARAMETER :: deltamin = 1.0e-5_dp
+
+!~~~> initialize statistics
+ istatus(1:8) = 0
+ rstatus(1:3) = zero
+
+!~~~> autonomous or time dependent ode. default is time dependent.
+ autonomous = .not.(icntrl(1) == 0)
+
+!~~~> for scalar tolerances (icntrl(2).ne.0) the code uses abstol(1)and reltol(1)
+! For Vector tolerances (ICNTRL(2) == 0) the code uses AbsTol(1:N) and RelTol(1:N)
+ IF (icntrl(2) == 0)THEN
+ vectortol = .true.
+ uplimtol = n
+ ELSE
+ vectortol = .false.
+ uplimtol = 1
+ ENDIF
+
+!~~~> initialize the particular rosenbrock method selected
+ select CASE (icntrl(3))
+ CASE (1)
+ CALL ros2
+ CASE (2)
+ CALL ros3
+ CASE (3)
+ CALL ros4
+ CASE (0,4)
+ CALL rodas3
+ CASE (5)
+ CALL rodas4
+ CASE (6)
+ CALL rang3
+ CASE default
+ PRINT *,'Unknown Rosenbrock method: ICNTRL(3) =',ICNTRL(3)
+ CALL ros_errormsg(- 2,tstart,zero,ierr)
+ RETURN
+ END select
+
+!~~~> the maximum number of steps admitted
+ IF (icntrl(4) == 0)THEN
+ max_no_steps = 200000
+ ELSEIF (icntrl(4)> 0)THEN
+ max_no_steps=icntrl(4)
+ ELSE
+ PRINT *,'User-selected max no. of steps: ICNTRL(4) =',ICNTRL(4)
+ CALL ros_errormsg(- 1,tstart,zero,ierr)
+ RETURN
+ ENDIF
+
+!~~~> unit roundoff (1+ roundoff>1)
+ Roundoff = WLAMCH('E')
+
+!~~~> lower bound on the step size: (positive value)
+ IF (rcntrl(1) == zero)THEN
+ hmin = zero
+ ELSEIF (rcntrl(1)> zero)THEN
+ hmin = rcntrl(1)
+ ELSE
+ PRINT *,'User-selected Hmin: RCNTRL(1) =',RCNTRL(1)
+ CALL ros_errormsg(- 3,tstart,zero,ierr)
+ RETURN
+ ENDIF
+!~~~> upper bound on the step size: (positive value)
+ IF (rcntrl(2) == zero)THEN
+ hmax = abs(tend-tstart)
+ ELSEIF (rcntrl(2)> zero)THEN
+ hmax = min(abs(rcntrl(2)),abs(tend-tstart))
+ ELSE
+ PRINT *,'User-selected Hmax: RCNTRL(2) =',RCNTRL(2)
+ CALL ros_errormsg(- 3,tstart,zero,ierr)
+ RETURN
+ ENDIF
+!~~~> starting step size: (positive value)
+ IF (rcntrl(3) == zero)THEN
+ hstart = max(hmin,deltamin)
+ ELSEIF (rcntrl(3)> zero)THEN
+ hstart = min(abs(rcntrl(3)),abs(tend-tstart))
+ ELSE
+ PRINT *,'User-selected Hstart: RCNTRL(3) =',RCNTRL(3)
+ CALL ros_errormsg(- 3,tstart,zero,ierr)
+ RETURN
+ ENDIF
+!~~~> step size can be changed s.t. facmin < hnew/hold < facmax
+ IF (rcntrl(4) == zero)THEN
+ facmin = 0.2_dp
+ ELSEIF (rcntrl(4)> zero)THEN
+ facmin = rcntrl(4)
+ ELSE
+ PRINT *,'User-selected FacMin: RCNTRL(4) =',RCNTRL(4)
+ CALL ros_errormsg(- 4,tstart,zero,ierr)
+ RETURN
+ ENDIF
+ IF (rcntrl(5) == zero)THEN
+ facmax = 6.0_dp
+ ELSEIF (rcntrl(5)> zero)THEN
+ facmax = rcntrl(5)
+ ELSE
+ PRINT *,'User-selected FacMax: RCNTRL(5) =',RCNTRL(5)
+ CALL ros_errormsg(- 4,tstart,zero,ierr)
+ RETURN
+ ENDIF
+!~~~> facrej: factor to decrease step after 2 succesive rejections
+ IF (rcntrl(6) == zero)THEN
+ facrej = 0.1_dp
+ ELSEIF (rcntrl(6)> zero)THEN
+ facrej = rcntrl(6)
+ ELSE
+ PRINT *,'User-selected FacRej: RCNTRL(6) =',RCNTRL(6)
+ CALL ros_errormsg(- 4,tstart,zero,ierr)
+ RETURN
+ ENDIF
+!~~~> facsafe: safety factor in the computation of new step size
+ IF (rcntrl(7) == zero)THEN
+ facsafe = 0.9_dp
+ ELSEIF (rcntrl(7)> zero)THEN
+ facsafe = rcntrl(7)
+ ELSE
+ PRINT *,'User-selected FacSafe: RCNTRL(7) =',RCNTRL(7)
+ CALL ros_errormsg(- 4,tstart,zero,ierr)
+ RETURN
+ ENDIF
+!~~~> check IF tolerances are reasonable
+ DO i=1,uplimtol
+ IF((abstol(i)<= zero).or. (reltol(i)<= 10.0_dp*roundoff)&
+ .or. (reltol(i)>= 1.0_dp))THEN
+ PRINT *,' AbsTol(',i,') = ',AbsTol(i)
+ PRINT *,' RelTol(',i,') = ',RelTol(i)
+ CALL ros_errormsg(- 5,tstart,zero,ierr)
+ RETURN
+ ENDIF
+ ENDDO
+
+
+!~~~> CALL rosenbrock method
+ CALL ros_integrator(y,tstart,tend,texit, &
+ abstol,reltol, &
+! Integration parameters
+ autonomous,vectortol,max_no_steps, &
+ roundoff,hmin,hmax,hstart, &
+ facmin,facmax,facrej,facsafe, &
+! Error indicator
+ ierr)
+
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+CONTAINS ! SUBROUTINEs internal to rosenbrock
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ SUBROUTINE ros_errormsg(code,t,h,ierr)
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+! Handles all error messages
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+ REAL(kind=dp),INTENT(in):: t,h
+ INTEGER,INTENT(in) :: code
+ INTEGER,INTENT(out):: ierr
+
+ ierr = code
+ print *,&
+ 'Forced exit from Rosenbrock due to the following error:'
+
+ select CASE (code)
+ CASE (- 1)
+ PRINT *,'--> Improper value for maximal no of steps'
+ CASE (- 2)
+ PRINT *,'--> Selected Rosenbrock method not implemented'
+ CASE (- 3)
+ PRINT *,'--> Hmin/Hmax/Hstart must be positive'
+ CASE (- 4)
+ PRINT *,'--> FacMin/FacMax/FacRej must be positive'
+ CASE (- 5)
+ PRINT *,'--> Improper tolerance values'
+ CASE (- 6)
+ PRINT *,'--> No of steps exceeds maximum bound'
+ CASE (- 7)
+ PRINT *,'--> Step size too small: T + 10*H = T',&
+ ' or H < Roundoff'
+ CASE (- 8)
+ PRINT *,'--> Matrix is repeatedly singular'
+ CASE default
+ PRINT *,'Unknown Error code: ',Code
+ END select
+
+ print *,"t=",t,"and h=",h
+
+ END SUBROUTINE ros_errormsg
+
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ SUBROUTINE ros_integrator (y,tstart,tend,t, &
+ abstol,reltol, &
+!~~~> integration PARAMETERs
+ autonomous,vectortol,max_no_steps, &
+ roundoff,hmin,hmax,hstart, &
+ facmin,facmax,facrej,facsafe, &
+!~~~> error indicator
+ ierr)
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+! Template for the implementation of a generic Rosenbrock method
+! defined by ros_S (no of stages)
+! and its coefficients ros_{A,C,M,E,Alpha,Gamma}
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+!~~~> input: the initial condition at tstart; output: the solution at t
+ REAL(kind=dp),INTENT(inout):: y(n)
+!~~~> input: integration interval
+ REAL(kind=dp),INTENT(in):: tstart,tend
+!~~~> output: time at which the solution is RETURNed (t=tENDIF success)
+ REAL(kind=dp),INTENT(out):: t
+!~~~> input: tolerances
+ REAL(kind=dp),INTENT(in):: abstol(n),reltol(n)
+!~~~> input: integration PARAMETERs
+ LOGICAL,INTENT(in):: autonomous,vectortol
+ REAL(kind=dp),INTENT(in):: hstart,hmin,hmax
+ INTEGER,INTENT(in):: max_no_steps
+ REAL(kind=dp),INTENT(in):: roundoff,facmin,facmax,facrej,facsafe
+!~~~> output: error indicator
+ INTEGER,INTENT(out):: ierr
+! ~~~~ Local variables
+ REAL(kind=dp):: ynew(n),fcn0(n),fcn(n)
+ REAL(kind=dp):: k(n*ros_s),dfdt(n)
+#ifdef full_algebra
+ REAL(kind=dp):: jac0(n,n),ghimj(n,n)
+#else
+ REAL(kind=dp):: jac0(lu_nonzero),ghimj(lu_nonzero)
+#endif
+ REAL(kind=dp):: h,hnew,hc,hg,fac,tau
+ REAL(kind=dp):: err,yerr(n)
+ INTEGER :: pivot(n),direction,ioffset,j,istage
+ LOGICAL :: rejectlasth,rejectmoreh,singular
+!~~~> local PARAMETERs
+ REAL(kind=dp),PARAMETER :: zero = 0.0_dp, one = 1.0_dp
+ REAL(kind=dp),PARAMETER :: deltamin = 1.0e-5_dp
+!~~~> locally called FUNCTIONs
+! REAL(kind=dp) WLAMCH
+! EXTERNAL WLAMCH
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+!~~~> initial preparations
+ t = tstart
+ rstatus(nhexit) = zero
+ h = min( max(abs(hmin),abs(hstart)),abs(hmax))
+ IF (abs(h)<= 10.0_dp*roundoff)h = deltamin
+
+ IF (tEND >= tstart)THEN
+ direction = + 1
+ ELSE
+ direction = - 1
+ ENDIF
+ h = direction*h
+
+ rejectlasth=.false.
+ rejectmoreh=.false.
+
+!~~~> time loop begins below
+
+timeloop: DO WHILE((direction > 0).and.((t- tEND)+ roundoff <= zero)&
+ .or. (direction < 0).and.((tend-t)+ roundoff <= zero))
+
+ IF(istatus(nstp)> max_no_steps)THEN ! too many steps
+ CALL ros_errormsg(- 6,t,h,ierr)
+ RETURN
+ ENDIF
+ IF(((t+ 0.1_dp*h) == t).or.(h <= roundoff))THEN ! step size too small
+ CALL ros_errormsg(- 7,t,h,ierr)
+ RETURN
+ ENDIF
+
+!~~~> limit h IF necessary to avoid going beyond tend
+ h = min(h,abs(tend-t))
+
+!~~~> compute the FUNCTION at current time
+ CALL funtemplate(t,y,fcn0)
+ istatus(nfun) = istatus(nfun)+ 1
+
+!~~~> compute the FUNCTION derivative with respect to t
+ IF (.not.autonomous)THEN
+ CALL ros_funtimederivative(t,roundoff,y,&
+ fcn0,dfdt)
+ ENDIF
+
+!~~~> compute the jacobian at current time
+ CALL jactemplate(t,y,jac0)
+ istatus(njac) = istatus(njac)+ 1
+
+!~~~> repeat step calculation until current step accepted
+untilaccepted: do
+
+ CALL ros_preparematrix(h,direction,ros_gamma(1),&
+ jac0,ghimj,pivot,singular)
+ IF (singular)THEN ! more than 5 consecutive failed decompositions
+ CALL ros_errormsg(- 8,t,h,ierr)
+ RETURN
+ ENDIF
+
+!~~~> compute the stages
+stage: DO istage = 1,ros_s
+
+ ! current istage offset. current istage vector is k(ioffset+ 1:ioffset+ n)
+ ioffset = n*(istage-1)
+
+ ! for the 1st istage the FUNCTION has been computed previously
+ IF(istage == 1)THEN
+ !slim: CALL wcopy(n,fcn0,1,fcn,1)
+ fcn(1:n) = fcn0(1:n)
+ ! istage>1 and a new FUNCTION evaluation is needed at the current istage
+ ELSEIF(ros_newf(istage))THEN
+ !slim: CALL wcopy(n,y,1,ynew,1)
+ ynew(1:n) = y(1:n)
+ DO j = 1,istage-1
+ CALL waxpy(n,ros_a((istage-1)*(istage-2)/2+ j),&
+ k(n*(j- 1)+ 1),1,ynew,1)
+ ENDDO
+ tau = t + ros_alpha(istage)*direction*h
+ CALL funtemplate(tau,ynew,fcn)
+ istatus(nfun) = istatus(nfun)+ 1
+ ENDIF ! IF istage == 1 ELSEIF ros_newf(istage)
+ !slim: CALL wcopy(n,fcn,1,k(ioffset+ 1),1)
+ k(ioffset+ 1:ioffset+ n) = fcn(1:n)
+ DO j = 1,istage-1
+ hc = ros_c((istage-1)*(istage-2)/2+ j)/(direction*h)
+ CALL waxpy(n,hc,k(n*(j- 1)+ 1),1,k(ioffset+ 1),1)
+ ENDDO
+ IF ((.not. autonomous).and.(ros_gamma(istage).ne.zero))THEN
+ hg = direction*h*ros_gamma(istage)
+ CALL waxpy(n,hg,dfdt,1,k(ioffset+ 1),1)
+ ENDIF
+ CALL ros_solve(ghimj,pivot,k(ioffset+ 1))
+
+ END DO stage
+
+
+!~~~> compute the new solution
+ !slim: CALL wcopy(n,y,1,ynew,1)
+ ynew(1:n) = y(1:n)
+ DO j=1,ros_s
+ CALL waxpy(n,ros_m(j),k(n*(j- 1)+ 1),1,ynew,1)
+ ENDDO
+
+!~~~> compute the error estimation
+ !slim: CALL wscal(n,zero,yerr,1)
+ yerr(1:n) = zero
+ DO j=1,ros_s
+ CALL waxpy(n,ros_e(j),k(n*(j- 1)+ 1),1,yerr,1)
+ ENDDO
+ err = ros_errornorm(y,ynew,yerr,abstol,reltol,vectortol)
+
+!~~~> new step size is bounded by facmin <= hnew/h <= facmax
+ fac = min(facmax,max(facmin,facsafe/err**(one/ros_elo)))
+ hnew = h*fac
+
+!~~~> check the error magnitude and adjust step size
+ istatus(nstp) = istatus(nstp)+ 1
+ IF((err <= one).or.(h <= hmin))THEN !~~~> accept step
+ istatus(nacc) = istatus(nacc)+ 1
+ !slim: CALL wcopy(n,ynew,1,y,1)
+ y(1:n) = ynew(1:n)
+ t = t + direction*h
+ hnew = max(hmin,min(hnew,hmax))
+ IF (rejectlasth)THEN ! no step size increase after a rejected step
+ hnew = min(hnew,h)
+ ENDIF
+ rstatus(nhexit) = h
+ rstatus(nhnew) = hnew
+ rstatus(ntexit) = t
+ rejectlasth = .false.
+ rejectmoreh = .false.
+ h = hnew
+ exit untilaccepted ! exit the loop: WHILE step not accepted
+ ELSE !~~~> reject step
+ IF (rejectmoreh)THEN
+ hnew = h*facrej
+ ENDIF
+ rejectmoreh = rejectlasth
+ rejectlasth = .true.
+ h = hnew
+ IF (istatus(nacc)>= 1) istatus(nrej) = istatus(nrej)+ 1
+ ENDIF ! err <= 1
+
+ END DO untilaccepted
+
+ END DO timeloop
+
+!~~~> succesful exit
+ ierr = 1 !~~~> the integration was successful
+
+ END SUBROUTINE ros_integrator
+
+
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ REAL(kind=dp)FUNCTION ros_errornorm(y,ynew,yerr,&
+ abstol,reltol,vectortol)
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!~~~> computes the "scaled norm" of the error vector yerr
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+! Input arguments
+ REAL(kind=dp),INTENT(in):: y(n),ynew(n),&
+ yerr(n),abstol(n),reltol(n)
+ LOGICAL,INTENT(in):: vectortol
+! Local variables
+ REAL(kind=dp):: err,scale,ymax
+ INTEGER :: i
+ REAL(kind=dp),PARAMETER :: zero = 0.0_dp
+
+ err = zero
+ DO i=1,n
+ ymax = max(abs(y(i)),abs(ynew(i)))
+ IF (vectortol)THEN
+ scale = abstol(i)+ reltol(i)*ymax
+ ELSE
+ scale = abstol(1)+ reltol(1)*ymax
+ ENDIF
+ err = err+(yerr(i)/scale)**2
+ ENDDO
+ err = sqrt(err/n)
+
+ ros_errornorm = max(err,1.0d-10)
+
+ END FUNCTION ros_errornorm
+
+
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ SUBROUTINE ros_funtimederivative(t,roundoff,y,&
+ fcn0,dfdt)
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!~~~> the time partial derivative of the FUNCTION by finite differences
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+!~~~> input arguments
+ REAL(kind=dp),INTENT(in):: t,roundoff,y(n),fcn0(n)
+!~~~> output arguments
+ REAL(kind=dp),INTENT(out):: dfdt(n)
+!~~~> local variables
+ REAL(kind=dp):: delta
+ REAL(kind=dp),PARAMETER :: one = 1.0_dp, deltamin = 1.0e-6_dp
+
+ delta = sqrt(roundoff)*max(deltamin,abs(t))
+ CALL funtemplate(t+ delta,y,dfdt)
+ istatus(nfun) = istatus(nfun)+ 1
+ CALL waxpy(n,(- one),fcn0,1,dfdt,1)
+ CALL wscal(n,(one/delta),dfdt,1)
+
+ END SUBROUTINE ros_funtimederivative
+
+
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ SUBROUTINE ros_preparematrix(h,direction,gam,&
+ jac0,ghimj,pivot,singular)
+! --- --- --- --- --- --- --- --- --- --- --- --- ---
+! Prepares the LHS matrix for stage calculations
+! 1. Construct Ghimj = 1/(H*ham) - Jac0
+! "(Gamma H) Inverse Minus Jacobian"
+! 2. Repeat LU decomposition of Ghimj until successful.
+! -half the step size if LU decomposition fails and retry
+! -exit after 5 consecutive fails
+! --- --- --- --- --- --- --- --- --- --- --- --- ---
+
+!~~~> input arguments
+#ifdef full_algebra
+ REAL(kind=dp),INTENT(in):: jac0(n,n)
+#else
+ REAL(kind=dp),INTENT(in):: jac0(lu_nonzero)
+#endif
+ REAL(kind=dp),INTENT(in):: gam
+ INTEGER,INTENT(in):: direction
+!~~~> output arguments
+#ifdef full_algebra
+ REAL(kind=dp),INTENT(out):: ghimj(n,n)
+#else
+ REAL(kind=dp),INTENT(out):: ghimj(lu_nonzero)
+#endif
+ LOGICAL,INTENT(out):: singular
+ INTEGER,INTENT(out):: pivot(n)
+!~~~> inout arguments
+ REAL(kind=dp),INTENT(inout):: h ! step size is decreased when lu fails
+!~~~> local variables
+ INTEGER :: i,ising,nconsecutive
+ REAL(kind=dp):: ghinv
+ REAL(kind=dp),PARAMETER :: one = 1.0_dp, half = 0.5_dp
+
+ nconsecutive = 0
+ singular = .true.
+
+ DO WHILE (singular)
+
+!~~~> construct ghimj = 1/(h*gam)- jac0
+#ifdef full_algebra
+ !slim: CALL wcopy(n*n,jac0,1,ghimj,1)
+ !slim: CALL wscal(n*n,(- one),ghimj,1)
+ ghimj = - jac0
+ ghinv = one/(direction*h*gam)
+ DO i=1,n
+ ghimj(i,i) = ghimj(i,i)+ ghinv
+ ENDDO
+#else
+ !slim: CALL wcopy(lu_nonzero,jac0,1,ghimj,1)
+ !slim: CALL wscal(lu_nonzero,(- one),ghimj,1)
+ ghimj(1:lu_nonzero) = - jac0(1:lu_nonzero)
+ ghinv = one/(direction*h*gam)
+ DO i=1,n
+ ghimj(lu_diag(i)) = ghimj(lu_diag(i))+ ghinv
+ ENDDO
+#endif
+!~~~> compute lu decomposition
+ CALL ros_decomp( ghimj,pivot,ising)
+ IF (ising == 0)THEN
+!~~~> IF successful done
+ singular = .false.
+ ELSE ! ising .ne. 0
+!~~~> IF unsuccessful half the step size; IF 5 consecutive fails THEN RETURN
+ istatus(nsng) = istatus(nsng)+ 1
+ nconsecutive = nconsecutive+1
+ singular = .true.
+ PRINT*,'Warning: LU Decomposition returned ISING = ',ISING
+ IF (nconsecutive <= 5)THEN ! less than 5 consecutive failed decompositions
+ h = h*half
+ ELSE ! more than 5 consecutive failed decompositions
+ RETURN
+ ENDIF ! nconsecutive
+ ENDIF ! ising
+
+ END DO ! WHILE singular
+
+ END SUBROUTINE ros_preparematrix
+
+
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ SUBROUTINE ros_decomp( a,pivot,ising)
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+! Template for the LU decomposition
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!~~~> inout variables
+#ifdef full_algebra
+ REAL(kind=dp),INTENT(inout):: a(n,n)
+#else
+ REAL(kind=dp),INTENT(inout):: a(lu_nonzero)
+#endif
+!~~~> output variables
+ INTEGER,INTENT(out):: pivot(n),ising
+
+#ifdef full_algebra
+ CALL dgetrf( n,n,a,n,pivot,ising)
+#else
+ CALL kppdecomp(a,ising)
+ pivot(1) = 1
+#endif
+ istatus(ndec) = istatus(ndec)+ 1
+
+ END SUBROUTINE ros_decomp
+
+
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ SUBROUTINE ros_solve( a,pivot,b)
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+! Template for the forward/backward substitution (using pre-computed LU decomposition)
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!~~~> input variables
+#ifdef full_algebra
+ REAL(kind=dp),INTENT(in):: a(n,n)
+ INTEGER :: ising
+#else
+ REAL(kind=dp),INTENT(in):: a(lu_nonzero)
+#endif
+ INTEGER,INTENT(in):: pivot(n)
+!~~~> inout variables
+ REAL(kind=dp),INTENT(inout):: b(n)
+
+#ifdef full_algebra
+ CALL DGETRS( 'N',N ,1,A,N,Pivot,b,N,ISING)
+ IF(info < 0)THEN
+ print*,"error in dgetrs. ising=",ising
+ ENDIF
+#else
+ CALL kppsolve( a,b)
+#endif
+
+ istatus(nsol) = istatus(nsol)+ 1
+
+ END SUBROUTINE ros_solve
+
+
+
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ SUBROUTINE ros2
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+! --- AN L-STABLE METHOD,2 stages,order 2
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+ double precision g
+
+ g = 1.0_dp + 1.0_dp/sqrt(2.0_dp)
+ rosmethod = rs2
+!~~~> name of the method
+ ros_Name = 'ROS-2'
+!~~~> number of stages
+ ros_s = 2
+
+!~~~> the coefficient matrices a and c are strictly lower triangular.
+! The lower triangular (subdiagonal) elements are stored in row-wise order:
+! A(2,1) = ros_A(1),A(3,1) =ros_A(2),A(3,2) =ros_A(3),etc.
+! The general mapping formula is:
+! A(i,j) = ros_A( (i-1)*(i-2)/2 + j)
+! C(i,j) = ros_C( (i-1)*(i-2)/2 + j)
+
+ ros_a(1) = (1.0_dp)/g
+ ros_c(1) = (- 2.0_dp)/g
+!~~~> does the stage i require a new FUNCTION evaluation (ros_newf(i) =true)
+! or does it re-use the function evaluation from stage i-1 (ros_NewF(i) =FALSE)
+ ros_newf(1) = .true.
+ ros_newf(2) = .true.
+!~~~> m_i = coefficients for new step solution
+ ros_m(1) = (3.0_dp)/(2.0_dp*g)
+ ros_m(2) = (1.0_dp)/(2.0_dp*g)
+! E_i = Coefficients for error estimator
+ ros_e(1) = 1.0_dp/(2.0_dp*g)
+ ros_e(2) = 1.0_dp/(2.0_dp*g)
+!~~~> ros_elo = estimator of local order - the minimum between the
+! main and the embedded scheme orders plus one
+ ros_elo = 2.0_dp
+!~~~> y_stage_i ~ y( t + h*alpha_i)
+ ros_alpha(1) = 0.0_dp
+ ros_alpha(2) = 1.0_dp
+!~~~> gamma_i = \sum_j gamma_{i,j}
+ ros_gamma(1) = g
+ ros_gamma(2) =- g
+
+ END SUBROUTINE ros2
+
+
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ SUBROUTINE ros3
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+! --- AN L-STABLE METHOD,3 stages,order 3,2 function evaluations
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+ rosmethod = rs3
+!~~~> name of the method
+ ros_Name = 'ROS-3'
+!~~~> number of stages
+ ros_s = 3
+
+!~~~> the coefficient matrices a and c are strictly lower triangular.
+! The lower triangular (subdiagonal) elements are stored in row-wise order:
+! A(2,1) = ros_A(1),A(3,1) =ros_A(2),A(3,2) =ros_A(3),etc.
+! The general mapping formula is:
+! A(i,j) = ros_A( (i-1)*(i-2)/2 + j)
+! C(i,j) = ros_C( (i-1)*(i-2)/2 + j)
+
+ ros_a(1) = 1.0_dp
+ ros_a(2) = 1.0_dp
+ ros_a(3) = 0.0_dp
+
+ ros_c(1) = - 0.10156171083877702091975600115545e+01_dp
+ ros_c(2) = 0.40759956452537699824805835358067e+01_dp
+ ros_c(3) = 0.92076794298330791242156818474003e+01_dp
+!~~~> does the stage i require a new FUNCTION evaluation (ros_newf(i) =true)
+! or does it re-use the function evaluation from stage i-1 (ros_NewF(i) =FALSE)
+ ros_newf(1) = .true.
+ ros_newf(2) = .true.
+ ros_newf(3) = .false.
+!~~~> m_i = coefficients for new step solution
+ ros_m(1) = 0.1e+01_dp
+ ros_m(2) = 0.61697947043828245592553615689730e+01_dp
+ ros_m(3) = - 0.42772256543218573326238373806514_dp
+! E_i = Coefficients for error estimator
+ ros_e(1) = 0.5_dp
+ ros_e(2) = - 0.29079558716805469821718236208017e+01_dp
+ ros_e(3) = 0.22354069897811569627360909276199_dp
+!~~~> ros_elo = estimator of local order - the minimum between the
+! main and the embedded scheme orders plus 1
+ ros_elo = 3.0_dp
+!~~~> y_stage_i ~ y( t + h*alpha_i)
+ ros_alpha(1) = 0.0_dp
+ ros_alpha(2) = 0.43586652150845899941601945119356_dp
+ ros_alpha(3) = 0.43586652150845899941601945119356_dp
+!~~~> gamma_i = \sum_j gamma_{i,j}
+ ros_gamma(1) = 0.43586652150845899941601945119356_dp
+ ros_gamma(2) = 0.24291996454816804366592249683314_dp
+ ros_gamma(3) = 0.21851380027664058511513169485832e+01_dp
+
+ END SUBROUTINE ros3
+
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ SUBROUTINE ros4
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+! L-STABLE ROSENBROCK METHOD OF ORDER 4,WITH 4 STAGES
+! L-STABLE EMBEDDED ROSENBROCK METHOD OF ORDER 3
+!
+! E. HAIRER AND G. WANNER,SOLVING ORDINARY DIFFERENTIAL
+! EQUATIONS II. STIFF AND DIFFERENTIAL-ALGEBRAIC PROBLEMS.
+! SPRINGER SERIES IN COMPUTATIONAL MATHEMATICS,
+! SPRINGER-VERLAG (1990)
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+ rosmethod = rs4
+!~~~> name of the method
+ ros_Name = 'ROS-4'
+!~~~> number of stages
+ ros_s = 4
+
+!~~~> the coefficient matrices a and c are strictly lower triangular.
+! The lower triangular (subdiagonal) elements are stored in row-wise order:
+! A(2,1) = ros_A(1),A(3,1) =ros_A(2),A(3,2) =ros_A(3),etc.
+! The general mapping formula is:
+! A(i,j) = ros_A( (i-1)*(i-2)/2 + j)
+! C(i,j) = ros_C( (i-1)*(i-2)/2 + j)
+
+ ros_a(1) = 0.2000000000000000e+01_dp
+ ros_a(2) = 0.1867943637803922e+01_dp
+ ros_a(3) = 0.2344449711399156_dp
+ ros_a(4) = ros_a(2)
+ ros_a(5) = ros_a(3)
+ ros_a(6) = 0.0_dp
+
+ ros_c(1) =- 0.7137615036412310e+01_dp
+ ros_c(2) = 0.2580708087951457e+01_dp
+ ros_c(3) = 0.6515950076447975_dp
+ ros_c(4) =- 0.2137148994382534e+01_dp
+ ros_c(5) =- 0.3214669691237626_dp
+ ros_c(6) =- 0.6949742501781779_dp
+!~~~> does the stage i require a new FUNCTION evaluation (ros_newf(i) =true)
+! or does it re-use the function evaluation from stage i-1 (ros_NewF(i) =FALSE)
+ ros_newf(1) = .true.
+ ros_newf(2) = .true.
+ ros_newf(3) = .true.
+ ros_newf(4) = .false.
+!~~~> m_i = coefficients for new step solution
+ ros_m(1) = 0.2255570073418735e+01_dp
+ ros_m(2) = 0.2870493262186792_dp
+ ros_m(3) = 0.4353179431840180_dp
+ ros_m(4) = 0.1093502252409163e+01_dp
+!~~~> e_i = coefficients for error estimator
+ ros_e(1) =- 0.2815431932141155_dp
+ ros_e(2) =- 0.7276199124938920e-01_dp
+ ros_e(3) =- 0.1082196201495311_dp
+ ros_e(4) =- 0.1093502252409163e+01_dp
+!~~~> ros_elo = estimator of local order - the minimum between the
+! main and the embedded scheme orders plus 1
+ ros_elo = 4.0_dp
+!~~~> y_stage_i ~ y( t + h*alpha_i)
+ ros_alpha(1) = 0.0_dp
+ ros_alpha(2) = 0.1145640000000000e+01_dp
+ ros_alpha(3) = 0.6552168638155900_dp
+ ros_alpha(4) = ros_alpha(3)
+!~~~> gamma_i = \sum_j gamma_{i,j}
+ ros_gamma(1) = 0.5728200000000000_dp
+ ros_gamma(2) =- 0.1769193891319233e+01_dp
+ ros_gamma(3) = 0.7592633437920482_dp
+ ros_gamma(4) =- 0.1049021087100450_dp
+
+ END SUBROUTINE ros4
+
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ SUBROUTINE rodas3
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+! --- A STIFFLY-STABLE METHOD,4 stages,order 3
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+ rosmethod = rd3
+!~~~> name of the method
+ ros_Name = 'RODAS-3'
+!~~~> number of stages
+ ros_s = 4
+
+!~~~> the coefficient matrices a and c are strictly lower triangular.
+! The lower triangular (subdiagonal) elements are stored in row-wise order:
+! A(2,1) = ros_A(1),A(3,1) =ros_A(2),A(3,2) =ros_A(3),etc.
+! The general mapping formula is:
+! A(i,j) = ros_A( (i-1)*(i-2)/2 + j)
+! C(i,j) = ros_C( (i-1)*(i-2)/2 + j)
+
+ ros_a(1) = 0.0_dp
+ ros_a(2) = 2.0_dp
+ ros_a(3) = 0.0_dp
+ ros_a(4) = 2.0_dp
+ ros_a(5) = 0.0_dp
+ ros_a(6) = 1.0_dp
+
+ ros_c(1) = 4.0_dp
+ ros_c(2) = 1.0_dp
+ ros_c(3) =- 1.0_dp
+ ros_c(4) = 1.0_dp
+ ros_c(5) =- 1.0_dp
+ ros_c(6) =- (8.0_dp/3.0_dp)
+
+!~~~> does the stage i require a new FUNCTION evaluation (ros_newf(i) =true)
+! or does it re-use the function evaluation from stage i-1 (ros_NewF(i) =FALSE)
+ ros_newf(1) = .true.
+ ros_newf(2) = .false.
+ ros_newf(3) = .true.
+ ros_newf(4) = .true.
+!~~~> m_i = coefficients for new step solution
+ ros_m(1) = 2.0_dp
+ ros_m(2) = 0.0_dp
+ ros_m(3) = 1.0_dp
+ ros_m(4) = 1.0_dp
+!~~~> e_i = coefficients for error estimator
+ ros_e(1) = 0.0_dp
+ ros_e(2) = 0.0_dp
+ ros_e(3) = 0.0_dp
+ ros_e(4) = 1.0_dp
+!~~~> ros_elo = estimator of local order - the minimum between the
+! main and the embedded scheme orders plus 1
+ ros_elo = 3.0_dp
+!~~~> y_stage_i ~ y( t + h*alpha_i)
+ ros_alpha(1) = 0.0_dp
+ ros_alpha(2) = 0.0_dp
+ ros_alpha(3) = 1.0_dp
+ ros_alpha(4) = 1.0_dp
+!~~~> gamma_i = \sum_j gamma_{i,j}
+ ros_gamma(1) = 0.5_dp
+ ros_gamma(2) = 1.5_dp
+ ros_gamma(3) = 0.0_dp
+ ros_gamma(4) = 0.0_dp
+
+ END SUBROUTINE rodas3
+
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ SUBROUTINE rodas4
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+! STIFFLY-STABLE ROSENBROCK METHOD OF ORDER 4,WITH 6 STAGES
+!
+! E. HAIRER AND G. WANNER,SOLVING ORDINARY DIFFERENTIAL
+! EQUATIONS II. STIFF AND DIFFERENTIAL-ALGEBRAIC PROBLEMS.
+! SPRINGER SERIES IN COMPUTATIONAL MATHEMATICS,
+! SPRINGER-VERLAG (1996)
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+ rosmethod = rd4
+!~~~> name of the method
+ ros_Name = 'RODAS-4'
+!~~~> number of stages
+ ros_s = 6
+
+!~~~> y_stage_i ~ y( t + h*alpha_i)
+ ros_alpha(1) = 0.000_dp
+ ros_alpha(2) = 0.386_dp
+ ros_alpha(3) = 0.210_dp
+ ros_alpha(4) = 0.630_dp
+ ros_alpha(5) = 1.000_dp
+ ros_alpha(6) = 1.000_dp
+
+!~~~> gamma_i = \sum_j gamma_{i,j}
+ ros_gamma(1) = 0.2500000000000000_dp
+ ros_gamma(2) =- 0.1043000000000000_dp
+ ros_gamma(3) = 0.1035000000000000_dp
+ ros_gamma(4) =- 0.3620000000000023e-01_dp
+ ros_gamma(5) = 0.0_dp
+ ros_gamma(6) = 0.0_dp
+
+!~~~> the coefficient matrices a and c are strictly lower triangular.
+! The lower triangular (subdiagonal) elements are stored in row-wise order:
+! A(2,1) = ros_A(1),A(3,1) =ros_A(2),A(3,2) =ros_A(3),etc.
+! The general mapping formula is: A(i,j) = ros_A( (i-1)*(i-2)/2 + j)
+! C(i,j) = ros_C( (i-1)*(i-2)/2 + j)
+
+ ros_a(1) = 0.1544000000000000e+01_dp
+ ros_a(2) = 0.9466785280815826_dp
+ ros_a(3) = 0.2557011698983284_dp
+ ros_a(4) = 0.3314825187068521e+01_dp
+ ros_a(5) = 0.2896124015972201e+01_dp
+ ros_a(6) = 0.9986419139977817_dp
+ ros_a(7) = 0.1221224509226641e+01_dp
+ ros_a(8) = 0.6019134481288629e+01_dp
+ ros_a(9) = 0.1253708332932087e+02_dp
+ ros_a(10) =- 0.6878860361058950_dp
+ ros_a(11) = ros_a(7)
+ ros_a(12) = ros_a(8)
+ ros_a(13) = ros_a(9)
+ ros_a(14) = ros_a(10)
+ ros_a(15) = 1.0_dp
+
+ ros_c(1) =- 0.5668800000000000e+01_dp
+ ros_c(2) =- 0.2430093356833875e+01_dp
+ ros_c(3) =- 0.2063599157091915_dp
+ ros_c(4) =- 0.1073529058151375_dp
+ ros_c(5) =- 0.9594562251023355e+01_dp
+ ros_c(6) =- 0.2047028614809616e+02_dp
+ ros_c(7) = 0.7496443313967647e+01_dp
+ ros_c(8) =- 0.1024680431464352e+02_dp
+ ros_c(9) =- 0.3399990352819905e+02_dp
+ ros_c(10) = 0.1170890893206160e+02_dp
+ ros_c(11) = 0.8083246795921522e+01_dp
+ ros_c(12) =- 0.7981132988064893e+01_dp
+ ros_c(13) =- 0.3152159432874371e+02_dp
+ ros_c(14) = 0.1631930543123136e+02_dp
+ ros_c(15) =- 0.6058818238834054e+01_dp
+
+!~~~> m_i = coefficients for new step solution
+ ros_m(1) = ros_a(7)
+ ros_m(2) = ros_a(8)
+ ros_m(3) = ros_a(9)
+ ros_m(4) = ros_a(10)
+ ros_m(5) = 1.0_dp
+ ros_m(6) = 1.0_dp
+
+!~~~> e_i = coefficients for error estimator
+ ros_e(1) = 0.0_dp
+ ros_e(2) = 0.0_dp
+ ros_e(3) = 0.0_dp
+ ros_e(4) = 0.0_dp
+ ros_e(5) = 0.0_dp
+ ros_e(6) = 1.0_dp
+
+!~~~> does the stage i require a new FUNCTION evaluation (ros_newf(i) =true)
+! or does it re-use the function evaluation from stage i-1 (ros_NewF(i) =FALSE)
+ ros_newf(1) = .true.
+ ros_newf(2) = .true.
+ ros_newf(3) = .true.
+ ros_newf(4) = .true.
+ ros_newf(5) = .true.
+ ros_newf(6) = .true.
+
+!~~~> ros_elo = estimator of local order - the minimum between the
+! main and the embedded scheme orders plus 1
+ ros_elo = 4.0_dp
+
+ END SUBROUTINE rodas4
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ SUBROUTINE rang3
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+! STIFFLY-STABLE W METHOD OF ORDER 3,WITH 4 STAGES
+!
+! J. RANG and L. ANGERMANN
+! NEW ROSENBROCK W-METHODS OF ORDER 3
+! FOR PARTIAL DIFFERENTIAL ALGEBRAIC
+! EQUATIONS OF INDEX 1
+! BIT Numerical Mathematics (2005) 45: 761-787
+! DOI: 10.1007/s10543-005-0035-y
+! Table 4.1-4.2
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+ rosmethod = rg3
+!~~~> name of the method
+ ros_Name = 'RANG-3'
+!~~~> number of stages
+ ros_s = 4
+
+ ros_a(1) = 5.09052051067020d+00;
+ ros_a(2) = 5.09052051067020d+00;
+ ros_a(3) = 0.0d0;
+ ros_a(4) = 4.97628111010787d+00;
+ ros_a(5) = 2.77268164715849d-02;
+ ros_a(6) = 2.29428036027904d-01;
+
+ ros_c(1) = - 1.16790812312283d+01;
+ ros_c(2) = - 1.64057326467367d+01;
+ ros_c(3) = - 2.77268164715850d-01;
+ ros_c(4) = - 8.38103960500476d+00;
+ ros_c(5) = - 8.48328409199343d-01;
+ ros_c(6) = 2.87009860433106d-01;
+
+ ros_m(1) = 5.22582761233094d+00;
+ ros_m(2) = - 5.56971148154165d-01;
+ ros_m(3) = 3.57979469353645d-01;
+ ros_m(4) = 1.72337398521064d+00;
+
+ ros_e(1) = - 5.16845212784040d+00;
+ ros_e(2) = - 1.26351942603842d+00;
+ ros_e(3) = - 1.11022302462516d-16;
+ ros_e(4) = 2.22044604925031d-16;
+
+ ros_alpha(1) = 0.0d00;
+ ros_alpha(2) = 2.21878746765329d+00;
+ ros_alpha(3) = 2.21878746765329d+00;
+ ros_alpha(4) = 1.55392337535788d+00;
+
+ ros_gamma(1) = 4.35866521508459d-01;
+ ros_gamma(2) = - 1.78292094614483d+00;
+ ros_gamma(3) = - 2.46541900496934d+00;
+ ros_gamma(4) = - 8.05529997906370d-01;
+
+
+!~~~> does the stage i require a new FUNCTION evaluation (ros_newf(i) =true)
+! or does it re-use the function evaluation from stage i-1 (ros_NewF(i) =FALSE)
+ ros_newf(1) = .true.
+ ros_newf(2) = .true.
+ ros_newf(3) = .true.
+ ros_newf(4) = .true.
+
+!~~~> ros_elo = estimator of local order - the minimum between the
+! main and the embedded scheme orders plus 1
+ ros_elo = 3.0_dp
+
+ END SUBROUTINE rang3
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+! End of the set of internal Rosenbrock subroutines
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+END SUBROUTINE rosenbrock
+
+SUBROUTINE funtemplate( t,y,ydot)
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+! Template for the ODE function call.
+! Updates the rate coefficients (and possibly the fixed species) at each call
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!~~~> input variables
+ REAL(kind=dp):: t,y(nvar)
+!~~~> output variables
+ REAL(kind=dp):: ydot(nvar)
+!~~~> local variables
+ REAL(kind=dp):: told
+
+ told = time
+ time = t
+ CALL fun( y,fix,rconst,ydot)
+ time = told
+
+END SUBROUTINE funtemplate
+
+SUBROUTINE jactemplate( t,y,jcb)
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+! Template for the ODE Jacobian call.
+! Updates the rate coefficients (and possibly the fixed species) at each call
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!~~~> input variables
+ REAL(kind=dp):: t,y(nvar)
+!~~~> output variables
+#ifdef full_algebra
+ REAL(kind=dp):: jv(lu_nonzero),jcb(nvar,nvar)
+#else
+ REAL(kind=dp):: jcb(lu_nonzero)
+#endif
+!~~~> local variables
+ REAL(kind=dp):: told
+#ifdef full_algebra
+ INTEGER :: i,j
+#endif
+
+ told = time
+ time = t
+#ifdef full_algebra
+ CALL jac_sp(y,fix,rconst,jv)
+ DO j=1,nvar
+ DO i=1,nvar
+ jcb(i,j) = 0.0_dp
+ ENDDO
+ ENDDO
+ DO i=1,lu_nonzero
+ jcb(lu_irow(i),lu_icol(i)) = jv(i)
+ ENDDO
+#else
+ CALL jac_sp( y,fix,rconst,jcb)
+#endif
+ time = told
+
+END SUBROUTINE jactemplate
+
+SUBROUTINE chem_gasphase_integrate (time_step_len,conc,tempk,photo,ierrf,xnacc,xnrej,istatus,l_debug,pe)
+
+ IMPLICIT NONE
+
+ REAL(dp), INTENT(IN) :: time_step_len
+ REAL(dp), DIMENSION(:,:), INTENT(INOUT) :: conc
+ REAL(dp), DIMENSION(:,:), INTENT(INOUT) :: photo
+ REAL(dp), DIMENSION(:), INTENT(IN) :: tempk
+ INTEGER, INTENT(OUT), OPTIONAL :: ierrf(:)
+ INTEGER, INTENT(OUT), OPTIONAL :: xnacc(:)
+ INTEGER, INTENT(OUT), OPTIONAL :: xnrej(:)
+ INTEGER, INTENT(INOUT), OPTIONAL :: istatus(:)
+ INTEGER, INTENT(IN), OPTIONAL :: pe
+ LOGICAL, INTENT(IN), OPTIONAL :: l_debug
+
+ INTEGER :: k ! loop variable
+ REAL(dp) :: dt
+ INTEGER, DIMENSION(20) :: istatus_u
+ INTEGER :: ierr_u
+
+
+ if (present (istatus)) istatus = 0
+
+ DO k=1,vl_glo,vl_dim
+ is = k
+ ie = min(k+vl_dim-1,vl_glo)
+ vl = ie-is+1
+
+ c(:) = conc(is,:)
+
+ temp = tempk(is)
+
+ phot(:) = photo(is,:)
+
+ CALL update_rconst
+
+ dt = time_step_len
+
+ ! integrate from t=0 to t=dt
+ CALL integrate(0._dp, dt,icntrl,rcntrl,istatus_u = istatus_u,ierr_u=ierr_u)
+
+
+ IF (PRESENT(l_debug) .AND. PRESENT(pe)) THEN
+ IF (l_debug) CALL error_output(conc(is,:),ierr_u,pe)
+ ENDIF
+ conc(is,:) = c(:)
+
+ ! Return Diagnostic Information
+
+ if(PRESENT(ierrf)) ierrf(is) = ierr_u
+ if(PRESENT(xnacc)) xnacc(is) = istatus_u(4)
+ if(PRESENT(xnrej)) xnrej(is) = istatus_u(5)
+
+ if (PRESENT (istatus)) then
+ istatus(1:8) = istatus(1:8) + istatus_u(1:8)
+ ENDIF
+
+ END DO
+
+
+! Deallocate input arrays
+
+ if (ALLOCATED(temp)) DEALLOCATE(temp)
+
+ data_loaded = .false.
+
+ RETURN
+END SUBROUTINE chem_gasphase_integrate
+
+ SUBROUTINE fill_temp(status,array)
+
+ INTEGER, INTENT(OUT) :: status
+ REAL(dp), INTENT(IN), DIMENSION(:) :: array
+
+ status = 0
+ IF (.not. ALLOCATED(temp)) &
+ ALLOCATE(temp(size(array)))
+
+ IF (data_loaded .AND. (vl_glo /= size(array,1))) THEN
+ status = 1
+ RETURN
+ END IF
+
+ vl_glo = size(array,1)
+ temp = array
+ data_loaded = .TRUE.
+
+ RETURN
+
+ END SUBROUTINE fill_temp
+
+END MODULE chem_gasphase_mod
+
Index: palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_salsa+simple/chem_gasphase_mod.kpp
===================================================================
--- palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_salsa+simple/chem_gasphase_mod.kpp (revision 3582)
+++ palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_salsa+simple/chem_gasphase_mod.kpp (revision 3582)
@@ -0,0 +1,45 @@
+//chem_gasphase_mod.kpp
+//
+// Current revision
+// forkel 20.04.2018: added F90_INIT for initialization of fix compounds
+//
+//
+//Former revisions
+//----------------
+// $Id: chem_gasphase_mod.kpp 2459 2017-09-13 14:10:33Z forkel $
+//
+#include salsa+simple.spc
+#include salsa+simple.eqn
+#INTEGRATOR rosenbrock
+#LANGUAGE Fortran90
+#HESSIAN on
+#STOICMAT on
+#INLINE F90_GLOBAL
+! QVAP - Water vapor
+ REAL(dp) :: qvap
+! FAKT - Conversion factor
+ REAL(dp) :: fakt
+! Declaration of global variable declarations for photolysis will come from INLINE F90_DATA
+#ENDINLINE
+//
+// *******************************************************************************************
+// *** adapt the lines below occurding to the photolysis reactions of your mechanism *
+// *** adapt the number of photolysis frequencies NPHO *
+// *** adapt/extend the indices in the INTEGER, PARAMETER,PUBLIC statement below *
+// *** adapt/extend PHOT_NAMES: Note that the order of PHOT_NAMES and the indices must match *
+// *******************************************************************************************
+//
+#INLINE F90_DATA
+ ! INLINE F90_DATA: Declaration of global variables for photolysis
+ ! REAL(kind=dp) :: phot(nphot) must eventually be moved to GLOBAL later for vector version
+ INTEGER, PARAMETER :: nphot = 2
+ ! phot Photolysis frequencies
+ REAL(kind=dp) :: phot(nphot)
+
+ INTEGER, PARAMETER,PUBLIC :: j_no2 = 1
+ INTEGER, PARAMETER,PUBLIC :: j_o31d = 2
+
+ CHARACTER(LEN=15), PARAMETER, DIMENSION(NPHOT) :: phot_names = (/ &
+ 'J_NO2 ','J_O31D '/)
+#ENDINLINE
+
Index: palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_salsa+simple/salsa+simple.eqn
===================================================================
--- palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_salsa+simple/salsa+simple.eqn (revision 3582)
+++ palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_salsa+simple/salsa+simple.eqn (revision 3582)
@@ -0,0 +1,22 @@
+{salsa+simple.eqn
+Current revision
+----------------
+ 20180903 Added SALSA variables monakurppa
+ 201711 Created simple.eqn with 6 equations forkel
+ 20180316 Added equation no. 7 forkel
+}
+#EQUATIONS
+
+{ simplified smog (by forkel) and salsa variables }
+
+ { 1.} NO2 + hv = NO + O3 : phot(j_no2);
+ { 2.} O3 + hv = 2OH + O2 : phot(j_o31d);
+ { 3.} NO + O3 = NO2 : arr2(1.80E-12_dp, 1370.0_dp, temp);
+ { 4.} RH + OH = RO2 + H2O : arr2(2.00E-11_dp, 500.0_dp, temp);
+ { 5.} RO2 + NO = NO2 + RCHO + HO2 : arr2(4.20E-12_dp, -180.0_dp, temp);
+ { 6.} HO2 + NO = NO2 + OH : arr2(3.70E-12_dp, -240.0_dp, temp);
+ { 7.} NO2 + OH = HNO3 : arr2(1.15E-11_dp, 0.0_dp, temp);
+ { 8.} H2SO4 = H2SO4 : 1.0_dp;
+ { 9.} NH3 = NH3 : 1.0_dp;
+ { 10.} OCNV = OCNV : 1.0_dp;
+ { 11.} OCSV = OCSV : 1.0_dp;
Index: palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_salsa+simple/salsa+simple.spc
===================================================================
--- palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_salsa+simple/salsa+simple.spc (revision 3582)
+++ palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_salsa+simple/salsa+simple.spc (revision 3582)
@@ -0,0 +1,50 @@
+{salsa+simple.spc
+Current revision
+----------------
+ 20180903 Added SALSA variables monakurppa
+Former revisions
+----------------
+ $Id: smog.spc 2459 2017-09-13 14:10:33Z forkel $
+}
+#include atoms
+
+ #DEFVAR
+ O = O ; {oxygen atomic ground state (3P)}
+ O3 = 3O ; {ozone}
+ NO = N + O ; {nitric oxide}
+ NO2 = N + 2O ; {nitrogen dioxide}
+ NO3 = N + 3O ; {nitrogen trioxide}
+ N2O5 = 2N + 5O ; {dinitrogen pentoxide}
+ HNO3 = H + N + 3O ; { nitric acid }
+ HNO4 = H + N + 4O ; {HO2NO2 pernitric acid}
+ H = H ; {hydrogen atomic ground state (2S)}
+ OH = O + H ; {hydroxyl radical}
+ HO2 = H + 2O ; {perhydroxyl radical}
+ H2O2 = 2H + 2O ; {hydrogen peroxide}
+ CH3 = C + 3H ; {methyl radical}
+ CH3O = C + 3H + O ; {methoxy radical}
+ CH3O2 = C + 3H + 2O ; {methylperoxy radical}
+ CH3OOH = C + 4H + 2O ; {CH4O2 methylperoxy alcohol}
+ HCO = H + C + O ; {CHO formyl radical}
+ CH2O = C + 2H + O ; {formalydehyde}
+ CO = C + O ; {carbon monoxide}
+
+ RH = ignore ; {alkanes}
+ RO2 = ignore ; {alkyl peroxy radical}
+ RCHO = ignore ; {carbonyl}
+ RCOO2 = ignore ;
+ RCOO2NO2= ignore ;
+
+ H2SO4 = 2H + S +4O ; {sulfuric acid}
+ NH3 = 3H + N ; {ammonia}
+ OCNV = ignore ; {non-volatile OC}
+ OCSV = ignore ; {semi-volatile OC}
+
+#DEFFIX
+ H2O = H + 2O ; {water}
+ H2 = 2H ; {molecular hydrogen}
+ O2 = 2O ; {molecular oxygen}
+ N2 = 2N ; {molecular nitrogen}
+ CH4 = C + 4H ; {methane}
+ CO2 = C + 2O ; {carbon dioxide}
+
Index: palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_salsagas/chem_gasphase_mod.kpp
===================================================================
--- palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_salsagas/chem_gasphase_mod.kpp (revision 3582)
+++ palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_salsagas/chem_gasphase_mod.kpp (revision 3582)
@@ -0,0 +1,36 @@
+//chem_gasphase_mod.kpp
+//
+//Former revisions
+//----------------
+// $Id: chem_gasphase_mod.kpp 2459 2017-09-13 14:10:33Z forkel $
+//
+#include salsagas.spc
+#include salsagas.eqn
+#INTEGRATOR rosenbrock
+#LANGUAGE Fortran90
+#HESSIAN on
+#STOICMAT on
+#INLINE F90_GLOBAL
+ ! Declaration of global variable declarations for photolysis will come from INLINE F90_DATA
+#ENDINLINE
+//
+// *******************************************************************************************
+// *** adapt the lines below occurding to the photolysis reactions of your mechanism *
+// *** adapt the number of photolysis frequencies NPHO *
+// *** adapt/extend the indices in the INTEGER, PARAMETER,PUBLIC statement below *
+// *** adapt/extend PHOT_NAMES: Note that the order of PHOT_NAMES and the indices must match *
+// *******************************************************************************************
+//
+#INLINE F90_DATA
+ ! INLINE F90_DATA: Declaration of global variables for photolysis
+ ! REAL(kind=dp) :: phot(nphot) must eventually be moved to GLOBAL later for vector version
+ INTEGER, PARAMETER :: nphot = 1
+ ! phot Photolysis frequencies
+ REAL(kind=dp) :: phot(nphot)
+
+ INTEGER, PARAMETER,PUBLIC :: j_no2 = 1
+
+ CHARACTER(LEN=15), PARAMETER, DIMENSION(NPHOT) :: phot_names = (/ &
+ 'J_NO2 '/)
+#ENDINLINE
+
Index: palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_salsagas/salsagas.eqn
===================================================================
--- palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_salsagas/salsagas.eqn (revision 3582)
+++ palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_salsagas/salsagas.eqn (revision 3582)
@@ -0,0 +1,13 @@
+{salsagas.eqn
+Former revisions
+----------------
+ $Id$
+}
+#EQUATIONS
+
+{ passive: does nothing }
+ { 1.} H2SO4 = H2SO4 : 1.0_dp ;
+ { 2.} HNO3 = HNO3 : 1.0_dp ;
+ { 3.} NH3 = NH3 : 1.0_dp ;
+ { 4.} OCNV = OCNV : 1.0_dp ;
+ { 5.} OCSV = OCSV : 1.0_dp ;
Index: palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_salsagas/salsagas.spc
===================================================================
--- palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_salsagas/salsagas.spc (revision 3582)
+++ palm/trunk/UTIL/chemistry/gasphase_preproc/mechanisms/def_salsagas/salsagas.spc (revision 3582)
@@ -0,0 +1,22 @@
+{salsagas.spc
+Former revisions
+----------------
+ $Id$
+}
+#include atoms
+
+ #DEFVAR
+ HNO3 = H + N + 3O ; { nitric acid }
+ H2SO4 = 2H + S +4O ; {sulfuric acid}
+ NH3 = 3H + N ; {ammonia}
+ OCNV = ignore ; {non-volatile OC}
+ OCSV = ignore ; {semi-volatile OC}
+
+#DEFFIX
+ H2O = H + 2O ; {water}
+ H2 = 2H ; {molecular hydrogen}
+ O2 = 2O ; {molecular oxygen}
+ N2 = 2N ; {molecular nitrogen}
+ CH4 = C + 4H ; {methane}
+ CO2 = C + 2O ; {carbon dioxide}
+