module sfx_run !< @brief sfx driver ! directives list ! -------------------------------------------------------------------------------- implicit none private ! -------------------------------------------------------------------------------- ! public interface ! -------------------------------------------------------------------------------- public :: set_run public :: run_dataset ! -------------------------------------------------------------------------------- contains !> @brief run sfx on dataset ! ---------------------------------------------------------------------------- subroutine run_dataset(filename_out, dataset, model, ierr) ! modules used ! -------------------------------------------------------------------------------- use sfx_phys_const use sfx_common use sfx_config use sfx_surface use sfx_io use sfx_data use sfx_esm, only: & get_surface_fluxes_vec_esm => get_surface_fluxes_vec, & numericsType_esm => numericsType use sfx_log, only: & get_surface_fluxes_vec_log => get_surface_fluxes_vec, & numericsType_log => numericsType use sfx_most, only: & get_surface_fluxes_vec_most => get_surface_fluxes_vec, & numericsType_most => numericsType use sfx_sheba, only: & get_surface_fluxes_vec_sheba => get_surface_fluxes_vec, & numericsType_sheba => numericsType use sfx_sheba_noniterative, only: & get_surface_fluxes_vec_sheba_noit => get_surface_fluxes_vec, & numericsType_sheba_noit => numericsType use sfx_most_snow, only: & get_surface_fluxes_vec_most_snow => get_surface_fluxes_vec, & numericsType_most_snow => numericsType ! -------------------------------------------------------------------------------- character(len=*), intent(in) :: filename_out type(sfxDatasetType), intent(in) :: dataset integer, intent(in) :: model integer, intent(out) :: ierr ! input/output model data ! -------------------------------------------------------------------------------- type(meteoDataVecType) :: meteo !< meteorological data (input) type(meteoDataType) :: meteo_cell type(sfxDataVecType) :: sfx !< surface fluxes (output) type(numericsType_esm) :: numerics_esm !< surface flux module (ESM) numerics parameters type(numericsType_log) :: numerics_log !< surface flux module (LOG) numerics parameters type(numericsType_most) :: numerics_most !< surface flux module (MOST) numerics parameters type(numericsType_sheba) :: numerics_sheba !< surface flux module (SHEBA) numerics parameters type(numericsType_sheba_noit) :: numerics_sheba_noit !< surface flux module (SHEBA) numerics parameters type(numericsType_most_snow) :: numerics_most_snow !< surface flux module (MOST_SNOW) numerics parameters integer :: num !< number of 'cells' in input ! -------------------------------------------------------------------------------- ! local variables ! -------------------------------------------------------------------------------- integer :: i integer :: io, status ! -------------------------------------------------------------------------------- ierr = 0 ! = OK write(*, *) ' Running SFX:' write(*, '(a,a)') ' model = ', trim(get_model_tag(model)) write(*, '(a,a)') ' dataset = ', trim(get_dataset_tag(dataset%id)) write(*, '(a,a)') ' filename[IN] = ', trim(dataset%filename) write(*, '(a,a)') ' filename[OUT] = ', trim(filename_out) write(*, '(a,g0)') ' surface type = ', trim(get_surface_tag(dataset%surface)) write(*, '(a,g0)') ' h = ', dataset%h write(*, '(a,g0)') ' z0(m) = ', dataset%z0_m write(*, '(a,g0)') ' z0(h) = ', dataset%z0_h write(*, '(a,g0)') ' lai = ', dataset%lai write(*, '(a,g0)') ' depth = ', dataset%depth write(*, '(a,g0)') ' surface_type = ', dataset%surface_type ! --- define number of elements open(newunit = io, file = dataset%filename, iostat = status, status ='old') if (status /= 0) then write(*, *) ' FAILURE! > unable to open file: ', trim(dataset%filename) ierr = status return end if num = 0 status = 0 do while (status.eq.0) read (io, *, iostat = status) meteo_cell%U, meteo_cell%dT, meteo_cell%Tsemi, meteo_cell%dQ num = num + 1 enddo num = num - 1 close(io) ! --- print number of elements in dataset write(*, '(a,g0)') ' size = ', num if (dataset%nmax > 0) then write(*, '(a,g0)') ' nmax = ', dataset%nmax num = min(num, dataset%nmax) end if ! --- allocate input & output data call allocate_meteo_vec(meteo, num) call allocate_sfx_vec(sfx, num) ! --- setting height & roughness meteo_cell%h = dataset%h meteo_cell%z0_m = dataset%z0_m meteo_cell%depth = dataset%depth meteo_cell%lai = dataset%lai meteo_cell%surface_type = dataset%surface_type ! --- read input data open(newunit = io, file = dataset%filename, iostat = status, status = 'old') if (status /= 0) then write(*, *) ' FAILURE! > unable to open file: ', trim(dataset%filename) ierr = status return end if do i = 1, num read(io, *) meteo_cell%U, meteo_cell%dT, meteo_cell%Tsemi, meteo_cell%dQ meteo%h(i) = meteo_cell%h meteo%depth(i)=meteo_cell%depth meteo%lai(i)=meteo_cell%lai meteo%surface_type(i)=meteo_cell%surface_type meteo%U(i) = meteo_cell%U meteo%dT(i) = meteo_cell%dT meteo%Tsemi(i) = meteo_cell%Tsemi meteo%dQ(i) = meteo_cell%dQ meteo%z0_m(i) = meteo_cell%z0_m enddo close(io) ! --- calling flux module if (model == model_esm) then call get_surface_fluxes_vec_esm(sfx, meteo, numerics_esm, num) else if (model == model_log) then call get_surface_fluxes_vec_log(sfx, meteo, numerics_log, num) else if (model == model_most) then call get_surface_fluxes_vec_most(sfx, meteo, numerics_most, num) else if (model == model_sheba) then call get_surface_fluxes_vec_sheba(sfx, meteo, numerics_sheba, num) else if (model == model_sheba_noit) then call get_surface_fluxes_vec_sheba_noit(sfx, meteo, numerics_sheba_noit, num) else if (model == model_most_snow) then call get_surface_fluxes_vec_most_snow(sfx, meteo, numerics_most_snow, num) end if ! --- write output data call write_ascii_vec11(filename_out, & sfx%zeta, sfx%Rib, & sfx%Re, sfx%B, sfx%z0_m, sfx%z0_t, & sfx%Rib_conv_lim, & sfx%Cm,sfx%Ct, sfx%Km, sfx%Pr_t_inv, num, '(11(f10.4,3x))', status) if (status /= 0) then write(*, *) ' FAILURE! > unable to write to file: ', trim(filename_out) ierr = status return end if ! --- deallocate input & output data call deallocate_meteo_vec(meteo) call deallocate_sfx_vec(sfx) end subroutine !> @brief set sfx run on dataset ! ---------------------------------------------------------------------------- subroutine set_run(filename_out, dataset, model, ierr) ! modules used ! -------------------------------------------------------------------------------- #ifdef USE_CONFIG_PARSER use iso_c_binding, only: C_NULL_CHAR use config_parser #endif use sfx_common use sfx_config use sfx_surface ! -------------------------------------------------------------------------------- character(len=:), allocatable, intent(out) :: filename_out type(sfxDatasetType), intent(out) :: dataset integer, intent(out) :: model integer, intent(out) :: ierr ! command line arguments ! -------------------------------------------------------------------------------- integer :: num_args character(len = 128) :: arg character(len = 128), parameter :: arg_key_model = '--model' character(len = 128), parameter :: arg_key_dataset = '--dataset' character(len = 128), parameter :: arg_key_output = '--output' character(len = 128), parameter :: arg_key_nmax = '--nmax' character(len = 128), parameter :: arg_key_help = '--help' character(len = 128), parameter :: arg_key_config = "--config" integer :: is_output_set ! -------------------------------------------------------------------------------- ! local variables ! -------------------------------------------------------------------------------- integer :: i, status integer :: id, nmax #ifdef USE_CONFIG_PARSER character, allocatable :: config_field(:) #endif ! -------------------------------------------------------------------------------- ierr = 0 ! = OK ! --- default model & dataset model = model_esm ! default = ESM call set_dataset(dataset, dataset_mosaic) ! default = MOSAiC is_output_set = 0 ! default = auto define output filename ! --- command line arguments processing num_args = command_argument_count() do i = 1, num_args call get_command_argument(i, arg) if (trim(arg) == trim(arg_key_help)) then write(*, *) ' sfx model, usage:' write(*, *) ' --help' write(*, *) ' print usage options' write(*, *) ' --model [key]' write(*, *) ' key = esm (default) || log || most || sheba || sheba_noit || most_snow' write(*, *) ' --dataset [key]' write(*, *) ' key = mosaic (default) || irgason || sheba' write(*, *) ' = lake || papa || toga || user [filename] [param]' write(*, *) ' param = [surface(type)] [h] [z0(m)] [z0(h)]' write(*, *) ' surface(type) = ocean | land | lake | snow' write(*, *) ' --output [filename]' write(*, *) ' set output filename' write(*, *) ' --config [filename]' write(*, *) ' use configuration file' write(*, *) ' --nmax [value]' write(*, *) ' max number of data points > 0' return end if if (trim(arg) == trim(arg_key_model)) then if (i == num_args) then write(*, *) ' FAILURE! > missing model [key] argument' ierr = 1 ! signal ERROR return end if call get_command_argument(i + 1, arg) model = get_model_id(arg) if (model == -1) then write(*, *) ' FAILURE! > unknown model [key]: ', trim(arg) ierr = 1 ! signal ERROR return end if else if (trim(arg) == trim(arg_key_dataset)) then if (i == num_args) then write(*, *) ' FAILURE! > missing dataset [key] argument' ierr = 1 ! signal ERROR return end if call get_command_argument(i + 1, arg) id = get_dataset_id(arg) if (id == -1) then write(*, *) ' FAILURE! > unknown dataset [key]: ', trim(arg) ierr = 1 ! signal ERROR return end if !< save nmax if previously set nmax = dataset%nmax call set_dataset(dataset, id) dataset%nmax = nmax if (dataset%id == dataset_user) then !< @brief user-defined dataset if (i + 6 > num_args) then write(*, *) ' FAILURE! > incorrect arguments for [user] dataset' ierr = 1 ! signal ERROR return end if !< filename call get_command_argument(i + 2, dataset%filename) !< surface type call get_command_argument(i + 3, arg) dataset%surface = get_surface_id(arg) if (dataset%surface == -1) then write(*, *) ' FAILURE! > unknown surface [key]: ', trim(arg) ierr = 1 ! signal ERROR return end if !< reading 'h' call get_command_argument(i + 4, arg) call str2real(dataset%h, arg, status) if (status /= 0) then write(*, *) ' FAILURE! > expecting real h [value]' ierr = 1 ! signal ERROR return end if if (dataset%h <= 0) then write(*, *) ' FAILURE! > h [value] should be positive' ierr = 1 ! signal ERROR return end if !< reading 'z0(m)' call get_command_argument(i + 5, arg) call str2real(dataset%z0_m, arg, status) if (status /= 0) then write(*, *) ' FAILURE! > expecting real z0(m) [value]' ierr = 1 ! signal ERROR return end if !< reading 'z0(h)' call get_command_argument(i + 6, arg) call str2real(dataset%z0_h, arg, status) if (status /= 0) then write(*, *) ' FAILURE! > expecting real z0(h) [value]' ierr = 1 ! signal ERROR return end if end if else if (trim(arg) == trim(arg_key_output)) then if (i == num_args) then write(*, *) ' FAILURE! > missing output [key] argument' ierr = 1 ! signal ERROR return end if call get_command_argument(i + 1, arg) filename_out = trim(arg) is_output_set = 1 else if (trim(arg) == trim(arg_key_nmax)) then if (i == num_args) then write(*, *) ' FAILURE! > missing nmax [key] argument' ierr = 1 ! signal ERROR return end if call get_command_argument(i + 1, arg) call str2int(dataset%nmax, arg, status) if (status /= 0) then write(*, *) ' FAILURE! > expecting int nmax [value]' ierr = 1 ! signal ERROR return end if if (dataset%nmax <= 0) then write(*, *) ' FAILURE! > nmax [value] should be positive' ierr = 1 ! signal ERROR return end if else if (trim(arg) == trim(arg_key_config)) then if (i == num_args) then write(*, *) ' FAILURE! > missing configuration file [key] argument' ierr = 1 ! signal ERROR return end if call get_command_argument(i + 1, arg) #ifdef USE_CONFIG_PARSER call c_config_run(trim(arg)//C_NULL_CHAR, status) if (status == 0) then write(*, *) ' FAILURE! > unable to parse configuration file: ', trim(arg) ierr = 1 ! signal ERROR return end if call c_config_is_varname("model.id"//C_NULL_CHAR, status) if (status /= 0) then call c_config_get_string("model.id"//C_NULL_CHAR, config_field, status) if (status == 0) then ierr = 1 ! signal ERROR return end if model = get_model_id(char_array2str(config_field)) if (model == -1) then write(*, *) ' FAILURE! > unknown model [key]: ', trim(char_array2str(config_field)) ierr = 1 ! signal ERROR return end if end if call c_config_is_varname("dataset.id"//C_NULL_CHAR, status) if (status /= 0) then call c_config_get_string("dataset.id"//C_NULL_CHAR, config_field, status) if (status == 0) then ierr = 1 ! signal ERROR return end if id = get_dataset_id(char_array2str(config_field)) if (id == -1) then write(*, *) ' FAILURE! > unknown dataset [key]: ', trim(char_array2str(config_field)) ierr = 1 ! signal ERROR return end if !< save nmax if previously set nmax = dataset%nmax call set_dataset(dataset, id) dataset%nmax = nmax call c_config_is_varname("dataset.filename"//C_NULL_CHAR, status) if ((status /= 0).or.(dataset%id == dataset_user)) then !< mandatory in user dataset call c_config_get_string("dataset.filename"//C_NULL_CHAR, config_field, status) if (status == 0) then ierr = 1 ! signal ERROR return end if dataset%filename = char_array2str(config_field) end if call c_config_is_varname("dataset.surface"//C_NULL_CHAR, status) if ((status /= 0).or.(dataset%id == dataset_user)) then !< mandatory in user dataset call c_config_get_string("dataset.surface"//C_NULL_CHAR, config_field, status) if (status == 0) then ierr = 1 ! signal ERROR return end if dataset%surface = get_surface_id(char_array2str(config_field)) if (dataset%surface == -1) then write(*, *) ' FAILURE! > unknown surface [key]: ', trim(char_array2str(config_field)) ierr = 1 ! signal ERROR return end if endif call c_config_is_varname("dataset.h"//C_NULL_CHAR, status) if ((status /= 0).or.(dataset%id == dataset_user)) then !< mandatory in user dataset call c_config_get_float("dataset.h"//C_NULL_CHAR, dataset%h, status) if (status == 0) then ierr = 1 ! signal ERROR return end if end if call c_config_is_varname("dataset.z0_m"//C_NULL_CHAR, status) if ((status /= 0).or.(dataset%id == dataset_user)) then !< mandatory in user dataset call c_config_get_float("dataset.z0_m"//C_NULL_CHAR, dataset%z0_m, status) if (status == 0) then ierr = 1 ! signal ERROR return end if end if call c_config_is_varname("dataset.z0_h"//C_NULL_CHAR, status) if ((status /= 0).or.(dataset%id == dataset_user)) then !< mandatory in user dataset call c_config_get_float("dataset.z0_h"//C_NULL_CHAR, dataset%z0_h, status) if (status == 0) then ierr = 1 ! signal ERROR return end if end if end if call c_config_is_varname("dataset.nmax"//C_NULL_CHAR, status) if (status /= 0) then call c_config_get_int("dataset.nmax"//C_NULL_CHAR, dataset%nmax, status) if (status == 0) then ierr = 1 ! signal ERROR return end if end if call c_config_is_varname("output.filename"//C_NULL_CHAR, status) if (status /= 0) then call c_config_get_string("output.filename"//C_NULL_CHAR, config_field, status) if (status == 0) then ierr = 1 ! signal ERROR return end if filename_out = char_array2str(config_field) is_output_set = 1 end if if (allocated(config_field)) deallocate(config_field) #endif end if end do !< set auto-defined output filename if (is_output_set == 0) then filename_out = 'output-' // trim(get_dataset_tag(dataset%id)) // '.txt' end if end subroutine end module sfx_run