diff --git a/CHANGELOG.rst b/CHANGELOG.rst index d9c34d9b5c..1780196b44 100644 --- a/CHANGELOG.rst +++ b/CHANGELOG.rst @@ -22,6 +22,11 @@ individual files. The changes are now listed with the most recent at the top. +**September 22 2022 :: CAM-SE. Tag: v10.5.0** + +- CAM-SE interface for Manhattan +- Shared code for CAM-SE and CAM-FV model_mods in cam-common-code + **September 21 2022 :: ROMS model_mod perturbation routine Tag: v10.4.0** - Adds a pert_model_copies subroutine to the ROMS model_mod to enable proper diff --git a/conf.py b/conf.py index af1db2e2fd..900526e284 100644 --- a/conf.py +++ b/conf.py @@ -21,7 +21,7 @@ author = 'Data Assimilation Research Section' # The full version, including alpha/beta/rc tags -release = '10.4.0' +release = '10.5.0' master_doc = 'README' # -- General configuration --------------------------------------------------- diff --git a/guide/important-capabilities-dart.rst b/guide/important-capabilities-dart.rst index 89afff037e..7abb5044e0 100644 --- a/guide/important-capabilities-dart.rst +++ b/guide/important-capabilities-dart.rst @@ -33,7 +33,7 @@ FESOM Manhattan NOAH-MP Manhattan WRF-Hydro Manhattan GCCOM Lanai LMDZ Lanai MITgcm_ocean Lanai NAAPS Lanai AM2 Lanai -CAM-SE Lanai CLM Lanai +CAM-SE Manhattan CLM Manhattan COAMPS Lanai COSMO Lanai Dynamo Lanai GITM Lanai Ikeda Lanai JULES Lanai diff --git a/models/CESM/readme.rst b/models/CESM/readme.rst index 7b05a843e4..cc8ca68b64 100644 --- a/models/CESM/readme.rst +++ b/models/CESM/readme.rst @@ -197,11 +197,11 @@ $DART/models/{cesm components} organization .. container:: keepspace - ================================= ================================================================================== + ================================= ======================================================================================= PATHNAMES NOTES - ================================= ================================================================================== + ================================= ======================================================================================= \ - $DART/models/**cam-fv**/ An interface for the CAM-FV dynamical core (CAM-SE will be available in 2021) + $DART/models/**cam-fv**/ An interface for the CAM-FV dynamical core (CAM-SE is available in $DART/models/cam-se) ...model_mod.\* The fortran interface between CAM-FV and DART ...work/ Build DART executables (filter, ...) here before running setup\_\* ...shell_scripts/ Setup and support scripts @@ -242,7 +242,7 @@ $DART/models/{cesm components} organization ......run_perfect_model_obs.csh Script to run a perfect model observation job. ... \ - ================================= ================================================================================== + ================================= ======================================================================================= .. warning:: Experience on a variety of machines has shown that it is a very good idea diff --git a/models/cam-common-code/cam_common_code_mod.f90 b/models/cam-common-code/cam_common_code_mod.f90 new file mode 100644 index 0000000000..4970e16474 --- /dev/null +++ b/models/cam-common-code/cam_common_code_mod.f90 @@ -0,0 +1,2209 @@ +module cam_common_code_mod + +! This module contains only code that is used by both the cam-fv and cam-se model mods. +! Much of this has to do with general computations for unstaggered columns, but there are a +! number of utility routines, also. The individual model_mods still contain significant overlap +! in code in some places where communication, especially of the namelist, made sharing code +! problematic. + +use types_mod, only : MISSING_R8, MISSING_I, r8, i8, DEG2RAD, vtablenamelength + +use utilities_mod, only : E_ERR, E_MSG, error_handler, find_enclosing_indices, to_upper, & + array_dump, file_exist, string_to_logical, string_to_real + +use obs_kind_mod, only : QTY_SURFACE_ELEVATION, QTY_SURFACE_PRESSURE, QTY_PRESSURE, QTY_VERTLEVEL, & + QTY_GEOMETRIC_HEIGHT, & + get_quantity_for_type_of_obs, get_num_quantities, get_index_for_quantity + +use location_mod, only : location_type, get_close_type, vertical_localization_on, get_dist, & + set_location, query_location, get_maxdist, is_vertical, & + VERTISUNDEF, VERTISPRESSURE, VERTISHEIGHT, VERTISLEVEL, VERTISSCALEHEIGHT, & + VERTISSURFACE, set_vertical_localization_coord + +use state_structure_mod, only : get_varid_from_kind, get_model_variable_indices, add_domain + +use ensemble_manager_mod, only : ensemble_type, get_my_num_vars, get_my_vars + +use netcdf_utilities_mod, only : nc_open_file_readonly, nc_close_file, nc_get_variable, nc_get_variable_size, & + nc_variable_exists + +use netcdf_utilities_mod, only : nc_get_variable, nc_get_variable_size, nc_create_file, & + nc_add_attribute_to_variable, & + nc_define_integer_variable, nc_define_double_variable, & + nc_define_real_variable, & + nc_define_real_scalar, & + nc_add_global_creation_time, & + nc_add_global_attribute, & + nc_define_dimension, nc_put_variable, & + nc_synchronize_file, nc_end_define_mode, & + nc_begin_define_mode, nc_open_file_readonly, & + nc_close_file, nc_variable_exists, nc_get_global_attribute, & + nc_get_dimension_size + +use time_manager_mod, only : time_type, get_date, set_date, set_time + +use netcdf_utilities_mod, only : nc_begin_define_mode, nc_define_integer_variable, & + nc_end_define_mode, nc_put_variable + +use random_seq_mod, only : random_seq_type, init_random_seq, random_gaussian + +use mpi_utilities_mod, only : my_task_id + +implicit none +private + +public :: above_ramp_start, are_damping, build_cam_pressure_columns, build_heights, & + cam_grid, cdebug_level, check_good_levels, cno_normalization_of_scale_heights, & + pert_model_copies, cuse_log_vertical_scale, discarding_high_obs, & + free_cam_grid, free_std_atm_tables, generic_height_to_pressure, & + gph2gmh, height_to_level, init_damping_ramp_info, & + init_discard_high_obs, init_globals, init_sign_of_vert_units, & + is_surface_field, obs_too_high, ok_to_interpolate, pressure_to_level, ramp_end, & + read_model_time, ref_model_top_pressure, ref_nlevels, scale_height, & + set_vert_localization, vert_interp, vertical_localization_type, write_model_time + +public :: nc_write_model_atts, grid_data, read_grid_info, set_cam_variable_info, & + MAX_STATE_VARIABLES, num_state_table_columns, common_initialized, & + MAX_PERT, shortest_time_between_assimilations, domain_id, & + ccustom_routine_to_generate_ensemble, & + cfields_to_perturb, & + cperturbation_amplitude, & + cassimilation_period_days, & + cassimilation_period_seconds, & + csuppress_grid_info_in_output + + +! version controlled file description for error handling, do not edit +character(len=256), parameter :: source = 'cam_common_code.f90' +character(len=32 ), parameter :: revision = '' +character(len=128), parameter :: revdate = '' + +!> Metadata from the template netCDF file that describes +!> where the variable data is located and what size it is. +type cam_1d_array + integer :: nsize + real(r8), allocatable :: vals(:) +end type + +! Note that the cam_grid type contains information about staggered grids that are only for FV +type cam_grid + type(cam_1d_array) :: lon + type(cam_1d_array) :: lat + type(cam_1d_array) :: slon + type(cam_1d_array) :: slat + type(cam_1d_array) :: lev + type(cam_1d_array) :: ilev + type(cam_1d_array) :: gw + type(cam_1d_array) :: hyai + type(cam_1d_array) :: hybi + type(cam_1d_array) :: hyam + type(cam_1d_array) :: hybm + type(cam_1d_array) :: P0 +end type + +type(cam_grid) :: grid_data + +! this id allows us access to all of the state structure +! info and is required for getting state variables. +integer :: domain_id = -1 + +integer, parameter :: MAX_STATE_VARIABLES = 100 +integer, parameter :: num_state_table_columns = 5 +! maximum number of fields you can list to be perturbed +! to generate an ensemble if starting from a single state. +integer, parameter :: MAX_PERT = 100 + + +logical :: common_initialized = .false. ! static_init_model sets this to true + +! Value from namelist in model_mod CAM +logical :: cuse_log_vertical_scale = .false. +logical :: cno_normalization_of_scale_heights = .true. +integer :: cdebug_level = 0 +logical :: ccustom_routine_to_generate_ensemble = .true. +character(len=32) :: cfields_to_perturb(MAX_PERT) = "" +real(r8) :: cperturbation_amplitude(MAX_PERT) = 0.0_r8 +integer :: cassimilation_period_days = 0 +integer :: cassimilation_period_seconds = 21600 +logical :: csuppress_grid_info_in_output = .false. + +! Just a global storage for output strings +character(len=512) :: string1, string2, string3 + +! default to localizing in pressure. override with namelist +integer :: vertical_localization_type = VERTISPRESSURE + +! flag used to know if the vertical unit system has numbers +! that get larger as you move away from the earth's surface +! (e.g. height) or smaller (e.g. pressure) +logical :: higher_is_smaller + +! things related to damping at the model top +logical :: are_damping = .false. +real(r8) :: ramp_end ! fixed top of ramp; the start (bottom) varies +logical :: discarding_high_obs = .false. +real(r8) :: no_assim_above_height = -1.0_r8 +real(r8) :: no_assim_above_level = -1.0_r8 +real(r8) :: no_assim_above_pressure = -1.0_r8 + + +!>@todo FIXME ask kevin if this threshold value is small enough +! to distinguish cam from waccm configurations? + +! an arbitrary value to test the model top against to see +! if we're running cam vs waccm or waccm-x. it changes the +! standard atmosphere table we use to convert pressure to height, +! and changes the formatting of numbers in dart_log output. +real(r8), parameter :: high_top_threshold = 0.3_r8 ! pascals + +! commonly used numbers that we'll set in static_init_model +real(r8) :: ref_model_top_pressure +real(r8) :: ref_surface_pressure +integer :: ref_nlevels + +! Precompute pressure <-> height map once based on either a low-top or +! high-top table depending on what the model top is. +! Used only to discard obs on heights above the user-defined top threshold. +integer, parameter :: HIGH_TOP_TABLE = 1 +integer, parameter :: LOW_TOP_TABLE = 2 +integer :: std_atm_table_len +real(r8), allocatable :: std_atm_hgt_col(:) +real(r8), allocatable :: std_atm_pres_col(:) + +contains + + +!----------------------------------------------------------------------- +!> +!> Fill the array of requested variables, dart kinds, possible min/max +!> values and whether or not to update the field in the output file. +!> Then calls 'add_domain()' to tell the DART code which variables to +!> read into the state vector after this code returns. +!> +!>@param variable_array the list of variables and kinds from model_mod_nml +!>@param nfields the number of variable/Quantity pairs specified + +subroutine set_cam_variable_info(cam_template_filename, variable_array) + +character(len=*), intent(in) :: cam_template_filename +character(len=*), intent(in) :: variable_array(:) + +character(len=*), parameter :: routine = 'set_cam_variable_info:' + +integer :: i, nfields +integer, parameter :: MAX_STRING_LEN = 128 + +character(len=MAX_STRING_LEN) :: varname ! column 1, NetCDF variable name +character(len=MAX_STRING_LEN) :: dartstr ! column 2, DART Quantity +character(len=MAX_STRING_LEN) :: minvalstr ! column 3, Clamp min val +character(len=MAX_STRING_LEN) :: maxvalstr ! column 4, Clamp max val +character(len=MAX_STRING_LEN) :: updatestr ! column 5, Update output or not + +character(len=vtablenamelength) :: var_names(MAX_STATE_VARIABLES) = ' ' +logical :: update_list(MAX_STATE_VARIABLES) = .FALSE. +integer :: kind_list(MAX_STATE_VARIABLES) = MISSING_I +real(r8) :: clamp_vals(MAX_STATE_VARIABLES,2) = MISSING_R8 + +nfields = 0 +ParseVariables : do i = 1, MAX_STATE_VARIABLES + + varname = variable_array(num_state_table_columns*i-4) + dartstr = variable_array(num_state_table_columns*i-3) + minvalstr = variable_array(num_state_table_columns*i-2) + maxvalstr = variable_array(num_state_table_columns*i-1) + updatestr = variable_array(num_state_table_columns*i ) + + if ( varname == ' ' .and. dartstr == ' ' ) exit ParseVariables ! Found end of list. + + if ( varname == ' ' .or. dartstr == ' ' ) then + string1 = 'model_nml:model "state_variables" not fully specified' + call error_handler(E_ERR,routine,string1,source,revision,revdate) + endif + + ! Make sure DART kind is valid + + if( get_index_for_quantity(dartstr) < 0 ) then + write(string1,'(3A)') 'there is no obs_kind "', trim(dartstr), '" in obs_kind_mod.f90' + call error_handler(E_ERR,routine,string1,source,revision,revdate) + endif + + call to_upper(minvalstr) + call to_upper(maxvalstr) + call to_upper(updatestr) + + var_names( i) = varname + kind_list( i) = get_index_for_quantity(dartstr) + clamp_vals(i,1) = string_to_real(minvalstr) + clamp_vals(i,2) = string_to_real(maxvalstr) + update_list( i) = string_to_logical(updatestr, 'UPDATE') + + nfields = nfields + 1 + +enddo ParseVariables + +if (nfields == MAX_STATE_VARIABLES) then + write(string1,'(2A)') 'WARNING: There is a possibility you need to increase ', & + 'MAX_STATE_VARIABLES in the global variables in model_mod.f90' + + write(string2,'(A,i4,A)') 'WARNING: you have specified at least ', nfields, & + ' perhaps more' + + call error_handler(E_MSG,routine,string1,source,revision,revdate,text2=string2) +endif + +! CAM only has a single domain (only a single grid, no nests or multiple grids) + +domain_id = add_domain(cam_template_filename, nfields, var_names, kind_list, & + clamp_vals, update_list) + +end subroutine set_cam_variable_info + + + +!----------------------------------------------------------------------- +!> Read the data from the various cam grid arrays +!> +!>@todo FIXME not all of these are used. can we either +!> not read them in, or make them optional? this does affect +!> what we can write out in the diagnostic file. if we have +!> to have them in the diag files then we have to read them all +!> even if we never use them. both ilev and gw currently fall +!> into this category. +!> + +subroutine get_cam_grid(grid_file) +character(len=*), intent(in) :: grid_file + +character(len=*), parameter :: routine = 'get_cam_grid:' + +integer :: ncid + +! put this in a subroutine that deals with the grid +ncid = nc_open_file_readonly(grid_file, routine) + +call fill_cam_1d_array(ncid, 'lon', grid_data%lon) +call fill_cam_1d_array(ncid, 'lat', grid_data%lat) +call fill_cam_1d_array(ncid, 'lev', grid_data%lev) +call fill_cam_1d_array(ncid, 'ilev', grid_data%ilev) ! for staggered vertical grid +call fill_cam_1d_array(ncid, 'slon', grid_data%slon) +call fill_cam_1d_array(ncid, 'slat', grid_data%slat) +call fill_cam_1d_array(ncid, 'gw', grid_data%gw) ! gauss weights +call fill_cam_1d_array(ncid, 'hyai', grid_data%hyai) +call fill_cam_1d_array(ncid, 'hybi', grid_data%hybi) +call fill_cam_1d_array(ncid, 'hyam', grid_data%hyam) +call fill_cam_1d_array(ncid, 'hybm', grid_data%hybm) + +! P0 is a scalar with no dimensionality +call fill_cam_0d_array(ncid, 'P0', grid_data%P0) + +call nc_close_file(ncid, routine) + +end subroutine get_cam_grid + + +!----------------------------------------------------------------------- +!> +!> allocate space for a scalar variable and read values into the grid_array +!> + + +subroutine fill_cam_1d_array(ncid, varname, grid_array) +integer, intent(in) :: ncid +character(len=*), intent(in) :: varname +type(cam_1d_array), intent(inout) :: grid_array + +character(len=*), parameter :: routine = 'fill_cam_1d_array' + +! SENote: For the SE core, three of these don't exist (gw, slon, slat) so need to check + +if(nc_variable_exists(ncid, varname)) then + + call nc_get_variable_size(ncid, varname, grid_array%nsize) + allocate(grid_array%vals(grid_array%nsize)) + + call nc_get_variable(ncid, varname, grid_array%vals, routine) + + if (cdebug_level > 80) call array_dump(grid_array%vals, label=varname) + +!SENote: this is the else statement to create something for the slon, slat, and gw fields that aren't used in SE CORE +else + allocate(grid_array%vals(1)) + grid_array%nsize = -1 ! so you can test before writing + grid_array%vals(1) = MISSING_R8 +endif + +end subroutine fill_cam_1d_array + +!----------------------------------------------------------------------- +!> +!> free space in the various grid arrays +!> + +subroutine free_cam_grid(grid) + +type(cam_grid), intent(inout) :: grid + +call free_cam_1d_array(grid%lon) +call free_cam_1d_array(grid%lat) +call free_cam_1d_array(grid%lev) +call free_cam_1d_array(grid%ilev) +call free_cam_1d_array(grid%slon) +call free_cam_1d_array(grid%slat) +call free_cam_1d_array(grid%gw) +call free_cam_1d_array(grid%hyai) +call free_cam_1d_array(grid%hybi) +call free_cam_1d_array(grid%hyam) +call free_cam_1d_array(grid%hybm) +call free_cam_1d_array(grid%P0) + +end subroutine free_cam_grid + + + + +!----------------------------------------------------------------------- +!> +!> Writes the model-specific attributes to a DART 'diagnostic' netCDF file. +!> This includes coordinate variables and some metadata, but NOT the +!> actual DART state. +!> +!> @param ncid the netCDF handle of the DART diagnostic file opened by +!> assim_model_mod:init_diag_output + +subroutine nc_write_model_atts(ncid, dom_id) + +integer, intent(in) :: ncid ! netCDF file identifier +integer, intent(in) :: dom_id ! not used since there is only one domain + +!---------------------------------------------------------------------- +! local variables +!---------------------------------------------------------------------- + +character(len=*), parameter :: routine = 'nc_write_model_atts' + +!------------------------------------------------------------------------------- +! Write Global Attributes +!------------------------------------------------------------------------------- + +call nc_begin_define_mode(ncid, routine) + +call nc_add_global_creation_time(ncid, routine) + +call nc_add_global_attribute(ncid, "model_source", source, routine) +call nc_add_global_attribute(ncid, "model_revision", revision, routine) +call nc_add_global_attribute(ncid, "model_revdate", revdate, routine) + +call nc_add_global_attribute(ncid, "model", "CAM", routine) + +! this option is for users who want the smallest output +! or diagnostic files - only the state vector data will +! be written. otherwise, if you want to plot this data +! the rest of this routine writes out enough grid info +! to make the output file look like the input. +if (csuppress_grid_info_in_output) then + call nc_end_define_mode(ncid, routine) + return +endif + +!---------------------------------------------------------------------------- +! Output the grid variables. +!---------------------------------------------------------------------------- +! Define the new dimensions IDs +!---------------------------------------------------------------------------- + +call nc_define_dimension(ncid, 'lon', grid_data%lon%nsize, routine) +call nc_define_dimension(ncid, 'lat', grid_data%lat%nsize, routine) +call nc_define_dimension(ncid, 'lev', grid_data%lev%nsize, routine) +call nc_define_dimension(ncid, 'ilev', grid_data%ilev%nsize, routine) +call nc_define_dimension(ncid, 'hyam', grid_data%hyam%nsize, routine) +call nc_define_dimension(ncid, 'hybm', grid_data%hybm%nsize, routine) +call nc_define_dimension(ncid, 'hyai', grid_data%hyai%nsize, routine) +call nc_define_dimension(ncid, 'hybi', grid_data%hybi%nsize, routine) + +! cam-fv only variables +if(grid_data%slon%nsize > 0) call nc_define_dimension(ncid, 'slon', grid_data%slon%nsize, routine) +if(grid_data%slat%nsize > 0) call nc_define_dimension(ncid, 'slat', grid_data%slat%nsize, routine) +if(grid_data%gw%nsize > 0) call nc_define_dimension(ncid, 'gw', grid_data%gw%nsize, routine) + +!---------------------------------------------------------------------------- +! Create the Coordinate Variables and the Attributes +! The contents will be written in a later block of code. +!---------------------------------------------------------------------------- + +! U,V Grid Longitudes +call nc_define_real_variable( ncid, 'lon', (/ 'lon' /), routine) +call nc_add_attribute_to_variable(ncid, 'lon', 'long_name', 'longitude', routine) +call nc_add_attribute_to_variable(ncid, 'lon', 'units', 'degrees_east', routine) + +! U,V Grid Latitudes +call nc_define_real_variable( ncid, 'lat', (/ 'lat' /), routine) +call nc_add_attribute_to_variable(ncid, 'lat', 'long_name', 'latitude', routine) +call nc_add_attribute_to_variable(ncid, 'lat', 'units', 'degrees_north', routine) + +! Vertical Grid Latitudes +call nc_define_real_variable( ncid, 'lev', (/ 'lev' /), routine) +call nc_add_attribute_to_variable(ncid, 'lev', 'long_name', 'hybrid level at midpoints (1000*(A+B))', routine) +call nc_add_attribute_to_variable(ncid, 'lev', 'units', 'hPa', routine) +call nc_add_attribute_to_variable(ncid, 'lev', 'positive', 'down', routine) +call nc_add_attribute_to_variable(ncid, 'lev', 'standard_name', 'atmosphere_hybrid_sigma_pressure_coordinate', routine) +call nc_add_attribute_to_variable(ncid, 'lev', 'formula_terms', 'a: hyam b: hybm p0: P0 ps: PS', routine) + + +call nc_define_real_variable( ncid, 'ilev', (/ 'ilev' /), routine) +call nc_add_attribute_to_variable(ncid, 'ilev', 'long_name', 'hybrid level at interfaces (1000*(A+B))', routine) +call nc_add_attribute_to_variable(ncid, 'ilev', 'units', 'hPa', routine) +call nc_add_attribute_to_variable(ncid, 'ilev', 'positive', 'down', routine) +call nc_add_attribute_to_variable(ncid, 'ilev', 'standard_name', 'atmosphere_hybrid_sigma_pressure_coordinate', routine) +call nc_add_attribute_to_variable(ncid, 'ilev', 'formula_terms', 'a: hyai b: hybi p0: P0 ps: PS', routine) + +! Hybrid Coefficients +call nc_define_real_variable( ncid, 'hyam', (/ 'lev' /), routine) +call nc_add_attribute_to_variable(ncid, 'hyam', 'long_name', 'hybrid A coefficient at layer midpoints', routine) + +call nc_define_real_variable( ncid, 'hybm', (/ 'lev' /), routine) +call nc_add_attribute_to_variable(ncid, 'hybm', 'long_name', 'hybrid B coefficient at layer midpoints', routine) + + +call nc_define_real_variable( ncid, 'hyai', (/ 'ilev' /), routine) +call nc_add_attribute_to_variable(ncid, 'hyai', 'long_name', 'hybrid A coefficient at layer interfaces', routine) + + +call nc_define_real_variable( ncid, 'hybi', (/ 'ilev' /), routine) +call nc_add_attribute_to_variable(ncid, 'hybi', 'long_name', 'hybrid B coefficient at layer interfaces', routine) + +call nc_define_real_scalar( ncid, 'P0', routine) +call nc_add_attribute_to_variable(ncid, 'P0', 'long_name', 'reference pressure', routine) +call nc_add_attribute_to_variable(ncid, 'P0', 'units', 'Pa', routine) + +! FV only variables +if(grid_data%slon%nsize > 0) then + call nc_define_real_variable( ncid, 'slon', (/ 'slon' /), routine) + call nc_add_attribute_to_variable(ncid, 'slon', 'long_name', 'staggered longitude', routine) + call nc_add_attribute_to_variable(ncid, 'slon', 'units', 'degrees_east', routine) +endif +if(grid_data%slat%nsize > 0) then + call nc_define_real_variable( ncid, 'slat', (/ 'slat' /), routine) + call nc_add_attribute_to_variable(ncid, 'slat', 'long_name', 'staggered latitude', routine) + call nc_add_attribute_to_variable(ncid, 'slat', 'units', 'degrees_north', routine) +endif +if(grid_data%gw%nsize > 0) then + ! Gaussian Weights + call nc_define_real_variable( ncid, 'gw', (/ 'lat' /), routine) + call nc_add_attribute_to_variable(ncid, 'gw', 'long_name', 'gauss weights', routine) +endif + +! Finished with dimension/variable definitions, must end 'define' mode to fill. + +call nc_end_define_mode(ncid, routine) + +!---------------------------------------------------------------------------- +! Fill the coordinate variables +!---------------------------------------------------------------------------- + + + +call nc_put_variable(ncid, 'lon', grid_data%lon%vals, routine) +call nc_put_variable(ncid, 'lat', grid_data%lat%vals, routine) +call nc_put_variable(ncid, 'lev', grid_data%lev%vals, routine) +call nc_put_variable(ncid, 'ilev', grid_data%ilev%vals, routine) +call nc_put_variable(ncid, 'hyam', grid_data%hyam%vals, routine) +call nc_put_variable(ncid, 'hybm', grid_data%hybm%vals, routine) +call nc_put_variable(ncid, 'hyai', grid_data%hyai%vals, routine) +call nc_put_variable(ncid, 'hybi', grid_data%hybi%vals, routine) +call nc_put_variable(ncid, 'P0', grid_data%P0%vals, routine) + +!SENote: all the staggered stuff is gone for SE +if(grid_data%slon%nsize > 0) call nc_put_variable(ncid, 'slon', grid_data%slon%vals, routine) +if(grid_data%slat%nsize > 0) call nc_put_variable(ncid, 'slat', grid_data%slat%vals, routine) +if(grid_data%gw%nsize > 0) call nc_put_variable(ncid, 'gw', grid_data%gw%vals, routine) + +! flush any pending i/o to disk +call nc_synchronize_file(ncid, routine) + +end subroutine nc_write_model_atts + + +!----------------------------------------------------------------------- +!> + +subroutine free_cam_1d_array(grid_array) +type(cam_1d_array), intent(inout) :: grid_array + +deallocate(grid_array%vals) +grid_array%nsize = -1 + +end subroutine free_cam_1d_array + +!----------------------------------------------------------------------- +!> +!> allocate space for a scalar variable and read values into the grid_array +!> + +subroutine fill_cam_0d_array(ncid, varname, grid_array) +integer, intent(in) :: ncid +character(len=*), intent(in) :: varname +type(cam_1d_array), intent(inout) :: grid_array + +character(len=*), parameter :: routine = 'fill_cam_0d_array' + +grid_array%nsize = 1 +allocate(grid_array%vals(grid_array%nsize)) + +!SENOte WARNING: This is the issue with P0 not being in the SE restart files. For now, if it is not in the file +! set to 100000, the value from standard FV files. NEED TO CLARIFY THIS WITH PETER LAURITZEN. +! CGD notes that P0 was removed and Ptop is only in history files, so no alternative for now. +if(varname == 'P0') then + ! See if PO exists in the netcdf file + if(.not. nc_variable_exists(ncid, 'PO')) then + grid_array%vals(1) = 100000 + return + endif +endif + +call nc_get_variable(ncid, varname, grid_array%vals, routine) + +if (cdebug_level > 80) print*, 'variable name ', trim(varname), grid_array%vals + +end subroutine fill_cam_0d_array + +!----------------------------------------------------------------------- +!> return my_status /= 0 if obs is above a user-defined threshold. +!> intended to be quick (low-cost) and not exact. +!> This intentionally does NOT have a case for vert type of +!> SCALEHEIGHT - because this routine is only used to look at +!> observation locations. we have not yet encountered obs +!> with that vertical type. + +subroutine obs_too_high(vert_value, which_vert, my_status) +real(r8), intent(in) :: vert_value +integer, intent(in) :: which_vert +integer, intent(out) :: my_status + +! assume ok to begin with +my_status = 0 + +if (which_vert == VERTISPRESSURE) then + ! lower pressures are higher; watch the less than/greater than tests + if (vert_value < no_assim_above_pressure) my_status = 14 + return +endif + +! these are always ok +if (which_vert == VERTISSURFACE .or. which_vert == VERTISUNDEF) return + +if (which_vert == VERTISHEIGHT) then + if (vert_value > no_assim_above_height) my_status = 14 + return +endif + +if (which_vert == VERTISLEVEL) then + ! level 1 is top; watch less than/greater than in tests + if (vert_value < no_assim_above_level) my_status = 14 + return +endif + +! for now we haven't run into observations where the vertical coordinate +! (of the OBS) is in scale height - but if we do it will fall into here. + +write(string2, *) 'vertical type: ', which_vert +call error_handler(E_ERR, 'obs_too_high', 'unrecognized vertical type', & + source, revision, revdate, text2=string2) + +end subroutine obs_too_high + +!----------------------------------------------------------------------- +!> return 0 (ok) if we know how to interpolate this quantity. +!> if it is a field in the state, return the variable id from +!> the state structure. if not in the state, varid will return -1 + +subroutine ok_to_interpolate(obs_qty, varid, my_status) +integer, intent(in) :: obs_qty +integer, intent(out) :: varid +integer, intent(out) :: my_status + +! See if the state contains the obs quantity +varid = get_varid_from_kind(domain_id, obs_qty) + +! in the state vector +if (varid > 0) then + my_status = 0 + return +endif + +! add any quantities that can be interpolated to this list if they +! are not in the state vector. +select case (obs_qty) + case (QTY_SURFACE_ELEVATION, & + QTY_PRESSURE, & + QTY_GEOMETRIC_HEIGHT, & + QTY_VERTLEVEL) + my_status = 0 + case default + my_status = 2 +end select + +end subroutine ok_to_interpolate + +!----------------------------------------------------------------------- +!> convert from string to integer, and set in the dart code the +!> vertical type we are going to want to localize in. + +subroutine set_vert_localization(typename) +character(len=*), intent(in) :: typename + +character(len=*), parameter :: routine = 'set_vert_localization' + +character(len=32) :: ucasename +integer :: vcoord + +ucasename = typename +call to_upper(ucasename) + +select case (ucasename) + case ("PRESSURE") + vcoord = VERTISPRESSURE + case ("HEIGHT") + vcoord = VERTISHEIGHT + case ("SCALEHEIGHT", "SCALE_HEIGHT", "SCALE HEIGHT") + vcoord = VERTISSCALEHEIGHT + case ("LEVEL", "MODEL_LEVEL", "MODEL LEVEL") + vcoord = VERTISLEVEL + case default + write(string1,*)'unrecognized vertical localization coordinate type: '//trim(typename) + write(string2,*)'valid values are: PRESSURE, HEIGHT, SCALEHEIGHT, LEVEL' + call error_handler(E_ERR,routine,string1,source,revision,revdate,text2=string2) +end select + +! during assimilation, when get_close() is called to compute the separation distance +! between items, convert all state and obs to use this vertical type if vertical localization +! is enabled (usually true for cam). + +call set_vertical_localization_coord(vcoord) + +! save in module global for later use. +vertical_localization_type = vcoord + +end subroutine set_vert_localization + +!----------------------------------------------------------------------- +!> This code is using a finite difference method to evaluate an +!> integral to solve the hydrostatic equation. +!> +!> The details are in the reference given below. +!> Don't change this code until you have read the paper and +!> understand what they're doing. The paper uses a matrix +!> while this code gets away with ignoring 'l' and evaluating +!> the 'k' vector directly. +!> +!> Equation references are to "Hybrid Coordinates for CCM1" +!> https://opensky.ucar.edu/islandora/object/technotes%3A149/datastream/PDF/view +!> +!> Here is a comment from the NCL function that does the +!> same thing for them. +!> +!> Purpose: +!> To compute geopotential height using the CCM2 hybrid coordinate +!> vertical slice. Since the vertical integration matrix is a +!> function of latitude and longitude, it is not explicitly +!> computed as for sigma coordinates. The integration algorithm +!> is derived from Boville's mods in the ibm file hybrid 1mods +!> (6/17/88). All vertical slice arrays are oriented top to +!> bottom as in CCM2. This field is on full model levels (aka +!> "midpoints") not half levels. +!> +!> careful - if the calling code passes in the mbar() parameter a different gas +!> constant is used instead. an mbar() array of 1.0 is not the same +!> as no parameter specified. + +subroutine build_heights(nlevels,p_surf,h_surf, pressure, virtual_temp,height_midpts,height_interf,mbar) + +integer, intent(in) :: nlevels ! Number of vertical levels +real(r8), intent(in) :: p_surf ! Surface pressure (pascals) +real(r8), intent(in) :: h_surf ! Surface height (m) +real(r8), intent(in) :: pressure( nlevels) ! Pressure +real(r8), intent(in) :: virtual_temp( nlevels) ! Virtual Temperature +real(r8), intent(out) :: height_midpts(nlevels) ! Geopotential height at midpoints, top to bottom +real(r8), intent(out), optional :: height_interf(nlevels+1) ! Geopotential height at interfaces, top to bottom +real(r8), intent(in), optional :: mbar(nlevels) ! Factor to support for variable gas constant + +! Local variables +!>@todo FIXME can we use the types_mod values here? or have a model constants module? +real(r8), parameter :: const_r = 287.04_r8 ! Different than model_heights (dry air gas constant) +real(r8), parameter :: universal_gas_constant = 8314.0_r8 ! [J/K/kmol] +real(r8), parameter :: g0 = 9.80616_r8 ! Different than model_heights (gph2gmh:G) ! + +integer :: k,l + +! an array now: real(r8), parameter :: rbyg=r/g0 +real(r8) :: pterm(nlevels) ! vertical scratch space, to improve computational efficiency +real(r8) :: r_g0_tv(nlevels) ! rbyg=r/g0 * tv +real(r8) :: pm_ln(nlevels+1) ! logs of midpoint pressures plus surface interface pressure + +! cam uses a uniform gas constant value, but high top +! models like waccm change the gas constant with height. +! allow for the calling code to pass in an array of r. + +! if mbar() array is present notice that the units are different +! for the gas constants, so an mbar() array of 1.0s will NOT give +! the same results as if it isn't present. + +if (present(mbar)) then + r_g0_tv(:) = (universal_gas_constant / (mbar(:)*g0)) * virtual_temp(:) +else + r_g0_tv(:) = (const_r / g0) * virtual_temp(:) +endif + +! calculate the log of the pressure column midpoints. +! items 1:nlevels are the midpoints, but NOTICE THAT +! the pressure at nlevels+1 is the pressure of the +! actual surface interface, not a midpoint!! + +! The original routine that did this conversion allowed the bottom boundary of the lowest pressure +! level to be something other than the surface pressure and computed it with the following : +! p_surf * grid_data%hybi%vals(nlevels+1) ! surface interface +! However, all modern SE models appear to have the lowest level boundary the same as the surface. This +! means that this can be replaced by just the surface pressure. If this is not true, careful thought is +! required, especially for the dry_mass_vertical_coordinate. +if(grid_data%hybi%vals(nlevels + 1) /= 1.0_r8) then + call error_handler(E_ERR, 'build_heights in cam_common_code_mod.f90', & + 'lowest interface hybi not exactly 1. See comments in code', source, revision, revdate) +endif + +! Put the log of the surface pressure in the top entry of the log pressure column for the conversion +pm_ln(nlevels+1) = log(p_surf) + +! Some weird vertical coord could have top pressure 0, so leave this check +where (pressure > 0.0_r8) + pm_ln(1:nlevels) = log(pressure) +else where (pressure <= 0.0_r8) + pm_ln(1:nlevels) = 0 +end where + + +! height_midpts(1)=top -> height_midpts(nlevels)=bottom +! +! level +! 1/2 --------------------------------------------------------------- +! 1 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - top +! 3/2 --------------------------------------------------------------- +! +! --------------------------------------------- +! --------/ \-------- +! - - - - - - - - - - - - - - - - - - - - - - - - +! NL - - - / \ - - - bottom +! --------------------------------------------------- +! NL+1/2 -----/|||||||||||||||||||||||||||||||||||||||||||||||||||\----- + + +! now the finite differences. +! Eq 3.a.109 has 5 piecewise (PW) terms. The numbers below refer to each of these terms +! in the order they're listed in the paper. + +! +! See 2nd PW term here: Eq 3.a.109 where l=K,kK, k Convert a 2d array of geopotential altitudes to mean sea level altitudes. +!> To avoid overflow with very high model tops, convert to km first, compute, +!> then convert back. + +subroutine gph2gmh(h, lat) +real(r8), intent(inout) :: h(:,:) ! geopotential altitude in m +real(r8), intent(in) :: lat ! latitude in degrees. + +real(r8), parameter :: be = 6356.7516_r8 ! min earth radius, km +real(r8), parameter :: ae = 6378.1363_r8 ! max earth radius, km +real(r8), parameter :: G = 0.00980665_r8 ! WMO reference g value, km/s**2, at 45.542N(S) + +real(r8) :: g0 +real(r8) :: r0 +real(r8) :: latr + +integer :: i, j + +latr = lat * DEG2RAD ! convert to radians +call compute_surface_gravity(latr, g0) + +! compute local earth's radius using ellipse equation + +r0 = sqrt( ae**2 * cos(latr)**2 + be**2 * sin(latr)**2) + +! Compute altitude above sea level +do j=1, size(h, 2) + do i=1, size(h, 1) + h(i,j) = h(i,j) / 1000.0_r8 ! m to km + if ( ((g0*r0)/G) - h(i,j) > 0) & + h(i,j) = (r0 * h(i,j)) / (((g0*r0)/G) - h(i,j)) + h(i,j) = h(i,j) * 1000.0_r8 ! km to m + enddo +enddo + +end subroutine gph2gmh + +!----------------------------------------------------------------------- +!> This subroutine computes the Earth's gravity at any latitude. +!> The model assumes the Earth is an oblate spheriod rotating at +!> the Earth's spin rate. The model was taken from +!> "Geophysical Geodesy, Kurt Lambeck, 1988". +!> +!> input: xlat, latitude in radians +!> output: galt, gravity at the given lat, km/sec**2 +!> +!> taken from code from author Bill Schreiner, 5/95 +!> +!> + +subroutine compute_surface_gravity(xlat, galt) +real(r8), intent(in) :: xlat +real(r8), intent(out) :: galt + +real(r8),parameter :: xmu = 398600.4415_r8 ! km^3/s^2 +real(r8),parameter :: ae = 6378.1363_r8 ! km +real(r8),parameter :: f = 1.0_r8/298.2564_r8 +real(r8),parameter :: xm = 0.003468_r8 ! +real(r8),parameter :: f2 = 5.3481622134089e-03_r8 ! f2 = -f + 5.0* 0.50*xm - 17.0/14.0*f*xm + 15.0/4.0*xm**2 +real(r8),parameter :: f4 = 2.3448248012911e-05_r8 ! f4 = -f**2* 0.50 + 5.0* 0.50*f*xm + +real(r8) :: g +!real(r8) :: alt = 0.0_r8 + +! gravity at the equator, km/s2 +real(r8), parameter :: ge = xmu/ae**2/(1.0_r8 - f + 1.5_r8*xm - 15.0_r8/14.0_r8*xm*f) + + +! compute gravity at any latitude, km/s2 +g = ge*(1.0_r8 + f2*(sin(xlat))**2 - 1.0_r8/4.0_r8*f4*(sin(2.0_r8*xlat))**2) + +! at a fixed altitude of 0.0, g and galt are the same +galt = g + +! FIXME: if alt is hardcoded to 0.0, none of this code is needed. +! +! keep it for now in case we want gravity to vary with height. +! +!! compute gravity at any latitude and at any height, km/s2 +!galt = g - 2.0_r8*ge*alt/ae*(1.0_r8 + f + xm + (-3.0_r8*f + 5.0_r8* 0.50_r8*xm)* & +! (sin(xlat))**2) + 3.0_r8*ge*alt**2/ae**2 +! +!if (g /= galt) print *, 'g, galt: ', g, galt +! +!!! compute gravity at any latitude, km/s2 +!!galt = ge*(1.0_r8 + f2*(sin(xlat))**2 - 1.0_r8/4.0_r8*f4*(sin(2.0_r8*xlat))**2) +! +!! convert to meters/s2 +!!galt = galt*1000.0_r8 + +end subroutine compute_surface_gravity + +!-------------------------------------------------------------------- +!> using a standard atmosphere pressure column, convert a height directly to pressure + +function generic_height_to_pressure(height, status) +real(r8), intent(in) :: height +integer, intent(out) :: status +real(r8) :: generic_height_to_pressure + +integer :: lev1, lev2 +real(r8) :: fract + +generic_height_to_pressure = MISSING_R8 + +call height_to_level(std_atm_table_len, std_atm_hgt_col, height, & + lev1, lev2, fract, status) +if (status /= 0) return + +generic_height_to_pressure = std_atm_pres_col(lev1) * (1.0_r8-fract) + & + std_atm_pres_col(lev2) * (fract) + +end function generic_height_to_pressure + +!----------------------------------------------------------------------- +!> interpolate in the vertical between 2 arrays of items. +!> +!> vert_fracts: 0 is 100% of the first level and +!> 1 is 100% of the second level + +subroutine vert_interp(nitems, levs1, levs2, vert_fracts, out_vals) +integer, intent(in) :: nitems +real(r8), intent(in) :: levs1(nitems) +real(r8), intent(in) :: levs2(nitems) +real(r8), intent(in) :: vert_fracts(nitems) +real(r8), intent(out) :: out_vals(nitems) + +out_vals(:) = (levs1(:) * (1.0_r8-vert_fracts(:))) + & + (levs2(:) * vert_fracts(:)) + +end subroutine vert_interp + + +!----------------------------------------------------------------------- +!> writes CAM's model date and time of day into file. CAM uses +!> integer date values and integer time of day measured in seconds +!> +!> @param ncid name of the file +!> @param model_time the current time of the model state +!> + +subroutine write_model_time(ncid, model_time) +integer, intent(in) :: ncid +type(time_type), intent(in) :: model_time + +integer :: iyear, imonth, iday, ihour, iminute, isecond +integer :: cam_date(1), cam_tod(1) + +character(len=*), parameter :: routine = 'write_model_time' + +!SENote: this used to have a test for initialized, but it's not useful to get +! here without already being initialized +!if ( .not. module_initialized ) call static_init_model + +call get_date(model_time, iyear, imonth, iday, ihour, iminute, isecond) + +cam_date = iyear*10000 + imonth*100 + iday +cam_tod = ihour*3600 + iminute*60 + isecond + +! if the file doesn't already have a "date" variable make one +if (.not. nc_variable_exists(ncid, "date")) then + call nc_begin_define_mode(ncid, routine) + call nc_define_integer_variable(ncid, 'date', (/ 'time' /), routine) + call nc_end_define_mode(ncid, routine) + call nc_put_variable(ncid, 'date', cam_date, routine) +endif + +! if the file doesn't already have a "datesec" variable make one +if (.not. nc_variable_exists(ncid, "datesec")) then + call nc_begin_define_mode(ncid, routine) + call nc_define_integer_variable(ncid, 'datesec', (/ 'time' /), routine) + call nc_end_define_mode(ncid, routine) + call nc_put_variable(ncid, 'datesec', cam_tod, routine) +endif + +end subroutine write_model_time + +!-------------------------------------------------------------------- +!> +!> Read the time from the input file +!> +!> @param filename name of file that contains the time +!> + +function read_model_time(filename) + +character(len=*), intent(in) :: filename +type(time_type) :: read_model_time + +integer :: ncid +integer :: cam_date, cam_tod +integer :: iyear, imonth, iday, ihour, imin, isec, rem + +character(len=*), parameter :: routine = 'read_model_time' + +!SENote: Doesn't actually need model to be initialized +!if ( .not. module_initialized ) call static_init_model + +if ( .not. file_exist(filename) ) then + write(string1,*) trim(filename), ' does not exist.' + call error_handler(E_ERR,routine,string1,source,revision,revdate) +endif + +ncid = nc_open_file_readonly(filename, routine) + +! CAM initial files have two variables of length +! 'time' (the unlimited dimension): date, datesec + +call nc_get_variable(ncid, 'date', cam_date, routine) +call nc_get_variable(ncid, 'datesec', cam_tod, routine) + +! 'date' is YYYYMMDD +! 'cam_tod' is seconds of current day +iyear = cam_date / 10000 +rem = cam_date - iyear*10000 +imonth = rem / 100 +iday = rem - imonth*100 + +ihour = cam_tod / 3600 +rem = cam_tod - ihour*3600 +imin = rem / 60 +isec = rem - imin*60 + +! some cam files are from before the start of the gregorian calendar. +! since these are 'arbitrary' years, just change the offset. +if (iyear < 1601) then + write(string1,*)' ' + write(string2,*)'WARNING - ',trim(filename),' changing year from ', & + iyear,'to',iyear+1601 + + call error_handler(E_MSG, routine, string1, source, revision, & + revdate, text2=string2,text3='to make it a valid Gregorian date.') + + write(string1,*)' ' + call error_handler(E_MSG, routine, string1, source, revision) + iyear = iyear + 1601 +endif + +read_model_time = set_date(iyear,imonth,iday,ihour,imin,isec) + +call nc_close_file(ncid, routine) + +end function read_model_time + +!-------------------------------------------------------------------- +!> if the namelist is set to not use this custom routine, the default +!> dart routine will add 'pert_amp' of noise to every field in the state +!> to generate an ensemble from a single member. if it is set to true +!> this routine will be called. the pert_amp will be ignored, and the +!> given list of quantities will be perturbed by the given amplitude +!> (which can be different for each field) to generate an ensemble. +subroutine pert_model_copies(state_ens_handle, ens_size, pert_amp, interf_provided) + +type(ensemble_type), intent(inout) :: state_ens_handle +integer, intent(in) :: ens_size +real(r8), intent(in) :: pert_amp ! ignored in this version +logical, intent(out) :: interf_provided + +type(random_seq_type) :: seq + +integer :: iloc, jloc, vloc, myqty +integer :: max_qtys, j + +integer(i8) :: i, state_items +integer(i8), allocatable :: my_vars(:) + +logical, allocatable :: do_these_qtys(:) +real(r8), allocatable :: perturb_by(:) + +character(len=*), parameter :: routine = 'pert_model_copies' + +if (.not. common_initialized) call error_handler(E_ERR, 'routine', 'static_init_model not called') + +! set by namelist to select using the default routine in filter +! (adds the same noise to all parts of the state vector) +! or the code here that lets you specify which fields get perturbed. +if (ccustom_routine_to_generate_ensemble) then + interf_provided = .true. +else + interf_provided = .false. + return +endif + +! make sure each task is using a different random sequence +call init_random_seq(seq, my_task_id()) + +max_qtys = get_num_quantities() +allocate(do_these_qtys(0:max_qtys), perturb_by(0:max_qtys)) + +do_these_qtys(:) = .false. +perturb_by(:) = 0.0_r8 + +! this loop is over the number of field names/perturb values +! in the namelist. it quits when it finds a blank field name. +do i=1, MAX_PERT + if (cfields_to_perturb(i) == '') exit + + myqty = get_index_for_quantity(cfields_to_perturb(i)) + if (myqty < 0) then + string1 = 'unrecognized quantity name in "fields_to_perturb" list: ' // & + trim(cfields_to_perturb(i)) + call error_handler(E_ERR,routine,string1,source,revision,revdate) + endif + + do_these_qtys(myqty) = .true. + perturb_by(myqty) = cperturbation_amplitude(i) +enddo + +! get the global index numbers of the part of the state that +! we have in this task. here is an example of how to work with +! just the part of the state that is on the current task. +state_items = get_my_num_vars(state_ens_handle) +allocate(my_vars(state_items)) +call get_my_vars(state_ens_handle, my_vars) + +! this loop is over all the subset of the state items +! that are on this MPI task. +do i=1, state_items + + ! for each global index number in the state vector find + ! what quantity it is. (iloc,jloc,vloc are unused here) + call get_model_variable_indices(my_vars(i), iloc, jloc, vloc, kind_index=myqty) + + ! if myqty is in the namelist, perturb it. otherwise cycle + if (.not. do_these_qtys(myqty)) cycle + + ! this loop is over the number of ensembles + do j=1, ens_size + state_ens_handle%copies(j, i) = random_gaussian(seq, state_ens_handle%copies(j, i), perturb_by(myqty)) + enddo + +enddo + +deallocate(my_vars) +deallocate(do_these_qtys, perturb_by) + +end subroutine pert_model_copies + +!----------------------------------------------------------------------- +!> +!> Set the desired minimum model advance time. This is generally NOT the +!> dynamical timestep of the model, but rather the shortest forecast length +!> you are willing to make. This impacts how frequently the observations +!> may be assimilated. +!> +!> + +function shortest_time_between_assimilations() + +character(len=*), parameter :: routine = 'shortest_time_between_assimilations:' + +type(time_type) :: shortest_time_between_assimilations + +if (.not. common_initialized) call error_handler(E_ERR, 'routine', 'static_init_model not called') + +shortest_time_between_assimilations = set_time(cassimilation_period_seconds, & + cassimilation_period_days) + +write(string1,*)'assimilation period is ',cassimilation_period_days, ' days ', & + cassimilation_period_seconds,' seconds' +call error_handler(E_MSG,routine,string1,source,revision,revdate) + +end function shortest_time_between_assimilations + + +!-------------------------------------------------------------------- +!> in cam level 1 is at the model top, level N is the lowest level +!> our convention in this code is: between levels a fraction of 0 +!> is 100% level 1, and fraction of 1 is 100% level 2. + +function check_good_levels(vert_value, valid_range, l1, l2, fract) +real(r8), intent(in) :: vert_value +integer, intent(in) :: valid_range +integer, intent(out) :: l1 +integer, intent(out) :: l2 +real(r8), intent(out) :: fract +logical :: check_good_levels + +integer :: integer_level +real(r8) :: fract_level + +! be a pessimist, then you're never disappointed +check_good_levels = .false. +l1 = MISSING_I +l2 = MISSING_I +fract = MISSING_R8 + +! out of range checks +if (vert_value < 1.0_r8 .or. vert_value > valid_range) return + +integer_level = floor(vert_value) +fract_level = vert_value - integer_level + +! cam levels start at the top so level 1 is +! the highest level and increases on the way down. + +!>might want to allow extrapolation - which means +!>allowing out of range values here and handling +!>them correctly in the calling and vert_interp() code. + +if (vert_value /= valid_range) then + l1 = integer_level + l2 = integer_level + 1 + fract = fract_level +else + ! equal to the largest level number + l1 = integer_level - 1 + l2 = integer_level + fract = 1.0_r8 +endif + +check_good_levels = .true. + +end function check_good_levels + +!----------------------------------------------------------------------- +!> return the level indices and fraction across the level. +!> level 1 is model top, level N is model bottom. +!> height is largest at the top, so the values *are* inverted +!> in the array. +!> fract = 0 means full lev1 value, +!> fract = 1 means full lev2 value. +!> return non-zero if value outside valid range. + +subroutine height_to_level(nlevels, heights, h_val, & + lev1, lev2, fract, my_status) + +integer, intent(in) :: nlevels +real(r8), intent(in) :: heights(:) +real(r8), intent(in) :: h_val +integer, intent(out) :: lev1 +integer, intent(out) :: lev2 +real(r8), intent(out) :: fract +integer, intent(out) :: my_status + +character(len=*), parameter :: routine = 'height_to_level:' + +my_status = 0 + +call find_enclosing_indices(nlevels, heights, h_val, lev1, lev2, fract, my_status, & + inverted = .true., log_scale = .false.) + +if (my_status /= 0) my_status = 11 + +end subroutine height_to_level + +!----------------------------------------------------------------------- +!> Compute the pressures at the layer midpoints for multiple columns + +subroutine build_cam_pressure_columns(ens_size, surface_pressure, n_levels, pressure_array) + +integer, intent(in) :: ens_size +real(r8), intent(in) :: surface_pressure(:) ! in pascals +integer, intent(in) :: n_levels +real(r8), intent(out) :: pressure_array(:,:) + +integer :: j, k + +! Set midpoint pressures. This array mirrors the order of the +! cam model levels: 1 is the model top, N is the bottom. + +do j=1, ens_size + call single_pressure_column(surface_pressure(j), n_levels, pressure_array(:, j)) +enddo + +end subroutine build_cam_pressure_columns + +!----------------------------------------------------------------------- +!> Compute column of pressures at the layer midpoints for the given +!> surface pressure. +!> +!> to get pressure on layer interfaces, the computation would be identical +!> but use hyai, hybi. (also have n_levels+1) + +subroutine single_pressure_column(surface_pressure, n_levels, pressure_array) + +real(r8), intent(in) :: surface_pressure ! in pascals +integer, intent(in) :: n_levels +real(r8), intent(out) :: pressure_array(n_levels) + +integer :: k +real(r8) :: am(n_levels) + +! Set midpoint pressures. +!SENote: There is an inconsistency between hyam and the mean of surrounding hyai in the +! caminput.nc files. Suspect that a few of the hyam's are bad, but it could also be +! they hyai's or some combination. For now, need to compare +! to results for the dry mass which use the hyai, so switch to that here. +! Have switched back to try to maintain bitwise consistency with original versions +! but this issue needs to be resolved with the CAM developers. +!!! am = (grid_data%hyai%vals(1:n_levels) + grid_data%hyai%vals(2:n_levels + 1)) / 2.0_r8 +!!!pressure_array(1:n_levels) = ref_surface_pressure * am(1:n_levels) + & + !!!surface_pressure * grid_data%hybm%vals(1:n_levels) + +!SENote: Original code follows +pressure_array(1:n_levels) = ref_surface_pressure * grid_data%hyam%vals(1:n_levels) + & + surface_pressure * grid_data%hybm%vals(1:n_levels) + +end subroutine single_pressure_column + +!-------------------------------------------------------------------- + +subroutine init_discard_high_obs(no_obs_assim_above_level) + +integer, intent(in) :: no_obs_assim_above_level + +! compute a conversion table between height and pressure based on +! a surface pressure of 1010 mb. this is a fixed table and does not +! vary with temperature, humidity or surface elevation. +! use only for quick conversions when absolute accuracy +! isn't a primary concern. It also is based on the standard (not the dry +! mass) vertical coordinate. If there were a situation where the differences +! were big might want to find a way to do this with dry mass, but probably +! not an issue for any earth atmosphere. + +character(len=*), parameter :: routine = 'init_discard_high_obs' +integer :: my_status + +integer :: table_type +character(len=16) :: out_fmt, out_fmt1, pres_fmt +real(r8) :: no_assim_above_scaleh +real(r8) :: temp_p_col(ref_nlevels) + +! pick the better table: +! one is more accurate for the lower atmosphere, +! and the other has a very high top. +table_type = store_std_atm_tables(ref_model_top_pressure) + +! set formatting which is easiest to read in the log. +! the very high top table has very small numbers that need +! exponential notation. +out_fmt = '(A,F12.5,A)' +out_fmt1 = '(A,I5)' +pres_fmt = out_fmt +if (table_type == HIGH_TOP_TABLE) pres_fmt = '(A,E12.5,A)' + +! levels can be fractional but the namelist only allows integer, so simplify the formatting +write(string1, out_fmt1) & + 'Discarding observations higher than model level ', no_obs_assim_above_level +call error_handler(E_MSG, 'init_discard_high_obs', string1, source, revision, revdate) + +! SENote: Accuracy in this computation is not necessary. This just assumed a dry climatological +! column and is one of only two places that the dry vertical coordinate interface ignores +! the impact of water tracers. +call single_pressure_column(ref_surface_pressure, ref_nlevels, temp_p_col) +no_assim_above_pressure = temp_p_col(no_obs_assim_above_level) +write(string1, pres_fmt) & + ' ... which is equivalent to pressure level ', no_assim_above_pressure, ' Pascals' +call error_handler(E_MSG, 'init_discard_high_obs', string1, source, revision, revdate) + +no_assim_above_height = generic_pressure_to_height(no_assim_above_pressure, my_status) +if (my_status /= 0) then + call error_handler(E_ERR, routine, 'error converting pressure to height', & + source, revision, revdate, text2='"no_assim_above_pressure" invalid value') +endif + +write(string1, out_fmt) & + ' ... which is equivalent to height ', no_assim_above_height, ' meters' +call error_handler(E_MSG, 'init_discard_high_obs', string1, source, revision, revdate) + +! print this out, but don't save the value unless we encounter +! incoming observations which have vertical units of scale height. +! so far we have localized in scale height but never had obs +! which had an incoming vertical unit of scale height. +no_assim_above_scaleh = scale_height(no_assim_above_pressure, ref_surface_pressure, .false.) +write(string1, out_fmt) & + ' ... which is equivalent to scale height ', no_assim_above_scaleh +call error_handler(E_MSG, 'init_discard_high_obs', string1, source, revision, revdate) + +end subroutine init_discard_high_obs + +!-------------------------------------------------------------------- +! initialize what we can here. the highest end of the ramp is fixed; +! the start depends on the cutoff distance which can be observation +! type dependent. at the time the ramping adjustment is applied all +! vertical coordinates will have already been converted to the +! vertical localization type. + +subroutine init_damping_ramp_info(model_damping_ends_at_level) + +integer, intent(in) :: model_damping_ends_at_level + +real(r8) :: model_top + +character(len=*), parameter :: routine = 'init_damping_ramp_info' + +integer :: table_type +character(len=16) :: out_fmt + +! pick the better table: +! one is more accurate for the lower atmosphere, +! and the other has a very high top. +table_type = store_std_atm_tables(ref_model_top_pressure) + +! set formatting which is easiest to read in the log. +! the very high top table has very small numbers that need +! exponential notation. +out_fmt = '(A,F12.5,A)' +if (table_type == HIGH_TOP_TABLE .and. & + vertical_localization_type == VERTISPRESSURE) out_fmt = '(A,E12.5,A)' + +! convert to vertical localization units +call convert_vertical_level_generic(model_damping_ends_at_level, & + vertical_localization_type, ramp_end, string3, no_norm=.false.) + +! check for conversion errors +if (ramp_end == MISSING_R8) then + write(string1, *) 'error converting ramp_end to vertical localization units' + call error_handler(E_MSG, routine, 'unexpected error', & + source, revision, revdate, text2=string1) +endif + +! this value only used for print statement, unused otherwise +call convert_vertical_level_generic(1, vertical_localization_type, & + model_top, string3, no_norm=.false.) + +! check for conversion errors +if (model_top == MISSING_R8) then + write(string1, *) 'error converting model_top to vertical localization units' + call error_handler(E_MSG, routine, 'unexpected error', & + source, revision, revdate, text2=string1) +endif + +! at this point, ramp_end and model_top are in the localization units + +! let the log know what we're doing +write(string1, '(A,I5)') 'Increments will go to 0.0 at model level ', model_damping_ends_at_level +write(string2, out_fmt) 'which is ', ramp_end, ' '//trim(string3) +call error_handler(E_MSG, routine, & + 'Decreasing increments in region damped in the model', & + string1, source, revision, revdate, text2=string1, text3=string2) + +write(string1, out_fmt) 'For reference, model top is ', model_top, ' '//trim(string3) +call error_handler(E_MSG, routine, string1, source, revision, revdate) + +end subroutine init_damping_ramp_info + +!-------------------------------------------------------------------- +!> for pressure, level, and one flavor of scale height +!> smaller numbers are further away from the surface. +!> for height and the other flavor of scale height +!> the opposite is true. set this once at init time. + +subroutine init_sign_of_vert_units() + +if (vertical_localization_type == VERTISHEIGHT) then + higher_is_smaller = .false. + +else if (vertical_localization_type == VERTISSCALEHEIGHT) then + ! FIXME: note from nick on scale height: + ! If no_normalization_of_scale_heights is true, then SH=log(pressure), + ! and scale height will decrease with increasing height. + ! However, if it is false then SH= -1*log(pressure/surface_pressure) + ! and it will increase with increasing height. + + if (cno_normalization_of_scale_heights) then + higher_is_smaller = .true. + else + higher_is_smaller = .false. + endif + +else + higher_is_smaller = .true. + +endif + +end subroutine init_sign_of_vert_units + +!-------------------------------------------------------------------- +!> this should only be used for converting vertical values which +!> are the same for all ensemble members at all locations. +!> it uses generic values to do a vertical conversion. + +subroutine convert_vertical_level_generic(level_value, want_vert_type, out_value, out_label, no_norm) +integer, intent(in) :: level_value +integer, intent(in) :: want_vert_type +real(r8), intent(out) :: out_value +character(len=*), intent(out), optional :: out_label +logical, intent(in), optional :: no_norm + +character(len=*), parameter :: routine = 'convert_vertical_level_generic' + +integer :: status +real(r8) :: tmp_val, temp_p_col(ref_nlevels) +logical :: no_norm_flag + +if (present(no_norm)) then + no_norm_flag = no_norm +else + no_norm_flag = cno_normalization_of_scale_heights +endif + +if (want_vert_type == VERTISLEVEL) then + out_value = real(level_value, r8) + if (present(out_label)) out_label = 'levels' +else + ! convert to the requested units. start by going to pressure + ! SENote: Accuracy in this computation is not necessary. This just assumed a dry climatological + ! column and is one of only two places that the dry vertical coordinate interface ignores + ! the impact of water tracers. + call single_pressure_column(ref_surface_pressure, ref_nlevels, temp_p_col) + tmp_val = temp_p_col(level_value) + + select case (want_vert_type) + case (VERTISPRESSURE) + out_value = tmp_val + if (present(out_label)) out_label = 'pascals' + + case (VERTISSCALEHEIGHT) + out_value = scale_height(tmp_val, ref_surface_pressure, no_norm_flag) + if (present(out_label)) out_label = 'scale heights' + + case (VERTISHEIGHT) + out_value = generic_pressure_to_height(tmp_val, status) + if (status /= 0) out_value = MISSING_R8 + if (present(out_label)) out_label = 'meters' + + case default + write(string1, *) 'unknown requested vertical type ', want_vert_type + call error_handler(E_MSG, routine, 'unexpected error', & + source, revision, revdate, text2=string1) + end select +endif + +end subroutine convert_vertical_level_generic + +!----------------------------------------------------------------------- +!> return the level indices and fraction across the level. +!> level 1 is model top, level N is model bottom. +!> pressure is smallest at the top, so the values are not inverted +!> in the array. +!> fract = 0 means full lev1 value, +!> fract = 1 means full lev2 value. +!> return non-zero if value outside valid range. + +subroutine pressure_to_level(nlevels, pressures, p_val, & + lev1, lev2, fract, my_status) + +integer, intent(in) :: nlevels +real(r8), intent(in) :: pressures(:) +real(r8), intent(in) :: p_val +integer, intent(out) :: lev1 +integer, intent(out) :: lev2 +real(r8), intent(out) :: fract +integer, intent(out) :: my_status + +my_status = 0 + +call find_enclosing_indices(nlevels, pressures, p_val, lev1, lev2, fract, my_status, & + inverted = .false., log_scale = cuse_log_vertical_scale) + +if (my_status /= 0) my_status = 10 + +end subroutine pressure_to_level + +!-------------------------------------------------------------------- +!> using a standard atmosphere pressure column, convert a pressure directly to height + +function generic_pressure_to_height(pressure, status) +real(r8), intent(in) :: pressure +integer, intent(out) :: status +real(r8) :: generic_pressure_to_height + +integer :: lev1, lev2 +real(r8) :: fract + +generic_pressure_to_height = MISSING_R8 + +call pressure_to_level(std_atm_table_len, std_atm_pres_col, pressure, & + lev1, lev2, fract, status) +if (status /= 0) return + +generic_pressure_to_height = std_atm_hgt_col(lev1) * (1.0_r8 - fract) + & + std_atm_hgt_col(lev2) * (fract) + +end function generic_pressure_to_height + +!-------------------------------------------------------------------- +! JLA Make sure that sections are coherenet at the end +! vertical functions - these deal with the fact that pressure, +! scale height, and model levels all get larger as you go from +! higher in the atmosphere to lower in the atmosphere, but height +! is the opposite. these all depend on the global setting of the +! vertical localization type. + + +!-------------------------------------------------------------------- +!> pressure gets smaller as you go up, everything else gets larger. +!> return true if this value is above the start of the ramp. +!> test_value and ramp_end need to already be in vert localization units + +! FIXME: test this new code section carefully. +! +! right now the calling code is expecting extra_dist to be added +! to the original get_dist() value, so any scaling or modifications +! should happen in this routine. +! +! do we need the 2 locations here to compute the horizontal distance? +! or is having the total dist and the vertical separation enough? + +function above_ramp_start(test_value, gc, obs_type, ramp_end, total_dist, extra_dist) +real(r8), intent(in) :: test_value +type(get_close_type), intent(in) :: gc +integer, intent(in) :: obs_type +real(r8), intent(in) :: ramp_end +real(r8), intent(in) :: total_dist +real(r8), intent(out) :: extra_dist +logical :: above_ramp_start + +real(r8) :: vert_localize_dist, ramp_start, norm, vert_norm, vert_only_dist +real(r8) :: horiz_dist, ramp_dist, ramp_width +type(location_type) :: this_loc, ramp_start_loc, loc1, loc2 +logical, save :: onetime = .true. + + +! do the easy cases first - either above the ramp end +! or below the ramp start. leave the middle ground for +! last because we have to then compute a damping factor. + +! FIXME: test this!!! +! is it above the ramp end? set damp dist to something +! large enough to turn off all impacts. is vert_localize_dist enough? +vert_localize_dist = get_maxdist(gc, obs_type) +if (.false. .and. onetime) then + print *, 'vert_localize_dist = ', vert_localize_dist + onetime = .false. +endif + +if (v_above(test_value, ramp_end)) then + extra_dist = vert_localize_dist + above_ramp_start = .true. + return +endif + +! compute ramp start and see if we're lower than that. + +! vert norm for this obs type +loc1 = set_location(0.0_r8, 0.0_r8, 0.0_r8, vertical_localization_type) +loc2 = set_location(0.0_r8, 0.0_r8, 1.0_r8, vertical_localization_type) +norm = get_dist(loc1, loc2, obs_type) ! units: rad/loc units +vert_norm = 1.0_r8 / norm ! units now: loc units/rad + +ramp_start = v_down(ramp_end, vert_norm * vert_localize_dist) + +!print *, 'computing ramp start: ramp_end, vert_norm, vert_localize_dist', & +! ramp_start, ramp_end, vert_norm, vert_localize_dist + +if (.not. v_above(test_value, ramp_start)) then + extra_dist = 0.0_r8 + above_ramp_start = .false. + return +endif + + + +! ok, we're somewhere inbetween. compute horiz and vert distances +! and see what the ramping factor needs to be. + +!print *, 'test value within ramp range: ', ramp_start, test_value, ramp_end +above_ramp_start = .true. + +! see what the vertical separation is from obs to start of ramp +this_loc = set_location(0.0_r8, 0.0_r8, test_value, vertical_localization_type) +ramp_start_loc = set_location(0.0_r8, 0.0_r8, ramp_start, vertical_localization_type) + +! do we need this? i think so. radians +vert_only_dist = get_dist(ramp_start_loc, this_loc, obs_type) + +! we need this to compute what? +if (vert_only_dist > total_dist) then + !print *, 'unexpected, vert larger than total: ', vert_only_dist, total_dist + !print *, 'obs_type, vert_norm = ', obs_type, vert_norm + horiz_dist = 0.0_r8 +else + horiz_dist = sqrt(total_dist**2 - vert_only_dist**2) +endif + +ramp_dist = v_difference(test_value, ramp_start) +ramp_width = v_difference(ramp_end, ramp_start) +extra_dist = (ramp_dist / ramp_width) * vert_localize_dist + +! DEBUG - disable for now +if (.false. .and. above_ramp_start) then + print *, 'ramp s/v/e: ', ramp_start, test_value, ramp_end + print *, 'v, h: ', vert_only_dist, horiz_dist + print *, 'rampd, tot: ', ramp_dist, ramp_width + print *, 'ed, return: ', extra_dist, above_ramp_start +endif + +end function above_ramp_start + +!-------------------------------------------------------------------- +! returns true if a is above b (higher in the atmosphere, +! further from the surface of the earth). + +pure function v_above(a, b) +real(r8), intent(in) :: a, b +logical :: v_above + +if (higher_is_smaller) then + v_above = (a < b) +else + v_above = (a > b) +endif + +end function v_above + +!-------------------------------------------------------------------- +! returns new value of moving b distance down in the atmosphere +! starting at a. for height, this results in a smaller value +! (also one flavor of scale height), but for other vertical types +! this results in a larger value. + +pure function v_down(a, b) +real(r8), intent(in) :: a, b +real(r8) :: v_down + +if (higher_is_smaller) then + v_down = (a + b) +else + v_down = (a - b) +endif + +end function v_down + +!-------------------------------------------------------------------- +! returns difference of a and b +! (doesn't depend on the vertical_localization_type) + +pure function v_difference(a, b) +real(r8), intent(in) :: a, b +real(r8) :: v_difference + +v_difference = abs(a - b) + +end function v_difference + +!---------------------------------------------------------------------------- + +!> set values that are used by many routines here and which do not +!> change during the execution of filter. + +subroutine init_globals() + +ref_surface_pressure = grid_data%P0%vals(1) +ref_model_top_pressure = grid_data%hyai%vals(1) * ref_surface_pressure +ref_nlevels = grid_data%lev%nsize + +end subroutine init_globals + +!-------------------------------------------------------------------- + +! add any 2d fields here that are surface quantities + +function is_surface_field(qty) +integer, intent(in) :: qty +logical :: is_surface_field + +select case (qty) + case (QTY_SURFACE_PRESSURE, QTY_SURFACE_ELEVATION) + is_surface_field = .true. + +! example: +! case (QTY_SFNUM_A1, QTY_SFNUM_A2, QTY_SFNUM_A3, QTY_SFNUM_A4, QTY_SFPOM_A4, QTY_SFBC_A4, & +! QTY_SFSO4_A1, QTY_SFSO4_A2, QTY_SFCO, QTY_SFCO01, QTY_SFCO02 ) +! is_surface_field = .true. + + case default + is_surface_field = .false. + +end select + +end function is_surface_field + +!-------------------------------------------------------------------- +! Function to calculate scale height given a pressure and optionally +! a surface pressure. (See the namelist item which controls whether to +! normalize the pressure value aloft with the surface pressure or not. +! We currently only use scale height for computing distances between +! two locations, so the surface pressure terms cancel out - exactly if +! the two locations are co-located horizontally, almost if they are not. +! Normalizing by the surface pressure means in areas of high orography +! the surface differences propagate all the way to the model top. +! To be backwards-compatible, do this normalization; the current thinking +! is we shouldn't do it both for scientific reasons and because it +! doubles the work if it's expensive to find the correct horizontal +! location, i.e. mpas irregular grids. In this model we always have +! the surface pressure at a location so it's not a performance issue.) +! +! Watch out for unusual cases that could crash the log() function +! We pass in the surface pressure here even if it isn't going to be +! used because in all the cases above we seem to have it (or the standard +! reference pressure) everywhere we are going to compute this value. +! The "skip_norm" parameter controls whether this code uses the +! surface pressure or not. + +function scale_height(p_above, p_surface, skip_norm) +real(r8), intent(in) :: p_above +real(r8), intent(in) :: p_surface +logical, intent(in) :: skip_norm +real(r8) :: scale_height + +real(r8), parameter :: tiny = epsilon(1.0_r8) +real(r8) :: diff + +if (skip_norm) then + scale_height = log(p_above) + return +endif + +diff = p_surface - p_above ! should be positive + +if (abs(diff) < tiny) then + ! surface obs will have (almost) identical values + scale_height = 0.0_r8 ! -log(1.0_r8) + +else if (diff <= tiny .or. p_above <= 0.0_r8) then + ! weed out bad cases + scale_height = MISSING_R8 + +else + ! normal computation - should be safe now + scale_height = -log(p_above / p_surface ) + +endif + +end function scale_height + +!----------------------------------------------------------------------- +!> Store a table of pressures and heights. based on a std atmosphere. +!> not precise - use only when rough numbers are good enough. +!> return which table was used. +!> +!> table from: http://www.pdas.com/atmos.html +!> and also see: http://www.pdas.com/upatmos.html +!> for a good explanation of why you can't use the standard +!> equations at high altitudes. the low tables came from +!> tables.c, and the high one came from bigtables.out. +!> (all found in the atmos.zip file from that web site.) + + +function store_std_atm_tables(this_model_top) +real(r8), intent(in) :: this_model_top +integer :: store_std_atm_tables + +logical, save :: table_initialized = .false. + +if (this_model_top < high_top_threshold) then + if (.not. table_initialized) call load_high_top_table() + store_std_atm_tables = HIGH_TOP_TABLE +else + if (.not. table_initialized) call load_low_top_table() + store_std_atm_tables = LOW_TOP_TABLE +endif + +table_initialized = .true. + +end function store_std_atm_tables + +!----------------------------------------------------------------------- +!> Free arrays associated with generic tables + +subroutine free_std_atm_tables() + +if (allocated(std_atm_hgt_col)) deallocate(std_atm_hgt_col) +if (allocated(std_atm_pres_col)) deallocate(std_atm_pres_col) + +end subroutine free_std_atm_tables + +!-------------------------------------------------------------------- + +subroutine load_low_top_table() + +std_atm_table_len = 45 +allocate(std_atm_hgt_col(std_atm_table_len), std_atm_pres_col(std_atm_table_len)) + +std_atm_hgt_col(1) = 86.0_r8 ; std_atm_pres_col(1) = 3.732E-01_r8 +std_atm_hgt_col(2) = 84.0_r8 ; std_atm_pres_col(2) = 5.308E-01_r8 +std_atm_hgt_col(3) = 82.0_r8 ; std_atm_pres_col(3) = 7.498E-01_r8 +std_atm_hgt_col(4) = 80.0_r8 ; std_atm_pres_col(4) = 1.052E+00_r8 +std_atm_hgt_col(5) = 78.0_r8 ; std_atm_pres_col(5) = 1.467E+00_r8 +std_atm_hgt_col(6) = 76.0_r8 ; std_atm_pres_col(6) = 2.033E+00_r8 +std_atm_hgt_col(7) = 74.0_r8 ; std_atm_pres_col(7) = 2.800E+00_r8 +std_atm_hgt_col(8) = 72.0_r8 ; std_atm_pres_col(8) = 3.835E+00_r8 +std_atm_hgt_col(9) = 70.0_r8 ; std_atm_pres_col(9) = 5.220E+00_r8 +std_atm_hgt_col(10) = 68.0_r8 ; std_atm_pres_col(10) = 7.051E+00_r8 +std_atm_hgt_col(11) = 66.0_r8 ; std_atm_pres_col(11) = 9.459E+00_r8 +std_atm_hgt_col(12) = 64.0_r8 ; std_atm_pres_col(12) = 1.260E+01_r8 +std_atm_hgt_col(13) = 62.0_r8 ; std_atm_pres_col(13) = 1.669E+01_r8 +std_atm_hgt_col(14) = 60.0_r8 ; std_atm_pres_col(14) = 2.196E+01_r8 +std_atm_hgt_col(15) = 58.0_r8 ; std_atm_pres_col(15) = 2.872E+01_r8 +std_atm_hgt_col(16) = 56.0_r8 ; std_atm_pres_col(16) = 3.736E+01_r8 +std_atm_hgt_col(17) = 54.0_r8 ; std_atm_pres_col(17) = 4.833E+01_r8 +std_atm_hgt_col(18) = 52.0_r8 ; std_atm_pres_col(18) = 6.221E+01_r8 +std_atm_hgt_col(19) = 50.0_r8 ; std_atm_pres_col(19) = 7.977E+01_r8 +std_atm_hgt_col(20) = 48.0_r8 ; std_atm_pres_col(20) = 1.023E+02_r8 +std_atm_hgt_col(21) = 46.0_r8 ; std_atm_pres_col(21) = 1.313E+02_r8 +std_atm_hgt_col(22) = 44.0_r8 ; std_atm_pres_col(22) = 1.695E+02_r8 +std_atm_hgt_col(23) = 42.0_r8 ; std_atm_pres_col(23) = 2.200E+02_r8 +std_atm_hgt_col(24) = 40.0_r8 ; std_atm_pres_col(24) = 2.871E+02_r8 +std_atm_hgt_col(25) = 38.0_r8 ; std_atm_pres_col(25) = 3.771E+02_r8 +std_atm_hgt_col(26) = 36.0_r8 ; std_atm_pres_col(26) = 4.985E+02_r8 +std_atm_hgt_col(27) = 34.0_r8 ; std_atm_pres_col(27) = 6.634E+02_r8 +std_atm_hgt_col(28) = 32.0_r8 ; std_atm_pres_col(28) = 8.890E+02_r8 +std_atm_hgt_col(29) = 30.0_r8 ; std_atm_pres_col(29) = 1.197E+03_r8 +std_atm_hgt_col(30) = 28.0_r8 ; std_atm_pres_col(30) = 1.616E+03_r8 +std_atm_hgt_col(31) = 26.0_r8 ; std_atm_pres_col(31) = 2.188E+03_r8 +std_atm_hgt_col(32) = 24.0_r8 ; std_atm_pres_col(32) = 2.972E+03_r8 +std_atm_hgt_col(33) = 22.0_r8 ; std_atm_pres_col(33) = 4.047E+03_r8 +std_atm_hgt_col(34) = 20.0_r8 ; std_atm_pres_col(34) = 5.529E+03_r8 +std_atm_hgt_col(35) = 18.0_r8 ; std_atm_pres_col(35) = 7.565E+03_r8 +std_atm_hgt_col(36) = 16.0_r8 ; std_atm_pres_col(36) = 1.035E+04_r8 +std_atm_hgt_col(37) = 14.0_r8 ; std_atm_pres_col(37) = 1.417E+04_r8 +std_atm_hgt_col(38) = 12.0_r8 ; std_atm_pres_col(38) = 1.940E+04_r8 +std_atm_hgt_col(39) = 10.0_r8 ; std_atm_pres_col(39) = 2.650E+04_r8 +std_atm_hgt_col(40) = 8.0_r8 ; std_atm_pres_col(40) = 3.565E+04_r8 +std_atm_hgt_col(41) = 6.0_r8 ; std_atm_pres_col(41) = 4.722E+04_r8 +std_atm_hgt_col(42) = 4.0_r8 ; std_atm_pres_col(42) = 6.166E+04_r8 +std_atm_hgt_col(43) = 2.0_r8 ; std_atm_pres_col(43) = 7.950E+04_r8 +std_atm_hgt_col(44) = 0.0_r8 ; std_atm_pres_col(44) = 1.013E+05_r8 +std_atm_hgt_col(45) = -2.0_r8 ; std_atm_pres_col(45) = 1.278E+05_r8 + +! convert km to m +std_atm_hgt_col(:) = std_atm_hgt_col(:) * 1000.0_r8 + +end subroutine load_low_top_table + +!-------------------------------------------------------------------- + +subroutine load_high_top_table() + +std_atm_table_len = 201 +allocate(std_atm_hgt_col(std_atm_table_len), std_atm_pres_col(std_atm_table_len)) + +std_atm_hgt_col(1) = 1000.0_r8 ; std_atm_pres_col(1) = 7.518E-09_r8 +std_atm_hgt_col(2) = 995.0_r8 ; std_atm_pres_col(2) = 7.651E-09_r8 +std_atm_hgt_col(3) = 990.0_r8 ; std_atm_pres_col(3) = 7.790E-09_r8 +std_atm_hgt_col(4) = 985.0_r8 ; std_atm_pres_col(4) = 7.931E-09_r8 +std_atm_hgt_col(5) = 980.0_r8 ; std_atm_pres_col(5) = 8.075E-09_r8 +std_atm_hgt_col(6) = 975.0_r8 ; std_atm_pres_col(6) = 8.222E-09_r8 +std_atm_hgt_col(7) = 970.0_r8 ; std_atm_pres_col(7) = 8.371E-09_r8 +std_atm_hgt_col(8) = 965.0_r8 ; std_atm_pres_col(8) = 8.524E-09_r8 +std_atm_hgt_col(9) = 960.0_r8 ; std_atm_pres_col(9) = 8.680E-09_r8 +std_atm_hgt_col(10) = 955.0_r8 ; std_atm_pres_col(10) = 8.839E-09_r8 +std_atm_hgt_col(11) = 950.0_r8 ; std_atm_pres_col(11) = 9.001E-09_r8 +std_atm_hgt_col(12) = 945.0_r8 ; std_atm_pres_col(12) = 9.168E-09_r8 +std_atm_hgt_col(13) = 940.0_r8 ; std_atm_pres_col(13) = 9.338E-09_r8 +std_atm_hgt_col(14) = 935.0_r8 ; std_atm_pres_col(14) = 9.513E-09_r8 +std_atm_hgt_col(15) = 930.0_r8 ; std_atm_pres_col(15) = 9.692E-09_r8 +std_atm_hgt_col(16) = 925.0_r8 ; std_atm_pres_col(16) = 9.875E-09_r8 +std_atm_hgt_col(17) = 920.0_r8 ; std_atm_pres_col(17) = 1.006E-08_r8 +std_atm_hgt_col(18) = 915.0_r8 ; std_atm_pres_col(18) = 1.026E-08_r8 +std_atm_hgt_col(19) = 910.0_r8 ; std_atm_pres_col(19) = 1.046E-08_r8 +std_atm_hgt_col(20) = 905.0_r8 ; std_atm_pres_col(20) = 1.066E-08_r8 +std_atm_hgt_col(21) = 900.0_r8 ; std_atm_pres_col(21) = 1.087E-08_r8 +std_atm_hgt_col(22) = 895.0_r8 ; std_atm_pres_col(22) = 1.109E-08_r8 +std_atm_hgt_col(23) = 890.0_r8 ; std_atm_pres_col(23) = 1.132E-08_r8 +std_atm_hgt_col(24) = 885.0_r8 ; std_atm_pres_col(24) = 1.155E-08_r8 +std_atm_hgt_col(25) = 880.0_r8 ; std_atm_pres_col(25) = 1.179E-08_r8 +std_atm_hgt_col(26) = 875.0_r8 ; std_atm_pres_col(26) = 1.203E-08_r8 +std_atm_hgt_col(27) = 870.0_r8 ; std_atm_pres_col(27) = 1.229E-08_r8 +std_atm_hgt_col(28) = 865.0_r8 ; std_atm_pres_col(28) = 1.255E-08_r8 +std_atm_hgt_col(29) = 860.0_r8 ; std_atm_pres_col(29) = 1.283E-08_r8 +std_atm_hgt_col(30) = 855.0_r8 ; std_atm_pres_col(30) = 1.311E-08_r8 +std_atm_hgt_col(31) = 850.0_r8 ; std_atm_pres_col(31) = 1.340E-08_r8 +std_atm_hgt_col(32) = 845.0_r8 ; std_atm_pres_col(32) = 1.371E-08_r8 +std_atm_hgt_col(33) = 840.0_r8 ; std_atm_pres_col(33) = 1.402E-08_r8 +std_atm_hgt_col(34) = 835.0_r8 ; std_atm_pres_col(34) = 1.435E-08_r8 +std_atm_hgt_col(35) = 830.0_r8 ; std_atm_pres_col(35) = 1.469E-08_r8 +std_atm_hgt_col(36) = 825.0_r8 ; std_atm_pres_col(36) = 1.504E-08_r8 +std_atm_hgt_col(37) = 820.0_r8 ; std_atm_pres_col(37) = 1.541E-08_r8 +std_atm_hgt_col(38) = 815.0_r8 ; std_atm_pres_col(38) = 1.579E-08_r8 +std_atm_hgt_col(39) = 810.0_r8 ; std_atm_pres_col(39) = 1.619E-08_r8 +std_atm_hgt_col(40) = 805.0_r8 ; std_atm_pres_col(40) = 1.660E-08_r8 +std_atm_hgt_col(41) = 800.0_r8 ; std_atm_pres_col(41) = 1.704E-08_r8 +std_atm_hgt_col(42) = 795.0_r8 ; std_atm_pres_col(42) = 1.749E-08_r8 +std_atm_hgt_col(43) = 790.0_r8 ; std_atm_pres_col(43) = 1.795E-08_r8 +std_atm_hgt_col(44) = 785.0_r8 ; std_atm_pres_col(44) = 1.844E-08_r8 +std_atm_hgt_col(45) = 780.0_r8 ; std_atm_pres_col(45) = 1.896E-08_r8 +std_atm_hgt_col(46) = 775.0_r8 ; std_atm_pres_col(46) = 1.949E-08_r8 +std_atm_hgt_col(47) = 770.0_r8 ; std_atm_pres_col(47) = 2.006E-08_r8 +std_atm_hgt_col(48) = 765.0_r8 ; std_atm_pres_col(48) = 2.064E-08_r8 +std_atm_hgt_col(49) = 760.0_r8 ; std_atm_pres_col(49) = 2.126E-08_r8 +std_atm_hgt_col(50) = 755.0_r8 ; std_atm_pres_col(50) = 2.191E-08_r8 +std_atm_hgt_col(51) = 750.0_r8 ; std_atm_pres_col(51) = 2.260E-08_r8 +std_atm_hgt_col(52) = 745.0_r8 ; std_atm_pres_col(52) = 2.331E-08_r8 +std_atm_hgt_col(53) = 740.0_r8 ; std_atm_pres_col(53) = 2.407E-08_r8 +std_atm_hgt_col(54) = 735.0_r8 ; std_atm_pres_col(54) = 2.487E-08_r8 +std_atm_hgt_col(55) = 730.0_r8 ; std_atm_pres_col(55) = 2.571E-08_r8 +std_atm_hgt_col(56) = 725.0_r8 ; std_atm_pres_col(56) = 2.660E-08_r8 +std_atm_hgt_col(57) = 720.0_r8 ; std_atm_pres_col(57) = 2.755E-08_r8 +std_atm_hgt_col(58) = 715.0_r8 ; std_atm_pres_col(58) = 2.854E-08_r8 +std_atm_hgt_col(59) = 710.0_r8 ; std_atm_pres_col(59) = 2.960E-08_r8 +std_atm_hgt_col(60) = 705.0_r8 ; std_atm_pres_col(60) = 3.072E-08_r8 +std_atm_hgt_col(61) = 700.0_r8 ; std_atm_pres_col(61) = 3.191E-08_r8 +std_atm_hgt_col(62) = 695.0_r8 ; std_atm_pres_col(62) = 3.317E-08_r8 +std_atm_hgt_col(63) = 690.0_r8 ; std_atm_pres_col(63) = 3.451E-08_r8 +std_atm_hgt_col(64) = 685.0_r8 ; std_atm_pres_col(64) = 3.594E-08_r8 +std_atm_hgt_col(65) = 680.0_r8 ; std_atm_pres_col(65) = 3.746E-08_r8 +std_atm_hgt_col(66) = 675.0_r8 ; std_atm_pres_col(66) = 3.908E-08_r8 +std_atm_hgt_col(67) = 670.0_r8 ; std_atm_pres_col(67) = 4.080E-08_r8 +std_atm_hgt_col(68) = 665.0_r8 ; std_atm_pres_col(68) = 4.264E-08_r8 +std_atm_hgt_col(69) = 660.0_r8 ; std_atm_pres_col(69) = 4.459E-08_r8 +std_atm_hgt_col(70) = 655.0_r8 ; std_atm_pres_col(70) = 4.668E-08_r8 +std_atm_hgt_col(71) = 650.0_r8 ; std_atm_pres_col(71) = 4.892E-08_r8 +std_atm_hgt_col(72) = 645.0_r8 ; std_atm_pres_col(72) = 5.130E-08_r8 +std_atm_hgt_col(73) = 640.0_r8 ; std_atm_pres_col(73) = 5.385E-08_r8 +std_atm_hgt_col(74) = 635.0_r8 ; std_atm_pres_col(74) = 5.659E-08_r8 +std_atm_hgt_col(75) = 630.0_r8 ; std_atm_pres_col(75) = 5.951E-08_r8 +std_atm_hgt_col(76) = 625.0_r8 ; std_atm_pres_col(76) = 6.264E-08_r8 +std_atm_hgt_col(77) = 620.0_r8 ; std_atm_pres_col(77) = 6.600E-08_r8 +std_atm_hgt_col(78) = 615.0_r8 ; std_atm_pres_col(78) = 6.961E-08_r8 +std_atm_hgt_col(79) = 610.0_r8 ; std_atm_pres_col(79) = 7.349E-08_r8 +std_atm_hgt_col(80) = 605.0_r8 ; std_atm_pres_col(80) = 7.765E-08_r8 +std_atm_hgt_col(81) = 600.0_r8 ; std_atm_pres_col(81) = 8.213E-08_r8 +std_atm_hgt_col(82) = 595.0_r8 ; std_atm_pres_col(82) = 8.695E-08_r8 +std_atm_hgt_col(83) = 590.0_r8 ; std_atm_pres_col(83) = 9.214E-08_r8 +std_atm_hgt_col(84) = 585.0_r8 ; std_atm_pres_col(84) = 9.774E-08_r8 +std_atm_hgt_col(85) = 580.0_r8 ; std_atm_pres_col(85) = 1.038E-07_r8 +std_atm_hgt_col(86) = 575.0_r8 ; std_atm_pres_col(86) = 1.103E-07_r8 +std_atm_hgt_col(87) = 570.0_r8 ; std_atm_pres_col(87) = 1.173E-07_r8 +std_atm_hgt_col(88) = 565.0_r8 ; std_atm_pres_col(88) = 1.249E-07_r8 +std_atm_hgt_col(89) = 560.0_r8 ; std_atm_pres_col(89) = 1.330E-07_r8 +std_atm_hgt_col(90) = 555.0_r8 ; std_atm_pres_col(90) = 1.418E-07_r8 +std_atm_hgt_col(91) = 550.0_r8 ; std_atm_pres_col(91) = 1.514E-07_r8 +std_atm_hgt_col(92) = 545.0_r8 ; std_atm_pres_col(92) = 1.617E-07_r8 +std_atm_hgt_col(93) = 540.0_r8 ; std_atm_pres_col(93) = 1.728E-07_r8 +std_atm_hgt_col(94) = 535.0_r8 ; std_atm_pres_col(94) = 1.849E-07_r8 +std_atm_hgt_col(95) = 530.0_r8 ; std_atm_pres_col(95) = 1.979E-07_r8 +std_atm_hgt_col(96) = 525.0_r8 ; std_atm_pres_col(96) = 2.120E-07_r8 +std_atm_hgt_col(97) = 520.0_r8 ; std_atm_pres_col(97) = 2.273E-07_r8 +std_atm_hgt_col(98) = 515.0_r8 ; std_atm_pres_col(98) = 2.439E-07_r8 +std_atm_hgt_col(99) = 510.0_r8 ; std_atm_pres_col(99) = 2.618E-07_r8 +std_atm_hgt_col(100) = 505.0_r8 ; std_atm_pres_col(100) = 2.813E-07_r8 +std_atm_hgt_col(101) = 500.0_r8 ; std_atm_pres_col(101) = 3.024E-07_r8 +std_atm_hgt_col(102) = 495.0_r8 ; std_atm_pres_col(102) = 3.252E-07_r8 +std_atm_hgt_col(103) = 490.0_r8 ; std_atm_pres_col(103) = 3.501E-07_r8 +std_atm_hgt_col(104) = 485.0_r8 ; std_atm_pres_col(104) = 3.770E-07_r8 +std_atm_hgt_col(105) = 480.0_r8 ; std_atm_pres_col(105) = 4.063E-07_r8 +std_atm_hgt_col(106) = 475.0_r8 ; std_atm_pres_col(106) = 4.382E-07_r8 +std_atm_hgt_col(107) = 470.0_r8 ; std_atm_pres_col(107) = 4.728E-07_r8 +std_atm_hgt_col(108) = 465.0_r8 ; std_atm_pres_col(108) = 5.104E-07_r8 +std_atm_hgt_col(109) = 460.0_r8 ; std_atm_pres_col(109) = 5.514E-07_r8 +std_atm_hgt_col(110) = 455.0_r8 ; std_atm_pres_col(110) = 5.960E-07_r8 +std_atm_hgt_col(111) = 450.0_r8 ; std_atm_pres_col(111) = 6.445E-07_r8 +std_atm_hgt_col(112) = 445.0_r8 ; std_atm_pres_col(112) = 6.974E-07_r8 +std_atm_hgt_col(113) = 440.0_r8 ; std_atm_pres_col(113) = 7.550E-07_r8 +std_atm_hgt_col(114) = 435.0_r8 ; std_atm_pres_col(114) = 8.179E-07_r8 +std_atm_hgt_col(115) = 430.0_r8 ; std_atm_pres_col(115) = 8.864E-07_r8 +std_atm_hgt_col(116) = 425.0_r8 ; std_atm_pres_col(116) = 9.612E-07_r8 +std_atm_hgt_col(117) = 420.0_r8 ; std_atm_pres_col(117) = 1.043E-06_r8 +std_atm_hgt_col(118) = 415.0_r8 ; std_atm_pres_col(118) = 1.132E-06_r8 +std_atm_hgt_col(119) = 410.0_r8 ; std_atm_pres_col(119) = 1.229E-06_r8 +std_atm_hgt_col(120) = 405.0_r8 ; std_atm_pres_col(120) = 1.336E-06_r8 +std_atm_hgt_col(121) = 400.0_r8 ; std_atm_pres_col(121) = 1.452E-06_r8 +std_atm_hgt_col(122) = 395.0_r8 ; std_atm_pres_col(122) = 1.579E-06_r8 +std_atm_hgt_col(123) = 390.0_r8 ; std_atm_pres_col(123) = 1.718E-06_r8 +std_atm_hgt_col(124) = 385.0_r8 ; std_atm_pres_col(124) = 1.870E-06_r8 +std_atm_hgt_col(125) = 380.0_r8 ; std_atm_pres_col(125) = 2.037E-06_r8 +std_atm_hgt_col(126) = 375.0_r8 ; std_atm_pres_col(126) = 2.220E-06_r8 +std_atm_hgt_col(127) = 370.0_r8 ; std_atm_pres_col(127) = 2.421E-06_r8 +std_atm_hgt_col(128) = 365.0_r8 ; std_atm_pres_col(128) = 2.641E-06_r8 +std_atm_hgt_col(129) = 360.0_r8 ; std_atm_pres_col(129) = 2.884E-06_r8 +std_atm_hgt_col(130) = 355.0_r8 ; std_atm_pres_col(130) = 3.151E-06_r8 +std_atm_hgt_col(131) = 350.0_r8 ; std_atm_pres_col(131) = 3.445E-06_r8 +std_atm_hgt_col(132) = 345.0_r8 ; std_atm_pres_col(132) = 3.769E-06_r8 +std_atm_hgt_col(133) = 340.0_r8 ; std_atm_pres_col(133) = 4.126E-06_r8 +std_atm_hgt_col(134) = 335.0_r8 ; std_atm_pres_col(134) = 4.521E-06_r8 +std_atm_hgt_col(135) = 330.0_r8 ; std_atm_pres_col(135) = 4.957E-06_r8 +std_atm_hgt_col(136) = 325.0_r8 ; std_atm_pres_col(136) = 5.440E-06_r8 +std_atm_hgt_col(137) = 320.0_r8 ; std_atm_pres_col(137) = 5.975E-06_r8 +std_atm_hgt_col(138) = 315.0_r8 ; std_atm_pres_col(138) = 6.568E-06_r8 +std_atm_hgt_col(139) = 310.0_r8 ; std_atm_pres_col(139) = 7.226E-06_r8 +std_atm_hgt_col(140) = 305.0_r8 ; std_atm_pres_col(140) = 7.957E-06_r8 +std_atm_hgt_col(141) = 300.0_r8 ; std_atm_pres_col(141) = 8.770E-06_r8 +std_atm_hgt_col(142) = 295.0_r8 ; std_atm_pres_col(142) = 9.676E-06_r8 +std_atm_hgt_col(143) = 290.0_r8 ; std_atm_pres_col(143) = 1.069E-05_r8 +std_atm_hgt_col(144) = 285.0_r8 ; std_atm_pres_col(144) = 1.181E-05_r8 +std_atm_hgt_col(145) = 280.0_r8 ; std_atm_pres_col(145) = 1.308E-05_r8 +std_atm_hgt_col(146) = 275.0_r8 ; std_atm_pres_col(146) = 1.449E-05_r8 +std_atm_hgt_col(147) = 270.0_r8 ; std_atm_pres_col(147) = 1.608E-05_r8 +std_atm_hgt_col(148) = 265.0_r8 ; std_atm_pres_col(148) = 1.787E-05_r8 +std_atm_hgt_col(149) = 260.0_r8 ; std_atm_pres_col(149) = 1.989E-05_r8 +std_atm_hgt_col(150) = 255.0_r8 ; std_atm_pres_col(150) = 2.218E-05_r8 +std_atm_hgt_col(151) = 250.0_r8 ; std_atm_pres_col(151) = 2.476E-05_r8 +std_atm_hgt_col(152) = 245.0_r8 ; std_atm_pres_col(152) = 2.770E-05_r8 +std_atm_hgt_col(153) = 240.0_r8 ; std_atm_pres_col(153) = 3.105E-05_r8 +std_atm_hgt_col(154) = 235.0_r8 ; std_atm_pres_col(154) = 3.488E-05_r8 +std_atm_hgt_col(155) = 230.0_r8 ; std_atm_pres_col(155) = 3.927E-05_r8 +std_atm_hgt_col(156) = 225.0_r8 ; std_atm_pres_col(156) = 4.432E-05_r8 +std_atm_hgt_col(157) = 220.0_r8 ; std_atm_pres_col(157) = 5.015E-05_r8 +std_atm_hgt_col(158) = 215.0_r8 ; std_atm_pres_col(158) = 5.690E-05_r8 +std_atm_hgt_col(159) = 210.0_r8 ; std_atm_pres_col(159) = 6.476E-05_r8 +std_atm_hgt_col(160) = 205.0_r8 ; std_atm_pres_col(160) = 7.394E-05_r8 +std_atm_hgt_col(161) = 200.0_r8 ; std_atm_pres_col(161) = 8.474E-05_r8 +std_atm_hgt_col(162) = 195.0_r8 ; std_atm_pres_col(162) = 9.749E-05_r8 +std_atm_hgt_col(163) = 190.0_r8 ; std_atm_pres_col(163) = 1.127E-04_r8 +std_atm_hgt_col(164) = 185.0_r8 ; std_atm_pres_col(164) = 1.308E-04_r8 +std_atm_hgt_col(165) = 180.0_r8 ; std_atm_pres_col(165) = 1.527E-04_r8 +std_atm_hgt_col(166) = 175.0_r8 ; std_atm_pres_col(166) = 1.794E-04_r8 +std_atm_hgt_col(167) = 170.0_r8 ; std_atm_pres_col(167) = 2.121E-04_r8 +std_atm_hgt_col(168) = 165.0_r8 ; std_atm_pres_col(168) = 2.528E-04_r8 +std_atm_hgt_col(169) = 160.0_r8 ; std_atm_pres_col(169) = 3.039E-04_r8 +std_atm_hgt_col(170) = 155.0_r8 ; std_atm_pres_col(170) = 3.693E-04_r8 +std_atm_hgt_col(171) = 150.0_r8 ; std_atm_pres_col(171) = 4.542E-04_r8 +std_atm_hgt_col(172) = 145.0_r8 ; std_atm_pres_col(172) = 5.669E-04_r8 +std_atm_hgt_col(173) = 140.0_r8 ; std_atm_pres_col(173) = 7.203E-04_r8 +std_atm_hgt_col(174) = 135.0_r8 ; std_atm_pres_col(174) = 9.357E-04_r8 +std_atm_hgt_col(175) = 130.0_r8 ; std_atm_pres_col(175) = 1.250E-03_r8 +std_atm_hgt_col(176) = 125.0_r8 ; std_atm_pres_col(176) = 1.736E-03_r8 +std_atm_hgt_col(177) = 120.0_r8 ; std_atm_pres_col(177) = 2.537E-03_r8 +std_atm_hgt_col(178) = 115.0_r8 ; std_atm_pres_col(178) = 4.004E-03_r8 +std_atm_hgt_col(179) = 110.0_r8 ; std_atm_pres_col(179) = 7.149E-03_r8 +std_atm_hgt_col(180) = 105.0_r8 ; std_atm_pres_col(180) = 1.442E-02_r8 +std_atm_hgt_col(181) = 100.0_r8 ; std_atm_pres_col(181) = 3.201E-02_r8 +std_atm_hgt_col(182) = 95.0_r8 ; std_atm_pres_col(182) = 7.577E-02_r8 +std_atm_hgt_col(183) = 90.0_r8 ; std_atm_pres_col(183) = 1.844E-01_r8 +std_atm_hgt_col(184) = 85.0_r8 ; std_atm_pres_col(184) = 4.457E-01_r8 +std_atm_hgt_col(185) = 80.0_r8 ; std_atm_pres_col(185) = 1.052E+00_r8 +std_atm_hgt_col(186) = 75.0_r8 ; std_atm_pres_col(186) = 2.388E+00_r8 +std_atm_hgt_col(187) = 70.0_r8 ; std_atm_pres_col(187) = 5.221E+00_r8 +std_atm_hgt_col(188) = 65.0_r8 ; std_atm_pres_col(188) = 1.093E+01_r8 +std_atm_hgt_col(189) = 60.0_r8 ; std_atm_pres_col(189) = 2.196E+01_r8 +std_atm_hgt_col(190) = 55.0_r8 ; std_atm_pres_col(190) = 4.253E+01_r8 +std_atm_hgt_col(191) = 50.0_r8 ; std_atm_pres_col(191) = 7.978E+01_r8 +std_atm_hgt_col(192) = 45.0_r8 ; std_atm_pres_col(192) = 1.491E+02_r8 +std_atm_hgt_col(193) = 40.0_r8 ; std_atm_pres_col(193) = 2.871E+02_r8 +std_atm_hgt_col(194) = 35.0_r8 ; std_atm_pres_col(194) = 5.746E+02_r8 +std_atm_hgt_col(195) = 30.0_r8 ; std_atm_pres_col(195) = 1.197E+03_r8 +std_atm_hgt_col(196) = 25.0_r8 ; std_atm_pres_col(196) = 2.549E+03_r8 +std_atm_hgt_col(197) = 20.0_r8 ; std_atm_pres_col(197) = 5.529E+03_r8 +std_atm_hgt_col(198) = 15.0_r8 ; std_atm_pres_col(198) = 1.211E+04_r8 +std_atm_hgt_col(199) = 10.0_r8 ; std_atm_pres_col(199) = 2.650E+04_r8 +std_atm_hgt_col(200) = 5.0_r8 ; std_atm_pres_col(200) = 5.405E+04_r8 +std_atm_hgt_col(201) = 0.0_r8 ; std_atm_pres_col(201) = 1.013E+05_r8 + +! convert km to m +std_atm_hgt_col(:) = std_atm_hgt_col(:) * 1000.0_r8 + +end subroutine load_high_top_table + +!----------------------------------------------------------------------- +!> Read in the grid information from the given CAM restart file. +!> Note that none of the data will be used from this file; just the +!> grid size and locations. +subroutine read_grid_info(grid_file) +character(len=*), intent(in) :: grid_file ! cam template file + +! Get the grid info plus additional non-state arrays +call get_cam_grid(grid_file) + +end subroutine read_grid_info + +!======================================================================== + +end module cam_common_code_mod diff --git a/models/cam-fv/chem_tables_mod.f90 b/models/cam-common-code/chem_tables_mod.f90 similarity index 100% rename from models/cam-fv/chem_tables_mod.f90 rename to models/cam-common-code/chem_tables_mod.f90 diff --git a/models/cam-fv/deprecated/README b/models/cam-fv/deprecated/README deleted file mode 100644 index 2f873faa7f..0000000000 --- a/models/cam-fv/deprecated/README +++ /dev/null @@ -1,84 +0,0 @@ -# DART software - Copyright UCAR. This open source software is provided -# by UCAR, "as is", without charge, subject to all terms of use at -# http://www.image.ucar.edu/DAReS/DART/DART_download -# -# DART $Id$ - -The files in this directory are deprecated. - -Thu Apr 17 15:16:29 MDT 2014 -I am removing these files from the deprecated directory. -These are the last versions, should you need to get them again. - - 6886 6524 thoar assimilate.Fzagar.csh - 6886 6524 thoar assimilate.hopper.csh - 6886 6524 thoar assimilate.ned.csh - 6886 6524 thoar assimilate.zagar.csh - 6886 6524 thoar auto_diagPOP2hpss_LSF.csh - 6886 6541 thoar CESM_setup_startup.csh - 6886 6524 thoar CESM_setup_startup_hopper.csh - 6886 6524 thoar CESM_setup_zagar.csh - 6886 6524 thoar CESM_setup_zagar_pmo.csh - 6886 6524 thoar clm.cpl7.template - 6886 6524 thoar clm_FillValue_vars.csh - 6886 6524 thoar input.normal.nml - 6886 6524 thoar input.pert0.nml - 6886 6524 thoar job_mpi_blueice_fragment.csh - 6886 6256 thoar mkmf_trans_date_to_dart - 6886 6256 thoar mkmf_trans_pv_sv - 6886 6256 thoar mkmf_trans_pv_sv_pert0 - 6886 6256 thoar mkmf_trans_pv_sv_time0 - 6886 6256 thoar mkmf_trans_sv_pv - 6886 6256 thoar mkmf_trans_time - 6886 4941 thoar path_names_trans_date_to_dart - 6886 6256 thoar path_names_trans_pv_sv - 6886 6256 thoar path_names_trans_pv_sv_pert0 - 6886 6256 thoar path_names_trans_pv_sv_time0 - 6886 6256 thoar path_names_trans_sv_pv - 6886 6256 thoar path_names_trans_time - 6886 6524 thoar pmo.ned.csh - 6886 6524 thoar setup_cesm_case.hopper.csh - 6886 6524 thoar setup_cesm_case.ned.csh - 6886 6524 thoar setup_cesm_case.pmo.csh - 6886 6256 thoar trans_date_to_dart.f90 - 6886 6340 nancy trans_date_to_dart.html - 6886 6256 thoar trans_pv_sv.f90 - 6886 6256 thoar trans_pv_sv_pert0.f90 - 6886 6256 thoar trans_pv_sv_time0.f90 - 6886 6340 nancy trans_pv_sv_time0.html - 6886 6256 thoar trans_sv_pv.f90 - 6886 6256 thoar trans_time.f90 - -The mkmf_trans_* and path_names_trans_* files are for building -the original translation tools between DART initial condition/ -restart file format and CAM netCDF file format, and also translating -time between DART and CAM formats. All are completely superceeded -by the following 3 tools: - -dart_to_cam -cam_to_dart -advance_time - -If you need to continue to use the original tools, -copy the source files into DART/models/cam, copy the mkmf_* -and path_names_* files into ../work, and run ./quickbuild.csh -from the work directory. - --=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- - -Tue Aug 20 16:03:31 2019 -0600 - - The bisection code has moved into the utilities_mod.f90 file. - this was an initial version for testing. it can be deleted from the repo. - also the external high top and low top tables are also obsolete - - they're hardcoded in the cam model_mod itself now. - - delete mode 100644 models/cam-fv/bisection_subr.f90 - delete mode 100644 models/cam-fv/high_top_table.f90 - delete mode 100644 models/cam-fv/low_top_table.f90 - - -# -# $URL$ -# $Revision$ -# $Date$ diff --git a/models/cam-fv/doc/README_cam-se b/models/cam-fv/doc/README_cam-se deleted file mode 100644 index 2d2fe25d73..0000000000 --- a/models/cam-fv/doc/README_cam-se +++ /dev/null @@ -1,40 +0,0 @@ -Status of the CAM-SE CESM/DART assimilation: - -DART supports assimilation using the CAM-SE model -in the DART Classic release. The scripting supports -CESM release 1.2.1 and some support for release 1.5. - -Contact us at dart@ucar.edu for more information. - - - -Notes from the model developer: - -Tasks from 2017-8-activities: - - CESM2 uses ne0 for var res CAM-SE assim setup. - There are 4 predefined resolutions, like - ne0np4_conus_x4v1_lowcon_ne0np4_conus_x4v1_lowcon -> I can't ask for lon-lat and PHIS fields to be written from CAM-SE to the same file, - or PHIS won't be usable by model_mod. Can lon-lat be written to h1, or the last h#? - Or what standard is being adopted by Karspeck/multi-component? - Test xyz_location; find closest 2 - Much slower than the single-closest xyz_location. - 2nd test with more boxes even slower; handed off to Nancy. - Need seems to be reduced; choosing correct compiler options makes speed - comparable to FV core, and minimal compared to file I/O and archiving. - Script to make cross sections of CAM-SE output? - Interpolated to a lon,lat grid? - Work on scripts for automating some of the processing of CAM-SE+DART output, - so that there aren't so many manual steps in dealing with the cubed-sphere fields. - -CAM-SE as of 2017-9 needs new/different initial files according to Lauritzen -because of a new vertical coordinate. - -The last committed model_mod which handles CAM-SE is - Working Copy Root Path: /glade/u/home/raeder/DART/Trunk - Relative URL: ^/DART/trunk/models/cam -It's not RMAized or Manhattanized. -Now that the cam-fv has been rewritten (2017-10) this model_mod -will only be useful as a source of subroutines and how to use them. -The subroutines will probably need to be updated for RMA. diff --git a/models/cam-fv/model_mod.f90 b/models/cam-fv/model_mod.f90 index e5603cd65d..0c754dfe32 100644 --- a/models/cam-fv/model_mod.f90 +++ b/models/cam-fv/model_mod.f90 @@ -13,8 +13,7 @@ module model_mod use types_mod, only : MISSING_R8, MISSING_I, i8, r8, vtablenamelength, & gravity, DEG2RAD -use time_manager_mod, only : set_time, time_type, set_date, & - set_calendar_type, get_date +use time_manager_mod, only : set_calendar_type use location_mod, only : location_type, set_vertical, set_location, & get_location, write_location, is_vertical, & VERTISUNDEF, VERTISSURFACE, VERTISLEVEL, & @@ -84,6 +83,31 @@ module model_mod init_time => fail_init_time, & init_conditions => fail_init_conditions +use cam_common_code_mod, only : above_ramp_start, are_damping, build_cam_pressure_columns, build_heights, & + cam_grid, cdebug_level, check_good_levels, cno_normalization_of_scale_heights, & + pert_model_copies, cuse_log_vertical_scale, discarding_high_obs, & + free_cam_grid, free_std_atm_tables, generic_height_to_pressure, & + gph2gmh, grid_data, height_to_level, init_damping_ramp_info, & + init_discard_high_obs, init_globals, init_sign_of_vert_units, & + is_surface_field, obs_too_high, ok_to_interpolate, pressure_to_level, ramp_end, & + read_model_time, ref_model_top_pressure, ref_nlevels, scale_height, & + set_vert_localization, vert_interp, vertical_localization_type, write_model_time + +use cam_common_code_mod, only : nc_write_model_atts, grid_data, read_grid_info, & + set_cam_variable_info, MAX_STATE_VARIABLES, & + num_state_table_columns, MAX_PERT, & + shortest_time_between_assimilations, domain_id, & + cuse_log_vertical_scale, & + cno_normalization_of_scale_heights, & + cdebug_level, & + ccustom_routine_to_generate_ensemble, & + cfields_to_perturb, & + cperturbation_amplitude, & + cassimilation_period_days, & + cassimilation_period_seconds, & + csuppress_grid_info_in_output, & + common_initialized + implicit none private @@ -117,9 +141,6 @@ module model_mod character(len=*), parameter :: revision = '' character(len=*), parameter :: revdate = '' -! maximum number of fields you can list to be perturbed -! to generate an ensemble if starting from a single state. -integer, parameter :: MAX_PERT = 100 ! model_nml namelist variables and default values character(len=256) :: cam_template_filename = 'caminput.nc' @@ -156,8 +177,6 @@ module model_mod ! for no clamping, use the string 'NA' ! to have the assimilation change the variable use 'UPDATE', else 'NO_UPDATE' -integer, parameter :: MAX_STATE_VARIABLES = 100 -integer, parameter :: num_state_table_columns = 5 character(len=vtablenamelength) :: state_variables(MAX_STATE_VARIABLES * & num_state_table_columns ) = ' ' @@ -184,36 +203,6 @@ module model_mod character(len=512) :: string1, string2, string3 logical, save :: module_initialized = .false. -! this id allows us access to all of the state structure -! info and is required for getting state variables. -integer :: domain_id - -!> Metadata from the template netCDF file that describes -!> where the variable data is located and what size it is. - -type cam_1d_array - integer :: nsize - real(r8), allocatable :: vals(:) -end type - -type cam_grid - type(cam_1d_array) :: lon - type(cam_1d_array) :: lat - type(cam_1d_array) :: slon - type(cam_1d_array) :: slat - type(cam_1d_array) :: lev - type(cam_1d_array) :: ilev - type(cam_1d_array) :: gw - type(cam_1d_array) :: hyai - type(cam_1d_array) :: hybi - type(cam_1d_array) :: hyam - type(cam_1d_array) :: hybm - type(cam_1d_array) :: P0 -end type - -type(cam_grid) :: grid_data - - integer, parameter :: STAGGER_NONE = -1 integer, parameter :: STAGGER_U = 1 integer, parameter :: STAGGER_V = 2 @@ -229,55 +218,11 @@ module model_mod ! Surface potential; used for calculation of geometric heights. real(r8), allocatable :: phis(:, :) -! default to localizing in pressure. override with namelist -integer :: vertical_localization_type = VERTISPRESSURE - -! flag used to know if the vertical unit system has numbers -! that get larger as you move away from the earth's surface -! (e.g. height) or smaller (e.g. pressure) -logical :: higher_is_smaller - -! commonly used numbers that we'll set in static_init_model -real(r8) :: ref_model_top_pressure -real(r8) :: ref_surface_pressure -integer :: ref_nlevels - -!>@todo FIXME ask kevin if this threshold value is small enough -! to distinguish cam from waccm configurations? - -! an arbitrary value to test the model top against to see -! if we're running cam vs waccm or waccm-x. it changes the -! standard atmosphere table we use to convert pressure to height, -! and changes the formatting of numbers in dart_log output. -real(r8), parameter :: high_top_threshold = 0.3_r8 ! pascals - -! things related to damping at the model top -logical :: are_damping = .false. -real(r8) :: ramp_end ! fixed top of ramp; the start (bottom) varies -logical :: discarding_high_obs = .false. -real(r8) :: no_assim_above_height = -1.0_r8 -real(r8) :: no_assim_above_level = -1.0_r8 -real(r8) :: no_assim_above_pressure = -1.0_r8 - !> build a pressure/height conversion column based on a !> standard atmosphere. this can only be used when we !> don't have a real ensemble to use, or we don't care !> about absolute accuracy. -interface single_pressure_value - module procedure single_pressure_value_int - module procedure single_pressure_value_real -end interface - -! Precompute pressure <-> height map once based on either a low-top or -! high-top table depending on what the model top is. -! Used only to discard obs on heights above the user-defined top threshold. -integer, parameter :: HIGH_TOP_TABLE = 1 -integer, parameter :: LOW_TOP_TABLE = 2 -integer :: std_atm_table_len -real(r8), allocatable :: std_atm_hgt_col(:) -real(r8), allocatable :: std_atm_pres_col(:) - ! Horizontal interpolation code. Need a handle for nonstaggered, U and V. type(quad_interp_handle) :: interp_nonstaggered, & interp_u_staggered, & @@ -306,7 +251,6 @@ module model_mod subroutine static_init_model() integer :: iunit, io -integer :: nfields character(len=*), parameter :: routine = 'static_init_model' @@ -316,6 +260,7 @@ subroutine static_init_model() call register_module(source, revision, revdate) module_initialized = .true. +common_initialized = .true. ! Read the DART namelist for this model call find_namelist_in_file('input.nml', 'model_nml', iunit) @@ -326,16 +271,36 @@ subroutine static_init_model() if (do_nml_file()) write(nmlfileunit, nml=model_nml) if (do_nml_term()) write( * , nml=model_nml) +! Set values from namelist in cam_common_code_mod +cuse_log_vertical_scale = use_log_vertical_scale +cno_normalization_of_scale_heights = no_normalization_of_scale_heights +cdebug_level = debug_level +ccustom_routine_to_generate_ensemble = custom_routine_to_generate_ensemble +ccustom_routine_to_generate_ensemble = custom_routine_to_generate_ensemble +cperturbation_amplitude = perturbation_amplitude +cassimilation_period_days = assimilation_period_days +cassimilation_period_seconds = assimilation_period_seconds +csuppress_grid_info_in_output = suppress_grid_info_in_output + + call set_calendar_type('GREGORIAN') -call read_grid_info(cam_template_filename, grid_data) +call read_grid_info(cam_template_filename) +! This non-state variable is used to compute surface elevation. +call read_cam_phis_array(cam_phis_filename) +call setup_interpolation() !grid is global ! initialize global values that are used frequently call init_globals() ! read the namelist &model_nml :: state_variables ! to set up what will be read into the cam state vector -call set_cam_variable_info(state_variables, nfields) +call set_cam_variable_info(cam_template_filename, state_variables) + +call fill_cam_stagger_info(grid_stagger) + +if (debug_level > 100) call state_structure_info(domain_id) + ! convert from string in namelist to integer (e.g. VERTISxxx) ! and tell the dart code which vertical type we want to localize in. @@ -351,7 +316,7 @@ subroutine static_init_model() ! choosing not to support this.) if (model_damping_ends_at_level > 0) then if (vertical_localization_on()) then - call init_damping_ramp_info() + call init_damping_ramp_info(model_damping_ends_at_level) are_damping = .true. else string1='cannot support model top damping unless also using vertical localization' @@ -364,7 +329,7 @@ subroutine static_init_model() ! set top limit where obs are discarded. -1 to disable. if (no_obs_assim_above_level > 0) then - call init_discard_high_obs() + call init_discard_high_obs(no_obs_assim_above_level) discarding_high_obs = .true. endif @@ -904,51 +869,6 @@ subroutine interpolate_values(state_handle, ens_size, location, obs_qty, varid, end subroutine interpolate_values -!----------------------------------------------------------------------- -!> return my_status /= 0 if obs is above a user-defined threshold. -!> intended to be quick (low-cost) and not exact. -!> This intentionally does NOT have a case for vert type of -!> SCALEHEIGHT - because this routine is only used to look at -!> observation locations. we have not yet encountered obs -!> with that vertical type. - -subroutine obs_too_high(vert_value, which_vert, my_status) -real(r8), intent(in) :: vert_value -integer, intent(in) :: which_vert -integer, intent(out) :: my_status - -! assume ok to begin with -my_status = 0 - -if (which_vert == VERTISPRESSURE) then - ! lower pressures are higher; watch the less than/greater than tests - if (vert_value < no_assim_above_pressure) my_status = 14 - return -endif - -! these are always ok -if (which_vert == VERTISSURFACE .or. which_vert == VERTISUNDEF) return - -if (which_vert == VERTISHEIGHT) then - if (vert_value > no_assim_above_height) my_status = 14 - return -endif - -if (which_vert == VERTISLEVEL) then - ! level 1 is top; watch less than/greater than in tests - if (vert_value < no_assim_above_level) my_status = 14 - return -endif - -! for now we haven't run into observations where the vertical coordinate -! (of the OBS) is in scale height - but if we do it will fall into here. - -write(string2, *) 'vertical type: ', which_vert -call error_handler(E_ERR, 'obs_too_high', 'unrecognized vertical type', & - source, revision, revdate, text2=string2) - -end subroutine obs_too_high - !----------------------------------------------------------------------- !> @@ -1171,42 +1091,6 @@ function get_dims_from_qty(obs_quantity, var_id) end function get_dims_from_qty -!----------------------------------------------------------------------- -!> return 0 (ok) if we know how to interpolate this quantity. -!> if it is a field in the state, return the variable id from -!> the state structure. if not in the state, varid will return -1 - -subroutine ok_to_interpolate(obs_qty, varid, my_status) -integer, intent(in) :: obs_qty -integer, intent(out) :: varid -integer, intent(out) :: my_status - -! See if the state contains the obs quantity -varid = get_varid_from_kind(domain_id, obs_qty) - -! in the state vector -if (varid > 0) then - my_status = 0 - return -endif - - -! add any quantities that can be interpolated to this list if they -! are not in the state vector. -select case (obs_qty) - case (QTY_SURFACE_ELEVATION, & - QTY_PRESSURE, & - QTY_GEOMETRIC_HEIGHT, & - QTY_VERTLEVEL) - my_status = 0 - case default - my_status = 2 -end select - - -end subroutine ok_to_interpolate - - !----------------------------------------------------------------------- !> !> This is for 2d special observations quantities not in the state @@ -1246,7 +1130,8 @@ subroutine get_quad_values(ens_size, lon_index, lat_index, obs_quantity, stagger ! no stagger - cell centers, or W stagger case default - vals = phis(lon_index, lat_index) + + vals = phis(lon_index, lat_index) end select @@ -1262,25 +1147,6 @@ subroutine get_quad_values(ens_size, lon_index, lat_index, obs_quantity, stagger end subroutine get_quad_values - -!----------------------------------------------------------------------- -!> interpolate in the vertical between 2 arrays of items. -!> -!> vert_fracts: 0 is 100% of the first level and -!> 1 is 100% of the second level - -subroutine vert_interp(nitems, levs1, levs2, vert_fracts, out_vals) -integer, intent(in) :: nitems -real(r8), intent(in) :: levs1(nitems) -real(r8), intent(in) :: levs2(nitems) -real(r8), intent(in) :: vert_fracts(nitems) -real(r8), intent(out) :: out_vals(nitems) - -out_vals(:) = (levs1(:) * (1.0_r8-vert_fracts(:))) + & - (levs2(:) * vert_fracts(:)) - -end subroutine vert_interp - !----------------------------------------------------------------------- !> given lon/lat indices, add one to lat and subtract one from lon !> check for wraparound in lon, and north pole at lat. @@ -1462,6 +1328,7 @@ subroutine cam_height_levels(ens_handle, ens_size, lon_index, lat_index, nlevels integer :: k, level_one, imember, status1 real(r8) :: surface_elevation(1) real(r8) :: surface_pressure(ens_size), mbar(nlevels, ens_size) +real(r8) :: pressure(nlevels, ens_size) real(r8) :: tv(nlevels, ens_size) ! Virtual temperature, top to bottom ! this is for surface obs @@ -1481,6 +1348,9 @@ subroutine cam_height_levels(ens_handle, ens_size, lon_index, lat_index, nlevels return endif +! Build the pressure columns for the entire ensemble +call build_cam_pressure_columns(ens_size, surface_pressure, nlevels, pressure) + if (use_variable_mean_mass) then call compute_mean_mass(ens_handle, ens_size, lon_index, lat_index, nlevels, qty, mbar, status1) @@ -1492,7 +1362,7 @@ subroutine cam_height_levels(ens_handle, ens_size, lon_index, lat_index, nlevels ! compute the height columns for each ensemble member - passing mbar() array in. do imember = 1, ens_size call build_heights(nlevels, surface_pressure(imember), surface_elevation(1), & - tv(:, imember), height_array(:, imember), mbar=mbar(:, imember)) + pressure(:, imember), tv(:, imember), height_array(:, imember), mbar=mbar(:, imember)) enddo else @@ -1501,7 +1371,7 @@ subroutine cam_height_levels(ens_handle, ens_size, lon_index, lat_index, nlevels ! in the variable mean mass case.) do imember = 1, ens_size call build_heights(nlevels, surface_pressure(imember), surface_elevation(1), & - tv(:, imember), height_array(:, imember)) + pressure(:, imember), tv(:, imember), height_array(:, imember)) enddo endif @@ -1536,214 +1406,6 @@ subroutine cam_height_levels(ens_handle, ens_size, lon_index, lat_index, nlevels end subroutine cam_height_levels -!----------------------------------------------------------------------- -!> Compute the pressures at the layer midpoints for multiple columns - -subroutine build_cam_pressure_columns(ens_size, surface_pressure, n_levels, pressure_array) - -integer, intent(in) :: ens_size -real(r8), intent(in) :: surface_pressure(:) ! in pascals -integer, intent(in) :: n_levels -real(r8), intent(out) :: pressure_array(:,:) - -integer :: j, k - -! Set midpoint pressures. This array mirrors the order of the -! cam model levels: 1 is the model top, N is the bottom. - -do j=1, ens_size - do k=1,n_levels - pressure_array(k, j) = ref_surface_pressure * grid_data%hyam%vals(k) + & - surface_pressure(j) * grid_data%hybm%vals(k) - enddo -enddo - -end subroutine build_cam_pressure_columns - - -!----------------------------------------------------------------------- -!> Compute column of pressures at the layer midpoints for the given -!> surface pressure. -!> -!> to get pressure on layer interfaces, the computation would be identical -!> but use hyai, hybi. (also have n_levels+1) - -subroutine single_pressure_column(surface_pressure, n_levels, pressure_array) - -real(r8), intent(in) :: surface_pressure ! in pascals -integer, intent(in) :: n_levels -real(r8), intent(out) :: pressure_array(n_levels) - -integer :: k - -! Set midpoint pressures. This array mirrors the order of the -! cam model levels: 1 is the model top, N is the bottom. - -do k=1, n_levels - pressure_array(k) = ref_surface_pressure * grid_data%hyam%vals(k) + & - surface_pressure * grid_data%hybm%vals(k) -enddo - -end subroutine single_pressure_column - -!----------------------------------------------------------------------- -!> Compute pressure at one level given the surface pressure -!> cam model levels: 1 is the model top, N is the bottom. -!> in this version of the routine level is integer/whole value - -function single_pressure_value_int(surface_pressure, level) - -real(r8), intent(in) :: surface_pressure ! in pascals -integer, intent(in) :: level -real(r8) :: single_pressure_value_int - -! cam model levels: 1 is the model top, N is the bottom. - -single_pressure_value_int = ref_surface_pressure * grid_data%hyam%vals(level) + & - surface_pressure * grid_data%hybm%vals(level) - -end function single_pressure_value_int - -!----------------------------------------------------------------------- -!> Compute pressure at one level given the surface pressure -!> cam model levels: 1 is the model top, N is the bottom. -!> fraction = 0 is full level 1, fraction = 1 is full level 2 -!> level is real/fractional value - - -function single_pressure_value_real(surface_pressure, level) - -real(r8), intent(in) :: surface_pressure ! in pascals -real(r8), intent(in) :: level -real(r8) :: single_pressure_value_real - -integer :: k -real(r8) :: fract, pres1, pres2 - -k = int(level) -fract = level - int(level) - -if (k /= ref_nlevels) then - pres1 = single_pressure_value_int(surface_pressure, k) - pres2 = single_pressure_value_int(surface_pressure, k+1) -else - pres1 = single_pressure_value_int(surface_pressure, k-1) - pres2 = single_pressure_value_int(surface_pressure, k) - fract = 1.0_r8 -endif - -single_pressure_value_real = (pres1 * (1.0_r8 - fract)) + & - pres2 * (fract) - -end function single_pressure_value_real - -!----------------------------------------------------------------------- -!> return the level indices and fraction across the level. -!> level 1 is model top, level N is model bottom. -!> pressure is smallest at the top, so the values are not inverted -!> in the array. -!> fract = 0 means full lev1 value, -!> fract = 1 means full lev2 value. -!> return non-zero if value outside valid range. - -subroutine pressure_to_level(nlevels, pressures, p_val, & - lev1, lev2, fract, my_status) - -integer, intent(in) :: nlevels -real(r8), intent(in) :: pressures(:) -real(r8), intent(in) :: p_val -integer, intent(out) :: lev1 -integer, intent(out) :: lev2 -real(r8), intent(out) :: fract -integer, intent(out) :: my_status - -call find_enclosing_indices(nlevels, pressures, p_val, lev1, lev2, fract, my_status, & - inverted = .false., log_scale = use_log_vertical_scale) - -if (my_status /= 0) my_status = 10 - -end subroutine pressure_to_level - -!----------------------------------------------------------------------- -!> return the level indices and fraction across the level. -!> level 1 is model top, level N is model bottom. -!> height is largest at the top, so the values *are* inverted -!> in the array. -!> fract = 0 means full lev1 value, -!> fract = 1 means full lev2 value. -!> return non-zero if value outside valid range. - -subroutine height_to_level(nlevels, heights, h_val, & - lev1, lev2, fract, my_status) - -integer, intent(in) :: nlevels -real(r8), intent(in) :: heights(:) -real(r8), intent(in) :: h_val -integer, intent(out) :: lev1 -integer, intent(out) :: lev2 -real(r8), intent(out) :: fract -integer, intent(out) :: my_status - -character(len=*), parameter :: routine = 'height_to_level:' - -call find_enclosing_indices(nlevels, heights, h_val, lev1, lev2, fract, my_status, & - inverted = .true., log_scale = .false.) - -if (my_status /= 0) my_status = 11 - -end subroutine height_to_level - -!----------------------------------------------------------------------- -!> in cam level 1 is at the model top, level N is the lowest level -!> our convention in this code is: between levels a fraction of 0 -!> is 100% level 1, and fraction of 1 is 100% level 2. - -function check_good_levels(vert_value, valid_range, l1, l2, fract) -real(r8), intent(in) :: vert_value -integer, intent(in) :: valid_range -integer, intent(out) :: l1 -integer, intent(out) :: l2 -real(r8), intent(out) :: fract -logical :: check_good_levels - -integer :: integer_level -real(r8) :: fract_level - -! be a pessimist, then you're never disappointed -check_good_levels = .false. -l1 = MISSING_I -l2 = MISSING_I -fract = MISSING_R8 - -! out of range checks -if (vert_value < 1.0_r8 .or. vert_value > valid_range) return - -integer_level = floor(vert_value) -fract_level = vert_value - integer_level - -! cam levels start at the top so level 1 is -! the highest level and increases on the way down. - -!>might want to allow extrapolation - which means -!>allowing out of range values here and handling -!>them correctly in the calling and vert_interp() code. - -if (vert_value /= valid_range) then - l1 = integer_level - l2 = integer_level + 1 - fract = fract_level -else - ! equal to the largest level number - l1 = integer_level - 1 - l2 = integer_level - fract = 1.0_r8 -endif - -check_good_levels = .true. - -end function check_good_levels - - !----------------------------------------------------------------------- !> based on the stagger that corresponds to the given quantity, !> return the handle to the interpolation grid @@ -1775,35 +1437,6 @@ function get_interp_handle(obs_quantity) end function get_interp_handle -!----------------------------------------------------------------------- -!> -!> Set the desired minimum model advance time. This is generally NOT the -!> dynamical timestep of the model, but rather the shortest forecast length -!> you are willing to make. This impacts how frequently the observations -!> may be assimilated. -!> -!> - -function shortest_time_between_assimilations() - -character(len=*), parameter :: routine = 'shortest_time_between_assimilations:' - -type(time_type) :: shortest_time_between_assimilations - -if ( .not. module_initialized ) call static_init_model - -shortest_time_between_assimilations = set_time(assimilation_period_seconds, & - assimilation_period_days) - -write(string1,*)'assimilation period is ',assimilation_period_days, ' days ', & - assimilation_period_seconds,' seconds' -call error_handler(E_MSG,routine,string1,source,revision,revdate) - -end function shortest_time_between_assimilations - - - - !----------------------------------------------------------------------- !> !> Does any shutdown and clean-up needed for model. @@ -1815,6 +1448,8 @@ subroutine end_model() call free_cam_grid(grid_data) +deallocate(phis) + call free_std_atm_tables() call finalize_quad_interp(interp_nonstaggered) @@ -1825,1127 +1460,221 @@ subroutine end_model() end subroutine end_model +!----------------------------------------------------------------------- +! The remaining (private) interfaces come last. +! None of the private interfaces need to call static_init_model() +!----------------------------------------------------------------------- !----------------------------------------------------------------------- !> -!> Writes the model-specific attributes to a DART 'diagnostic' netCDF file. -!> This includes coordinate variables and some metadata, but NOT the -!> actual DART state. +!> Fill the qty_stagger array to tell what type of stagger each variable +!> has. This will be useful for interpolating observations. +!> This currently doesn't support both slon/slat stagger - but cam-fv +!> doesn't have any fields like that. !> -!> @param ncid the netCDF handle of the DART diagnostic file opened by -!> assim_model_mod:init_diag_output - -subroutine nc_write_model_atts(ncid, dom_id) - -integer, intent(in) :: ncid ! netCDF file identifier -integer, intent(in) :: dom_id ! not used since there is only one domain - -!---------------------------------------------------------------------- -! local variables -!---------------------------------------------------------------------- - -character(len=*), parameter :: routine = 'nc_write_model_atts' - -if ( .not. module_initialized ) call static_init_model - -!------------------------------------------------------------------------------- -! Write Global Attributes -!------------------------------------------------------------------------------- - -call nc_begin_define_mode(ncid, routine) - -call nc_add_global_creation_time(ncid, routine) -call nc_add_global_attribute(ncid, "model_source", source, routine) -call nc_add_global_attribute(ncid, "model_revision", revision, routine) -call nc_add_global_attribute(ncid, "model_revdate", revdate, routine) - -call nc_add_global_attribute(ncid, "model", "CAM", routine) +subroutine fill_cam_stagger_info(stagger) +type(cam_stagger), intent(inout) :: stagger -! this option is for users who want the smallest output -! or diagnostic files - only the state vector data will -! be written. otherwise, if you want to plot this data -! the rest of this routine writes out enough grid info -! to make the output file look like the input. -if (suppress_grid_info_in_output) then - call nc_end_define_mode(ncid, routine) - return -endif +integer :: ivar, jdim, qty_index -!---------------------------------------------------------------------------- -! Output the grid variables. -!---------------------------------------------------------------------------- -! Define the new dimensions IDs -!---------------------------------------------------------------------------- +allocate(stagger%qty_stagger(0:get_num_quantities())) -call nc_define_dimension(ncid, 'lon', grid_data%lon%nsize, routine) -call nc_define_dimension(ncid, 'lat', grid_data%lat%nsize, routine) -call nc_define_dimension(ncid, 'slon', grid_data%slon%nsize, routine) -call nc_define_dimension(ncid, 'slat', grid_data%slat%nsize, routine) -call nc_define_dimension(ncid, 'lev', grid_data%lev%nsize, routine) -call nc_define_dimension(ncid, 'ilev', grid_data%ilev%nsize, routine) -call nc_define_dimension(ncid, 'gw', grid_data%gw%nsize, routine) -call nc_define_dimension(ncid, 'hyam', grid_data%hyam%nsize, routine) -call nc_define_dimension(ncid, 'hybm', grid_data%hybm%nsize, routine) -call nc_define_dimension(ncid, 'hyai', grid_data%hyai%nsize, routine) -call nc_define_dimension(ncid, 'hybi', grid_data%hybi%nsize, routine) +stagger%qty_stagger = STAGGER_NONE -!---------------------------------------------------------------------------- -! Create the Coordinate Variables and the Attributes -! The contents will be written in a later block of code. -!---------------------------------------------------------------------------- +do ivar = 1, get_num_variables(domain_id) + do jdim = 1, get_num_dims(domain_id, ivar) -! U,V Grid Longitudes -call nc_define_real_variable( ncid, 'lon', (/ 'lon' /), routine) -call nc_add_attribute_to_variable(ncid, 'lon', 'long_name', 'longitude', routine) -call nc_add_attribute_to_variable(ncid, 'lon', 'units', 'degrees_east', routine) + if (get_dim_name(domain_id, ivar, jdim) == 'slat') then + qty_index = get_kind_index(domain_id, ivar) + stagger%qty_stagger(qty_index) = STAGGER_U + endif + if (get_dim_name(domain_id, ivar, jdim) == 'slon') then + qty_index = get_kind_index(domain_id, ivar) + stagger%qty_stagger(qty_index) = STAGGER_V + endif -call nc_define_real_variable( ncid, 'slon', (/ 'slon' /), routine) -call nc_add_attribute_to_variable(ncid, 'slon', 'long_name', 'staggered longitude', routine) -call nc_add_attribute_to_variable(ncid, 'slon', 'units', 'degrees_east', routine) + if (get_dim_name(domain_id, ivar, jdim) == 'ilev') then + qty_index = get_kind_index(domain_id, ivar) + stagger%qty_stagger(qty_index) = STAGGER_W + endif -! U,V Grid Latitudes -call nc_define_real_variable( ncid, 'lat', (/ 'lat' /), routine) -call nc_add_attribute_to_variable(ncid, 'lat', 'long_name', 'latitude', routine) -call nc_add_attribute_to_variable(ncid, 'lat', 'units', 'degrees_north', routine) + enddo +enddo +end subroutine fill_cam_stagger_info -call nc_define_real_variable( ncid, 'slat', (/ 'slat' /), routine) -call nc_add_attribute_to_variable(ncid, 'slat', 'long_name', 'staggered latitude', routine) -call nc_add_attribute_to_variable(ncid, 'slat', 'units', 'degrees_north', routine) +!----------------------------------------------------------------------- +!> +!> +!> -! Vertical Grid Latitudes -call nc_define_real_variable( ncid, 'lev', (/ 'lev' /), routine) -call nc_add_attribute_to_variable(ncid, 'lev', 'long_name', 'hybrid level at midpoints (1000*(A+B))', routine) -call nc_add_attribute_to_variable(ncid, 'lev', 'units', 'hPa', routine) -call nc_add_attribute_to_variable(ncid, 'lev', 'positive', 'down', routine) -call nc_add_attribute_to_variable(ncid, 'lev', 'standard_name', 'atmosphere_hybrid_sigma_pressure_coordinate', routine) -call nc_add_attribute_to_variable(ncid, 'lev', 'formula_terms', 'a: hyam b: hybm p0: P0 ps: PS', routine) +subroutine setup_interpolation() +!>@todo FIXME the cam fv grid is really evenly spaced in lat and lon, +!>even though they provide full lon() and lat() arrays. providing the deltas +!>between each pair would be slightly faster inside the interp code. -call nc_define_real_variable( ncid, 'ilev', (/ 'ilev' /), routine) -call nc_add_attribute_to_variable(ncid, 'ilev', 'long_name', 'hybrid level at interfaces (1000*(A+B))', routine) -call nc_add_attribute_to_variable(ncid, 'ilev', 'units', 'hPa', routine) -call nc_add_attribute_to_variable(ncid, 'ilev', 'positive', 'down', routine) -call nc_add_attribute_to_variable(ncid, 'ilev', 'standard_name', 'atmosphere_hybrid_sigma_pressure_coordinate', routine) -call nc_add_attribute_to_variable(ncid, 'ilev', 'formula_terms', 'a: hyai b: hybi p0: P0 ps: PS', routine) +!print *, 'setting up interpolation: lon/lat sizes = ', grid%lon%nsize, grid%lat%nsize, & +! grid%slon%nsize, grid%slat%nsize -! Hybrid Coefficients -call nc_define_real_variable( ncid, 'hyam', (/ 'lev' /), routine) -call nc_add_attribute_to_variable(ncid, 'hyam', 'long_name', 'hybrid A coefficient at layer midpoints', routine) +! mass points at cell centers +call init_quad_interp(GRID_QUAD_IRREG_SPACED_REGULAR, grid_data%lon%nsize, grid_data%lat%nsize, & + QUAD_LOCATED_CELL_CENTERS, & + global=.true., spans_lon_zero=.true., pole_wrap=.true., & + interp_handle=interp_nonstaggered) +call set_quad_coords(interp_nonstaggered, grid_data%lon%vals, grid_data%lat%vals) -call nc_define_real_variable( ncid, 'hybm', (/ 'lev' /), routine) -call nc_add_attribute_to_variable(ncid, 'hybm', 'long_name', 'hybrid B coefficient at layer midpoints', routine) +! U stagger +call init_quad_interp(GRID_QUAD_IRREG_SPACED_REGULAR, grid_data%lon%nsize, grid_data%slat%nsize, & + QUAD_LOCATED_CELL_CENTERS, & + global=.true., spans_lon_zero=.true., pole_wrap=.true., & + interp_handle=interp_u_staggered) +call set_quad_coords(interp_u_staggered, grid_data%lon%vals, grid_data%slat%vals) +! V stagger +call init_quad_interp(GRID_QUAD_IRREG_SPACED_REGULAR, grid_data%slon%nsize, grid_data%lat%nsize, & + QUAD_LOCATED_CELL_CENTERS, & + global=.true., spans_lon_zero=.true., pole_wrap=.true., & + interp_handle=interp_v_staggered) +call set_quad_coords(interp_v_staggered, grid_data%slon%vals, grid_data%lat%vals) -call nc_define_real_variable( ncid, 'hyai', (/ 'ilev' /), routine) -call nc_add_attribute_to_variable(ncid, 'hyai', 'long_name', 'hybrid A coefficient at layer interfaces', routine) +end subroutine setup_interpolation +!----------------------------------------------------------------------- +!> +!> -call nc_define_real_variable( ncid, 'hybi', (/ 'ilev' /), routine) -call nc_add_attribute_to_variable(ncid, 'hybi', 'long_name', 'hybrid B coefficient at layer interfaces', routine) +subroutine read_cam_phis_array(phis_filename) +character(len=*), intent(in) :: phis_filename -! Gaussian Weights -call nc_define_real_variable( ncid, 'gw', (/ 'lat' /), routine) -call nc_add_attribute_to_variable(ncid, 'gw', 'long_name', 'gauss weights', routine) +character(len=*), parameter :: routine = 'read_cam_phis_array' -call nc_define_real_scalar( ncid, 'P0', routine) -call nc_add_attribute_to_variable(ncid, 'P0', 'long_name', 'reference pressure', routine) -call nc_add_attribute_to_variable(ncid, 'P0', 'units', 'Pa', routine) +integer :: ncid, nsize(3) ! lon, lat, time -! Finished with dimension/variable definitions, must end 'define' mode to fill. +ncid = nc_open_file_readonly(phis_filename, routine) -call nc_end_define_mode(ncid, routine) +call nc_get_variable_size(ncid, 'PHIS', nsize(:), routine) +allocate( phis(nsize(1), nsize(2)) ) -!---------------------------------------------------------------------------- -! Fill the coordinate variables -!---------------------------------------------------------------------------- +call nc_get_variable(ncid, 'PHIS', phis, routine) -call nc_put_variable(ncid, 'lon', grid_data%lon%vals, routine) -call nc_put_variable(ncid, 'lat', grid_data%lat%vals, routine) -call nc_put_variable(ncid, 'slon', grid_data%slon%vals, routine) -call nc_put_variable(ncid, 'slat', grid_data%slat%vals, routine) -call nc_put_variable(ncid, 'lev', grid_data%lev%vals, routine) -call nc_put_variable(ncid, 'ilev', grid_data%ilev%vals, routine) -call nc_put_variable(ncid, 'gw', grid_data%gw%vals, routine) -call nc_put_variable(ncid, 'hyam', grid_data%hyam%vals, routine) -call nc_put_variable(ncid, 'hybm', grid_data%hybm%vals, routine) -call nc_put_variable(ncid, 'hyai', grid_data%hyai%vals, routine) -call nc_put_variable(ncid, 'hybi', grid_data%hybi%vals, routine) -call nc_put_variable(ncid, 'P0', grid_data%P0%vals, routine) +call nc_close_file(ncid, routine) -! flush any pending i/o to disk -call nc_synchronize_file(ncid, routine) +end subroutine read_cam_phis_array -end subroutine nc_write_model_atts !----------------------------------------------------------------------- -!> writes CAM's model date and time of day into file. CAM uses -!> integer date values and interger time of day measured in seconds +!> Compute the virtual temperature at the midpoints !> -!> @param ncid name of the file -!> @param model_time the current time of the model state +!> this version does all ensemble members at once. !> -subroutine write_model_time(ncid, model_time) -integer, intent(in) :: ncid -type(time_type), intent(in) :: model_time +subroutine compute_virtual_temperature(ens_handle, ens_size, lon_index, lat_index, nlevels, qty, tv, istatus) -integer :: iyear, imonth, iday, ihour, iminute, isecond -integer :: cam_date(1), cam_tod(1) +type(ensemble_type), intent(in) :: ens_handle +integer, intent(in) :: ens_size +integer, intent(in) :: lon_index +integer, intent(in) :: lat_index +integer, intent(in) :: nlevels +integer, intent(in) :: qty +real(r8), intent(out) :: tv(nlevels, ens_size) +integer, intent(out) :: istatus -character(len=*), parameter :: routine = 'write_model_time' +integer :: k +real(r8) :: temperature(ens_size), specific_humidity(ens_size) -if ( .not. module_initialized ) call static_init_model +!>@todo this should come from a model specific constant module. +!> the forward operators and model_mod should use it. +real(r8), parameter :: rd = 287.05_r8 ! dry air gas constant +real(r8), parameter :: rv = 461.51_r8 ! wet air gas constant +real(r8), parameter :: rr_factor = (rv/rd) - 1.0_r8 -call get_date(model_time, iyear, imonth, iday, ihour, iminute, isecond) -cam_date = iyear*10000 + imonth*100 + iday -cam_tod = ihour*3600 + iminute*60 + isecond +! construct a virtual temperature column, one for each ensemble member +do k = 1, nlevels + ! temperature + call get_staggered_values_from_qty(ens_handle, ens_size, QTY_TEMPERATURE, & + lon_index, lat_index, k, qty, temperature, istatus) -! if the file doesn't already have a "date" variable make one -if (.not. nc_variable_exists(ncid, "date")) then - call nc_begin_define_mode(ncid, routine) - call nc_define_integer_variable(ncid, 'date', (/ 'time' /), routine) - call nc_end_define_mode(ncid, routine) - call nc_put_variable(ncid, 'date', cam_date, routine) -endif - -! if the file doesn't already have a "datesec" variable make one -if (.not. nc_variable_exists(ncid, "datesec")) then - call nc_begin_define_mode(ncid, routine) - call nc_define_integer_variable(ncid, 'datesec', (/ 'time' /), routine) - call nc_end_define_mode(ncid, routine) - call nc_put_variable(ncid, 'datesec', cam_tod, routine) -endif - -end subroutine write_model_time - -!-------------------------------------------------------------------- -!> -!> Read the time from the input file -!> -!> @param filename name of file that contains the time -!> - -function read_model_time(filename) - -character(len=*), intent(in) :: filename -type(time_type) :: read_model_time - -integer :: ncid -integer :: cam_date, cam_tod -integer :: iyear, imonth, iday, ihour, imin, isec, rem - -character(len=*), parameter :: routine = 'read_model_time' - -if ( .not. module_initialized ) call static_init_model - -if ( .not. file_exist(filename) ) then - write(string1,*) trim(filename), ' does not exist.' - call error_handler(E_ERR,routine,string1,source,revision,revdate) -endif - -ncid = nc_open_file_readonly(filename, routine) - -! CAM initial files have two variables of length -! 'time' (the unlimited dimension): date, datesec - -call nc_get_variable(ncid, 'date', cam_date, routine) -call nc_get_variable(ncid, 'datesec', cam_tod, routine) - -! 'date' is YYYYMMDD -! 'cam_tod' is seconds of current day -iyear = cam_date / 10000 -rem = cam_date - iyear*10000 -imonth = rem / 100 -iday = rem - imonth*100 - -ihour = cam_tod / 3600 -rem = cam_tod - ihour*3600 -imin = rem / 60 -isec = rem - imin*60 - -! some cam files are from before the start of the gregorian calendar. -! since these are 'arbitrary' years, just change the offset. -if (iyear < 1601) then - write(string1,*)' ' - write(string2,*)'WARNING - ',trim(filename),' changing year from ', & - iyear,'to',iyear+1601 - - call error_handler(E_MSG, routine, string1, source, revision, & - revdate, text2=string2,text3='to make it a valid Gregorian date.') - - write(string1,*)' ' - call error_handler(E_MSG, routine, string1, source, revision) - iyear = iyear + 1601 -endif - -read_model_time = set_date(iyear,imonth,iday,ihour,imin,isec) - -call nc_close_file(ncid, routine) - -end function read_model_time - -!-------------------------------------------------------------------- -!> if the namelist is set to not use this custom routine, the default -!> dart routine will add 'pert_amp' of noise to every field in the state -!> to generate an ensemble from a single member. if it is set to true -!> this routine will be called. the pert_amp will be ignored, and the -!> given list of quantities will be perturbed by the given amplitude -!> (which can be different for each field) to generate an ensemble. - -subroutine pert_model_copies(state_ens_handle, ens_size, pert_amp, interf_provided) -type(ensemble_type), intent(inout) :: state_ens_handle -integer, intent(in) :: ens_size -real(r8), intent(in) :: pert_amp ! ignored in this version -logical, intent(out) :: interf_provided - -type(random_seq_type) :: seq - -integer :: iloc, jloc, vloc, myqty -integer :: max_qtys, j - -integer(i8) :: i, state_items -integer(i8), allocatable :: my_vars(:) - -logical, allocatable :: do_these_qtys(:) -real(r8), allocatable :: perturb_by(:) - -character(len=*), parameter :: routine = 'pert_model_copies:' - -! set by namelist to select using the default routine in filter -! (adds the same noise to all parts of the state vector) -! or the code here that lets you specify which fields get perturbed. -if (custom_routine_to_generate_ensemble) then - interf_provided = .true. -else - interf_provided = .false. - return -endif - -! make sure each task is using a different random sequence -call init_random_seq(seq, my_task_id()) - -max_qtys = get_num_quantities() -allocate(do_these_qtys(0:max_qtys), perturb_by(0:max_qtys)) - -do_these_qtys(:) = .false. -perturb_by(:) = 0.0_r8 - -! this loop is over the number of field names/perturb values -! in the namelist. it quits when it finds a blank field name. -do i=1, MAX_PERT - if (fields_to_perturb(i) == '') exit - - myqty = get_index_for_quantity(fields_to_perturb(i)) - if (myqty < 0) then - string1 = 'unrecognized quantity name in "fields_to_perturb" list: ' // & - trim(fields_to_perturb(i)) - call error_handler(E_ERR,routine,string1,source,revision,revdate) - endif - - do_these_qtys(myqty) = .true. - perturb_by(myqty) = perturbation_amplitude(i) -enddo - -! get the global index numbers of the part of the state that -! we have in this task. here is an example of how to work with -! just the part of the state that is on the current task. -state_items = get_my_num_vars(state_ens_handle) -allocate(my_vars(state_items)) -call get_my_vars(state_ens_handle, my_vars) - -! this loop is over all the subset of the state items -! that are on this MPI task. -do i=1, state_items - - ! for each global index number in the state vector find - ! what quantity it is. (iloc,jloc,vloc are unused here) - call get_model_variable_indices(my_vars(i), iloc, jloc, vloc, kind_index=myqty) - - ! if myqty is in the namelist, perturb it. otherwise cycle - if (.not. do_these_qtys(myqty)) cycle - - ! this loop is over the number of ensembles - do j=1, ens_size - state_ens_handle%copies(j, i) = random_gaussian(seq, state_ens_handle%copies(j, i), perturb_by(myqty)) - enddo - -enddo - -deallocate(my_vars) -deallocate(do_these_qtys, perturb_by) - -end subroutine pert_model_copies - - -!----------------------------------------------------------------------- -! The remaining (private) interfaces come last. -! None of the private interfaces need to call static_init_model() -!----------------------------------------------------------------------- - -!----------------------------------------------------------------------- -!> -!> Fill the array of requested variables, dart kinds, possible min/max -!> values and whether or not to update the field in the output file. -!> Then calls 'add_domain()' to tell the DART code which variables to -!> read into the state vector after this code returns. -!> -!>@param variable_array the list of variables and kinds from model_mod_nml -!>@param nfields the number of variable/Quantity pairs specified - -subroutine set_cam_variable_info( variable_array, nfields ) - -character(len=*), intent(in) :: variable_array(:) -integer, intent(out) :: nfields - -character(len=*), parameter :: routine = 'set_cam_variable_info:' - -integer :: i -integer, parameter :: MAX_STRING_LEN = 128 - -character(len=MAX_STRING_LEN) :: varname ! column 1, NetCDF variable name -character(len=MAX_STRING_LEN) :: dartstr ! column 2, DART Quantity -character(len=MAX_STRING_LEN) :: minvalstr ! column 3, Clamp min val -character(len=MAX_STRING_LEN) :: maxvalstr ! column 4, Clamp max val -character(len=MAX_STRING_LEN) :: updatestr ! column 5, Update output or not - -character(len=vtablenamelength) :: var_names(MAX_STATE_VARIABLES) = ' ' -logical :: update_list(MAX_STATE_VARIABLES) = .FALSE. -integer :: kind_list(MAX_STATE_VARIABLES) = MISSING_I -real(r8) :: clamp_vals(MAX_STATE_VARIABLES,2) = MISSING_R8 - - -nfields = 0 -ParseVariables : do i = 1, MAX_STATE_VARIABLES - - varname = variable_array(num_state_table_columns*i-4) - dartstr = variable_array(num_state_table_columns*i-3) - minvalstr = variable_array(num_state_table_columns*i-2) - maxvalstr = variable_array(num_state_table_columns*i-1) - updatestr = variable_array(num_state_table_columns*i ) - - if ( varname == ' ' .and. dartstr == ' ' ) exit ParseVariables ! Found end of list. - - if ( varname == ' ' .or. dartstr == ' ' ) then - string1 = 'model_nml:model "state_variables" not fully specified' - call error_handler(E_ERR,routine,string1,source,revision,revdate) - endif - - ! Make sure DART kind is valid - - if( get_index_for_quantity(dartstr) < 0 ) then - write(string1,'(3A)') 'there is no obs_kind "', trim(dartstr), '" in obs_kind_mod.f90' - call error_handler(E_ERR,routine,string1,source,revision,revdate) - endif - - call to_upper(minvalstr) - call to_upper(maxvalstr) - call to_upper(updatestr) - - var_names( i) = varname - kind_list( i) = get_index_for_quantity(dartstr) - clamp_vals(i,1) = string_to_real(minvalstr) - clamp_vals(i,2) = string_to_real(maxvalstr) - update_list( i) = string_to_logical(updatestr, 'UPDATE') - - nfields = nfields + 1 - -enddo ParseVariables - -if (nfields == MAX_STATE_VARIABLES) then - write(string1,'(2A)') 'WARNING: There is a possibility you need to increase ', & - 'MAX_STATE_VARIABLES in the global variables in model_mod.f90' - - write(string2,'(A,i4,A)') 'WARNING: you have specified at least ', nfields, & - ' perhaps more' - - call error_handler(E_MSG,routine,string1,source,revision,revdate,text2=string2) -endif - -! CAM only has a single domain (only a single grid, no nests or multiple grids) - -domain_id = add_domain(cam_template_filename, nfields, var_names, kind_list, & - clamp_vals, update_list) - -call fill_cam_stagger_info(grid_stagger) - -if (debug_level > 100) call state_structure_info(domain_id) - -end subroutine set_cam_variable_info - - -!----------------------------------------------------------------------- -!> -!> Fill the qty_stagger array to tell what type of stagger each variable -!> has. This will be useful for interpolating observations. -!> This currently doesn't support both slon/slat stagger - but cam-fv -!> doesn't have any fields like that. -!> - -subroutine fill_cam_stagger_info(stagger) -type(cam_stagger), intent(inout) :: stagger - -integer :: ivar, jdim, qty_index - -allocate(stagger%qty_stagger(0:get_num_quantities())) - -stagger%qty_stagger = STAGGER_NONE - -do ivar = 1, get_num_variables(domain_id) - do jdim = 1, get_num_dims(domain_id, ivar) - - if (get_dim_name(domain_id, ivar, jdim) == 'slat') then - qty_index = get_kind_index(domain_id, ivar) - stagger%qty_stagger(qty_index) = STAGGER_U - endif - - if (get_dim_name(domain_id, ivar, jdim) == 'slon') then - qty_index = get_kind_index(domain_id, ivar) - stagger%qty_stagger(qty_index) = STAGGER_V - endif - - if (get_dim_name(domain_id, ivar, jdim) == 'ilev') then - qty_index = get_kind_index(domain_id, ivar) - stagger%qty_stagger(qty_index) = STAGGER_W - endif - - enddo -enddo - -end subroutine fill_cam_stagger_info - - -!----------------------------------------------------------------------- -!> Read in the grid information from the given CAM restart file. -!> Note that none of the data will be used from this file; just the -!> grid size and locations. Also read in the elevation information -!> from the "PHIS' file. - -subroutine read_grid_info(grid_file, grid) -character(len=*), intent(in) :: grid_file -type(cam_grid), intent(out) :: grid - -! Get the grid info plus additional non-state arrays -call get_cam_grid(grid_file, grid) - -! This non-state variable is used to compute surface elevation. -call read_cam_phis_array(cam_phis_filename) - -! Set up the interpolation structures for later -call setup_interpolation(grid) - -end subroutine read_grid_info - - -!----------------------------------------------------------------------- -!> Read the data from the various cam grid arrays -!> -!>@todo FIXME not all of these are used. can we either -!> not read them in, or make them optional? this does affect -!> what we can write out in the diagnostic file. if we have -!> to have them in the diag files then we have to read them all -!> even if we never use them. both ilev and gw currently fall -!> into this category. -!> - -subroutine get_cam_grid(grid_file, grid) -character(len=*), intent(in) :: grid_file -type(cam_grid), intent(out) :: grid - -character(len=*), parameter :: routine = 'get_cam_grid:' - -integer :: ncid - -! put this in a subroutine that deals with the grid -ncid = nc_open_file_readonly(grid_file, routine) - -call fill_cam_1d_array(ncid, 'lon', grid%lon) -call fill_cam_1d_array(ncid, 'lat', grid%lat) -call fill_cam_1d_array(ncid, 'lev', grid%lev) -call fill_cam_1d_array(ncid, 'ilev', grid%ilev) ! for staggered vertical grid -call fill_cam_1d_array(ncid, 'slon', grid%slon) -call fill_cam_1d_array(ncid, 'slat', grid%slat) -call fill_cam_1d_array(ncid, 'gw', grid%gw) ! gauss weights -call fill_cam_1d_array(ncid, 'hyai', grid%hyai) -call fill_cam_1d_array(ncid, 'hybi', grid%hybi) -call fill_cam_1d_array(ncid, 'hyam', grid%hyam) -call fill_cam_1d_array(ncid, 'hybm', grid%hybm) - -! P0 is a scalar with no dimensionality -call fill_cam_0d_array(ncid, 'P0', grid%P0) - -call nc_close_file(ncid, routine) - -end subroutine get_cam_grid - - -!----------------------------------------------------------------------- -!> -!> allocate space for a scalar variable and read values into the grid_array -!> - - -subroutine fill_cam_1d_array(ncid, varname, grid_array) -integer, intent(in) :: ncid -character(len=*), intent(in) :: varname -type(cam_1d_array), intent(inout) :: grid_array - -character(len=*), parameter :: routine = 'fill_cam_1d_array' - -!>@todo do we need to check that this exists? if all cam input -!> files will have all the arrays we are asking for, then no. - -call nc_get_variable_size(ncid, varname, grid_array%nsize) -allocate(grid_array%vals(grid_array%nsize)) - -call nc_get_variable(ncid, varname, grid_array%vals, routine) - -if (debug_level > 80) call array_dump(grid_array%vals, label=varname) - -end subroutine fill_cam_1d_array - - -!----------------------------------------------------------------------- -!> -!> allocate space for a scalar variable and read values into the grid_array -!> - - -subroutine fill_cam_0d_array(ncid, varname, grid_array) -integer, intent(in) :: ncid -character(len=*), intent(in) :: varname -type(cam_1d_array), intent(inout) :: grid_array - -character(len=*), parameter :: routine = 'fill_cam_0d_array' - -grid_array%nsize = 1 -allocate(grid_array%vals(grid_array%nsize)) - -call nc_get_variable(ncid, varname, grid_array%vals, routine) - -if (debug_level > 80) print*, 'variable name ', trim(varname), grid_array%vals - -end subroutine fill_cam_0d_array - -!----------------------------------------------------------------------- -!> -!> free space in the various grid arrays -!> - -subroutine free_cam_grid(grid) - -type(cam_grid), intent(inout) :: grid - -call free_cam_1d_array(grid%lon) -call free_cam_1d_array(grid%lat) -call free_cam_1d_array(grid%lev) -call free_cam_1d_array(grid%ilev) -call free_cam_1d_array(grid%slon) -call free_cam_1d_array(grid%slat) -call free_cam_1d_array(grid%gw) -call free_cam_1d_array(grid%hyai) -call free_cam_1d_array(grid%hybi) -call free_cam_1d_array(grid%hyam) -call free_cam_1d_array(grid%hybm) - -call free_cam_1d_array(grid%P0) - -deallocate(phis) - -end subroutine free_cam_grid - - -!----------------------------------------------------------------------- -!> -!> -!> - -subroutine free_cam_1d_array(grid_array) -type(cam_1d_array), intent(inout) :: grid_array - -deallocate(grid_array%vals) -grid_array%nsize = -1 - -end subroutine free_cam_1d_array - -!----------------------------------------------------------------------- -!> convert from string to integer, and set in the dart code the -!> vertical type we are going to want to localize in. -!> - -subroutine set_vert_localization(typename) -character(len=*), intent(in) :: typename - -character(len=*), parameter :: routine = 'set_vert_localization' - -character(len=32) :: ucasename -integer :: vcoord - -ucasename = typename -call to_upper(ucasename) - -select case (ucasename) - case ("PRESSURE") - vcoord = VERTISPRESSURE - case ("HEIGHT") - vcoord = VERTISHEIGHT - case ("SCALEHEIGHT", "SCALE_HEIGHT", "SCALE HEIGHT") - vcoord = VERTISSCALEHEIGHT - case ("LEVEL", "MODEL_LEVEL", "MODEL LEVEL") - vcoord = VERTISLEVEL - case default - write(string1,*)'unrecognized vertical localization coordinate type: '//trim(typename) - write(string2,*)'valid values are: PRESSURE, HEIGHT, SCALEHEIGHT, LEVEL' - call error_handler(E_ERR,routine,string1,source,revision,revdate,text2=string2) -end select - -! during assimilation, when get_close() is called to compute the separation distance -! between items, convert all state and obs to use this vertical type if vertical localization -! is enabled (usually true for cam). - -call set_vertical_localization_coord(vcoord) - -! save in module global for later use. -vertical_localization_type = vcoord - -end subroutine set_vert_localization - -!----------------------------------------------------------------------- -!> -!> -!> - -subroutine setup_interpolation(grid) -type(cam_grid), intent(in) :: grid - -!>@todo FIXME the cam fv grid is really evenly spaced in lat and lon, -!>even though they provide full lon() and lat() arrays. providing the deltas -!>between each pair would be slightly faster inside the interp code. - -!print *, 'setting up interpolation: lon/lat sizes = ', grid%lon%nsize, grid%lat%nsize, & -! grid%slon%nsize, grid%slat%nsize - -! mass points at cell centers -call init_quad_interp(GRID_QUAD_IRREG_SPACED_REGULAR, grid%lon%nsize, grid%lat%nsize, & - QUAD_LOCATED_CELL_CENTERS, & - global=.true., spans_lon_zero=.true., pole_wrap=.true., & - interp_handle=interp_nonstaggered) -call set_quad_coords(interp_nonstaggered, grid%lon%vals, grid%lat%vals) - -! U stagger -call init_quad_interp(GRID_QUAD_IRREG_SPACED_REGULAR, grid%lon%nsize, grid%slat%nsize, & - QUAD_LOCATED_CELL_CENTERS, & - global=.true., spans_lon_zero=.true., pole_wrap=.true., & - interp_handle=interp_u_staggered) -call set_quad_coords(interp_u_staggered, grid%lon%vals, grid%slat%vals) - -! V stagger -call init_quad_interp(GRID_QUAD_IRREG_SPACED_REGULAR, grid%slon%nsize, grid%lat%nsize, & - QUAD_LOCATED_CELL_CENTERS, & - global=.true., spans_lon_zero=.true., pole_wrap=.true., & - interp_handle=interp_v_staggered) -call set_quad_coords(interp_v_staggered, grid%slon%vals, grid%lat%vals) - -end subroutine setup_interpolation - -!----------------------------------------------------------------------- -!> -!> - -subroutine read_cam_phis_array(phis_filename) -character(len=*), intent(in) :: phis_filename - -character(len=*), parameter :: routine = 'read_cam_phis_array' - -integer :: ncid, nsize(3) ! lon, lat, time - -ncid = nc_open_file_readonly(phis_filename, routine) - -call nc_get_variable_size(ncid, 'PHIS', nsize(:), routine) -allocate( phis(nsize(1), nsize(2)) ) - -call nc_get_variable(ncid, 'PHIS', phis, routine) - -call nc_close_file(ncid, routine) - -end subroutine read_cam_phis_array - - -!----------------------------------------------------------------------- -!> Compute the virtual temperature at the midpoints -!> -!> this version does all ensemble members at once. -!> - -subroutine compute_virtual_temperature(ens_handle, ens_size, lon_index, lat_index, nlevels, qty, tv, istatus) - -type(ensemble_type), intent(in) :: ens_handle -integer, intent(in) :: ens_size -integer, intent(in) :: lon_index -integer, intent(in) :: lat_index -integer, intent(in) :: nlevels -integer, intent(in) :: qty -real(r8), intent(out) :: tv(nlevels, ens_size) -integer, intent(out) :: istatus - -integer :: k -real(r8) :: temperature(ens_size), specific_humidity(ens_size) - -!>@todo this should come from a model specific constant module. -!> the forward operators and model_mod should use it. -real(r8), parameter :: rd = 287.05_r8 ! dry air gas constant -real(r8), parameter :: rv = 461.51_r8 ! wet air gas constant -real(r8), parameter :: rr_factor = (rv/rd) - 1.0_r8 - - -! construct a virtual temperature column, one for each ensemble member -do k = 1, nlevels - ! temperature - call get_staggered_values_from_qty(ens_handle, ens_size, QTY_TEMPERATURE, & - lon_index, lat_index, k, qty, temperature, istatus) - - if (istatus < 0) return - - ! specific humidity - call get_staggered_values_from_qty(ens_handle, ens_size, QTY_SPECIFIC_HUMIDITY, & - lon_index, lat_index, k, qty, specific_humidity, istatus) - if (istatus < 0) return - - !>tv == virtual temperature. - tv(k,:) = temperature(:)*(1.0_r8 + rr_factor*specific_humidity(:)) - !print*, 'tv(levels)', k,tv(k,1), temperature(1), specific_humidity(1) -enddo - - -end subroutine compute_virtual_temperature - - -!----------------------------------------------------------------------- -!> loop through all levels to get the mean mass. -!> - -subroutine compute_mean_mass(ens_handle, ens_size, lon_index, lat_index, nlevels, qty, mbar, istatus) -type(ensemble_type), intent(in) :: ens_handle -integer, intent(in) :: ens_size -integer, intent(in) :: lon_index -integer, intent(in) :: lat_index -integer, intent(in) :: nlevels -integer, intent(in) :: qty -real(r8), intent(out) :: mbar(nlevels, ens_size) -integer, intent(out) :: istatus - -integer :: k, this_qty -real(r8) :: mmr_o1(ens_size, nlevels), & - mmr_o2(ens_size, nlevels), & - mmr_h1(ens_size, nlevels), & - mmr_n2(ens_size, nlevels) -real(r8) :: O_molar_mass, O2_molar_mass, H_molar_mass, N2_molar_mass - -! do this outside the subroutine? it never changes throughout the -! run of the program -O_molar_mass = get_molar_mass(QTY_ATOMIC_OXYGEN_MIXING_RATIO) -O2_molar_mass = get_molar_mass(QTY_MOLEC_OXYGEN_MIXING_RATIO) -H_molar_mass = get_molar_mass(QTY_ATOMIC_H_MIXING_RATIO) -N2_molar_mass = get_molar_mass(QTY_NITROGEN) - - - -! High topped models (WACCM-X) need to account for the changing composition -! of the atmosphere with height. This requires several variables from the -! initial file, which may not be available from low topped models. -do k = 1, nlevels - - this_qty = QTY_ATOMIC_OXYGEN_MIXING_RATIO - call get_staggered_values_from_qty(ens_handle, ens_size, this_qty, & - lon_index, lat_index, k, qty, mmr_o1(:, k), istatus) - if (istatus /= 0) return - !print *, 'mmr: ', trim(get_name_for_quantity(this_qty)), mmr_o1(1, k) - - this_qty = QTY_MOLEC_OXYGEN_MIXING_RATIO - call get_staggered_values_from_qty(ens_handle, ens_size, this_qty, & - lon_index, lat_index, k, qty, mmr_o2(:, k), istatus) - if (istatus /= 0) return - !print *, 'mmr: ', trim(get_name_for_quantity(this_qty)), mmr_o2(1, k) - - this_qty = QTY_ATOMIC_H_MIXING_RATIO - call get_staggered_values_from_qty(ens_handle, ens_size, this_qty, & - lon_index, lat_index, k, qty, mmr_h1(:, k), istatus) - if (istatus /= 0) return - !print *, 'mmr: ', trim(get_name_for_quantity(this_qty)), mmr_h1(1, k) - - mmr_n2(:,k) = 1.0_r8 - (mmr_o1(:,k) + mmr_o2(:,k) + mmr_h1(:,k)) - mbar(k,:) = 1.0_r8/( mmr_o1(:,k)/O_molar_mass & - + mmr_o2(:,k)/O2_molar_mass & - + mmr_h1(:,k)/H_molar_mass & - + mmr_n2(:,k)/N2_molar_mass) -enddo - -end subroutine compute_mean_mass - -!----------------------------------------------------------------------- -!> This code is using a finite difference method to evaluate an -!> integral to solve the hydrostatic equation. -!> -!> The details are in the reference given below. -!> Don't change this code until you have read the paper and -!> understand what they're doing. The paper uses a matrix -!> while this code gets away with ignoring 'l' and evaluating -!> the 'k' vector directly. -!> -!> Equation references are to "Hybrid Coordinates for CCM1" -!> https://opensky.ucar.edu/islandora/object/technotes%3A149/datastream/PDF/view -!> -!> Here is a comment from the NCL function that does the -!> same thing for them. -!> -!> Purpose: -!> To compute geopotential height using the CCM2 hybrid coordinate -!> vertical slice. Since the vertical integration matrix is a -!> function of latitude and longitude, it is not explicitly -!> computed as for sigma coordinates. The integration algorithm -!> is derived from Boville's mods in the ibm file hybrid 1mods -!> (6/17/88). All vertical slice arrays are oriented top to -!> bottom as in CCM2. This field is on full model levels (aka -!> "midpoints") not half levels. -!> -!> careful - if the calling code passes in the mbar() parameter a different gas -!> constant is used instead. an mbar() array of 1.0 is not the same -!> as no parameter specified. - -subroutine build_heights(nlevels,p_surf,h_surf,virtual_temp,height_midpts,height_interf,mbar) - -integer, intent(in) :: nlevels ! Number of vertical levels -real(r8), intent(in) :: p_surf ! Surface pressure (pascals) -real(r8), intent(in) :: h_surf ! Surface height (m) -real(r8), intent(in) :: virtual_temp( nlevels) ! Virtual Temperature -real(r8), intent(out) :: height_midpts(nlevels) ! Geopotential height at midpoints, top to bottom -real(r8), intent(out), optional :: height_interf(nlevels+1) ! Geopotential height at interfaces, top to bottom -real(r8), intent(in), optional :: mbar(nlevels) ! Factor to support for variable gas constant - -! Local variables -!>@todo FIXME can we use the types_mod values here? or have a model constants module? -real(r8), parameter :: const_r = 287.04_r8 ! Different than model_heights (dry air gas constant) -real(r8), parameter :: universal_gas_constant = 8314.0_r8 ! [J/K/kmol] -real(r8), parameter :: g0 = 9.80616_r8 ! Different than model_heights (gph2gmh:G) ! - -integer :: k,l - -! an array now: real(r8), parameter :: rbyg=r/g0 -real(r8) :: pterm(nlevels) ! vertical scratch space, to improve computational efficiency -real(r8) :: r_g0_tv(nlevels) ! rbyg=r/g0 * tv -real(r8) :: pm_ln(nlevels+1) ! logs of midpoint pressures plus surface interface pressure - -! cam uses a uniform gas constant value, but high top -! models like waccm change the gas constant with height. -! allow for the calling code to pass in an array of r. - -! if mbar() array is present notice that the units are different -! for the gas constants, so an mbar() array of 1.0s will NOT give -! the same results as if it isn't present. - -if (present(mbar)) then - r_g0_tv(:) = (universal_gas_constant / (mbar(:)*g0)) * virtual_temp(:) -else - r_g0_tv(:) = (const_r / g0) * virtual_temp(:) -endif - -! calculate the log of the pressure column midpoints. -! items 1:nlevels are the midpoints, but NOTICE THAT -! the pressure at nlevels+1 is the pressure of the -! actual surface interface, not a midpoint!! - -call single_pressure_column(p_surf, nlevels, pm_ln) - -pm_ln(nlevels+1) = p_surf * grid_data%hybi%vals(nlevels+1) ! surface interface - -where (pm_ln > 0.0_r8) - pm_ln = log(pm_ln) -else where (pm_ln <= 0.0_r8) - pm_ln = 0 -end where - -!debug -!200 format (I3, 6(1X, F24.16)) -!201 format (A, 1X, I3, 6(1X, F24.16)) -!202 format (A, 6(1X, F24.16)) -!203 format (6(1X, F24.16)) -! -!print *, 'pm_ln: ' -!do i=1, nlevels+1 -! write(*, 200) i, pm_ln(i) -!enddo -!end debug - -! height_midpts(1)=top -> height_midpts(nlevels)=bottom -! -! level -! 1/2 --------------------------------------------------------------- -! 1 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - top -! 3/2 --------------------------------------------------------------- -! -! --------------------------------------------- -! --------/ \-------- -! - - - - - - - - - - - - - - - - - - - - - - - - -! NL - - - / \ - - - bottom -! --------------------------------------------------- -! NL+1/2 -----/|||||||||||||||||||||||||||||||||||||||||||||||||||\----- - - -! now the finite differences. -! Eq 3.a.109 has 5 piecewise (PW) terms. The numbers below refer to each of these terms -! in the order they're listed in the paper. - -! -! See 2nd PW term here: Eq 3.a.109 where l=K,kK, k Convert a 2d array of geopotential altitudes to mean sea level altitudes. -!> To avoid overflow with very high model tops, convert to km first, compute, -!> then convert back. bof. - -subroutine gph2gmh(h, lat) -real(r8), intent(inout) :: h(:,:) ! geopotential altitude in m -real(r8), intent(in) :: lat ! latitude in degrees. - -real(r8), parameter :: be = 6356.7516_r8 ! min earth radius, km -real(r8), parameter :: ae = 6378.1363_r8 ! max earth radius, km -real(r8), parameter :: G = 0.00980665_r8 ! WMO reference g value, km/s**2, at 45.542N(S) - -real(r8) :: g0 -real(r8) :: r0 -real(r8) :: latr - -integer :: i, j + if (istatus < 0) return -latr = lat * DEG2RAD ! convert to radians -call compute_surface_gravity(latr, g0) + ! specific humidity + call get_staggered_values_from_qty(ens_handle, ens_size, QTY_SPECIFIC_HUMIDITY, & + lon_index, lat_index, k, qty, specific_humidity, istatus) + if (istatus < 0) return -! compute local earth's radius using ellipse equation + !>tv == virtual temperature. + tv(k,:) = temperature(:)*(1.0_r8 + rr_factor*specific_humidity(:)) + !print*, 'tv(levels)', k,tv(k,1), temperature(1), specific_humidity(1) +enddo -r0 = sqrt( ae**2 * cos(latr)**2 + be**2 * sin(latr)**2) -! Compute altitude above sea level -do j=1, size(h, 2) - do i=1, size(h, 1) - h(i,j) = h(i,j) / 1000.0_r8 ! m to km - if ( ((g0*r0)/G) - h(i,j) > 0) & - h(i,j) = (r0 * h(i,j)) / (((g0*r0)/G) - h(i,j)) - h(i,j) = h(i,j) * 1000.0_r8 ! km to m - enddo -enddo +end subroutine compute_virtual_temperature -end subroutine gph2gmh !----------------------------------------------------------------------- -!> This subroutine computes the Earth's gravity at any latitude. -!> The model assumes the Earth is an oblate spheriod rotating at -!> the Earth's spin rate. The model was taken from -!> "Geophysical Geodesy, Kurt Lambeck, 1988". -!> -!> input: xlat, latitude in radians -!> output: galt, gravity at the given lat, km/sec**2 -!> -!> taken from code from author Bill Schreiner, 5/95 -!> +!> loop through all levels to get the mean mass. !> -subroutine compute_surface_gravity(xlat, galt) -real(r8), intent(in) :: xlat -real(r8), intent(out) :: galt - -real(r8),parameter :: xmu = 398600.4415_r8 ! km^3/s^2 -real(r8),parameter :: ae = 6378.1363_r8 ! km -real(r8),parameter :: f = 1.0_r8/298.2564_r8 -real(r8),parameter :: xm = 0.003468_r8 ! -real(r8),parameter :: f2 = 5.3481622134089e-03_r8 ! f2 = -f + 5.0* 0.50*xm - 17.0/14.0*f*xm + 15.0/4.0*xm**2 -real(r8),parameter :: f4 = 2.3448248012911e-05_r8 ! f4 = -f**2* 0.50 + 5.0* 0.50*f*xm - -real(r8) :: g -!real(r8) :: alt = 0.0_r8 +subroutine compute_mean_mass(ens_handle, ens_size, lon_index, lat_index, nlevels, qty, mbar, istatus) +type(ensemble_type), intent(in) :: ens_handle +integer, intent(in) :: ens_size +integer, intent(in) :: lon_index +integer, intent(in) :: lat_index +integer, intent(in) :: nlevels +integer, intent(in) :: qty +real(r8), intent(out) :: mbar(nlevels, ens_size) +integer, intent(out) :: istatus -! gravity at the equator, km/s2 -real(r8), parameter :: ge = xmu/ae**2/(1.0_r8 - f + 1.5_r8*xm - 15.0_r8/14.0_r8*xm*f) +integer :: k, this_qty +real(r8) :: mmr_o1(ens_size, nlevels), & + mmr_o2(ens_size, nlevels), & + mmr_h1(ens_size, nlevels), & + mmr_n2(ens_size, nlevels) +real(r8) :: O_molar_mass, O2_molar_mass, H_molar_mass, N2_molar_mass +! do this outside the subroutine? it never changes throughout the +! run of the program +O_molar_mass = get_molar_mass(QTY_ATOMIC_OXYGEN_MIXING_RATIO) +O2_molar_mass = get_molar_mass(QTY_MOLEC_OXYGEN_MIXING_RATIO) +H_molar_mass = get_molar_mass(QTY_ATOMIC_H_MIXING_RATIO) +N2_molar_mass = get_molar_mass(QTY_NITROGEN) + -! compute gravity at any latitude, km/s2 -g = ge*(1.0_r8 + f2*(sin(xlat))**2 - 1.0_r8/4.0_r8*f4*(sin(2.0_r8*xlat))**2) -! at a fixed altitude of 0.0, g and galt are the same -galt = g +! High topped models (WACCM-X) need to account for the changing composition +! of the atmosphere with height. This requires several variables from the +! initial file, which may not be available from low topped models. +do k = 1, nlevels -! FIXME: if alt is hardcoded to 0.0, none of this code is needed. -! -! keep it for now in case we want gravity to vary with height. -! -!! compute gravity at any latitude and at any height, km/s2 -!galt = g - 2.0_r8*ge*alt/ae*(1.0_r8 + f + xm + (-3.0_r8*f + 5.0_r8* 0.50_r8*xm)* & -! (sin(xlat))**2) + 3.0_r8*ge*alt**2/ae**2 -! -!if (g /= galt) print *, 'g, galt: ', g, galt -! -!!! compute gravity at any latitude, km/s2 -!!galt = ge*(1.0_r8 + f2*(sin(xlat))**2 - 1.0_r8/4.0_r8*f4*(sin(2.0_r8*xlat))**2) -! -!! convert to meters/s2 -!!galt = galt*1000.0_r8 + this_qty = QTY_ATOMIC_OXYGEN_MIXING_RATIO + call get_staggered_values_from_qty(ens_handle, ens_size, this_qty, & + lon_index, lat_index, k, qty, mmr_o1(:, k), istatus) + if (istatus /= 0) return + !print *, 'mmr: ', trim(get_name_for_quantity(this_qty)), mmr_o1(1, k) + + this_qty = QTY_MOLEC_OXYGEN_MIXING_RATIO + call get_staggered_values_from_qty(ens_handle, ens_size, this_qty, & + lon_index, lat_index, k, qty, mmr_o2(:, k), istatus) + if (istatus /= 0) return + !print *, 'mmr: ', trim(get_name_for_quantity(this_qty)), mmr_o2(1, k) + + this_qty = QTY_ATOMIC_H_MIXING_RATIO + call get_staggered_values_from_qty(ens_handle, ens_size, this_qty, & + lon_index, lat_index, k, qty, mmr_h1(:, k), istatus) + if (istatus /= 0) return + !print *, 'mmr: ', trim(get_name_for_quantity(this_qty)), mmr_h1(1, k) + + mmr_n2(:,k) = 1.0_r8 - (mmr_o1(:,k) + mmr_o2(:,k) + mmr_h1(:,k)) + mbar(k,:) = 1.0_r8/( mmr_o1(:,k)/O_molar_mass & + + mmr_o2(:,k)/O2_molar_mass & + + mmr_h1(:,k)/H_molar_mass & + + mmr_n2(:,k)/N2_molar_mass) +enddo -end subroutine compute_surface_gravity +end subroutine compute_mean_mass !----------------------------------------------------------------------- !> This subroutine computes converts vertical state @@ -3159,75 +1888,6 @@ subroutine state_vertical_to_level(ens_size, location, location_indx, qty) end subroutine state_vertical_to_level -!-------------------------------------------------------------------- -!> using a standard atmosphere pressure column, convert a height directly to pressure - -function generic_height_to_pressure(height, status) -real(r8), intent(in) :: height -integer, intent(out) :: status -real(r8) :: generic_height_to_pressure - -integer :: lev1, lev2 -real(r8) :: fract - -generic_height_to_pressure = MISSING_R8 - -call height_to_level(std_atm_table_len, std_atm_hgt_col, height, & - lev1, lev2, fract, status) -if (status /= 0) return - -generic_height_to_pressure = std_atm_pres_col(lev1) * (1.0_r8-fract) + & - std_atm_pres_col(lev2) * (fract) - -end function generic_height_to_pressure - -!-------------------------------------------------------------------- -!> using a standard atmosphere pressure column, convert a pressure directly to height - -function generic_pressure_to_height(pressure, status) -real(r8), intent(in) :: pressure -integer, intent(out) :: status -real(r8) :: generic_pressure_to_height - -integer :: lev1, lev2 -real(r8) :: fract - -generic_pressure_to_height = MISSING_R8 - -call pressure_to_level(std_atm_table_len, std_atm_pres_col, pressure, & - lev1, lev2, fract, status) -if (status /= 0) return - -generic_pressure_to_height = std_atm_hgt_col(lev1) * (1.0_r8 - fract) + & - std_atm_hgt_col(lev2) * (fract) - -end function generic_pressure_to_height - -!-------------------------------------------------------------------- -!> using the cam eta arrays, convert a pressure directly to model level -!> use P0 as surface, ignore elevation. - -function generic_cam_pressure_to_cam_level(pressure, status) -real(r8), intent(in) :: pressure -integer, intent(out) :: status -real(r8) :: generic_cam_pressure_to_cam_level - -integer :: lev1, lev2 -real(r8) :: fract -real(r8) :: pressure_array(ref_nlevels) - -generic_cam_pressure_to_cam_level = MISSING_R8 - -call single_pressure_column(ref_surface_pressure, ref_nlevels, pressure_array) - -call pressure_to_level(ref_nlevels, pressure_array, pressure, & - lev1, lev2, fract, status) -if (status /= 0) return - -generic_cam_pressure_to_cam_level = lev1 + fract - -end function generic_cam_pressure_to_cam_level - !----------------------------------------------------------------------- !> Compute the pressure values at midpoint levels !> @@ -3532,374 +2192,6 @@ end subroutine convert_vert_one_obs !-------------------------------------------------------------------- -subroutine init_discard_high_obs() - -! compute a conversion table between height and pressure based on -! a surface pressure of 1010 mb. this is a fixed table and does not -! vary with temperature, humidity or surface elevation. -! use only for quick conversions when absolute accuracy -! isn't a primary concern. - -character(len=*), parameter :: routine = 'init_discard_high_obs' -integer :: my_status - -integer :: table_type -character(len=16) :: out_fmt, out_fmt1, pres_fmt -real(r8) :: no_assim_above_scaleh - -! pick the better table: -! one is more accurate for the lower atmosphere, -! and the other has a very high top. -table_type = store_std_atm_tables(ref_model_top_pressure) - -! set formatting which is easiest to read in the log. -! the very high top table has very small numbers that need -! exponential notation. -out_fmt = '(A,F12.5,A)' -out_fmt1 = '(A,I5)' -pres_fmt = out_fmt -if (table_type == HIGH_TOP_TABLE) pres_fmt = '(A,E12.5,A)' - -! levels can be fractional but the namelist only allows integer, so simplify the formatting -write(string1, out_fmt1) & - 'Discarding observations higher than model level ', no_obs_assim_above_level -call error_handler(E_MSG, 'init_discard_high_obs', string1, source, revision, revdate) - -no_assim_above_pressure = single_pressure_value(ref_surface_pressure, no_obs_assim_above_level) -write(string1, pres_fmt) & - ' ... which is equivalent to pressure level ', no_assim_above_pressure, ' Pascals' -call error_handler(E_MSG, 'init_discard_high_obs', string1, source, revision, revdate) - -no_assim_above_height = generic_pressure_to_height(no_assim_above_pressure, my_status) -if (my_status /= 0) then - call error_handler(E_ERR, routine, 'error converting pressure to height', & - source, revision, revdate, text2='"no_assim_above_pressure" invalid value') -endif - -write(string1, out_fmt) & - ' ... which is equivalent to height ', no_assim_above_height, ' meters' -call error_handler(E_MSG, 'init_discard_high_obs', string1, source, revision, revdate) - -! print this out, but don't save the value unless we encounter -! incoming observations which have vertical units of scale height. -! so far we have localized in scale height but never had obs -! which had an incoming vertical unit of scale height. -no_assim_above_scaleh = scale_height(no_assim_above_pressure, ref_surface_pressure, .false.) -write(string1, out_fmt) & - ' ... which is equivalent to scale height ', no_assim_above_scaleh -call error_handler(E_MSG, 'init_discard_high_obs', string1, source, revision, revdate) - -end subroutine init_discard_high_obs - -!-------------------------------------------------------------------- -! initialize what we can here. the highest end of the ramp is fixed; -! the start depends on the cutoff distance which can be observation -! type dependent. at the time the ramping adjustment is applied all -! vertical coordinates will have already been converted to the -! vertical localization type. - -subroutine init_damping_ramp_info() - -real(r8) :: model_top - -character(len=*), parameter :: routine = 'init_damping_ramp_info' - -integer :: table_type -character(len=16) :: out_fmt - -! pick the better table: -! one is more accurate for the lower atmosphere, -! and the other has a very high top. -table_type = store_std_atm_tables(ref_model_top_pressure) - -! set formatting which is easiest to read in the log. -! the very high top table has very small numbers that need -! exponential notation. -out_fmt = '(A,F12.5,A)' -if (table_type == HIGH_TOP_TABLE .and. & - vertical_localization_type == VERTISPRESSURE) out_fmt = '(A,E12.5,A)' - -! convert to vertical localization units -call convert_vertical_level_generic(real(model_damping_ends_at_level, r8), & - vertical_localization_type, ramp_end, string3, no_norm=.false.) - -! check for conversion errors -if (ramp_end == MISSING_R8) then - write(string1, *) 'error converting ramp_end to vertical localization units' - call error_handler(E_MSG, routine, 'unexpected error', & - source, revision, revdate, text2=string1) -endif - -! this value only used for print statement, unused otherwise -call convert_vertical_level_generic(1.0_r8, vertical_localization_type, & - model_top, string3, no_norm=.false.) - -! check for conversion errors -if (model_top == MISSING_R8) then - write(string1, *) 'error converting model_top to vertical localization units' - call error_handler(E_MSG, routine, 'unexpected error', & - source, revision, revdate, text2=string1) -endif - -! at this point, ramp_end and model_top are in the localization units - -! let the log know what we're doing -write(string1, '(A,I5)') 'Increments will go to 0.0 at model level ', model_damping_ends_at_level -write(string2, out_fmt) 'which is ', ramp_end, ' '//trim(string3) -call error_handler(E_MSG, routine, & - 'Decreasing increments in region damped in the model', & - string1, source, revision, revdate, text2=string1, text3=string2) - -write(string1, out_fmt) 'For reference, model top is ', model_top, ' '//trim(string3) -call error_handler(E_MSG, routine, string1, source, revision, revdate) - -end subroutine init_damping_ramp_info - -!-------------------------------------------------------------------- -!> pressure gets smaller as you go up, everything else gets larger. -!> return true if this value is above the start of the ramp. -!> test_value and ramp_end need to already be in vert localization units - -! FIXME: test this new code section carefully. -! -! right now the calling code is expecting extra_dist to be added -! to the original get_dist() value, so any scaling or modifications -! should happen in this routine. -! -! do we need the 2 locations here to compute the horizontal distance? -! or is having the total dist and the vertical separation enough? - -function above_ramp_start(test_value, gc, obs_type, ramp_end, total_dist, extra_dist) -real(r8), intent(in) :: test_value -type(get_close_type), intent(in) :: gc -integer, intent(in) :: obs_type -real(r8), intent(in) :: ramp_end -real(r8), intent(in) :: total_dist -real(r8), intent(out) :: extra_dist -logical :: above_ramp_start - -real(r8) :: vert_localize_dist, ramp_start, norm, vert_norm, vert_only_dist -real(r8) :: horiz_dist, ramp_dist, ramp_width -type(location_type) :: this_loc, ramp_start_loc, loc1, loc2 -logical, save :: onetime = .true. - - -! do the easy cases first - either above the ramp end -! or below the ramp start. leave the middle ground for -! last because we have to then compute a damping factor. - -! FIXME: test this!!! -! is it above the ramp end? set damp dist to something -! large enough to turn off all impacts. is vert_localize_dist enough? -vert_localize_dist = get_maxdist(gc, obs_type) -if (.false. .and. onetime) then - print *, 'vert_localize_dist = ', vert_localize_dist - onetime = .false. -endif - -if (v_above(test_value, ramp_end)) then - extra_dist = vert_localize_dist - above_ramp_start = .true. - return -endif - -! compute ramp start and see if we're lower than that. - -! vert norm for this obs type -loc1 = set_location(0.0_r8, 0.0_r8, 0.0_r8, vertical_localization_type) -loc2 = set_location(0.0_r8, 0.0_r8, 1.0_r8, vertical_localization_type) -norm = get_dist(loc1, loc2, obs_type) ! units: rad/loc units -vert_norm = 1.0_r8 / norm ! units now: loc units/rad - -ramp_start = v_down(ramp_end, vert_norm * vert_localize_dist) - -!print *, 'computing ramp start: ramp_end, vert_norm, vert_localize_dist', & -! ramp_start, ramp_end, vert_norm, vert_localize_dist - -if (.not. v_above(test_value, ramp_start)) then - extra_dist = 0.0_r8 - above_ramp_start = .false. - return -endif - - -! ok, we're somewhere inbetween. compute horiz and vert distances -! and see what the ramping factor needs to be. - -!print *, 'test value within ramp range: ', ramp_start, test_value, ramp_end -above_ramp_start = .true. - -! see what the vertical separation is from obs to start of ramp -this_loc = set_location(0.0_r8, 0.0_r8, test_value, vertical_localization_type) -ramp_start_loc = set_location(0.0_r8, 0.0_r8, ramp_start, vertical_localization_type) - -! do we need this? i think so. radians -vert_only_dist = get_dist(ramp_start_loc, this_loc, obs_type) - -! we need this to compute what? -if (vert_only_dist > total_dist) then - !print *, 'unexpected, vert larger than total: ', vert_only_dist, total_dist - !print *, 'obs_type, vert_norm = ', obs_type, vert_norm - horiz_dist = 0.0_r8 -else - horiz_dist = sqrt(total_dist**2 - vert_only_dist**2) -endif - -ramp_dist = v_difference(test_value, ramp_start) -ramp_width = v_difference(ramp_end, ramp_start) -extra_dist = (ramp_dist / ramp_width) * vert_localize_dist - -! DEBUG - disable for now -if (.false. .and. above_ramp_start) then - print *, 'ramp s/v/e: ', ramp_start, test_value, ramp_end - print *, 'v, h: ', vert_only_dist, horiz_dist - print *, 'rampd, tot: ', ramp_dist, ramp_width - print *, 'ed, return: ', extra_dist, above_ramp_start -endif - -end function above_ramp_start - -!-------------------------------------------------------------------- -! vertical functions - these deal with the fact that pressure, -! scale height, and model levels all get larger as you go from -! higher in the atmosphere to lower in the atmosphere, but height -! is the opposite. these all depend on the global setting of the -! vertical localization type. - - -!-------------------------------------------------------------------- -!> for pressure, level, and one flavor of scale height -!> smaller numbers are further away from the surface. -!> for height and the other flavor of scale height -!> the opposite is true. set this once at init time. - -subroutine init_sign_of_vert_units() - -if (vertical_localization_type == VERTISHEIGHT) then - higher_is_smaller = .false. - -else if (vertical_localization_type == VERTISSCALEHEIGHT) then - ! FIXME: note from nick on scale height: - ! If no_normalization_of_scale_heights is true, then SH=log(pressure), - ! and scale height will decrease with increasing height. - ! However, if it is false then SH= -1*log(pressure/surface_pressure) - ! and it will increase with increasing height. - - if (no_normalization_of_scale_heights) then - higher_is_smaller = .true. - else - higher_is_smaller = .false. - endif - -else - higher_is_smaller = .true. - -endif - -end subroutine init_sign_of_vert_units - -!-------------------------------------------------------------------- -! returns true if a is above b (higher in the atmosphere, -! further from the surface of the earth). - -pure function v_above(a, b) -real(r8), intent(in) :: a, b -logical :: v_above - -if (higher_is_smaller) then - v_above = (a < b) -else - v_above = (a > b) -endif - -end function v_above - -!-------------------------------------------------------------------- -! returns new value of moving b distance down in the atmosphere -! starting at a. for height, this results in a smaller value -! (also one flavor of scale height), but for other vertical types -! this results in a larger value. - -pure function v_down(a, b) -real(r8), intent(in) :: a, b -real(r8) :: v_down - -if (higher_is_smaller) then - v_down = (a + b) -else - v_down = (a - b) -endif - -end function v_down - -!-------------------------------------------------------------------- -! returns difference of a and b -! (doesn't depend on the vertical_localization_type) - -pure function v_difference(a, b) -real(r8), intent(in) :: a, b -real(r8) :: v_difference - -v_difference = abs(a - b) - -end function v_difference - -!-------------------------------------------------------------------- -!> this should only be used for converting vertical values which -!> are the same for all ensemble members at all locations. -!> it uses generic values to do a vertical conversion. - -subroutine convert_vertical_level_generic(level_value, want_vert_type, out_value, out_label, no_norm) -real(r8), intent(in) :: level_value -integer, intent(in) :: want_vert_type -real(r8), intent(out) :: out_value -character(len=*), intent(out), optional :: out_label -logical, intent(in), optional :: no_norm - -character(len=*), parameter :: routine = 'convert_vertical_level_generic' - -integer :: status -real(r8) :: tmp_val -logical :: no_norm_flag - -if (present(no_norm)) then - no_norm_flag = no_norm -else - no_norm_flag = no_normalization_of_scale_heights -endif - -if (want_vert_type == VERTISLEVEL) then - out_value = level_value - if (present(out_label)) out_label = 'levels' -else - ! convert to the requested units. start by going to pressure - tmp_val = single_pressure_value(ref_surface_pressure, level_value) - - select case (want_vert_type) - case (VERTISPRESSURE) - out_value = tmp_val - if (present(out_label)) out_label = 'pascals' - - case (VERTISSCALEHEIGHT) - out_value = scale_height(tmp_val, ref_surface_pressure, no_norm_flag) - if (present(out_label)) out_label = 'scale heights' - - case (VERTISHEIGHT) - out_value = generic_pressure_to_height(tmp_val, status) - if (status /= 0) out_value = MISSING_R8 - if (present(out_label)) out_label = 'meters' - - case default - write(string1, *) 'unknown requested vertical type ', want_vert_type - call error_handler(E_MSG, routine, 'unexpected error', & - source, revision, revdate, text2=string1) - end select -endif - -end subroutine convert_vertical_level_generic - -!-------------------------------------------------------------------- - subroutine get_close_obs(gc, base_loc, base_type, locs, loc_qtys, loc_types, & num_close, close_ind, dist, ens_handle) @@ -4082,409 +2374,6 @@ subroutine get_close_state(gc, base_loc, base_type, locs, loc_qtys, loc_indx, & end subroutine get_close_state -!-------------------------------------------------------------------- -!> set values that are used by many routines here and which do not -!> change during the execution of filter. - -subroutine init_globals() - -ref_surface_pressure = grid_data%P0%vals(1) -ref_model_top_pressure = grid_data%hyai%vals(1) * ref_surface_pressure -ref_nlevels = grid_data%lev%nsize - -end subroutine init_globals - -!-------------------------------------------------------------------- -! Function to calculate scale height given a pressure and optionally -! a surface pressure. (See the namelist item which controls whether to -! normalize the pressure value aloft with the surface pressure or not. -! We currently only use scale height for computing distances between -! two locations, so the surface pressure terms cancel out - exactly if -! the two locations are co-located horizontally, almost if they are not. -! Normalizing by the surface pressure means in areas of high orography -! the surface differences propagate all the way to the model top. -! To be backwards-compatible, do this normalization; the current thinking -! is we shouldn't do it both for scientific reasons and because it -! doubles the work if it's expensive to find the correct horizontal -! location, i.e. mpas irregular grids. In this model we always have -! the surface pressure at a location so it's not a performance issue.) -! -! Watch out for unusual cases that could crash the log() function -! We pass in the surface pressure here even if it isn't going to be -! used because in all the cases above we seem to have it (or the standard -! reference pressure) everywhere we are going to compute this value. -! The "skip_norm" parameter controls whether this code uses the -! surface pressure or not. - -function scale_height(p_above, p_surface, skip_norm) -real(r8), intent(in) :: p_above -real(r8), intent(in) :: p_surface -logical, intent(in) :: skip_norm -real(r8) :: scale_height - -real(r8), parameter :: tiny = epsilon(1.0_r8) -real(r8) :: diff - -if (skip_norm) then - scale_height = log(p_above) - return -endif - -diff = p_surface - p_above ! should be positive - -if (abs(diff) < tiny) then - ! surface obs will have (almost) identical values - scale_height = 0.0_r8 ! -log(1.0_r8) - -else if (diff <= tiny .or. p_above <= 0.0_r8) then - ! weed out bad cases - scale_height = MISSING_R8 - -else - ! normal computation - should be safe now - scale_height = -log(p_above / p_surface ) - -endif - -end function scale_height - -!-------------------------------------------------------------------- - -! add any 2d fields here that are surface quantities - -function is_surface_field(qty) -integer, intent(in) :: qty -logical :: is_surface_field - -select case (qty) - case (QTY_SURFACE_PRESSURE, QTY_SURFACE_ELEVATION) - is_surface_field = .true. - -! example: -! case (QTY_SFNUM_A1, QTY_SFNUM_A2, QTY_SFNUM_A3, QTY_SFNUM_A4, QTY_SFPOM_A4, QTY_SFBC_A4, & -! QTY_SFSO4_A1, QTY_SFSO4_A2, QTY_SFCO, QTY_SFCO01, QTY_SFCO02 ) -! is_surface_field = .true. - - case default - is_surface_field = .false. - -end select - -end function is_surface_field - -!----------------------------------------------------------------------- -!> Store a table of pressures and heights. based on a std atmosphere. -!> not precise - use only when rough numbers are good enough. -!> return which table was used. -!> -!> table from: http://www.pdas.com/atmos.html -!> and also see: http://www.pdas.com/upatmos.html -!> for a good explanation of why you can't use the standard -!> equations at high altitudes. the low tables came from -!> tables.c, and the high one came from bigtables.out. -!> (all found in the atmos.zip file from that web site.) - - -function store_std_atm_tables(this_model_top) -real(r8), intent(in) :: this_model_top -integer :: store_std_atm_tables - -logical, save :: table_initialized = .false. - -if (this_model_top < high_top_threshold) then - if (.not. table_initialized) call load_high_top_table() - store_std_atm_tables = HIGH_TOP_TABLE -else - if (.not. table_initialized) call load_low_top_table() - store_std_atm_tables = LOW_TOP_TABLE -endif - -table_initialized = .true. - -end function store_std_atm_tables - -!----------------------------------------------------------------------- -!> Free arrays associated with generic tables - -subroutine free_std_atm_tables() - -if (allocated(std_atm_hgt_col)) deallocate(std_atm_hgt_col) -if (allocated(std_atm_pres_col)) deallocate(std_atm_pres_col) - -end subroutine free_std_atm_tables - -!-------------------------------------------------------------------- - -subroutine load_low_top_table() - -std_atm_table_len = 45 -allocate(std_atm_hgt_col(std_atm_table_len), std_atm_pres_col(std_atm_table_len)) - -std_atm_hgt_col(1) = 86.0_r8 ; std_atm_pres_col(1) = 3.732E-01_r8 -std_atm_hgt_col(2) = 84.0_r8 ; std_atm_pres_col(2) = 5.308E-01_r8 -std_atm_hgt_col(3) = 82.0_r8 ; std_atm_pres_col(3) = 7.498E-01_r8 -std_atm_hgt_col(4) = 80.0_r8 ; std_atm_pres_col(4) = 1.052E+00_r8 -std_atm_hgt_col(5) = 78.0_r8 ; std_atm_pres_col(5) = 1.467E+00_r8 -std_atm_hgt_col(6) = 76.0_r8 ; std_atm_pres_col(6) = 2.033E+00_r8 -std_atm_hgt_col(7) = 74.0_r8 ; std_atm_pres_col(7) = 2.800E+00_r8 -std_atm_hgt_col(8) = 72.0_r8 ; std_atm_pres_col(8) = 3.835E+00_r8 -std_atm_hgt_col(9) = 70.0_r8 ; std_atm_pres_col(9) = 5.220E+00_r8 -std_atm_hgt_col(10) = 68.0_r8 ; std_atm_pres_col(10) = 7.051E+00_r8 -std_atm_hgt_col(11) = 66.0_r8 ; std_atm_pres_col(11) = 9.459E+00_r8 -std_atm_hgt_col(12) = 64.0_r8 ; std_atm_pres_col(12) = 1.260E+01_r8 -std_atm_hgt_col(13) = 62.0_r8 ; std_atm_pres_col(13) = 1.669E+01_r8 -std_atm_hgt_col(14) = 60.0_r8 ; std_atm_pres_col(14) = 2.196E+01_r8 -std_atm_hgt_col(15) = 58.0_r8 ; std_atm_pres_col(15) = 2.872E+01_r8 -std_atm_hgt_col(16) = 56.0_r8 ; std_atm_pres_col(16) = 3.736E+01_r8 -std_atm_hgt_col(17) = 54.0_r8 ; std_atm_pres_col(17) = 4.833E+01_r8 -std_atm_hgt_col(18) = 52.0_r8 ; std_atm_pres_col(18) = 6.221E+01_r8 -std_atm_hgt_col(19) = 50.0_r8 ; std_atm_pres_col(19) = 7.977E+01_r8 -std_atm_hgt_col(20) = 48.0_r8 ; std_atm_pres_col(20) = 1.023E+02_r8 -std_atm_hgt_col(21) = 46.0_r8 ; std_atm_pres_col(21) = 1.313E+02_r8 -std_atm_hgt_col(22) = 44.0_r8 ; std_atm_pres_col(22) = 1.695E+02_r8 -std_atm_hgt_col(23) = 42.0_r8 ; std_atm_pres_col(23) = 2.200E+02_r8 -std_atm_hgt_col(24) = 40.0_r8 ; std_atm_pres_col(24) = 2.871E+02_r8 -std_atm_hgt_col(25) = 38.0_r8 ; std_atm_pres_col(25) = 3.771E+02_r8 -std_atm_hgt_col(26) = 36.0_r8 ; std_atm_pres_col(26) = 4.985E+02_r8 -std_atm_hgt_col(27) = 34.0_r8 ; std_atm_pres_col(27) = 6.634E+02_r8 -std_atm_hgt_col(28) = 32.0_r8 ; std_atm_pres_col(28) = 8.890E+02_r8 -std_atm_hgt_col(29) = 30.0_r8 ; std_atm_pres_col(29) = 1.197E+03_r8 -std_atm_hgt_col(30) = 28.0_r8 ; std_atm_pres_col(30) = 1.616E+03_r8 -std_atm_hgt_col(31) = 26.0_r8 ; std_atm_pres_col(31) = 2.188E+03_r8 -std_atm_hgt_col(32) = 24.0_r8 ; std_atm_pres_col(32) = 2.972E+03_r8 -std_atm_hgt_col(33) = 22.0_r8 ; std_atm_pres_col(33) = 4.047E+03_r8 -std_atm_hgt_col(34) = 20.0_r8 ; std_atm_pres_col(34) = 5.529E+03_r8 -std_atm_hgt_col(35) = 18.0_r8 ; std_atm_pres_col(35) = 7.565E+03_r8 -std_atm_hgt_col(36) = 16.0_r8 ; std_atm_pres_col(36) = 1.035E+04_r8 -std_atm_hgt_col(37) = 14.0_r8 ; std_atm_pres_col(37) = 1.417E+04_r8 -std_atm_hgt_col(38) = 12.0_r8 ; std_atm_pres_col(38) = 1.940E+04_r8 -std_atm_hgt_col(39) = 10.0_r8 ; std_atm_pres_col(39) = 2.650E+04_r8 -std_atm_hgt_col(40) = 8.0_r8 ; std_atm_pres_col(40) = 3.565E+04_r8 -std_atm_hgt_col(41) = 6.0_r8 ; std_atm_pres_col(41) = 4.722E+04_r8 -std_atm_hgt_col(42) = 4.0_r8 ; std_atm_pres_col(42) = 6.166E+04_r8 -std_atm_hgt_col(43) = 2.0_r8 ; std_atm_pres_col(43) = 7.950E+04_r8 -std_atm_hgt_col(44) = 0.0_r8 ; std_atm_pres_col(44) = 1.013E+05_r8 -std_atm_hgt_col(45) = -2.0_r8 ; std_atm_pres_col(45) = 1.278E+05_r8 - -! convert km to m -std_atm_hgt_col(:) = std_atm_hgt_col(:) * 1000.0_r8 - -end subroutine load_low_top_table - -!-------------------------------------------------------------------- - -subroutine load_high_top_table() - -std_atm_table_len = 201 -allocate(std_atm_hgt_col(std_atm_table_len), std_atm_pres_col(std_atm_table_len)) - -std_atm_hgt_col(1) = 1000.0_r8 ; std_atm_pres_col(1) = 7.518E-09_r8 -std_atm_hgt_col(2) = 995.0_r8 ; std_atm_pres_col(2) = 7.651E-09_r8 -std_atm_hgt_col(3) = 990.0_r8 ; std_atm_pres_col(3) = 7.790E-09_r8 -std_atm_hgt_col(4) = 985.0_r8 ; std_atm_pres_col(4) = 7.931E-09_r8 -std_atm_hgt_col(5) = 980.0_r8 ; std_atm_pres_col(5) = 8.075E-09_r8 -std_atm_hgt_col(6) = 975.0_r8 ; std_atm_pres_col(6) = 8.222E-09_r8 -std_atm_hgt_col(7) = 970.0_r8 ; std_atm_pres_col(7) = 8.371E-09_r8 -std_atm_hgt_col(8) = 965.0_r8 ; std_atm_pres_col(8) = 8.524E-09_r8 -std_atm_hgt_col(9) = 960.0_r8 ; std_atm_pres_col(9) = 8.680E-09_r8 -std_atm_hgt_col(10) = 955.0_r8 ; std_atm_pres_col(10) = 8.839E-09_r8 -std_atm_hgt_col(11) = 950.0_r8 ; std_atm_pres_col(11) = 9.001E-09_r8 -std_atm_hgt_col(12) = 945.0_r8 ; std_atm_pres_col(12) = 9.168E-09_r8 -std_atm_hgt_col(13) = 940.0_r8 ; std_atm_pres_col(13) = 9.338E-09_r8 -std_atm_hgt_col(14) = 935.0_r8 ; std_atm_pres_col(14) = 9.513E-09_r8 -std_atm_hgt_col(15) = 930.0_r8 ; std_atm_pres_col(15) = 9.692E-09_r8 -std_atm_hgt_col(16) = 925.0_r8 ; std_atm_pres_col(16) = 9.875E-09_r8 -std_atm_hgt_col(17) = 920.0_r8 ; std_atm_pres_col(17) = 1.006E-08_r8 -std_atm_hgt_col(18) = 915.0_r8 ; std_atm_pres_col(18) = 1.026E-08_r8 -std_atm_hgt_col(19) = 910.0_r8 ; std_atm_pres_col(19) = 1.046E-08_r8 -std_atm_hgt_col(20) = 905.0_r8 ; std_atm_pres_col(20) = 1.066E-08_r8 -std_atm_hgt_col(21) = 900.0_r8 ; std_atm_pres_col(21) = 1.087E-08_r8 -std_atm_hgt_col(22) = 895.0_r8 ; std_atm_pres_col(22) = 1.109E-08_r8 -std_atm_hgt_col(23) = 890.0_r8 ; std_atm_pres_col(23) = 1.132E-08_r8 -std_atm_hgt_col(24) = 885.0_r8 ; std_atm_pres_col(24) = 1.155E-08_r8 -std_atm_hgt_col(25) = 880.0_r8 ; std_atm_pres_col(25) = 1.179E-08_r8 -std_atm_hgt_col(26) = 875.0_r8 ; std_atm_pres_col(26) = 1.203E-08_r8 -std_atm_hgt_col(27) = 870.0_r8 ; std_atm_pres_col(27) = 1.229E-08_r8 -std_atm_hgt_col(28) = 865.0_r8 ; std_atm_pres_col(28) = 1.255E-08_r8 -std_atm_hgt_col(29) = 860.0_r8 ; std_atm_pres_col(29) = 1.283E-08_r8 -std_atm_hgt_col(30) = 855.0_r8 ; std_atm_pres_col(30) = 1.311E-08_r8 -std_atm_hgt_col(31) = 850.0_r8 ; std_atm_pres_col(31) = 1.340E-08_r8 -std_atm_hgt_col(32) = 845.0_r8 ; std_atm_pres_col(32) = 1.371E-08_r8 -std_atm_hgt_col(33) = 840.0_r8 ; std_atm_pres_col(33) = 1.402E-08_r8 -std_atm_hgt_col(34) = 835.0_r8 ; std_atm_pres_col(34) = 1.435E-08_r8 -std_atm_hgt_col(35) = 830.0_r8 ; std_atm_pres_col(35) = 1.469E-08_r8 -std_atm_hgt_col(36) = 825.0_r8 ; std_atm_pres_col(36) = 1.504E-08_r8 -std_atm_hgt_col(37) = 820.0_r8 ; std_atm_pres_col(37) = 1.541E-08_r8 -std_atm_hgt_col(38) = 815.0_r8 ; std_atm_pres_col(38) = 1.579E-08_r8 -std_atm_hgt_col(39) = 810.0_r8 ; std_atm_pres_col(39) = 1.619E-08_r8 -std_atm_hgt_col(40) = 805.0_r8 ; std_atm_pres_col(40) = 1.660E-08_r8 -std_atm_hgt_col(41) = 800.0_r8 ; std_atm_pres_col(41) = 1.704E-08_r8 -std_atm_hgt_col(42) = 795.0_r8 ; std_atm_pres_col(42) = 1.749E-08_r8 -std_atm_hgt_col(43) = 790.0_r8 ; std_atm_pres_col(43) = 1.795E-08_r8 -std_atm_hgt_col(44) = 785.0_r8 ; std_atm_pres_col(44) = 1.844E-08_r8 -std_atm_hgt_col(45) = 780.0_r8 ; std_atm_pres_col(45) = 1.896E-08_r8 -std_atm_hgt_col(46) = 775.0_r8 ; std_atm_pres_col(46) = 1.949E-08_r8 -std_atm_hgt_col(47) = 770.0_r8 ; std_atm_pres_col(47) = 2.006E-08_r8 -std_atm_hgt_col(48) = 765.0_r8 ; std_atm_pres_col(48) = 2.064E-08_r8 -std_atm_hgt_col(49) = 760.0_r8 ; std_atm_pres_col(49) = 2.126E-08_r8 -std_atm_hgt_col(50) = 755.0_r8 ; std_atm_pres_col(50) = 2.191E-08_r8 -std_atm_hgt_col(51) = 750.0_r8 ; std_atm_pres_col(51) = 2.260E-08_r8 -std_atm_hgt_col(52) = 745.0_r8 ; std_atm_pres_col(52) = 2.331E-08_r8 -std_atm_hgt_col(53) = 740.0_r8 ; std_atm_pres_col(53) = 2.407E-08_r8 -std_atm_hgt_col(54) = 735.0_r8 ; std_atm_pres_col(54) = 2.487E-08_r8 -std_atm_hgt_col(55) = 730.0_r8 ; std_atm_pres_col(55) = 2.571E-08_r8 -std_atm_hgt_col(56) = 725.0_r8 ; std_atm_pres_col(56) = 2.660E-08_r8 -std_atm_hgt_col(57) = 720.0_r8 ; std_atm_pres_col(57) = 2.755E-08_r8 -std_atm_hgt_col(58) = 715.0_r8 ; std_atm_pres_col(58) = 2.854E-08_r8 -std_atm_hgt_col(59) = 710.0_r8 ; std_atm_pres_col(59) = 2.960E-08_r8 -std_atm_hgt_col(60) = 705.0_r8 ; std_atm_pres_col(60) = 3.072E-08_r8 -std_atm_hgt_col(61) = 700.0_r8 ; std_atm_pres_col(61) = 3.191E-08_r8 -std_atm_hgt_col(62) = 695.0_r8 ; std_atm_pres_col(62) = 3.317E-08_r8 -std_atm_hgt_col(63) = 690.0_r8 ; std_atm_pres_col(63) = 3.451E-08_r8 -std_atm_hgt_col(64) = 685.0_r8 ; std_atm_pres_col(64) = 3.594E-08_r8 -std_atm_hgt_col(65) = 680.0_r8 ; std_atm_pres_col(65) = 3.746E-08_r8 -std_atm_hgt_col(66) = 675.0_r8 ; std_atm_pres_col(66) = 3.908E-08_r8 -std_atm_hgt_col(67) = 670.0_r8 ; std_atm_pres_col(67) = 4.080E-08_r8 -std_atm_hgt_col(68) = 665.0_r8 ; std_atm_pres_col(68) = 4.264E-08_r8 -std_atm_hgt_col(69) = 660.0_r8 ; std_atm_pres_col(69) = 4.459E-08_r8 -std_atm_hgt_col(70) = 655.0_r8 ; std_atm_pres_col(70) = 4.668E-08_r8 -std_atm_hgt_col(71) = 650.0_r8 ; std_atm_pres_col(71) = 4.892E-08_r8 -std_atm_hgt_col(72) = 645.0_r8 ; std_atm_pres_col(72) = 5.130E-08_r8 -std_atm_hgt_col(73) = 640.0_r8 ; std_atm_pres_col(73) = 5.385E-08_r8 -std_atm_hgt_col(74) = 635.0_r8 ; std_atm_pres_col(74) = 5.659E-08_r8 -std_atm_hgt_col(75) = 630.0_r8 ; std_atm_pres_col(75) = 5.951E-08_r8 -std_atm_hgt_col(76) = 625.0_r8 ; std_atm_pres_col(76) = 6.264E-08_r8 -std_atm_hgt_col(77) = 620.0_r8 ; std_atm_pres_col(77) = 6.600E-08_r8 -std_atm_hgt_col(78) = 615.0_r8 ; std_atm_pres_col(78) = 6.961E-08_r8 -std_atm_hgt_col(79) = 610.0_r8 ; std_atm_pres_col(79) = 7.349E-08_r8 -std_atm_hgt_col(80) = 605.0_r8 ; std_atm_pres_col(80) = 7.765E-08_r8 -std_atm_hgt_col(81) = 600.0_r8 ; std_atm_pres_col(81) = 8.213E-08_r8 -std_atm_hgt_col(82) = 595.0_r8 ; std_atm_pres_col(82) = 8.695E-08_r8 -std_atm_hgt_col(83) = 590.0_r8 ; std_atm_pres_col(83) = 9.214E-08_r8 -std_atm_hgt_col(84) = 585.0_r8 ; std_atm_pres_col(84) = 9.774E-08_r8 -std_atm_hgt_col(85) = 580.0_r8 ; std_atm_pres_col(85) = 1.038E-07_r8 -std_atm_hgt_col(86) = 575.0_r8 ; std_atm_pres_col(86) = 1.103E-07_r8 -std_atm_hgt_col(87) = 570.0_r8 ; std_atm_pres_col(87) = 1.173E-07_r8 -std_atm_hgt_col(88) = 565.0_r8 ; std_atm_pres_col(88) = 1.249E-07_r8 -std_atm_hgt_col(89) = 560.0_r8 ; std_atm_pres_col(89) = 1.330E-07_r8 -std_atm_hgt_col(90) = 555.0_r8 ; std_atm_pres_col(90) = 1.418E-07_r8 -std_atm_hgt_col(91) = 550.0_r8 ; std_atm_pres_col(91) = 1.514E-07_r8 -std_atm_hgt_col(92) = 545.0_r8 ; std_atm_pres_col(92) = 1.617E-07_r8 -std_atm_hgt_col(93) = 540.0_r8 ; std_atm_pres_col(93) = 1.728E-07_r8 -std_atm_hgt_col(94) = 535.0_r8 ; std_atm_pres_col(94) = 1.849E-07_r8 -std_atm_hgt_col(95) = 530.0_r8 ; std_atm_pres_col(95) = 1.979E-07_r8 -std_atm_hgt_col(96) = 525.0_r8 ; std_atm_pres_col(96) = 2.120E-07_r8 -std_atm_hgt_col(97) = 520.0_r8 ; std_atm_pres_col(97) = 2.273E-07_r8 -std_atm_hgt_col(98) = 515.0_r8 ; std_atm_pres_col(98) = 2.439E-07_r8 -std_atm_hgt_col(99) = 510.0_r8 ; std_atm_pres_col(99) = 2.618E-07_r8 -std_atm_hgt_col(100) = 505.0_r8 ; std_atm_pres_col(100) = 2.813E-07_r8 -std_atm_hgt_col(101) = 500.0_r8 ; std_atm_pres_col(101) = 3.024E-07_r8 -std_atm_hgt_col(102) = 495.0_r8 ; std_atm_pres_col(102) = 3.252E-07_r8 -std_atm_hgt_col(103) = 490.0_r8 ; std_atm_pres_col(103) = 3.501E-07_r8 -std_atm_hgt_col(104) = 485.0_r8 ; std_atm_pres_col(104) = 3.770E-07_r8 -std_atm_hgt_col(105) = 480.0_r8 ; std_atm_pres_col(105) = 4.063E-07_r8 -std_atm_hgt_col(106) = 475.0_r8 ; std_atm_pres_col(106) = 4.382E-07_r8 -std_atm_hgt_col(107) = 470.0_r8 ; std_atm_pres_col(107) = 4.728E-07_r8 -std_atm_hgt_col(108) = 465.0_r8 ; std_atm_pres_col(108) = 5.104E-07_r8 -std_atm_hgt_col(109) = 460.0_r8 ; std_atm_pres_col(109) = 5.514E-07_r8 -std_atm_hgt_col(110) = 455.0_r8 ; std_atm_pres_col(110) = 5.960E-07_r8 -std_atm_hgt_col(111) = 450.0_r8 ; std_atm_pres_col(111) = 6.445E-07_r8 -std_atm_hgt_col(112) = 445.0_r8 ; std_atm_pres_col(112) = 6.974E-07_r8 -std_atm_hgt_col(113) = 440.0_r8 ; std_atm_pres_col(113) = 7.550E-07_r8 -std_atm_hgt_col(114) = 435.0_r8 ; std_atm_pres_col(114) = 8.179E-07_r8 -std_atm_hgt_col(115) = 430.0_r8 ; std_atm_pres_col(115) = 8.864E-07_r8 -std_atm_hgt_col(116) = 425.0_r8 ; std_atm_pres_col(116) = 9.612E-07_r8 -std_atm_hgt_col(117) = 420.0_r8 ; std_atm_pres_col(117) = 1.043E-06_r8 -std_atm_hgt_col(118) = 415.0_r8 ; std_atm_pres_col(118) = 1.132E-06_r8 -std_atm_hgt_col(119) = 410.0_r8 ; std_atm_pres_col(119) = 1.229E-06_r8 -std_atm_hgt_col(120) = 405.0_r8 ; std_atm_pres_col(120) = 1.336E-06_r8 -std_atm_hgt_col(121) = 400.0_r8 ; std_atm_pres_col(121) = 1.452E-06_r8 -std_atm_hgt_col(122) = 395.0_r8 ; std_atm_pres_col(122) = 1.579E-06_r8 -std_atm_hgt_col(123) = 390.0_r8 ; std_atm_pres_col(123) = 1.718E-06_r8 -std_atm_hgt_col(124) = 385.0_r8 ; std_atm_pres_col(124) = 1.870E-06_r8 -std_atm_hgt_col(125) = 380.0_r8 ; std_atm_pres_col(125) = 2.037E-06_r8 -std_atm_hgt_col(126) = 375.0_r8 ; std_atm_pres_col(126) = 2.220E-06_r8 -std_atm_hgt_col(127) = 370.0_r8 ; std_atm_pres_col(127) = 2.421E-06_r8 -std_atm_hgt_col(128) = 365.0_r8 ; std_atm_pres_col(128) = 2.641E-06_r8 -std_atm_hgt_col(129) = 360.0_r8 ; std_atm_pres_col(129) = 2.884E-06_r8 -std_atm_hgt_col(130) = 355.0_r8 ; std_atm_pres_col(130) = 3.151E-06_r8 -std_atm_hgt_col(131) = 350.0_r8 ; std_atm_pres_col(131) = 3.445E-06_r8 -std_atm_hgt_col(132) = 345.0_r8 ; std_atm_pres_col(132) = 3.769E-06_r8 -std_atm_hgt_col(133) = 340.0_r8 ; std_atm_pres_col(133) = 4.126E-06_r8 -std_atm_hgt_col(134) = 335.0_r8 ; std_atm_pres_col(134) = 4.521E-06_r8 -std_atm_hgt_col(135) = 330.0_r8 ; std_atm_pres_col(135) = 4.957E-06_r8 -std_atm_hgt_col(136) = 325.0_r8 ; std_atm_pres_col(136) = 5.440E-06_r8 -std_atm_hgt_col(137) = 320.0_r8 ; std_atm_pres_col(137) = 5.975E-06_r8 -std_atm_hgt_col(138) = 315.0_r8 ; std_atm_pres_col(138) = 6.568E-06_r8 -std_atm_hgt_col(139) = 310.0_r8 ; std_atm_pres_col(139) = 7.226E-06_r8 -std_atm_hgt_col(140) = 305.0_r8 ; std_atm_pres_col(140) = 7.957E-06_r8 -std_atm_hgt_col(141) = 300.0_r8 ; std_atm_pres_col(141) = 8.770E-06_r8 -std_atm_hgt_col(142) = 295.0_r8 ; std_atm_pres_col(142) = 9.676E-06_r8 -std_atm_hgt_col(143) = 290.0_r8 ; std_atm_pres_col(143) = 1.069E-05_r8 -std_atm_hgt_col(144) = 285.0_r8 ; std_atm_pres_col(144) = 1.181E-05_r8 -std_atm_hgt_col(145) = 280.0_r8 ; std_atm_pres_col(145) = 1.308E-05_r8 -std_atm_hgt_col(146) = 275.0_r8 ; std_atm_pres_col(146) = 1.449E-05_r8 -std_atm_hgt_col(147) = 270.0_r8 ; std_atm_pres_col(147) = 1.608E-05_r8 -std_atm_hgt_col(148) = 265.0_r8 ; std_atm_pres_col(148) = 1.787E-05_r8 -std_atm_hgt_col(149) = 260.0_r8 ; std_atm_pres_col(149) = 1.989E-05_r8 -std_atm_hgt_col(150) = 255.0_r8 ; std_atm_pres_col(150) = 2.218E-05_r8 -std_atm_hgt_col(151) = 250.0_r8 ; std_atm_pres_col(151) = 2.476E-05_r8 -std_atm_hgt_col(152) = 245.0_r8 ; std_atm_pres_col(152) = 2.770E-05_r8 -std_atm_hgt_col(153) = 240.0_r8 ; std_atm_pres_col(153) = 3.105E-05_r8 -std_atm_hgt_col(154) = 235.0_r8 ; std_atm_pres_col(154) = 3.488E-05_r8 -std_atm_hgt_col(155) = 230.0_r8 ; std_atm_pres_col(155) = 3.927E-05_r8 -std_atm_hgt_col(156) = 225.0_r8 ; std_atm_pres_col(156) = 4.432E-05_r8 -std_atm_hgt_col(157) = 220.0_r8 ; std_atm_pres_col(157) = 5.015E-05_r8 -std_atm_hgt_col(158) = 215.0_r8 ; std_atm_pres_col(158) = 5.690E-05_r8 -std_atm_hgt_col(159) = 210.0_r8 ; std_atm_pres_col(159) = 6.476E-05_r8 -std_atm_hgt_col(160) = 205.0_r8 ; std_atm_pres_col(160) = 7.394E-05_r8 -std_atm_hgt_col(161) = 200.0_r8 ; std_atm_pres_col(161) = 8.474E-05_r8 -std_atm_hgt_col(162) = 195.0_r8 ; std_atm_pres_col(162) = 9.749E-05_r8 -std_atm_hgt_col(163) = 190.0_r8 ; std_atm_pres_col(163) = 1.127E-04_r8 -std_atm_hgt_col(164) = 185.0_r8 ; std_atm_pres_col(164) = 1.308E-04_r8 -std_atm_hgt_col(165) = 180.0_r8 ; std_atm_pres_col(165) = 1.527E-04_r8 -std_atm_hgt_col(166) = 175.0_r8 ; std_atm_pres_col(166) = 1.794E-04_r8 -std_atm_hgt_col(167) = 170.0_r8 ; std_atm_pres_col(167) = 2.121E-04_r8 -std_atm_hgt_col(168) = 165.0_r8 ; std_atm_pres_col(168) = 2.528E-04_r8 -std_atm_hgt_col(169) = 160.0_r8 ; std_atm_pres_col(169) = 3.039E-04_r8 -std_atm_hgt_col(170) = 155.0_r8 ; std_atm_pres_col(170) = 3.693E-04_r8 -std_atm_hgt_col(171) = 150.0_r8 ; std_atm_pres_col(171) = 4.542E-04_r8 -std_atm_hgt_col(172) = 145.0_r8 ; std_atm_pres_col(172) = 5.669E-04_r8 -std_atm_hgt_col(173) = 140.0_r8 ; std_atm_pres_col(173) = 7.203E-04_r8 -std_atm_hgt_col(174) = 135.0_r8 ; std_atm_pres_col(174) = 9.357E-04_r8 -std_atm_hgt_col(175) = 130.0_r8 ; std_atm_pres_col(175) = 1.250E-03_r8 -std_atm_hgt_col(176) = 125.0_r8 ; std_atm_pres_col(176) = 1.736E-03_r8 -std_atm_hgt_col(177) = 120.0_r8 ; std_atm_pres_col(177) = 2.537E-03_r8 -std_atm_hgt_col(178) = 115.0_r8 ; std_atm_pres_col(178) = 4.004E-03_r8 -std_atm_hgt_col(179) = 110.0_r8 ; std_atm_pres_col(179) = 7.149E-03_r8 -std_atm_hgt_col(180) = 105.0_r8 ; std_atm_pres_col(180) = 1.442E-02_r8 -std_atm_hgt_col(181) = 100.0_r8 ; std_atm_pres_col(181) = 3.201E-02_r8 -std_atm_hgt_col(182) = 95.0_r8 ; std_atm_pres_col(182) = 7.577E-02_r8 -std_atm_hgt_col(183) = 90.0_r8 ; std_atm_pres_col(183) = 1.844E-01_r8 -std_atm_hgt_col(184) = 85.0_r8 ; std_atm_pres_col(184) = 4.457E-01_r8 -std_atm_hgt_col(185) = 80.0_r8 ; std_atm_pres_col(185) = 1.052E+00_r8 -std_atm_hgt_col(186) = 75.0_r8 ; std_atm_pres_col(186) = 2.388E+00_r8 -std_atm_hgt_col(187) = 70.0_r8 ; std_atm_pres_col(187) = 5.221E+00_r8 -std_atm_hgt_col(188) = 65.0_r8 ; std_atm_pres_col(188) = 1.093E+01_r8 -std_atm_hgt_col(189) = 60.0_r8 ; std_atm_pres_col(189) = 2.196E+01_r8 -std_atm_hgt_col(190) = 55.0_r8 ; std_atm_pres_col(190) = 4.253E+01_r8 -std_atm_hgt_col(191) = 50.0_r8 ; std_atm_pres_col(191) = 7.978E+01_r8 -std_atm_hgt_col(192) = 45.0_r8 ; std_atm_pres_col(192) = 1.491E+02_r8 -std_atm_hgt_col(193) = 40.0_r8 ; std_atm_pres_col(193) = 2.871E+02_r8 -std_atm_hgt_col(194) = 35.0_r8 ; std_atm_pres_col(194) = 5.746E+02_r8 -std_atm_hgt_col(195) = 30.0_r8 ; std_atm_pres_col(195) = 1.197E+03_r8 -std_atm_hgt_col(196) = 25.0_r8 ; std_atm_pres_col(196) = 2.549E+03_r8 -std_atm_hgt_col(197) = 20.0_r8 ; std_atm_pres_col(197) = 5.529E+03_r8 -std_atm_hgt_col(198) = 15.0_r8 ; std_atm_pres_col(198) = 1.211E+04_r8 -std_atm_hgt_col(199) = 10.0_r8 ; std_atm_pres_col(199) = 2.650E+04_r8 -std_atm_hgt_col(200) = 5.0_r8 ; std_atm_pres_col(200) = 5.405E+04_r8 -std_atm_hgt_col(201) = 0.0_r8 ; std_atm_pres_col(201) = 1.013E+05_r8 - -! convert km to m -std_atm_hgt_col(:) = std_atm_hgt_col(:) * 1000.0_r8 - -end subroutine load_high_top_table - !=================================================================== ! End of model_mod !=================================================================== diff --git a/models/cam-fv/readme.rst b/models/cam-fv/readme.rst index f6c33c4e9a..7eec3b32cb 100644 --- a/models/cam-fv/readme.rst +++ b/models/cam-fv/readme.rst @@ -12,8 +12,7 @@ They are named according to their dynamical core ("dycore"). As of 2021 these include Finite Volume Community Atmosphere Model (CAM-FV), Spectral Element (CAM-SE), and MPAS. The DART system has supported data assimilation into CAM-FV continuously for many years. -It has also provided an interface to CAM-SE on an as-needed basis, -but we expect to make that a continuously supported interface in 2021. +An interface to CAM-SE was added to DART in 2022. An interface to MPAS is being developed (contact us about the current status). .. |CAM6_Rean| replace:: 1 degree reanalysis wiki @@ -833,6 +832,18 @@ of the following parameters in either the setup script or input.nml. inf_damping = 0.6, 0, +CAM-SE +------ + +DART requires more information than what is available in the default output files from CAM-SE. +Set the following options in the CESM ``user_nl_cam`` namelist to have CESM generate +the files required for DART. + + .. code-block:: text + + inithist = 'ENDOFRUN' + se_write_all_corners = .true. + .. Files ----- diff --git a/models/cam-fv/work/caminput.nc.REMOVED.git-id b/models/cam-fv/work/caminput.nc.REMOVED.git-id deleted file mode 100644 index 9597c2427f..0000000000 --- a/models/cam-fv/work/caminput.nc.REMOVED.git-id +++ /dev/null @@ -1 +0,0 @@ -b66bb5fa2dc23b05b54d3af7a58cba273dcf581c \ No newline at end of file diff --git a/models/cam-fv/work/input_pmo.nml b/models/cam-fv/work/input_pmo.nml deleted file mode 100644 index f755031c88..0000000000 --- a/models/cam-fv/work/input_pmo.nml +++ /dev/null @@ -1,157 +0,0 @@ -&assim_model_nml - write_binary_restart_files = .true. - netcdf_large_file_support = .true. -/ - - -&assim_tools_nml - filter_kind = 1 - cutoff = 0.2 - sort_obs_inc = .false. - spread_restoration = .false. - sampling_error_correction = .true. - adaptive_localization_threshold = -1 - output_localization_diagnostics = .false. - localization_diagnostics_file = 'localization_diagnostics' - print_every_nth_obs = 10000 -/ - - -&cam_to_dart_nml - cam_to_dart_input_file = 'caminput.nc' - cam_to_dart_output_file = 'perfect_ics' -/ - - -&cov_cutoff_nml - select_localization = 1 -/ - - -&dart_to_cam_nml - dart_to_cam_input_file = 'perfect_restart' - dart_to_cam_output_file = 'caminput.nc' - advance_time_present = .false. -/ - - -&ensemble_manager_nml - single_restart_file_in = .true. - single_restart_file_out = .true. - perturbation_amplitude = 0.0 -/ - - -&location_nml - horiz_dist_only = .false. - vert_normalization_pressure = 100000.0 - vert_normalization_height = 10000.0 - vert_normalization_level = 26.0 - approximate_distance = .true. - nlon = 141 - nlat = 72 - output_box_info = .false. -/ - - -&model_nml - output_state_vector = .false. - model_version = '4.0.1' - model_config_file = 'caminput.nc' - state_num_0d = 0 - state_num_1d = 0 - state_num_2d = 1 - state_num_3d = 6 - state_names_2d = 'PS' - state_names_3d = 'T', 'US', 'VS', 'Q', 'CLDLIQ', 'CLDICE' - which_vert_1d = 0 - which_vert_2d = -1 - which_vert_3d = 6*1 - pert_names = '' - pert_sd = -888888.0d0 - pert_base_vals = -888888.0d0 - highest_obs_pressure_mb = 1.0 - highest_state_pressure_mb = 1.0 - max_obs_lat_degree = 89.0 - time_step_seconds = 43200 - time_step_days = 0 - print_details = .false. -/ - - -&mpi_utilities_nml -/ - - -&obs_def_gps_nml - max_gpsro_obs = 100000 -/ - - -&obs_kind_nml - assimilate_these_obs_types = 'RADIOSONDE_TEMPERATURE', - 'RADIOSONDE_U_WIND_COMPONENT', - 'RADIOSONDE_V_WIND_COMPONENT' -/ - - -&obs_sequence_nml - write_binary_obs_sequence = .false. -/ - - -&perfect_model_obs_nml - start_from_restart = .true. - output_restart = .true. - async = 0 - tasks_per_model_advance = 1 - init_time_days = -1 - init_time_seconds = -1 - first_obs_days = -1 - first_obs_seconds = -1 - last_obs_days = -1 - last_obs_seconds = -1 - output_timestamps = .true. - trace_execution = .true. - output_forward_op_errors = .false. - print_every_nth_obs = 5000 - silence = .false. - output_interval = 1 - restart_in_file_name = "perfect_ics" - restart_out_file_name = "perfect_restart" - obs_seq_in_file_name = "obs_seq.in" - obs_seq_out_file_name = "obs_seq.out" - adv_ens_command = "no_model_advance" -/ - - -&preprocess_nml - input_obs_kind_mod_file = '../../../assimilation_code/modules/observations/DEFAULT_obs_kind_mod.F90' - output_obs_kind_mod_file = '../../../assimilation_code/modules/observations/obs_kind_mod.f90' - input_obs_def_mod_file = '../../../observations/forward_operators/DEFAULT_obs_def_mod.F90' - output_obs_def_mod_file = '../../../observations/forward_operators/obs_def_mod.f90' - input_files = '../../../observations/forward_operators/obs_def_gps_mod.f90', - '../../../observations/forward_operators/obs_def_altimeter_mod.f90', - '../../../observations/forward_operators/obs_def_reanalysis_bufr_mod.f90' -/ - - -®_factor_nml - select_regression = 1 - input_reg_file = "time_mean_reg" - save_reg_diagnostics = .false. - reg_diagnostics_file = 'reg_diagnostics' -/ - - -&utilities_nml - termlevel = 1 - module_details = .false. - logfilename = 'dart_log.out' - nmlfilename = 'dart_log.nml' - write_nml = 'file' -/ - - - - diff --git a/models/cam-fv/work/quickbuild.sh b/models/cam-fv/work/quickbuild.sh index df2243e1bd..d23016552d 100755 --- a/models/cam-fv/work/quickbuild.sh +++ b/models/cam-fv/work/quickbuild.sh @@ -11,6 +11,7 @@ source "$DART"/build_templates/buildfunctions.sh MODEL=cam-fv LOCATION=threed_sphere +EXTRA=$DART/models/cam-common-code programs=( diff --git a/models/cam-se/chem_tables.txt b/models/cam-se/chem_tables.txt new file mode 100644 index 0000000000..4325de2d32 --- /dev/null +++ b/models/cam-se/chem_tables.txt @@ -0,0 +1,146 @@ +! CAM-chem +! +! These lists were provided by Jerome Barre' and/or Avelino Arellano. +! +! Chemical quantities, and the molar mass of each chemical species + +! is column 1 the netcdf variable name? +! i think it should be the QTY_xxx value in dart +! or how about this? +! +! netcdf varname conversion val dart qty + + O3 47.9982 QTY_O3 + O 15.9994 QTY_O + O1D 15.9994 QTY_O1D + N2O 44.01288 QTY_N2O + NO 30.00614 QTY_NO + NO2 46.00554 QTY_NO2 + NO3 62.00494 QTY_NO3 + HNO3 63.01234 QTY_HNO3 + HO2NO2 79.01174 QTY_HO2NO2 + N2O5 108.01048 QTY_N2O5 + H2 2.0148 QTY_H2 + OH 17.0068 QTY_OH + HO2 33.0062 QTY_HO2 + H2O2 34.0136 QTY_H2O2 + CH4 16.0406 QTY_CH4 + CO 28.0104 QTY_CO + CH3O2 47.032 QTY_CH3O2 + CH3OOH 48.0394 QTY_CH3OOH + CH2O 30.0252 QTY_CH2O + CH3OH 32.04 QTY_CH3OH + C2H5OH 46.0658 QTY_C2H5OH + C2H4 28.0516 QTY_C2H4 + EO 61.0578 QTY_EO + EO2 77.0572 QTY_EO2 + CH3COOH 60.0504 QTY_CH3COOH + GLYALD 60.0504 QTY_GLYALD + C2H6 30.0664 QTY_C2H6 + C2H5O2 61.0578 QTY_C2H5O2 + C2H5OOH 62.0652 QTY_C2H5OOH + CH3CHO 44.051 QTY_CH3CHO + CH3CO3 75.0424 QTY_CH3CO3 + CH3COOOH 76.0498 QTY_CH3COOOH + C3H6 42.0774 QTY_C3H6 + C3H8 44.0922 QTY_C3H8 + C3H7O2 75.0836 QTY_C3H7O2 + C3H7OOH 76.091 QTY_C3H7OOH + PO2 91.083 QTY_PO2 + POOH 92.0904 QTY_POOH + CH3COCH3 58.0768 QTY_CH3COCH3 + RO2 89.0682 QTY_RO2 + ROOH 90.0756 QTY_ROOH + BIGENE 56.1032 QTY_BIGENE + ENEO2 105.1088 QTY_ENEO2 + MEK 72.1026 QTY_MEK + MEKO2 103.094 QTY_MEKO2 + MEKOOH 104.1014 QTY_MEKOOH + BIGALK 72.1438 QTY_BIGALK + ALKO2 103.1352 QTY_ALKO2 + ALKOOH 104.1426 QTY_ALKOOH + ISOP 68.1142 QTY_ISOP + ISOPO2 117.1198 QTY_ISOPO2 + ISOPOOH 118.1272 QTY_ISOPOOH + MVK 70.0878 QTY_MVK + MACR 70.0878 QTY_MACR + MACRO2 119.0934 QTY_MACRO2 + MACROOH 120.1008 QTY_MACROOH + MCO3 101.0792 QTY_MCO3 + HYDRALD 100.113 QTY_HYDRALD + HYAC 74.0762 QTY_HYAC + CH3COCHO 72.0614 QTY_CH3COCHO + XO2 149.1186 QTY_XO2 + XOOH 150.126 QTY_XOOH + C10H16 136.2284 QTY_C10H16 + TERPO2 185.234 QTY_TERPO2 + TERPOOH 186.2414 QTY_TERPOOH + TOLUENE 92.1362 QTY_TOLUENE + CRESOL 108.1356 QTY_CRESOL + TOLO2 173.1406 QTY_TOLO2 + TOLOOH 174.148 QTY_TOLOOH + XOH 190.1474 QTY_XOH + BIGALD 98.0982 QTY_BIGALD + GLYOXAL 58.0356 QTY_GLYOXAL + PAN 121.04794 QTY_PAN + ONIT 119.07434 QTY_ONIT + MPAN 147.08474 QTY_MPAN + ISOPNO3 162.11794 QTY_ISOPNO3 + ONITR 147.12594 QTY_ONITR + SOA 144.132 QTY_SOA + SO2 64.0648 QTY_SO2 + DMS 62.1324 QTY_DMS + NH3 17.02894 QTY_NH3 + NH4 18.03634 QTY_NH4 + NH4NO3 80.04128 QTY_NH4NO3 + Rn 222.0 QTY_Rn + Pb 207.2 QTY_Pb + HCN 27.02514 QTY_HCN + CH3CN 41.05094 QTY_CH3CN + C2H2 26.0368 QTY_C2H2 + HCOOH 46.0246 QTY_HCOOH + HOCH2OO 63.0314 QTY_HOCH2OO + H2SO4 98.0784 QTY_H2SO4 + SOAG 12.011 QTY_SOAG + so4_a1 115.10734 QTY_so4_a1 + pom_a1 12.011 QTY_pom_a1 + soa_a1 12.011 QTY_soa_a1 + bc_a1 12.011 QTY_bc_a1 + dst_a1 135.064039 QTY_dst_a1 + ncl_a1 58.442468 QTY_ncl_a1 + num_a1 1.0074 QTY_num_a1 + so4_a2 115.10734 QTY_so4_a2 + soa_a2 12.011 QTY_soa_a2 + ncl_a2 58.442468 QTY_ncl_a2 + num_a2 1.0074 QTY_num_a2 + dst_a3 135.064039 QTY_dst_a3 + ncl_a3 58.442468 QTY_ncl_a3 + so4_a3 115.10734 QTY_so4_a3 + num_a3 1.0074 QTY_num_a3 + CO01 28.0104 QTY_CO01 + CO02 28.0104 QTY_CO02 + CO03 28.0104 QTY_CO03 + CO04 28.0104 QTY_CO04 + CO05 28.0104 QTY_CO05 + CO06 28.0104 QTY_CO06 + CO07 28.0104 QTY_CO07 + CO08 28.0104 QTY_CO08 + CO09 28.0104 QTY_CO09 + CB1 12.011 QTY_CB1 + CB2 12.011 QTY_CB2 + OC1 12.011 QTY_OC1 + OC2 12.011 QTY_OC2 + CB101 12.011 QTY_CB101 + CB201 12.011 QTY_CB201 + OC101 12.011 QTY_OC101 + OC201 12.011 QTY_OC201 + CB102 12.011 QTY_CB102 + CB202 12.011 QTY_CB202 + OC102 12.011 QTY_OC102 + OC202 12.011 QTY_OC202 + + +! 2 unit conversion arrays derived from adv_mass will be filled in map_qtys. +real(r8), parameter :: molar_mass_dry_air = 28.9644 + +! CAM-chem end diff --git a/models/cam-se/column_rand.f90 b/models/cam-se/column_rand.f90 new file mode 100644 index 0000000000..163cd0bb34 --- /dev/null +++ b/models/cam-se/column_rand.f90 @@ -0,0 +1,161 @@ +! DART software - Copyright UCAR. This open source software is provided +! by UCAR, "as is", without charge, subject to all terms of use at +! http://www.image.ucar.edu/DAReS/DART/DART_download +! +! $Id$ + +program column_rand + +! Allows creation of input file for generating a set of randomly located +! observation stations with full column of obs for CAM model. + +use types_mod, only : r8, PI +use utilities_mod, only : get_unit, initialize_utilities, finalize_utilities +use random_seq_mod, only : random_seq_type, init_random_seq, random_uniform + +implicit none + +! version controlled file description for error handling, do not edit +character(len=256), parameter :: source = & + "$URL$" +character(len=32 ), parameter :: revision = "$Revision$" +character(len=128), parameter :: revdate = "$Date$" + +integer, allocatable :: levels(:) +integer :: level, num_cols, num_levs, i, iunit +real(r8) :: lat, lon, t_err_var, uv_err_var, ps_err_var, q_err_var +type(random_seq_type) :: r + +! Initialize the utilities +call initialize_utilities('Column_rand') + +! Initialize the random sequence +call init_random_seq(r) + +! Open an output file and write header info +iunit = get_unit() +open(unit = iunit, file = 'cam_column_rand.out') + +write(*, *) 'input the number of columns per set' +read(*, *) num_cols + +write(*, *) 'input the number of model levels in column' +read(*, *) num_levs + +allocate(levels(num_levs)) +do i = 1, num_levs + write(*, *) 'Input vertical level ', i + read(*, *) levels(i) +end do + +! Output the total number of obs in set; Q is being observed, too +write(*, *) 'total num is ', num_cols * (num_levs * 4 + 1) +write(iunit, *) num_cols * (num_levs * 4 + 1) + +! No copies or qc +write(iunit, *) 0 +write(iunit, *) 0 + +! First get error variance for surface pressure +write(*, *) 'Input error VARIANCE for surface pressure obs' +read(*, *) ps_err_var + +! Get error variance for t, and u and v +write(*, *) 'Input error VARIANCE for T obs' +read(*, *) t_err_var +write(*, *) 'Input error VARIANCE for U and V obs' +read(*, *) uv_err_var +write(*, *) 'Input error VARIANCE for Q obs' +read(*, *) q_err_var + + +! Loop through each column +do i = 1, num_cols + + ! Get a random lon lat location for this column + ! Longitude is random from 0 to 360 + lon = random_uniform(r) * 360.0_r8 + + ! Latitude must be area weighted + lat = asin(random_uniform(r) * 2.0_r8 - 1.0_r8) + + ! Now convert from radians to degrees latitude + lat = lat * 360.0_r8 / (2.0_r8 * PI) + + ! Do ps ob + write(iunit, *) 0 + ! Kind for surface pressure is 3 + write(iunit, *) 3 + write(iunit, *) 1 + ! Level is -1 for ps + write(iunit, *) -1 + write(iunit, *) lon + write(iunit, *) lat + write(iunit, *) 0, 0 + write(iunit, *) ps_err_var + + ! Loop through each observation in the column + do level = 1, num_levs + + ! Write out the t observation + write(iunit, *) 0 + ! Kind for t is 4 + write(iunit, *) 4 + write(iunit, *) 1 + write(iunit, *) levels(level) + write(iunit, *) lon + write(iunit, *) lat + write(iunit, *) 0, 0 + write(iunit, *) t_err_var + + + ! Write out the u observation + write(iunit, *) 0 + ! Kind for u is 1 + write(iunit, *) 1 + write(iunit, *) 1 + write(iunit, *) levels(level) + write(iunit, *) lon + write(iunit, *) lat + write(iunit, *) 0, 0 + write(iunit, *) uv_err_var + + + ! Write out the v observation + write(iunit, *) 0 + ! Kind for v is 2 + write(iunit, *) 2 + write(iunit, *) 1 + write(iunit, *) levels(level) + write(iunit, *) lon + write(iunit, *) lat + write(iunit, *) 0, 0 + write(iunit, *) uv_err_var + + + ! Write out the q observation + write(iunit, *) 0 + ! Kind for q is 5 + write(iunit, *) 5 + write(iunit, *) 1 + write(iunit, *) levels(level) + write(iunit, *) lon + write(iunit, *) lat + write(iunit, *) 0, 0 + write(iunit, *) q_err_var + + end do +end do + +write(iunit, *) 'set_def.out' + +! Shut down the utilities cleanly +call finalize_utilities('column_rand') + +end program column_rand + +! +! $URL$ +! $Id$ +! $Revision$ +! $Date$ diff --git a/models/cam-se/model_mod.f90 b/models/cam-se/model_mod.f90 new file mode 100644 index 0000000000..25912640f3 --- /dev/null +++ b/models/cam-se/model_mod.f90 @@ -0,0 +1,3332 @@ +! DART software - Copyright UCAR. This open source software is provided +! by ucar, "as is", without charge, subject to all terms of use at +! http://www.image.ucar.edu/dares/dart/dart_download +! +!---------------------------------------------------------------- +!> +!> this is the interface between the cam-se atmosphere model and dart. +!> the required public interfaces and arguments cannot be changed. +!> +!---------------------------------------------------------------- + +module model_mod + +use types_mod, only : MISSING_R8, MISSING_I, i8, r8, vtablenamelength, & + gravity, DEG2RAD, PI, earth_radius +use time_manager_mod, only : set_time, time_type, set_date, & + set_calendar_type, get_date +use location_mod, only : location_type, set_vertical, set_location, & + get_location, write_location, is_vertical, & + VERTISUNDEF, VERTISSURFACE, VERTISLEVEL, & + VERTISPRESSURE, VERTISHEIGHT, & + VERTISSCALEHEIGHT, query_location, & + set_vertical_localization_coord, get_dist, & + loc_get_close_obs => get_close_obs, & + get_close, & + loc_get_close_state => get_close_state, & + vertical_localization_on, get_close_type, get_maxdist, & + get_close_init + +use utilities_mod, only : find_namelist_in_file, check_namelist_read, & + string_to_logical, string_to_real,& + nmlfileunit, do_nml_file, do_nml_term, & + register_module, error_handler, & + file_exist, to_upper, E_ERR, E_MSG, E_WARN, array_dump +use obs_kind_mod, only : QTY_SURFACE_ELEVATION, QTY_PRESSURE, & + QTY_GEOMETRIC_HEIGHT, QTY_VERTLEVEL, & + QTY_SURFACE_PRESSURE, & + QTY_TEMPERATURE, QTY_SPECIFIC_HUMIDITY, & + QTY_MOLEC_OXYGEN_MIXING_RATIO, & + QTY_ION_O_MIXING_RATIO, QTY_ATOMIC_H_MIXING_RATIO, & + QTY_ATOMIC_OXYGEN_MIXING_RATIO, QTY_NITROGEN, & + QTY_U_WIND_COMPONENT, QTY_V_WIND_COMPONENT, QTY_CLOUD_LIQUID_WATER, QTY_CLOUD_ICE, & + get_index_for_quantity, get_num_quantities, & + get_name_for_quantity, get_quantity_for_type_of_obs + +! examples of additional quantities that cam-chem might need defined from the obs_kind_mod +! ! GASES +! QTY_CO, QTY_SFCO, QTY_SFCO01, QTY_SFCO02, QTY_SFCO03, & +! QTY_O3, QTY_OH, QTY_NO, QTY_NO2, QTY_NO3, QTY_CH2O, & +! ! AEROSOLS +! QTY_AOD, QTY_NUM_A1, QTY_NUM_A2, QTY_NUM_A3, QTY_NUM_A4, & ! AOD and Numbers +! QTY_SFNUM_A1, QTY_SFNUM_A2, QTY_SFNUM_A3, QTY_SFNUM_A4, & ! SF / Numbers +! QTY_POM_A1, QTY_POM_A4, QTY_BC_A1, QTY_BC_A4, & +! QTY_SFPOM_A4, QTY_SFBC_A4, & ! Carbon +! QTY_SO4_A1, QTY_SO4_A2, QTY_SO4_A3, QTY_SFSO4_A1, QTY_SFSO4_A2, & ! Sulfates +! QTY_DST_A1, QTY_DST_A2, QTY_DST_A3, QTY_NCL_A1, QTY_NCL_A2, QTY_NCL_A3, & +! QTY_SOA1_A1, QTY_SOA1_A2, QTY_SOA2_A1, QTY_SOA2_A2, QTY_SOA3_A1, QTY_SOA3_A2, & ! SOA +! QTY_SOA4_A1, QTY_SOA4_A2, QTY_SOA5_A1, QTY_SOA5_A2, & ! SOA + +use mpi_utilities_mod, only : my_task_id +use random_seq_mod, only : random_seq_type, init_random_seq, random_gaussian +use ensemble_manager_mod, only : ensemble_type, get_my_num_vars, get_my_vars +use distributed_state_mod, only : get_state +use state_structure_mod, only : add_domain, get_dart_vector_index, get_domain_size, & + get_dim_name, get_kind_index, get_num_dims, & + get_num_variables, get_varid_from_kind, & + get_model_variable_indices, state_structure_info, get_short_name, & + get_long_name, get_dim_lengths, get_variable_name +use netcdf_utilities_mod, only : nc_get_variable, nc_get_variable_size, nc_create_file, & + nc_add_attribute_to_variable, & + nc_define_integer_variable, nc_define_double_variable, & + nc_define_real_variable, & + nc_define_real_scalar, & + nc_add_global_creation_time, & + nc_add_global_attribute, & + nc_define_dimension, nc_put_variable, & + nc_synchronize_file, nc_end_define_mode, & + nc_begin_define_mode, nc_open_file_readonly, & + nc_close_file, nc_variable_exists, nc_get_global_attribute, & + nc_get_dimension_size +use chem_tables_mod, only : init_chem_tables, finalize_chem_tables, & + get_molar_mass, get_volume_mixing_ratio +use default_model_mod, only : adv_1step, nc_write_model_vars, & + init_time => fail_init_time, & + init_conditions => fail_init_conditions + +use cam_common_code_mod, only : above_ramp_start, are_damping, build_cam_pressure_columns, build_heights, & + cam_grid, cdebug_level, check_good_levels, cno_normalization_of_scale_heights, & + pert_model_copies, cuse_log_vertical_scale, discarding_high_obs, & + free_cam_grid, free_std_atm_tables, generic_height_to_pressure, & + gph2gmh, height_to_level, init_damping_ramp_info, & + init_discard_high_obs, init_globals, init_sign_of_vert_units, & + is_surface_field, obs_too_high, ok_to_interpolate, pressure_to_level, ramp_end, & + read_model_time, ref_model_top_pressure, ref_nlevels, scale_height, & + set_vert_localization, vert_interp, vertical_localization_type, write_model_time + + +use cam_common_code_mod, only : nc_write_model_atts, grid_data, read_grid_info, & + set_cam_variable_info, MAX_STATE_VARIABLES, & + num_state_table_columns, MAX_PERT, & + shortest_time_between_assimilations, domain_id, & + cuse_log_vertical_scale, & + cno_normalization_of_scale_heights, & + cdebug_level, & + ccustom_routine_to_generate_ensemble, & + cfields_to_perturb, & + cperturbation_amplitude, & + cassimilation_period_days, & + cassimilation_period_seconds, & + csuppress_grid_info_in_output, & + common_initialized + +implicit none +private + +! these routines must be public and you cannot change +! the arguments - they will be called *from* the dart code. + +! routines in this list have code in this module +public :: static_init_model, & + get_model_size, & + get_state_meta_data, & + model_interpolate, & + shortest_time_between_assimilations, & + nc_write_model_atts, & + write_model_time, & + read_model_time, & + end_model, & + pert_model_copies, & + convert_vertical_obs, & + convert_vertical_state, & + get_close_obs, & + get_close_state + +! code for these routines are in other modules +public :: nc_write_model_vars, & + adv_1step, & + init_time, & + init_conditions + +! version controlled file description for error handling, do not edit +character(len=*), parameter :: source = 'cam-se/model_mod.f90' +character(len=*), parameter :: revision = '' +character(len=*), parameter :: revdate = '' + +! model_nml namelist variables and default values +! Which vertical coordinate: Dry mass if for versions with CESM2 and later +logical :: dry_mass_vertical_coordinate = .true. +! If false, uses less precise but vastly cheaper traditional hybrid vertical coordinate for get_close +logical :: precise_dry_mass_get_close = .false. + +character(len=256) :: cam_template_filename = 'caminput.nc' +character(len=256) :: cam_phis_filename = 'cam_phis.nc' + +! Identify the CS grid mapping files +character(len=256) :: homme_map_file = 'SEMapping.nc' ! Corners of each cubed sphere cell. +character(len=256) :: cs_grid_file = 'SEMapping_cs_grid.nc' ! Relationships among corners/nodes. + +character(len=32) :: vertical_localization_coord = 'PRESSURE' +logical :: use_log_vertical_scale = .false. +integer :: assimilation_period_days = 0 +integer :: assimilation_period_seconds = 21600 +integer :: no_obs_assim_above_level = -1 ! model levels +integer :: model_damping_ends_at_level = -1 ! model levels +integer :: debug_level = 0 +logical :: suppress_grid_info_in_output = .false. +logical :: custom_routine_to_generate_ensemble = .true. +character(len=32) :: fields_to_perturb(MAX_PERT) = "" +real(r8) :: perturbation_amplitude(MAX_PERT)= 0.0_r8 +logical :: using_chemistry = .false. +logical :: use_variable_mean_mass = .false. + +! in converting to scale height for the vertical: +! set this to .true. to compute the log of the pressure. +! set this to .false. to additionally normalize by the surface +! pressure at this location. this option is backwards-compatible +! with previous versions of this code. +logical :: no_normalization_of_scale_heights = .true. + +! state_variables defines the contents of the state vector. +! each line of this input should have the form: +! +! netcdf_variable_name, dart_quantity, clamp_min, clamp_max, update_variable +! +! all items must be strings (even if numerical values). +! for no clamping, use the string 'NA' +! to have the assimilation change the variable use 'UPDATE', else 'NO_UPDATE' + +character(len=vtablenamelength) :: state_variables(MAX_STATE_VARIABLES * & + num_state_table_columns ) = ' ' + +namelist /model_nml/ & + dry_mass_vertical_coordinate, & + precise_dry_mass_get_close, & + cam_template_filename, & + cam_phis_filename, & + homme_map_file, & + cs_grid_file, & + vertical_localization_coord, & + state_variables, & + assimilation_period_days, & + assimilation_period_seconds, & + use_log_vertical_scale, & + no_obs_assim_above_level, & + model_damping_ends_at_level, & + suppress_grid_info_in_output, & + custom_routine_to_generate_ensemble, & + fields_to_perturb, & + perturbation_amplitude, & + no_normalization_of_scale_heights, & + use_variable_mean_mass, & + using_chemistry, & + debug_level + +! global variables +character(len=512) :: string1, string2, string3 +logical, save :: module_initialized = .false. + +! Surface potential; used for calculation of geometric heights. +! SENote: right now every process has their own complete copy of this +real(r8), allocatable :: phis(:) + +logical :: l_refined = .false. ! Flag to tell whether grid is a refined mesh or not. + +! A veriety of module storage data structures for geometry of grid +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! CS Variables holding relationships among cubed sphere nodes. + +! ne = global metadata from cam_template_filename, giving the number of 'elements' per face edge of the 'cube'. +! np = # of nodes/edge of each element. Edges are shared with adjacent elements. +! FIXME? put these in a derived type to prevent accidentally using them as local variables. +integer :: ne, np + +! Number of columns, or nodes, in the cubed-sphere grid. +integer :: ncol + +! The nominal resolution is (30 degrees/ne), assuming np = 4 (3x3 cells per element). +real(r8) :: coarse_grid + +! Dimensions of array 'corners', from homme_map_file. +integer :: ncorners, ncenters + +! Maximum number of neighbors a node can have (6 in refined, 4 otherwise) +! Get from namelist, to reduce file & array sizes? +! Or derive from l_refined, after ne is read from caminput.nc? +integer, parameter :: max_neighbors = 6 + +! Array from homme_map_file. +integer, allocatable :: corners(:,:) ! The 4 corners (nodes) of each cell, from HommeMapping.nc + +! 5 arrays from cs_grid_file +integer, allocatable :: num_nghbrs(:) ! Number of neighbors of each node/column in the cubed sphere grid. +integer, allocatable :: centers(:,:) ! The names of the cells that use each node as a corner. +real(r8), allocatable :: a(:,:,:) ! Coefficients of mapping from planar to unit square space for 'x' +real(r8), allocatable :: b(:,:,:) ! Coefficients of mapping from planar to unit square space for 'y' +real(r8), allocatable :: x_ax_bearings(:,:) ! The directions from each node to its neighbors, + ! measured from the vector pointing north. (-PI <= bearing <= PI) + +! Locations of cubed sphere nodes, in DART's location_type format. +type(location_type), allocatable :: cs_locs(:) + +! Used for finding horizontal bounding grid cells +type(get_close_type) :: cs_gc + +! Array of KINDs of cubed sphere grid points. +! As of 2014-3-28 this is only used by location_mod, which doesn't actually use it. +integer, allocatable :: cs_kinds(:) + +! Other useful 1D grid arrays (for cubed sphere) +real(r8), allocatable :: lon_rad(:), lat_rad(:) ! longitude and latitude in radians, used by bearings() + +! This integer is a reminder that some shared calls take 3 dimensions, but SE has only 2: Value is irrelevant +integer :: no_third_dimension = -99 + +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +!SENote: This variable gives extra output for the locations. More global way to do this? +! set to .true. to get more details about the state vector and the +! CAM fields and sizes in the init code. +logical :: print_details = .true. + +contains + +!----------------------------------------------------------------------- +! All the public interfaces are first. +!----------------------------------------------------------------------- + + +!----------------------------------------------------------------------- +!> Called to do one time initialization of the model. +!> In this case, it reads in the grid information, the namelist +!> containing the variables of interest, where to get them, their size, +!> their associated DART Quantity, etc. +!> +!> In addition to harvesting the model metadata (grid, +!> desired model advance step, etc.), it also fills a structure +!> containing information about what variables are where in the DART +!> framework. + +subroutine static_init_model() + +integer :: iunit, io, i +integer :: nc_file_ID +integer :: ncol_temp(1) + +character(len=*), parameter :: routine = 'static_init_model' + +if ( module_initialized ) return + +! Record version info +call register_module(source, revision, revdate) + +module_initialized = .true. +common_initialized = .true. + +! Read the DART namelist for this model +call find_namelist_in_file('input.nml', 'model_nml', iunit) +read(iunit, nml = model_nml, iostat = io) +call check_namelist_read(iunit, io, 'model_nml') + +! Record the namelist values used for the run +if (do_nml_file()) write(nmlfileunit, nml=model_nml) +if (do_nml_term()) write( * , nml=model_nml) + +! Set values from namelist in cam_common_code_mod +cuse_log_vertical_scale = use_log_vertical_scale +cno_normalization_of_scale_heights = no_normalization_of_scale_heights +cdebug_level = debug_level +ccustom_routine_to_generate_ensemble = custom_routine_to_generate_ensemble +cperturbation_amplitude = perturbation_amplitude +cassimilation_period_days = assimilation_period_days +cassimilation_period_seconds = assimilation_period_seconds +csuppress_grid_info_in_output = suppress_grid_info_in_output + +call set_calendar_type('GREGORIAN') + +call read_grid_info(cam_template_filename) +! This non-state variable is used to compute surface elevation. +call read_cam_phis_array(cam_phis_filename) + +! initialize global values that are used frequently +call init_globals() + +! read the namelist &model_nml :: state_variables +! to set up what will be read into the cam state vector +call set_cam_variable_info(cam_template_filename, state_variables) + +! The size of the only surface pressure dimension is the number of columns +ncol_temp = get_dim_lengths(domain_id, get_varid_from_kind(domain_id, QTY_SURFACE_PRESSURE)) +ncol = ncol_temp(1) + +if (debug_level > 100) call state_structure_info(domain_id) + +! convert from string in namelist to integer (e.g. VERTISxxx) +! and tell the dart code which vertical type we want to localize in. +call set_vert_localization(vertical_localization_coord) + +! if you have chemistry variables in the model state, set +! this namelist variable so we can initialize the proper tables +if (using_chemistry) call init_chem_tables() + +! set top limit where obs impacts are diminished to 0. +! only allowed if doing vertical localization. error if +! computing horizontal distances only (odd case, intentionally +! choosing not to support this.) +if (model_damping_ends_at_level > 0) then + if (vertical_localization_on()) then + call init_damping_ramp_info(model_damping_ends_at_level) + are_damping = .true. + else + string1='cannot support model top damping unless also using vertical localization' + string2='set "model_damping_ends_at_level = -1" in &model_nml, OR' + string3='set "horiz_dist_only = .false." in &location_nml' + call error_handler(E_ERR, routine, string1, source, revision, revdate, & + text2=string2, text3=string3) + endif +endif + +! set top limit where obs are discarded. -1 to disable. +if (no_obs_assim_above_level > 0) then + call init_discard_high_obs(no_obs_assim_above_level) + discarding_high_obs = .true. +endif + +! set a flag based on the vertical localization coordinate selected +call init_sign_of_vert_units() + + +!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! This section reads and/or builds the tables needed for model_interpolate for SE +! Read in or create a file containing the relationships among cubed sphere nodes, +! such as neighbors, centers, and bearings, which will be used to identify the cell +! which contains an observation. +! Fields will be stored in global storage. +! Write the cubed sphere grid arrays to a new NetCDF file. + +! Fill arrays that are useful for bearings and distances. +allocate(lon_rad(ncol), lat_rad(ncol)) +lon_rad(:) = grid_data%lon%vals(:)*DEG2RAD +lat_rad(:) = grid_data%lat%vals(:)*DEG2RAD + +! Following block is also used for search for close corners +! Read some attributes from the cubed sphere model_config_file. +! ne is the number of elements/cube edge. Usually 0 for refined grids. +! np is the number of nodes/element edge (shared with adjacent element. +nc_file_ID = nc_open_file_readonly(cam_template_filename, 'Reading ne and np from cam template file') +call nc_get_global_attribute(nc_file_ID, 'ne', ne, 'Reading ne from cam template file', cam_template_filename) +call nc_get_global_attribute(nc_file_ID, 'np', np, 'Reading np from cam template file', cam_template_filename) +call nc_close_file(nc_file_ID, 'Reading ne and np from cam template file', cam_template_filename) + +! Calculate the nominal resolution of the (coarse) grid, +! for use by model_interpolate's call to get_close_obs. +if (ne == 0) then + ! Refined mesh; assume the coarsest grid is the default '1-degree'. + ! Need factor of 1.5 to make sure that there are at least 2 nodes 'close' to any location. + ! There seems to be a tricky interplay between the lon-lat boxes used in the quick search + ! for potentially close nodes, and the cubed sphere grid, so that a coarse_grid of only + ! slightly more than 1.0 degrees can yield 0 close nodes. + coarse_grid = 1.2_r8 * DEG2RAD + l_refined = .true. +else + ! Standard cubed sphere; there are 3x num_elements/face_edge x 4 nodes + ! around the equator. ne = 30 -> 3x4x30 = 360 nodes -> '1-degree' + ! Yielded a location with only 1 close ob, but need 2. + ! coarse_grid = (30.01_r8/ne) * DEG2RAD + coarse_grid = 1.2_r8*(30.0_r8/ne) * DEG2RAD +endif +if (print_details) then + write(string1, *) 'Cubed sphere coarse_grid resolution (rad) used in cs_gc definition = ',& + coarse_grid,' because ne = ',ne + call error_handler(E_MSG, 'static_init_model', string1,source,revision,revdate) +endif + +! Fill cs_gc for use by model_mod. Inputs and outputs are in global storage. +call fill_gc() + +if (file_exist(cs_grid_file)) then + call nc_read_cs_grid_file() +elseif (file_exist(homme_map_file)) then + call create_cs_grid_arrays() + if (my_task_id() == 0) call nc_write_cs_grid_file( cs_grid_file, homme_map_file ) +else + write(string1, *)'No cs_grid_file "',trim(cs_grid_file), & + '" nor homme_map_file "',trim(homme_map_file),'"' + call error_handler(E_ERR,'static_init_model',string1,source,revision,revdate) +endif + +end subroutine static_init_model + +!----------------------------------------------------------------------- +!> Returns the size of the DART state vector (i.e. model) as an integer. +!> + +function get_model_size() + +integer(i8) :: get_model_size + +if ( .not. module_initialized ) call static_init_model + +get_model_size = get_domain_size(domain_id) + +end function get_model_size + +!----------------------------------------------------------------------- +!> Given an integer index into the state vector structure, returns the +!> associated location. A second intent(out) optional argument quantity +!> can be returned if the model has more than one type of field (for +!> instance temperature and zonal wind component). This interface is +!> required for all filter applications as it is required for computing +!> the distance between observations and state variables. +!> +!> @param index_in the index into the DART state vector +!> @param location the location at that index +!> @param var_type the DART Quantity at that index +!> + +subroutine get_state_meta_data(index_in, location, var_type) + +integer(i8), intent(in) :: index_in +type(location_type), intent(out) :: location +integer, optional, intent(out) :: var_type + +! Local variables + +integer :: column, level +integer :: myvarid, myqty, nd + +if ( .not. module_initialized ) call static_init_model + +call get_model_variable_indices(index_in, column, level, no_third_dimension, var_id=myvarid, kind_index=myqty) + +nd = get_num_dims(domain_id, myvarid) + +location = get_location_from_index(column, level, myqty, nd) + + +! return state quantity for this index if requested +if (present(var_type)) var_type = myqty + +end subroutine get_state_meta_data + +!----------------------------------------------------------------------- +!> +!> Model interpolate will interpolate any DART state variable +!> to the given location. +!> +!> @param state_handle DART ensemble handle +!> @param ens_size DART ensemble size +!> @param location the location of interest +!> @param obs_qty the DART Quantity of interest +!> @param interp_vals the estimated value of the DART state at the location +!> of interest (the interpolated value). +!> @param istatus interpolation status ... 0 == success, /=0 is a failure +!> +! Many of these error status returns cannot actually happen. Need to verify these. +!> istatus = 2 asked to interpolate an unknown/unsupported quantity +!> istatus = 8 cannot interpolate level, out of range +!> istatus = 10 cannot interpolate in pressure +!> istatus = 11 cannot interpolate in height +!> istatus = 12 cannot get values from obs quantity +!> istatus = 14 obs above user-defined assimilation top pressure +!> istatus = 16 cannot do vertical interpolation for bottom layer +!> istatus = 17 cannot do vertical interpolation for top layer +!> + +subroutine model_interpolate(state_handle, ens_size, location, obs_qty, interp_vals, istatus) + +type(ensemble_type), intent(in) :: state_handle +integer, intent(in) :: ens_size +type(location_type), intent(in) :: location +integer, intent(in) :: obs_qty +real(r8), intent(out) :: interp_vals(ens_size) !< array of interpolated values +integer, intent(out) :: istatus(ens_size) + +character(len=*), parameter :: routine = 'model_interpolate:' + +! Should dry mass vertical coordinate be used to build vertical pressure columns? +! This is expensive but probably necessary to get unbiased forward operators +logical :: precise = .true. + +integer :: varid, which_vert, status1 +real(r8) :: lon_lat_vert(3) +real(r8) :: quad_vals(4, ens_size) +integer :: cell_corners(4) +real(r8) :: l_weight, m_weight +type(location_type) :: location_copy + +if ( .not. module_initialized ) call static_init_model + +! Successful istatus is 0 +interp_vals(:) = MISSING_R8 +istatus(:) = 99 + +! do we know how to interpolate this quantity? Returns status1 = 0 if OK, status1 = 2 if not OK. +call ok_to_interpolate(obs_qty, varid, status1) + +if (status1 /= 0) then + if(debug_level > 12) then + write(string1,*)'did not find observation quantity ', obs_qty, ' in the state vector' + call error_handler(E_MSG,routine,string1,source,revision,revdate) + endif + istatus(:) = status1 ! this quantity not in the state vector + return +endif + +! unpack the location type into lon, lat, vert, vert_type +lon_lat_vert = get_location(location) +which_vert = nint(query_location(location)) + +! if we are avoiding assimilating obs above a given pressure, test here and return. +if (discarding_high_obs) then + ! Returns status1 = 0 if OK, status1 = 14 if too high. + call obs_too_high(lon_lat_vert(3), which_vert, status1) + if (status1 /= 0) then + istatus(:) = status1 + return + endif +endif + + +! Do the interpolation here +! First step, find the columns of the four 'corners' containing the location +! SENote2: In the CLASSIC, there is a possibility that the cell_corner was already found and this call can +! be skipped. Understand that and implement as needed. +! Note that cannot pass location directly because it is intent(inout) in coord_ind_cs. +location_copy = location +call coord_ind_cs(location_copy, obs_qty, cell_corners, l_weight, m_weight) + +! Now do vertical conversions and get the vertical index for each ensemble member +call get_se_quad_vals(state_handle, ens_size, varid, obs_qty, cell_corners, & + lon_lat_vert, which_vert, precise, quad_vals, istatus) + +!SENote Do further study of how we want to return istatus for various failures +! For now return istatus 12 for any of the failure modes +if (any(istatus /= 0)) then + istatus = 12 + return +endif + + +! Then interpolate horizontally to the (lon,lat) of the ob. +! The following uses JLA's recommended 'generalized quadrilateral interpolation', as in +! http://www.particleincell.com/2012/quad-interpolation/. +! Most of the work is done in create_cs_grid_arrays() and coord_ind_cs(). + +! Interpolate from the cell's corners to the ob location on the unit square. +! This is done by weighting the field at each corner by the rectangular area +! ((l,m) space) diagonally across the ob location from the corner. +! AKA 'linear area weighting'. + +interp_vals(:) = quad_vals(2, :) * l_weight * m_weight & + + quad_vals(1, :) * (1.0_r8 - l_weight)* m_weight & + + quad_vals(4, :) * (1.0_r8 - l_weight)*(1.0_r8 - m_weight) & + + quad_vals(3, :) * l_weight *(1.0_r8 - m_weight) + +if (using_chemistry) & + interp_vals = interp_vals * get_volume_mixing_ratio(obs_qty) + +! all interp values should be set by now. set istatus +istatus(:) = 0 + +end subroutine model_interpolate + +!----------------------------------------------------------------------- +!> +!> Does any shutdown and clean-up needed for model. +!> + +subroutine end_model() + +! deallocate arrays from grid and anything else + +call free_cam_grid(grid_data) + +deallocate(phis) + +call free_std_atm_tables() + +if (using_chemistry) call finalize_chem_tables() + +end subroutine end_model + + +!-------------------------------------------------------------------- +!> Does an conversion to localization vertical coordinate for a set of obs +!> Returns my_status 2 in not able to interp this quantity, 3 if get_se_quad_vals fails. + +subroutine convert_vertical_obs(ens_handle, num, locs, loc_qtys, loc_types, & + which_vert, my_status) + +type(ensemble_type), intent(in) :: ens_handle +integer, intent(in) :: num +type(location_type), intent(inout) :: locs(:) +integer, intent(in) :: loc_qtys(:) +integer, intent(in) :: loc_types(:) +integer, intent(in) :: which_vert +integer, intent(out) :: my_status(:) + +character(len=*), parameter :: routine = 'convert_vertical_obs' + +integer :: current_vert_type, i + +do i=1,num + current_vert_type = nint(query_location(locs(i))) + + if (( current_vert_type == which_vert ) .or. & + ( current_vert_type == VERTISUNDEF)) then + my_status(i) = 0 + cycle + endif + + select case (which_vert) + case (VERTISPRESSURE) + call obs_vertical_to_pressure( ens_handle, precise_dry_mass_get_close, locs(i), my_status(i)) + case (VERTISHEIGHT) + call obs_vertical_to_height( ens_handle, precise_dry_mass_get_close, locs(i), my_status(i)) + case (VERTISLEVEL) + call obs_vertical_to_level( ens_handle, precise_dry_mass_get_close, locs(i), my_status(i)) + case (VERTISSCALEHEIGHT) + call obs_vertical_to_scaleheight(ens_handle, precise_dry_mass_get_close, locs(i), my_status(i)) + case default + write(string1,*)'unable to convert vertical obs "', which_vert, '"' + call error_handler(E_ERR,routine,string1,source,revision,revdate) + end select +enddo + +end subroutine convert_vertical_obs + + +!----------------------------------------------------------------------- +!> This subroutine converts vertical state +!> +!> in: ens_handle - mean ensemble handle +!> in: num - number of locations +!> inout: locs(:) - locations +!> in: loc_qtys(:) - location quantities +!> in: loc_indx(:) - location index +!> in: which_vert - vertical location to convert +!> out: istatus - return status 0 is a successful conversion +!> At present there is no way for this routine to fail. !HK todo FV also +!> has no fail in this routine. Is this ok? + +subroutine convert_vertical_state(ens_handle, num, locs, loc_qtys, loc_indx, & + which_vert, istatus) +type(ensemble_type), intent(in) :: ens_handle +integer, intent(in) :: num +type(location_type), intent(inout) :: locs(:) +!SENote: This argument is not used here, but is required to support external calls. Should reexamine +integer, intent(in) :: loc_qtys(:) +integer(i8), intent(in) :: loc_indx(:) +integer, intent(in) :: which_vert +integer, intent(out) :: istatus + +character(len=*), parameter :: routine = 'convert_vertical_state' + +integer :: current_vert_type, ens_size, i + +ens_size = 1 + +!SENote: A general note. If many states in the same column are being converted this is a remarkably +!inefficient way to do it. + +do i=1,num + current_vert_type = nint(query_location(locs(i))) + + if ( current_vert_type == which_vert ) cycle + if ( current_vert_type == VERTISUNDEF) cycle + + select case (which_vert) + case (VERTISPRESSURE) + call state_vertical_to_pressure( ens_handle, ens_size, precise_dry_mass_get_close, locs(i), loc_indx(i)) + case (VERTISHEIGHT) + call state_vertical_to_height( ens_handle, ens_size, precise_dry_mass_get_close, locs(i), loc_indx(i)) + case (VERTISLEVEL) + call state_vertical_to_level( ens_size, locs(i), loc_indx(i)) + case (VERTISSCALEHEIGHT) + call state_vertical_to_scaleheight( ens_handle, ens_size, precise_dry_mass_get_close, locs(i), loc_indx(i)) + case default + write(string1,*)'unable to convert vertical state "', which_vert, '"' + call error_handler(E_MSG,routine,string1,source,revision,revdate) + end select +enddo + +istatus = 0 + +end subroutine convert_vertical_state + +!-------------------------------------------------------------------- + +subroutine get_close_obs(gc, base_loc, base_type, locs, loc_qtys, loc_types, & + num_close, close_ind, dist, ens_handle) + +! The specific type of the base observation, plus the generic kinds list +! for either the state or obs lists are available if a more sophisticated +! distance computation is needed. + +type(get_close_type), intent(in) :: gc +type(location_type), intent(inout) :: base_loc, locs(:) +integer, intent(in) :: base_type, loc_qtys(:), loc_types(:) +integer, intent(out) :: num_close, close_ind(:) +real(r8), optional, intent(out) :: dist(:) +type(ensemble_type), optional, intent(in) :: ens_handle + +character(len=*), parameter :: routine = 'get_close_obs' + +integer :: i, status(1), this, vert_type +real(r8) :: vert_value, extra_damping_dist +real(r8), parameter :: LARGE_DIST = 999999.0 ! positive and large + +! if absolute distances aren't needed, or vertical localization isn't on, +! the default version works fine since no conversion will be needed and +! there won't be any damping since there are no vert distances. +if (.not. present(dist) .or. .not. vertical_localization_on()) then + call loc_get_close_obs(gc, base_loc, base_type, locs, loc_qtys, loc_types, & + num_close, close_ind, dist, ens_handle) + return +endif + +if (.not. present(ens_handle)) then + call error_handler(E_ERR, routine, & + 'unexpected error: cannot convert distances without an ensemble handle', & + source, revision, revdate) +endif + +! does the base obs need conversion first? +vert_type = query_location(base_loc) + + +if (vert_type /= vertical_localization_type) then + call convert_vert_one_obs(ens_handle, base_loc, base_type, & + vertical_localization_type, status(1)) + if (status(1) /= 0) then + num_close = 0 + return + endif +endif + +! FIXME: is here where we need to compute start of ramp for this +! obs type? should we cache these? start with doing the computation +! each time, then make an array indexed by obs types with the +! start of the ramp and fill it in on demand. have to call for +! maxdist(obs_type) and do the math, but just once per type. + +! ok, distance is needed and we are localizing in the vertical. +! call default get close to get potentically close locations +! but call without distance so it doesn't do extra work. +call loc_get_close_obs(gc, base_loc, base_type, locs, loc_qtys, loc_types, & + num_close, close_ind) + +! compute distances, converting vertical first if need be. +do i=1, num_close + this = close_ind(i) + + vert_type = query_location(locs(this)) + + if (vert_type /= vertical_localization_type) then + call convert_vertical_obs(ens_handle, 1, locs(this:this), & + loc_qtys(this:this), loc_types(this:this), & + vertical_localization_type, status) + if (status(1) /= 0) then + dist(i) = LARGE_DIST + cycle + endif + + endif + + dist(i) = get_dist(base_loc, locs(this)) + + ! do not try to damp impacts when obs has "vert is undefined". + ! the impact will go all the way to the model top. + ! this is the agreed-on functionality. + if (.not. are_damping .or. vert_type == VERTISUNDEF) cycle + + vert_value = query_location(locs(this), 'VLOC') + if (above_ramp_start(vert_value, gc, base_type, ramp_end, dist(i), extra_damping_dist)) then + dist(i) = dist(i) + extra_damping_dist + endif +enddo + +end subroutine get_close_obs + +!---------------------------------------------------------------------------- + + +subroutine get_close_state(gc, base_loc, base_type, locs, loc_qtys, loc_indx, & + num_close, close_ind, dist, ens_handle) + +! The specific type of the base observation, plus the generic kinds list +! for either the state or obs lists are available if a more sophisticated +! distance computation is needed. + +type(get_close_type), intent(in) :: gc +type(location_type), intent(inout) :: base_loc, locs(:) +integer, intent(in) :: base_type, loc_qtys(:) +integer(i8), intent(in) :: loc_indx(:) +integer, intent(out) :: num_close, close_ind(:) +real(r8), optional, intent(out) :: dist(:) +type(ensemble_type), optional, intent(in) :: ens_handle + +character(len=*), parameter :: routine = 'get_close_state' + +integer :: i, status, this, vert_type +real(r8) :: vert_value, extra_damping_dist +real(r8), parameter :: LARGE_DIST = 999999.0 ! positive and large + +! if absolute distances aren't needed, or vertical localization isn't on, +! the default version works fine since no conversion will be needed and +! there won't be any damping since there are no vert distances. +if (.not. present(dist) .or. .not. vertical_localization_on()) then + call loc_get_close_state(gc, base_loc, base_type, locs, loc_qtys, loc_indx, & + num_close, close_ind, dist, ens_handle) + return +endif + +if (.not. present(ens_handle)) then + call error_handler(E_ERR, routine, & + 'unexpected error: cannot convert distances without an ensemble handle', & + source, revision, revdate) +endif + +! does the base obs need conversion first? +vert_type = query_location(base_loc) + +if (vert_type /= vertical_localization_type) then + call convert_vert_one_obs(ens_handle, base_loc, base_type, & + vertical_localization_type, status) + if (status /= 0) then + num_close = 0 + return + endif +endif + +! ok, distance is needed and we are localizing in the vertical. +! call default get close to get potentically close locations +! but call without distance so it doesn't do extra work. +call loc_get_close_state(gc, base_loc, base_type, locs, loc_qtys, loc_indx, & + num_close, close_ind) + +! compute distances, converting vertical first if need be. +do i=1, num_close + this = close_ind(i) + + vert_type = query_location(locs(this)) + + if (vert_type /= vertical_localization_type) then + call convert_vertical_state(ens_handle, 1, locs(this:this), & + loc_qtys(this:this), loc_indx(this:this), & + vertical_localization_type, status) + if (status /= 0) then + dist(i) = LARGE_DIST + cycle + endif + + endif + + dist(i) = get_dist(base_loc, locs(this)) + + ! do not try to damp impacts when obs has "vert is undefined". + ! the impact will go all the way to the model top. + ! this is the agreed-on functionality. + if (.not. are_damping .or. vert_type == VERTISUNDEF) cycle + + vert_value = query_location(locs(this), 'VLOC') + if (above_ramp_start(vert_value, gc, base_type, ramp_end, dist(i), extra_damping_dist)) then + dist(i) = dist(i) + extra_damping_dist + endif +enddo + +end subroutine get_close_state + + +!----------------------------------------------------------------------- + +subroutine fill_gc() + +! Subroutine to generate location_types of the cubed sphere grid +! and put them into get_close_type cs_gc, with other derived components. + +integer :: c + +!SENote: Really don't like all this use of global module storage for communicating among routines +! May want to eliminate some of this. +allocate(cs_locs(ncol), cs_kinds(ncol)) + +! CS inputs in degrees. +do c=1,ncol + cs_locs(c) = set_location(grid_data%lon%vals(c), grid_data%lat%vals(c), MISSING_R8, VERTISUNDEF) + cs_kinds(c) = 0 +enddo + +call get_close_init(cs_gc, ncol, coarse_grid, cs_locs) + +end subroutine fill_gc + +!----------------------------------------------------------------------- +!> given the column and level in the state vector, +!> and the quantity, and the dimensionality of the field (1d, 2d), +!> compute the location of that item. + +function get_location_from_index(column, level, qty, nd) +integer, intent(in) :: column +integer, intent(in) :: level +integer, intent(in) :: qty +integer, intent(in) :: nd +type(location_type) :: get_location_from_index + +character(len=*), parameter :: routine = 'get_location_from_index' +real(r8) :: use_vert_val +real(r8) :: my_lon, my_lat, my_vert + +! full 2d fields are returned with column/level. +! 1d fields are either surface fields, or if they +! are column integrated values then they are 'undefined' +! in the vertical. + +! All fields share the same first coordinate into the column list +my_lon = grid_data%lon%vals(column) +my_lat = grid_data%lat%vals(column) +! For SE 3d spatial fields have a 2d storage +if(nd == 2) then + my_vert = level + get_location_from_index = set_location(my_lon, my_lat, my_vert, VERTISLEVEL) +elseif(nd == 1) then + ! setting the vertical value to missing matches what the previous + ! version of this code did. other models choose to set the vertical + ! value to the model surface elevation at this location: + ! use_vert_val = phis(lon_index, lat_index) / gravity not available in SE + my_vert = MISSING_R8 + ! Add any 2d surface fields to this function + if(is_surface_field(qty)) then + get_location_from_index = set_location(my_lon, my_lat, my_vert, VERTISSURFACE) + else + get_location_from_index = set_location(my_lon, my_lat, my_vert, VERTISUNDEF) + endif +else + write(string1, *) 'state vector field not 1D or 2D and no code to handle other dimensionity' + write(string2, *) 'dimensionality = ', nd, ' quantity type = ', trim(get_name_for_quantity(qty)) + call error_handler(E_ERR,routine,string1,source,revision,revdate,text2=string2) +endif + +end function get_location_from_index + + +!----------------------------------------------------------------------- +!> this routine converts the column and level index values and a quantity into a state vector +!> offset and gets the ensemble of state values for that offset. this only +!> gets a single vertical location - if you need to get values which might +!> have different vertical locations in different ensemble members +!> see get_se_values_from_varid() below. +!> Returns a 0 for OK, returns 12 for my_status for unable to find. + +subroutine get_se_values_from_single_level(ens_handle, ens_size, qty, column, level, & + vals, my_status) +type(ensemble_type), intent(in) :: ens_handle +integer, intent(in) :: ens_size +integer, intent(in) :: qty +integer, intent(in) :: column +integer, intent(in) :: level +real(r8), intent(out) :: vals(ens_size) +integer, intent(out) :: my_status + +character(len=*), parameter :: routine = 'get_se_values_from_single_level:' + +integer :: varid +integer(i8) :: state_indx + +varid = get_varid_from_kind(domain_id, qty) +if (varid < 0) then + vals(:) = MISSING_R8 + my_status = 12 + return +endif + +state_indx = get_dart_vector_index(column, level, no_third_dimension, domain_id, varid) + +!SENote: Not clear we need error checks like this for things that should never happen. +if (state_indx < 1 .or. state_indx > get_domain_size(domain_id)) then + write(string1, *) 'state_index out of range: ', state_indx, ' not between ', 1, get_domain_size(domain_id) + call error_handler(E_ERR,routine,string1,source,revision,revdate,text2=string2,text3='should not happen') +endif +vals(:) = get_state(state_indx, ens_handle) + +my_status = 0 + +end subroutine get_se_values_from_single_level + +!----------------------------------------------------------------------- +!> this routine takes care of getting the actual state values. get_state() +!> communicates with other MPI tasks and can be expensive. +!> +!> all ensemble members have the same horizontal location, but different +!> ensemble members could have different vertical locations and +!> so be between different vertical layers. this code tries to do the fewest +!> calls to get_state by only calling it for levels that are actually needed +!> and setting all members with those same levels in a single pass. +!> + +subroutine get_se_values_from_varid(ens_handle, ens_size, column, levels, varid, & + vals, my_status) +type(ensemble_type), intent(in) :: ens_handle +integer, intent(in) :: ens_size +integer, intent(in) :: column +integer, intent(in) :: levels(ens_size) +integer, intent(in) :: varid +real(r8), intent(out) :: vals(ens_size) +integer, intent(out) :: my_status(ens_size) + +integer(i8) :: state_indx +integer :: i, j +real(r8) :: temp_vals(ens_size) +logical :: member_done(ens_size) + +character(len=*), parameter :: routine = 'get_se_values_from_varid:' + +! as we get the values for each ensemble member, we set the 'done' flag +! and a good return code. +my_status(:) = 12 +member_done(:) = .false. + +! start with levels(1). get the vals into a temp var. +! run through 2-N. any other member that has the same level +! set the outgoing values. keep a separate flag for which +! member(s) have been done. skip to the next undone member +! and get the state for that level. repeat until all levels done. + +do i=1, ens_size + + if (member_done(i)) cycle + state_indx = get_dart_vector_index(column, levels(i), no_third_dimension, domain_id, varid) + + !SENote: Do we need error checks like this? Watch out for the ensemble size with levels being too much + if (state_indx < 0) then + write(string1,*) 'Should not happen: could not find dart state index from ' + write(string2,*) 'column and level index :', column, levels + call error_handler(E_ERR,routine,string1,source,revision,revdate,text2=string2) + return + endif + + temp_vals(:) = get_state(state_indx, ens_handle) ! all the ensemble members for level (i) + + ! start at i, because my ensemble member is clearly at this level. + ! then continue on to see if any other members are also at this level. + do j=i, ens_size + if (member_done(j)) cycle + + if (levels(j) == levels(i)) then + vals(j) = temp_vals(j) + member_done(j) = .true. + my_status(j) = 0 + endif + + enddo +enddo + +end subroutine get_se_values_from_varid + + +!----------------------------------------------------------------------- +!> this is just for 2d fields + +subroutine get_se_values_from_nonstate_fields(ens_handle, ens_size, column, & + levels, obs_quantity, precise, vals, my_status) +type(ensemble_type), intent(in) :: ens_handle +integer, intent(in) :: ens_size +integer, intent(in) :: column +integer, intent(in) :: levels(ens_size) +integer, intent(in) :: obs_quantity +logical, intent(in) :: precise +real(r8), intent(out) :: vals(ens_size) +integer, intent(out) :: my_status(ens_size) + +integer :: imember +real(r8) :: vals_array(ref_nlevels,ens_size) + +character(len=*), parameter :: routine = 'get_se_values_from_nonstate_fields:' + +vals(:) = MISSING_R8 +! This 99 status value can never be returned. Left for backwards consistency +! with FV get_values_from_nonstate_fields but should be verified and removed +my_status(:) = 99 + +select case (obs_quantity) + case (QTY_PRESSURE) + call cam_se_pressure_levels(ens_handle, ens_size, column, ref_nlevels, & + precise, vals_array, my_status) + if (any(my_status /= 0)) return + + do imember=1,ens_size + vals(imember) = vals_array(levels(imember), imember) + enddo + + case (QTY_VERTLEVEL) + vals(:) = levels(:) + my_status(:) = 0 + +!SENote: Turns out there was no height localization for non-height vertical obs in Manhattan or Classic +!SENote: At present there is no QTY_GEOMETRIC_HEIGHT here as needed to convert to Height + + case default + write(string1,*)'contact dart support. unexpected error for quantity ', obs_quantity + call error_handler(E_ERR,routine,string1,source,revision,revdate) + +end select + +end subroutine get_se_values_from_nonstate_fields + +!----------------------------------------------------------------------- +!> internal only version of model interpolate. +!> does not check for locations too high - return all actual values. + +subroutine interpolate_se_values(state_handle, ens_size, location, obs_qty, varid, & + precise, interp_vals, istatus) + +type(ensemble_type), intent(in) :: state_handle +integer, intent(in) :: ens_size +type(location_type), intent(in) :: location +integer, intent(in) :: obs_qty +integer, intent(in) :: varid +logical, intent(in) :: precise +real(r8), intent(out) :: interp_vals(ens_size) +integer, intent(out) :: istatus(ens_size) + +character(len=*), parameter :: routine = 'interpolate_se_values:' + +integer :: which_vert +integer :: cell_corners(4), i +type(location_type) :: location_copy +real(r8) :: l_weight, m_weight +real(r8) :: lon_lat_vert(3), quad_vals(4, ens_size) + +interp_vals(:) = MISSING_R8 +istatus(:) = 99 + +lon_lat_vert = get_location(location) +which_vert = nint(query_location(location)) + +! Do not want to propagate changes to the location back up the calling tree +location_copy = location +call coord_ind_cs(location_copy, obs_qty, cell_corners, l_weight, m_weight) + +!Now work on the vertical conversions and getting the vertical index for each ensemble member +call get_se_quad_vals(state_handle, ens_size, varid, obs_qty, cell_corners, & + lon_lat_vert, which_vert, precise, quad_vals, istatus) + +!SENote: For now return a 12 for all istatus members if there is any failure from get_se_quad_vals +if (any(istatus /= 0)) then + istatus = 12 + return +endif + +! The following uses Jeff's recommended 'generalized quadrilateral interpolation', as in +! http://www.particleincell.com/2012/quad-interpolation/. +! Most of the work is done in create_cs_grid_arrays() and coord_ind_cs(). + +! Interpolate from the cell's corners to the ob location on the unit square. +! This is done by weighting the field at each corner by the rectangular area +! ((l,m) space) diagonally across the ob location from the corner. +! AKA 'linear area weighting'. + +interp_vals(:) = quad_vals(2, :) * l_weight * m_weight & + + quad_vals(1, :) * (1.0_r8 - l_weight)* m_weight & + + quad_vals(4, :) * (1.0_r8 - l_weight)*(1.0_r8 - m_weight) & + + quad_vals(3, :) * l_weight *(1.0_r8 - m_weight) + +end subroutine interpolate_se_values + +!----------------------------------------------------------------------- +!> +!> Finds the values at the quad corners for each ensemble member +!> Returns all ensemble size my_status as 12 if can't find values. +!> Returns 10 for any ensemble member that cannot be interpolated in presure. +!> Returns 11 for any ensemble member that cannot be interpolated in height. +!> Returns 8 for all ensemble members if level is out of range. +!> Returns for all ensemble members 16 for unable to find lower values, 17 for unable to find upper values. + +subroutine get_se_quad_vals(state_handle, ens_size, varid, obs_qty, corners, & + lon_lat_vert, which_vert, precise, quad_vals, my_status) +type(ensemble_type), intent(in) :: state_handle +integer, intent(in) :: ens_size +integer, intent(in) :: varid +integer, intent(in) :: obs_qty +integer, intent(in) :: corners(4) +real(r8), intent(in) :: lon_lat_vert(3) +integer, intent(in) :: which_vert +logical, intent(in) :: precise +real(r8), intent(out) :: quad_vals(4, ens_size) !< array of interpolated values +integer, intent(out) :: my_status(ens_size) + +integer :: icorner, numdims +integer :: level_one_array(ens_size) +integer :: four_levs1(4, ens_size), four_levs2(4, ens_size) +real(r8) :: four_vert_fracts(4, ens_size) + +character(len=*), parameter :: routine = 'get_se_quad_vals:' + +quad_vals(:,:) = MISSING_R8 +my_status(:) = 99 + +! need to consider the case for 2d vs 2d variables +numdims = get_dims_from_qty(obs_qty, varid) + +! Now here potentially we have different results for different +! ensemble members. the things that can vary are dimensioned by ens_size. + +if (numdims == 2) then + + ! build 4 columns to find vertical level numbers + do icorner=1, 4 + call find_se_vertical_levels(state_handle, ens_size, corners(icorner), lon_lat_vert(3), & + which_vert, precise, four_levs1(icorner, :), four_levs2(icorner, :), & + four_vert_fracts(icorner, :), my_status) + + if (any(my_status /= 0)) then + my_status = 12 + return + endif + enddo + + ! we have all the indices and fractions we could ever want. + ! now get the data values at the bottom levels, the top levels, + ! and do vertical interpolation to get the 4 values in the columns. + ! the final horizontal interpolation will happen later. + + if (varid > 0) then + + call get_se_four_state_values(state_handle, ens_size, corners, & + four_levs1, four_levs2, four_vert_fracts, & + varid, quad_vals, my_status) + + else ! get 2d special variables in another ways ( like QTY_PRESSURE ) + call get_se_four_nonstate_values(state_handle, ens_size, corners, & + four_levs1, four_levs2, four_vert_fracts, & + obs_qty, precise, quad_vals, my_status) + + endif + + !SENote Technically nothing happens after this point anyway? So is this statement needed. + if (any(my_status /= 0)) return + +else if (numdims == 1) then + + if (varid > 0) then + level_one_array(:) = 1 + do icorner=1, 4 + call get_se_values_from_varid(state_handle, ens_size, corners(icorner), & + level_one_array, varid, quad_vals(icorner,:),my_status) + + if (any(my_status /= 0)) return + + enddo + + else ! special 1d case + !SENote: Is this ever used at present? + do icorner=1, 4 + call get_se_quad_values(ens_size, corners(icorner), obs_qty, quad_vals(icorner,:)) + enddo + ! apparently this can't fail + my_status(:) = 0 + + endif + +else + write(string1, *) trim(get_name_for_quantity(obs_qty)), ' has dimension ', numdims + call error_handler(E_ERR, routine, 'only supports 1D or 2D fields', & + source, revision, revdate, text2=string1) +endif + +! when you get here, my_status() was set either by passing it to a +! subroutine, or setting it explicitly here. if this routine returns +! the default value of 99 something went wrong in this logic. + +end subroutine get_se_quad_vals + +!----------------------------------------------------------------------- +!> +! Returns my_status 0 for success, 16 if unable to find values at lower level +! and 17 if unable to find values at upper level. + +subroutine get_se_four_state_values(state_handle, ens_size, four_corners, & + four_levs1, four_levs2, four_vert_fracts, & + varid, quad_vals, my_status) + +type(ensemble_type), intent(in) :: state_handle +integer, intent(in) :: ens_size +integer, intent(in) :: four_corners(4) +integer, intent(in) :: four_levs1(4, ens_size), four_levs2(4, ens_size) +real(r8), intent(in) :: four_vert_fracts(4, ens_size) +integer, intent(in) :: varid +real(r8), intent(out) :: quad_vals(4, ens_size) !< array of interpolated values +integer, intent(out) :: my_status(ens_size) + +integer :: icorner +real(r8) :: vals1(ens_size), vals2(ens_size) + +character(len=*), parameter :: routine = 'get_se_four_state_values:' + + +! SENote This is inefficient since get_se_values_from_varid is messy. Once we know the lower level for an ensmble +! member, we know the level above and could minimize the work. +do icorner=1, 4 + call get_se_values_from_varid(state_handle, ens_size, four_corners(icorner), & + four_levs1(icorner, :), varid, vals1, my_status) + + if (any(my_status /= 0)) then + my_status(:) = 16 ! cannot retrieve vals1 values + return + endif + + call get_se_values_from_varid(state_handle, ens_size, four_corners(icorner), & + four_levs2(icorner, :), varid, vals2, my_status) + if (any(my_status /= 0)) then + my_status(:) = 17 ! cannot retrieve top values + return + endif + + !SENote: this is more general. The vertical interpolation is linear in level, but this may be biased for + !doing interpolation in height, scale_height, or pressure. Is it worth thinking about this? + call vert_interp(ens_size, vals1, vals2, four_vert_fracts(icorner, :), & + quad_vals(icorner, :)) + +enddo + + +end subroutine get_se_four_state_values + +!----------------------------------------------------------------------- +!> + +! Returns my_status 0 for success, 16 if unable to find values at lower level +! and 17 if unable to find values at upper level. + +subroutine get_se_four_nonstate_values(state_handle, ens_size, four_corners, & + four_levs1, four_levs2, four_vert_fracts, & + obs_qty, precise, quad_vals, my_status) + +type(ensemble_type), intent(in) :: state_handle +integer, intent(in) :: ens_size +integer, intent(in) :: four_corners(4) +integer, intent(in) :: four_levs1(4, ens_size), four_levs2(4, ens_size) +real(r8), intent(in) :: four_vert_fracts(4, ens_size) +integer, intent(in) :: obs_qty +logical, intent(in) :: precise +real(r8), intent(out) :: quad_vals(4, ens_size) !< array of interpolated values +integer, intent(out) :: my_status(ens_size) + +integer :: icorner +real(r8) :: vals1(ens_size), vals2(ens_size) + +character(len=*), parameter :: routine = 'get_se_four_nonstate_values:' + +do icorner=1, 4 + call get_se_values_from_nonstate_fields(state_handle, ens_size, four_corners(icorner), & + four_levs1(icorner, :), obs_qty, precise, vals1, my_status) + if (any(my_status /= 0)) then + my_status(:) = 16 ! cannot retrieve vals1 values + return + endif + + call get_se_values_from_nonstate_fields(state_handle, ens_size, four_corners(icorner), & + four_levs2(icorner, :), obs_qty, precise, vals2, my_status) + if (any(my_status /= 0)) then + my_status(:) = 17 ! cannot retrieve top values + return + endif + + call vert_interp(ens_size, vals1, vals2, four_vert_fracts(icorner, :), & + quad_vals(icorner, :)) + +enddo + +end subroutine get_se_four_nonstate_values + + +!----------------------------------------------------------------------- +!> figure out whether this is a 1d or 2d field based on the quantity. +!> if this field is in the state vector, use the state routines. +!> if it's not, there are cases for known other quantities we can +!> interpolate and return. add any new non-state fields here. + +function get_dims_from_qty(obs_quantity, var_id) +integer, intent(in) :: obs_quantity +integer, intent(in) :: var_id +integer :: get_dims_from_qty + +character(len=*), parameter :: routine = 'get_dims_from_qty:' + +if (var_id > 0) then + get_dims_from_qty = get_num_dims(domain_id,var_id) +else + select case (obs_quantity) + case (QTY_SURFACE_ELEVATION) + ! In SE this is a 1 dimensional field + get_dims_from_qty = 1 + case (QTY_PRESSURE, QTY_GEOMETRIC_HEIGHT) + ! In SE these are 2d fields + get_dims_from_qty = 2 + case default + write(string1, *) 'we can not interpolate qty "', get_name_for_quantity(obs_quantity), & + '" if the dimension is not known' + call error_handler(E_ERR,routine, string1,source,revision,revdate) + end select +endif + +end function get_dims_from_qty + +!----------------------------------------------------------------------- +!> +!> This is for 1d special observations quantities not in the state + +! For now this can onlu get surface elevation (phis) + +subroutine get_se_quad_values(ens_size, column, obs_quantity, vals) +integer, intent(in) :: ens_size +integer, intent(in) :: column +integer, intent(in) :: obs_quantity +real(r8), intent(out) :: vals(ens_size) + +character(len=*), parameter :: routine = 'get_se_quad_values' + +integer :: prev_lon, next_lat +real(r8) :: vals1(ens_size), vals2(ens_size) + + +select case (obs_quantity) + case (QTY_SURFACE_ELEVATION) + ! Just return phis for this column + vals = phis(column) + + !>@todo FIXME: + ! should this be using gravity at the given latitude? + vals = vals / gravity + + case default + write(string1, *) 'we can not interpolate qty', obs_quantity + call error_handler(E_ERR,routine,string1,source,revision,revdate) + +end select + +end subroutine get_se_quad_values + +!----------------------------------------------------------------------- +!> given a column index number, a quantity and a vertical value and type, +!> return which two levels these are between and the fraction across. +!> +! my_status is 0 for success, 12 for all ensemble members if values cannot be found, +! 10 for any ensemble member that cannot be interpolated in pressure. +! 11 for any ensemble member that cannot be interpolated in height. +! 8 for all ensemble members if cannot be interpolated in level. + +subroutine find_se_vertical_levels(ens_handle, ens_size, column, vert_val, & + which_vert, precise, levs1, levs2, vert_fracts, my_status) +type(ensemble_type), intent(in) :: ens_handle +integer, intent(in) :: ens_size +integer, intent(in) :: column +real(r8), intent(in) :: vert_val +integer, intent(in) :: which_vert +logical, intent(in) :: precise +integer, intent(out) :: levs1(ens_size) +integer, intent(out) :: levs2(ens_size) +real(r8), intent(out) :: vert_fracts(ens_size) +integer, intent(out) :: my_status(ens_size) + +character(len=*), parameter :: routine = 'find_se_vertical_levels:' + +integer :: l1, l2, imember, level_one, status1, k +real(r8) :: fract1 +real(r8) :: surf_pressure ( ens_size ) +real(r8) :: pressure_array( ref_nlevels, ens_size ) +real(r8) :: height_array ( ref_nlevels, ens_size ) + +! assume the worst +levs1(:) = MISSING_I +levs2(:) = MISSING_I +vert_fracts(:) = MISSING_R8 +my_status(:) = 98 + + +! ref_nlevels is the number of vertical levels (midlayer points) + +level_one = 1 + +select case (which_vert) + + case(VERTISPRESSURE) + ! construct a pressure column here and find the model levels that enclose this value + call get_se_values_from_single_level(ens_handle, ens_size, QTY_SURFACE_PRESSURE, column, level_one, & + surf_pressure, status1) + + ! Returns all my_status members as 12 if unable to find the value + if (status1 /= 0) then + my_status(:) = status1 + return + endif + + if(dry_mass_vertical_coordinate .and. precise) then + call build_dry_mass_pressure_columns(ens_handle, ens_size, ref_nlevels, column, surf_pressure, & + pressure_array, status1) + ! All output variables set to missing already, just return with all my_status as 12 + if(status1 /= 0) then + my_status = 12 + return + endif + else + call build_cam_pressure_columns(ens_size, surf_pressure, ref_nlevels, pressure_array) + endif + + do imember = 1, ens_size + ! Returns my_status 10 if unable to interpolate in this column + call pressure_to_level(ref_nlevels, pressure_array(:, imember), vert_val, & + levs1(imember), levs2(imember), vert_fracts(imember), my_status(imember)) + enddo + + !SENote: Can we somehow get all of these disruptive debug statements out of the code? Preprocess? + if (debug_level > 100) then + do k = 1,ens_size + print*, 'ISPRESSURE levs1(k), levs2(k), vert_fracts(k), vert_val', & + levs1(k), levs2(k), vert_fracts(k), vert_val, pressure_array(levs1(k) , k), pressure_array(levs2(k), k) + enddo + endif + + case(VERTISHEIGHT) + ! construct a height column here and find the model levels that enclose this value + ! All my_status are returned as 12 if a failure + call cam_se_height_levels(ens_handle, ens_size, column, ref_nlevels, & + precise, height_array, my_status) + + !>@todo FIXME let successful members continue? + if (any(my_status /= 0)) return + + if (debug_level > 400) then + do k = 1,ref_nlevels + print*, 'ISHEIGHT: ', k, height_array(k,1) + enddo + endif + + do imember=1, ens_size + ! Returns 11 if unable to interpolate in this column + call height_to_level(ref_nlevels, height_array(:, imember), vert_val, & + levs1(imember), levs2(imember), vert_fracts(imember), & + my_status(imember)) + enddo + + if (debug_level > 100) then + do k = 1,ens_size + print*, 'ISHEIGHT ens#, levs1(#), levs2(#), vert_fracts(#), top/bot height(#)', & + k, levs1(k), levs2(k), vert_fracts(k), height_array(levs2(k),k), height_array(levs1(k), k) + enddo + endif + + !>@todo FIXME let successful members continue? + + case(VERTISLEVEL) + ! this routine returns false if the level number is out of range. + if (.not. check_good_levels(vert_val, ref_nlevels, l1, l2, fract1)) then + my_status(:) = 8 + return + endif + + ! because we're given a model level as input, all the ensemble + ! members have the same outgoing values. + levs1(:) = l1 + levs2(:) = l2 + vert_fracts(:) = fract1 + my_status(:) = 0 + + if (debug_level > 100) then + do k = 1,ens_size + print*, 'ISLEVEL levs1(k), levs2(k), vert_fracts(k), vert_val', & + levs1(k), levs2(k), vert_fracts(k), vert_val + enddo + endif + +!SENote: This subroutine is only called from one place and only for 2d fields so this next block can't be reached +! This allows removal of the obs_qty and varid arguments from the call + ! 1d fields for SE + !case(VERTISUNDEF, VERTISSURFACE) + !if (get_dims_from_qty(obs_qty, var_id) == 2) then + !levs1(:) = ref_nlevels - 1 + !levs2(:) = ref_nlevels + !vert_fracts(:) = 1.0_r8 + !my_status(:) = 0 + !else + !my_status(:) = 4 ! can not get vertical levels + !endif + + case default + write(string1, *) 'unsupported vertical type: ', which_vert + call error_handler(E_ERR,routine,string1,source,revision,revdate) + +end select + +! by this time someone has already set my_status(), good or bad. + +end subroutine find_se_vertical_levels + + +!----------------------------------------------------------------------- +!> Compute pressure column for the dry mass vertical coordinate option +!> +!> this version does all ensemble members at once. + + +subroutine build_dry_mass_pressure_columns(ens_handle, ens_size, nlevels, column, surf_pressure, pressure, status) +type(ensemble_type), intent(in) :: ens_handle +integer, intent(in) :: ens_size +integer, intent(in) :: nlevels +integer, intent(in) :: column +real(r8), intent(in) :: surf_pressure(ens_size) +real(r8), intent(out) :: pressure(nlevels, ens_size) +integer, intent(out) :: status + +real(r8) :: specific_humidity(ens_size), cldliq(ens_size), cldice(ens_size), sum_specific_water_ratios(ens_size) +real(r8) :: a_width(nlevels), b_width(nlevels) +real(r8) :: sum_dry_mix_ratio(nlevels, ens_size), dry_mass_top, mass_diff_term, denom, numer +real(r8) :: dry_mass_sfc(ens_size), half_pressure(nlevels + 1) +integer :: k, n, istatus + +! Building pressure columns for dry mass vertical coordinate; Add in references to Lauritzen and pointer +! to the document on the algorithm + +! Begin by getting column values for specific mixing ratio for water vapor (specific humidity), cloud liquid +! and cloud ice. For more accuracy could also include rain, snow, and any other tracers. +! Note that other tracers in the dry mass cam/se have a dry mixing ratio, not specific mixing ratio (although +! Peter plans to change this for consistency). + +!SENote: The following should all be 0, but A's at levels 2, 3, 4, and 5 are not. +! This is confirmed in the caminput.nc file and is a PROBLEM. +! Some tests on the A and B coefficients +!do k = 1, nlevels + !write(*, *) k, (grid_data%hyai%vals(k) + grid_data%hyai%vals(k+1))/2.0_r8 - grid_data%hyam%vals(k) + !write(*, *) k, (grid_data%hybi%vals(k) + grid_data%hybi%vals(k+1))/2.0_r8 - grid_data%hybm%vals(k) +!enddo +!stop + +! For now, will fail all ensemble members and levels if any level/member fails + +! Need the water tracer specific mixing ratios for ever level in the column to compute their mass sum +do k = 1, nlevels + + ! Specific Humidity + call get_se_values_from_single_level(ens_handle, ens_size, QTY_SPECIFIC_HUMIDITY, column, k, & + specific_humidity, status) + if (status /= 0) then + pressure = MISSING_R8 + return + endif + + ! Cloud liquid + call get_se_values_from_single_level(ens_handle, ens_size, QTY_CLOUD_LIQUID_WATER, column, k, & + cldliq, status) + if (status /= 0) then + pressure = MISSING_R8 + return + endif + + ! Cloud ice + call get_se_values_from_single_level(ens_handle, ens_size, QTY_CLOUD_ICE, column, k, & + cldice, status) + if (status /= 0) then + pressure = MISSING_R8 + return + endif + + ! Compute the sum of the dry mixing ratio of dry air plus all the water tracers (ref. to notes) + sum_specific_water_ratios = specific_humidity(:) + cldliq(:) + cldice(:) + sum_dry_mix_ratio(k, :) = 1.0_r8 + sum_specific_water_ratios(:) / (1.0_r8 - sum_specific_water_ratios(:)) + + ! Compute the A 'width' and B 'width' of each level + a_width(k) = grid_data%hyai%vals(k + 1) - grid_data%hyai%vals(k) + b_width(k) = grid_data%hybi%vals(k + 1) - grid_data%hybi%vals(k) + +enddo + +! Compute the dry mass at the bottom of the column for each enseble member +! Do we need to worry about latitudinal variation in g? +! Nothing but dry air above the model top +dry_mass_top = ref_model_top_pressure / gravity +do n = 1, ens_size + mass_diff_term = (surf_pressure(n) - ref_model_top_pressure) / gravity + numer = mass_diff_term - dry_mass_top * sum(a_width(:) * sum_dry_mix_ratio(:, n)) / grid_data%hyai%vals(1) + denom = sum(b_width(:) * sum_dry_mix_ratio(:, n)) + dry_mass_sfc(n) = numer / denom + + ! Now compute the pressure columns + half_pressure(1) = ref_model_top_pressure + do k = 1, nlevels + half_pressure(k + 1) = half_pressure(k) + & + !gravity * (a_width(k)*dry_mass_top + b_width(k)*dry_mass_sfc(n)) * sum_dry_mix_ratio(k, n) + ! SENote: NEXT LINE IS BELIEVED TO BE CORRECT BUT NEEDS TO BE VETTED WITH CGD + gravity * (a_width(k)*dry_mass_top / grid_data%hyai%vals(1) + b_width(k)*dry_mass_sfc(n)) * sum_dry_mix_ratio(k, n) + pressure(k, n) = (half_pressure(k) + half_pressure(k + 1)) / 2 + end do +end do + +status = 0 + +end subroutine build_dry_mass_pressure_columns + + +!----------------------------------------------------------------------- +!> Compute the heights at pressure midpoints +!> +!> this version does all ensemble members at once. +!> Returns my_status 12 for all members if unable to compute levels. + +subroutine cam_se_height_levels(ens_handle, ens_size, column, nlevels, precise, height_array, my_status) +type(ensemble_type), intent(in) :: ens_handle +integer, intent(in) :: ens_size +integer, intent(in) :: column +integer, intent(in) :: nlevels +logical, intent(in) :: precise +real(r8), intent(out) :: height_array(nlevels, ens_size) +integer, intent(out) :: my_status(ens_size) + +integer :: k, level_one, imember, status1 +real(r8) :: surface_elevation(1) +real(r8) :: surface_pressure(ens_size), mbar(nlevels, ens_size) +real(r8) :: pressure(nlevels, ens_size) +real(r8) :: tv(nlevels, ens_size) ! Virtual temperature, top to bottom + +! this is for surface obs +level_one = 1 + +! Get the surface pressure at this column; Returns status1 12 if value cannot be found +call get_se_values_from_single_level(ens_handle, ens_size, QTY_SURFACE_PRESSURE, column, level_one, & + surface_pressure, status1) +if(status1 /= 0) then + my_status = status1 + return +endif + +! get the surface elevation from the phis +call get_se_quad_values(1, column, QTY_SURFACE_ELEVATION, surface_elevation) + +! Returns status1 12 if unsuccessful in getting needed quantities +call compute_se_virtual_temperature(ens_handle, ens_size, column, nlevels, tv, status1) + +if (status1 /= 0) then + my_status = status1 + return +endif + +! Build the pressure columns for the entire ensemble +if(dry_mass_vertical_coordinate .and. precise) then + call build_dry_mass_pressure_columns(ens_handle, ens_size, nlevels, column, surface_pressure, & + pressure, status1) + if(status1 /= 0) then + my_status = 12 + height_array = MISSING_R8 + return + endif +else + call build_cam_pressure_columns(ens_size, surface_pressure, nlevels, pressure) +endif + +if (use_variable_mean_mass) then + call compute_se_mean_mass(ens_handle, ens_size, column, nlevels, mbar, status1) + if (status1 /= 0) then + my_status = status1 + return + endif + + ! compute the height columns for each ensemble member - passing mbar() array in. + do imember = 1, ens_size + call build_heights(nlevels, surface_pressure(imember), surface_elevation(1), & + pressure(:, imember), tv(:, imember), height_array(:, imember), mbar=mbar(:, imember)) + enddo + +else + ! compute the height columns for each ensemble member - no mbar() argument here. + ! (you cannot just pass 1.0 in for the mbar() array; it uses a different gas constant + ! in the variable mean mass case.) + do imember = 1, ens_size + call build_heights(nlevels, surface_pressure(imember), surface_elevation(1), & + pressure(:, imember), tv(:, imember), height_array(:, imember)) + enddo +endif + + +if (debug_level > 100) then + do imember = 1, ens_size + print *, '' + print *, 'geopotential, member: ', imember + do k = 1, nlevels + print*, 'tv(level) ', k, tv(k, imember) + enddo + do k = 1, nlevels + print*, 'height(level)', k, height_array(k, imember) + enddo + enddo +endif + +! convert entire array to geometric height (from potential height) +call gph2gmh(height_array, grid_data%lat%vals(column)) + +if (debug_level > 100) then + do imember = 1, ens_size + print *, '' + print *, 'geometric, member: ', imember + do k = 1, nlevels + print*, 'height(level)', k, height_array(k, imember) + enddo + enddo +endif + +my_status(:) = 0 + +end subroutine cam_se_height_levels + +!----------------------------------------------------------------------- +! The remaining (private) interfaces come last. +! None of the private interfaces need to call static_init_model() +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +!> +!> + +subroutine read_cam_phis_array(phis_filename) +character(len=*), intent(in) :: phis_filename + +character(len=*), parameter :: routine = 'read_cam_phis_array' + +integer :: ncid, nsize(3) ! lon, lat, time !HK todo nope? space filling curve nsize=1 + +ncid = nc_open_file_readonly(phis_filename, routine) + +call nc_get_variable_size(ncid, 'PHIS', nsize(:), routine) + +allocate( phis(nsize(1))) + +call nc_get_variable(ncid, 'PHIS', phis, routine) + +call nc_close_file(ncid, routine) + +end subroutine read_cam_phis_array + + +!----------------------------------------------------------------------- +!> Compute the virtual temperature at the midpoints +!> +!> this version does all ensemble members at once. +!> + +subroutine compute_se_virtual_temperature(ens_handle, ens_size, column, nlevels, tv, istatus) + +type(ensemble_type), intent(in) :: ens_handle +integer, intent(in) :: ens_size +integer, intent(in) :: column +integer, intent(in) :: nlevels +real(r8), intent(out) :: tv(nlevels, ens_size) +integer, intent(out) :: istatus + +integer :: k +real(r8) :: temperature(ens_size), specific_humidity(ens_size) + +!>@todo this should come from a model specific constant module. +!> the forward operators and model_mod should use it. +real(r8), parameter :: rd = 287.05_r8 ! dry air gas constant +real(r8), parameter :: rv = 461.51_r8 ! wet air gas constant +real(r8), parameter :: rr_factor = (rv/rd) - 1.0_r8 + +! construct a virtual temperature column, one for each ensemble member +do k = 1, nlevels + ! temperature + call get_se_values_from_single_level(ens_handle, ens_size, QTY_TEMPERATURE, column, k, & + temperature, istatus) + + if (istatus < 0) return + + ! specific humidity + call get_se_values_from_single_level(ens_handle, ens_size, QTY_SPECIFIC_HUMIDITY, column, k, & + specific_humidity, istatus) + + if (istatus < 0) return + + !>tv == virtual temperature. + tv(k,:) = temperature(:)*(1.0_r8 + rr_factor*specific_humidity(:)) +enddo + +end subroutine compute_se_virtual_temperature + + +!----------------------------------------------------------------------- +!> loop through all levels to get the mean mass. +!> + + +subroutine compute_se_mean_mass(ens_handle, ens_size, column, nlevels, mbar, istatus) +type(ensemble_type), intent(in) :: ens_handle +integer, intent(in) :: ens_size +integer, intent(in) :: column +integer, intent(in) :: nlevels +real(r8), intent(out) :: mbar(nlevels, ens_size) +integer, intent(out) :: istatus + +integer :: k, this_qty +real(r8) :: mmr_o1(ens_size, nlevels), & + mmr_o2(ens_size, nlevels), & + mmr_h1(ens_size, nlevels), & + mmr_n2(ens_size, nlevels) +real(r8) :: O_molar_mass, O2_molar_mass, H_molar_mass, N2_molar_mass +integer :: my_status, varid + +character(len=*), parameter :: routine = 'compute_se_mean_mass' + +!SENote: This subroutine has not been tested yet for SE. Need to work with WACCM folks to test. +call error_handler(E_ERR, routine, 'Subroutine has not been tested', source, revision, revdate) + +! Default is successful return +istatus = 0 + +! do this outside the subroutine? it never changes throughout the +! run of the program +!SENote: could do an initialization with save storage +! See if the quantities can be interpolated. +call ok_to_interpolate(QTY_ATOMIC_OXYGEN_MIXING_RATIO, varid, my_status) +if(my_status /= 0) call error_handler(E_ERR, routine, 'Cannot get QTY_ATOMIC_OXYGEN_MIXING_RATIO', source, revision, revdate) +O_molar_mass = get_molar_mass(QTY_ATOMIC_OXYGEN_MIXING_RATIO) + +call ok_to_interpolate(QTY_MOLEC_OXYGEN_MIXING_RATIO, varid, my_status) +if(my_status /= 0) call error_handler(E_ERR, routine, 'Cannot get QTY_MOLEC_OXYGEN_MIXING_RATIO', source, revision, revdate) +O2_molar_mass = get_molar_mass(QTY_MOLEC_OXYGEN_MIXING_RATIO) + +call ok_to_interpolate(QTY_ATOMIC_H_MIXING_RATIO, varid,my_status) +if(my_status /= 0) call error_handler(E_ERR, routine, 'Cannot get QTY_ATOMIC_H_MIXING_RATIO', source, revision, revdate) +H_molar_mass = get_molar_mass(QTY_ATOMIC_H_MIXING_RATIO) + +call ok_to_interpolate(QTY_NITROGEN, varid, my_status) +if(my_status /= 0) call error_handler(E_ERR, routine, 'Cannot get QTY_NITROGEN', source, revision, revdate) +N2_molar_mass = get_molar_mass(QTY_NITROGEN) + + + +! High topped models (WACCM-X) need to account for the changing composition +! of the atmosphere with height. This requires several variables from the +! initial file, which may not be available from low topped models. +do k = 1, nlevels + + call get_se_values_from_single_level(ens_handle, ens_size, QTY_ATOMIC_OXYGEN_MIXING_RATIO, & + column, k, mmr_o1(:, k), istatus) + if (istatus /= 0) return + !print *, 'mmr: ', trim(get_name_for_quantity(this_qty)), mmr_o1(1, k) + + call get_se_values_from_single_level(ens_handle, ens_size, QTY_MOLEC_OXYGEN_MIXING_RATIO, & + column, k, mmr_o2(:, k), istatus) + if (istatus /= 0) return + !print *, 'mmr: ', trim(get_name_for_quantity(this_qty)), mmr_o2(1, k) + + call get_se_values_from_single_level(ens_handle, ens_size, QTY_ATOMIC_H_MIXING_RATIO, & + column, k, mmr_h1(:, k), istatus) + if (istatus /= 0) return + !print *, 'mmr: ', trim(get_name_for_quantity(this_qty)), mmr_h1(1, k) + + mmr_n2(:,k) = 1.0_r8 - (mmr_o1(:,k) + mmr_o2(:,k) + mmr_h1(:,k)) + mbar(k,:) = 1.0_r8/( mmr_o1(:,k)/O_molar_mass & + + mmr_o2(:,k)/O2_molar_mass & + + mmr_h1(:,k)/H_molar_mass & + + mmr_n2(:,k)/N2_molar_mass) +enddo + +end subroutine compute_se_mean_mass + +!-------------------------------------------------------------------- + +subroutine state_vertical_to_pressure(ens_handle, ens_size, precise, location, location_indx) +type(ensemble_type), intent(in) :: ens_handle +integer, intent(in) :: ens_size +logical, intent(in) :: precise +type(location_type), intent(inout) :: location +integer(i8), intent(in) :: location_indx + +integer :: column, level, myqty, level_one, status1 +integer :: my_status(ens_size) +real(r8) :: pressure_array(ref_nlevels), surface_pressure(ens_size) + + +call get_model_variable_indices(location_indx, column, level, no_third_dimension, kind_index=myqty) + +if (is_surface_field(myqty)) then + + level_one = 1 + call get_se_values_from_single_level(ens_handle, ens_size, QTY_SURFACE_PRESSURE, & + column, level_one, surface_pressure, status1) + + if (status1 /= 0) then + return + endif + call set_vertical(location, surface_pressure(1), VERTISPRESSURE) +else + call cam_se_pressure_levels(ens_handle, ens_size, column, ref_nlevels, & + precise, pressure_array, my_status) + + call set_vertical(location, pressure_array(level), VERTISPRESSURE) +endif + +end subroutine state_vertical_to_pressure + +!-------------------------------------------------------------------- + +subroutine state_vertical_to_height(ens_handle, ens_size, precise, location, location_indx) +type(ensemble_type), intent(in) :: ens_handle +integer, intent(in) :: ens_size +logical, intent(in) :: precise +type(location_type), intent(inout) :: location +integer(i8), intent(in) :: location_indx + +integer :: column, level, my_status(ens_size) +real(r8) :: height_array(ref_nlevels, ens_size) + +! build a height column and a pressure column and find the levels +call get_model_variable_indices(location_indx, column, level, no_third_dimension) + +call cam_se_height_levels(ens_handle, ens_size, column, ref_nlevels, & + precise, height_array, my_status) + +!>@todo FIXME this can only be used if ensemble size is 1 +call set_vertical(location, height_array(level, 1), VERTISHEIGHT) + +end subroutine state_vertical_to_height + +!-------------------------------------------------------------------- + +subroutine state_vertical_to_scaleheight(ens_handle, ens_size, precise, location, location_indx) +type(ensemble_type), intent(in) :: ens_handle +integer, intent(in) :: ens_size +logical, intent(in) :: precise +type(location_type), intent(inout) :: location +integer(i8), intent(in) :: location_indx + +integer :: column, level, no_third_dimension, level_one, status1, my_status(ens_size) +real(r8) :: pressure_array(ref_nlevels) +real(r8) :: surface_pressure(1), scaleheight_val + +!> this is currently only called with an ensemble size of 1 for +!> vertical conversion. since it is working only on state variables +!> we don't expect it to ever fail. + +level_one = 1 +scaleheight_val = MISSING_R8 + +if (no_normalization_of_scale_heights) then + + + if (query_location(location) == VERTISSURFACE) then + + ! get the surface pressure from the ens_handle + call get_model_variable_indices(location_indx, column, level, no_third_dimension) + + call get_se_values_from_single_level(ens_handle, ens_size, QTY_SURFACE_PRESSURE, & + column, level, surface_pressure, status1) + if (status1 /= 0) goto 200 + + scaleheight_val = log(surface_pressure(1)) + + else + + ! build a pressure column and and find the levels + call get_model_variable_indices(location_indx, column, level, no_third_dimension) + + call cam_se_pressure_levels(ens_handle, ens_size, column, ref_nlevels, & + precise, pressure_array, my_status) + if (any(my_status /= 0)) goto 200 + + scaleheight_val = log(pressure_array(level)) + + endif + +else + + ! handle surface obs separately here. + if (query_location(location) == VERTISSURFACE) then + + scaleheight_val = 0.0_r8 ! log(1.0) + + else + + ! build a pressure column and and find the levels + call get_model_variable_indices(location_indx, column, level, no_third_dimension) + + call cam_se_pressure_levels(ens_handle, ens_size, column, ref_nlevels, & + precise, pressure_array, my_status) + if (any(my_status /= 0)) goto 200 + + ! get the surface pressure from the ens_handle + call get_se_values_from_single_level(ens_handle, ens_size, QTY_SURFACE_PRESSURE, & + column, level, surface_pressure, status1) + if (status1 /= 0) goto 200 + + scaleheight_val = scale_height(pressure_array(level), surface_pressure(1), no_normalization_of_scale_heights) + + endif + +endif + +200 continue ! done + +call set_vertical(location, scaleheight_val, VERTISSCALEHEIGHT) + +end subroutine state_vertical_to_scaleheight + +!-------------------------------------------------------------------- + +subroutine state_vertical_to_level(ens_size, location, location_indx) +integer, intent(in) :: ens_size +type(location_type), intent(inout) :: location +integer(i8), intent(in) :: location_indx + +integer :: column, level + +!>@todo FIXME qty is currently unused. if we need it, its here. +!>if we really don't need it, we can remove it. all the other +!>corresponding routines like this use it. + +call get_model_variable_indices(location_indx, column, level, no_third_dimension) + +call set_vertical(location, real(level, r8), VERTISLEVEL) + +end subroutine state_vertical_to_level + + +!----------------------------------------------------------------------- +!> Compute the pressure values at midpoint levels +!> +!> this version does all ensemble members at once. + +subroutine cam_se_pressure_levels(ens_handle, ens_size, column, nlevels, & + precise, pressure_array, my_status) +type(ensemble_type), intent(in) :: ens_handle +integer, intent(in) :: ens_size +integer, intent(in) :: column +integer, intent(in) :: nlevels +logical, intent(in) :: precise +real(r8), intent(out) :: pressure_array(nlevels, ens_size) +integer, intent(out) :: my_status(ens_size) + +integer :: level_one, status1 +real(r8) :: surface_pressure(ens_size) + +! this is for surface obs +level_one = 1 + +! get the surface pressure from the ens_handle +call get_se_values_from_single_level(ens_handle, ens_size, QTY_SURFACE_PRESSURE, column, level_one, & + surface_pressure, status1) + +if (status1 /= 0) then + my_status(:) = status1 + return +endif + +if(dry_mass_vertical_coordinate .and. precise) then + call build_dry_mass_pressure_columns(ens_handle, ens_size, ref_nlevels, column, surface_pressure, & + pressure_array, status1) + if(status1 /= 0) then + my_status = 12 + pressure_array = MISSING_R8 + return + endif +else + call build_cam_pressure_columns(ens_size, surface_pressure, ref_nlevels, pressure_array) +endif + +! No error returns available if we get here, so all good +my_status(:) = 0 + +end subroutine cam_se_pressure_levels + +!-------------------------------------------------------------------- + +subroutine obs_vertical_to_pressure(ens_handle, precise, location, my_status) + +type(ensemble_type), intent(in) :: ens_handle +logical, intent(in) :: precise +type(location_type), intent(inout) :: location +integer, intent(out) :: my_status + +integer :: varid, ens_size, status(1), qty +real(r8) :: pressure_array(ref_nlevels) + +character(len=*), parameter :: routine = 'obs_vertical_to_pressure' + +ens_size = 1 + +qty = QTY_PRESSURE +if (query_location(location) == VERTISSURFACE) then + qty = QTY_SURFACE_PRESSURE +endif + +call ok_to_interpolate(qty, varid, my_status) +if (my_status /= 0) return + +call interpolate_se_values(ens_handle, ens_size, location, & + qty, varid, precise, pressure_array(:), status(:)) + +if (status(1) /= 0) then + my_status = status(1) + return +endif + +call set_vertical(location, pressure_array(1), VERTISPRESSURE) + +my_status = 0 + +end subroutine obs_vertical_to_pressure + +!-------------------------------------------------------------------- + +subroutine obs_vertical_to_height(ens_handle, precise, location, my_status) +type(ensemble_type), intent(in) :: ens_handle +logical, intent(in) :: precise +type(location_type), intent(inout) :: location +integer, intent(out) :: my_status + +integer :: varid, ens_size, status(1) +real(r8) :: height_array(1) + +character(len=*), parameter :: routine = 'obs_vertical_to_height' + +!SENote Does this work for the FV? +! Doesn't actually appear to work right for the FV which just blasts through a failed search +! for the height field. This could be fixed. +ens_size = 1 + +call ok_to_interpolate(QTY_GEOMETRIC_HEIGHT, varid, my_status) +if (my_status /= 0) return + +call interpolate_se_values(ens_handle, ens_size, location, & + QTY_GEOMETRIC_HEIGHT, varid, precise, height_array(:), status(:)) +if (status(1) /= 0) then + my_status = status(1) + return +endif + +call set_vertical(location, height_array(1), VERTISHEIGHT) + +my_status = 0 + +end subroutine obs_vertical_to_height + +!-------------------------------------------------------------------- + +subroutine obs_vertical_to_level(ens_handle, precise, location, my_status) +type(ensemble_type), intent(in) :: ens_handle +logical, intent(in) :: precise +type(location_type), intent(inout) :: location +integer, intent(out) :: my_status + +integer :: varid, ens_size, status(1) +real(r8) :: level_array(1) + +ens_size = 1 +varid = -1 +!SENote; This does not work yet so can't do vertical localization in level +! of observations that are not on level. +!SENote: could be implemented but is there any demand? +call error_handler(E_ERR, 'obs_vertical_to_level', & + 'Localization in level for obs not on levels is not implemented', & + source, revision, revdate) + +!SENote: This has not been checked, just swapped the call to interpolate_values +call interpolate_se_values(ens_handle, ens_size, location, & + QTY_VERTLEVEL, varid, precise, level_array(:), status(:)) +if (status(1) /= 0) then + my_status = status(1) + return +endif + +call set_vertical(location, level_array(1), VERTISLEVEL) + +my_status = 0 + +end subroutine obs_vertical_to_level + +!-------------------------------------------------------------------- + +subroutine obs_vertical_to_scaleheight(ens_handle, precise, location, my_status) +type(ensemble_type), intent(in) :: ens_handle +logical, intent(in) :: precise +type(location_type), intent(inout) :: location +integer, intent(out) :: my_status + +integer :: varid1, varid2, ens_size, status(1), ptype +real(r8) :: pressure_array(1), surface_pressure_array(1) +real(r8) :: scaleheight_val + +character(len=*), parameter :: routine = 'obs_vertical_to_scaleheight' + +ens_size = 1 + +! there are 4 cases here. + +if (no_normalization_of_scale_heights) then + + ! take log of pressure, either surface pressure or regular pressure + + if (query_location(location) == VERTISSURFACE) then + ptype = QTY_SURFACE_PRESSURE + else + ptype = QTY_PRESSURE + endif + + call ok_to_interpolate(ptype, varid1, my_status) + if (my_status /= 0) return + + !>@todo FIXME IFF the obs location is already pressure, we can take it at + !> face value here and not interpolate it. however it won't fail if the + !> pressure here is less than the ensemble mean pressure at this point. + !> is that ok? + + if (ptype == QTY_PRESSURE .and. is_vertical(location, "PRESSURE")) then + pressure_array(:) = query_location(location, "VLOC") + my_status = 0 + else + call interpolate_se_values(ens_handle, ens_size, location, ptype, varid1, & + precise, pressure_array(:), status(:)) + if (status(1) /= 0) then + my_status = status(1) + return + endif + endif + + scaleheight_val = log(pressure_array(1)) + +else + + ! handle surface obs separately here. + if (query_location(location) == VERTISSURFACE) then + + scaleheight_val = 0.0_r8 ! -log(1.0) + + else + + call ok_to_interpolate(QTY_PRESSURE, varid1, my_status) + if (my_status /= 0) return + + !>@todo FIXME IFF the obs location is already pressure, we can take it at + !> face value here and not interpolate it. however, it can result in negative + !> scale height values if the pressure is larger than the surface pressure at + !> that location. that's what the original cam model_mod did. is that ok? + + if (ptype == QTY_PRESSURE .and. is_vertical(location, "PRESSURE")) then + pressure_array(:) = query_location(location, "VLOC") + my_status = 0 + else + call interpolate_se_values(ens_handle, ens_size, location, QTY_PRESSURE, varid1, & + precise, pressure_array(:), status(:)) + if (status(1) /= 0) then + my_status = status(1) + return + endif + endif + + call ok_to_interpolate(QTY_SURFACE_PRESSURE, varid2, my_status) + if (my_status /= 0) return + + call interpolate_se_values(ens_handle, ens_size, location, QTY_SURFACE_PRESSURE, varid2, & + precise, surface_pressure_array(:), status(:)) + if (status(1) /= 0) then + my_status = status(1) + return + endif + + scaleheight_val = scale_height(pressure_array(1),surface_pressure_array(1), no_normalization_of_scale_heights) + + endif + +endif + +call set_vertical(location, scaleheight_val, VERTISSCALEHEIGHT) + +my_status = 0 + +end subroutine obs_vertical_to_scaleheight + +!-------------------------------------------------------------------- + +subroutine convert_vert_one_obs(ens_handle, loc, otype, vert_type, status1) +type(ensemble_type), intent(in) :: ens_handle +type(location_type), intent(inout) :: loc +integer, intent(in) :: otype +integer, intent(in) :: vert_type +integer, intent(out) :: status1 + +type(location_type) :: base_loc(1) +integer :: base_qty(1), base_type(1), status(1) + +! SENote: Only reason this is needed is to do the conversion from a scalar to a 1-element array. Annoying. + +! these need to be arrays. kinda a pain. +base_loc(1) = loc +base_type(1) = otype +base_qty(1) = get_quantity_for_type_of_obs(otype) + +call convert_vertical_obs(ens_handle, 1, base_loc, base_qty, base_type, vert_type, status) + +status1 = status(1) + +if (status1 /= 0) return + +loc = base_loc(1) + +end subroutine convert_vert_one_obs + + +!----------------------------------------------------------------------------------------------------- +! Routines for computing horizontal grid box location with cubed sphere spectral element grids follows +!----------------------------------------------------------------------------------------------------- + + +subroutine create_cs_grid_arrays() + +! Subroutine to create arrays of relationships between cubed sphere nodes (corners) +! and cell centers, including bearings between nodes. +! These will be used to identify the cell containing an observation. +! The relationships read from HommeMapping.nc will be augmented. +! All will be stored in global storage, and written to a new file for +! subsequent use. + +! Local variables +integer :: sh_corn(4), n(4) ! Shifted corners to put closest at the origin. +integer :: col, nbr, c, cent ! Indices for loops. +integer :: num_n, min_ind(1) +integer :: nc_file_ID +real(r8) :: dist, angle +real(r8) :: bearings(3), x_planar(3), y_planar(3) + +! ncol = number of nodes/corners/grid points. Global storage. +! corners = the names of the corners associated with each cell center +! neighbors = the nodes around each node which partner to make the sides of the cells +! which may contain an observation. + +! Get array of corner nodes/columns which define the cells (identified by 'center'). +if (file_exist(homme_map_file)) then + nc_file_ID = nc_open_file_readonly(homme_map_file) + ncorners = nc_get_dimension_size(nc_file_ID, 'ncorners') + ncenters = nc_get_dimension_size(nc_file_ID, 'ncenters') + + if (ncenters /= (ncol -2) ) then + write(string1, *) trim(homme_map_file),' ncenters inconsistent with ncol-2 ', ncenters, ncol + call error_handler(E_ERR,'create_cs_grid_arrays',string1,source,revision,revdate) + endif + + ! Allocate array for the homme mapping file contents + allocate(corners(ncenters, ncorners)) + + ! Read it in + call nc_get_variable(nc_file_ID, 'element_corners', corners) + call nc_close_file(nc_file_ID) + + allocate(num_nghbrs (ncol), centers(max_neighbors,ncol), a(3,ncorners,ncenters), & + b(2,ncorners,ncenters), x_ax_bearings(ncorners,ncenters)) + + num_nghbrs = 0 + centers = MISSING_I + a = MISSING_R8 + b = MISSING_R8 + x_planar = MISSING_R8 + y_planar = MISSING_R8 + x_ax_bearings = MISSING_R8 +else + write(string1, *) 'CAM-SE grid file "',trim(homme_map_file),'" can not be found ' + call error_handler(E_ERR,'create_cs_grid_arrays',string1,source,revision,revdate) +endif + +! Invert the element_corners array to compile all of the neighbors of each node (corner). +! Loop over HommeMapping cell centers. +Quads: do cent = 1,ncenters + Corns: do c = 1,4 + ! Get the node numbers that define this cell + ! and shift (rotate) them to create a separate mapping for each corner/node. + ! Shift the section of corners 1 place to the 'left'/lower for the first corner, + ! 2 for the 2nd, etc. This will put the node closest to the ob in position 4 + ! (of the shifted corners). Then the (x,y) origin will the the closest node, + ! and the indexing of the a,b,x_ax_bearing arrays will be easy. + ! Shifting preserves the order of the corners as we go around the cell (clockwise). + sh_corn = cshift(corners(cent,:), c) + + ! Increment the number of neighbors (and centers ) this corner(node) has. + ! sh_corn(4) is used for all cases because the corner we're working on always + ! ends up in that position, when c is incremented, then the corners are shifted. + n(c) = num_nghbrs(sh_corn(4)) + 1 + + ! Update the number of neighbors of each corner of the cell, + num_nghbrs(sh_corn(4)) = n(c) + + ! Store the info that this center is associated with 4 node->neighbor pairs. + centers(n(c),sh_corn(4)) = cent + + ! Define the planar coordinates for this center/cell and this corner/node. + ! The 4th corner is the origin, and the cell side from the 4th to the 3rd is + ! the x-axis of this cell's coordinate system for this corner. + ! This is established in the definition of bearings(). + ! This choice makes mapping coefficients a(0) and b(0) = 0 (see below). + ! It also helps make the indexing of bearings easy to use and store. + + ! Check a few cells for corner consistency + if (print_details .and. sh_corn(4) < 10) then + write(string1,'(A,3F10.6)') 'lon1, lat1 = ', lon_rad(sh_corn(4)), lat_rad(sh_corn(4)) + call error_handler(E_MSG, 'create_cs_grid_arrays', string1, source, revision, revdate) + endif + + ! Descend through neighbors so that bearings(3) is already defined when needed at loop end. + do nbr = 3,1,-1 + ! Bearings from the current origin node of the cell to the other 3. + bearings(nbr) = bearing(lon_rad(sh_corn(4)), lat_rad(sh_corn(4)), & + lon_rad(sh_corn(nbr)), lat_rad(sh_corn(nbr)) ) + + dist = get_dist(cs_locs(sh_corn(4)), cs_locs(sh_corn(nbr)), 0, 0, .true.) + + if (sh_corn(4) < 10) then + write(string1,'(A,3F10.6)') 'create_cs_grid: lon2, lat2, bearing = ', & + lon_rad(sh_corn(nbr)), lat_rad(sh_corn(nbr)), bearings(nbr) + call error_handler(E_MSG, 'create_cs_grid_arrays', string1, source, revision, revdate) + endif + + ! This difference order looks wrong, but we need to change the sign of angles from the + ! clockwise direction used by bearings to the counterclockwise direction used by + ! trig functions. + angle = bearings(3) - bearings(nbr) + + ! Normalize to -PI < angle <= PI. + angle = mod(angle,PI) - PI*int(angle/PI) + + ! Set the planar location of this corner/node. + x_planar(nbr) = dist * cos(angle) + y_planar(nbr) = dist * sin(angle) + + enddo + + ! Store the baseline for use when interpolating to an ob location. + x_ax_bearings(c,cent) = bearings(3) + + ! Define another bearings array to allow coord_ind_cs to find the right + ! cell around the closest node by using a search through bearings, + ! rather than a call to unit_square_location. + ! Propagate sort_bearings to writing and reading of HommeMapping_cs_grid.nc file. + ! real(r8), allocatable, :: sort_bearings(max_neighbors,ncol) + ! sort_bearings(n(c),sh_corn(4)) = bearings(3) + ! But see ordering of bearings, commented out below. + + ! Define quantities used to map the planar coordinate system of each cell + ! to the unit square coordinate system. + + ! I'll use the mapping from planar space (x,y) to unit square space (l,m): + ! x = a0 + a1*l*m + a2*m + a3*l + ! y = b0 + b1*l*m + b2*m + b3*l + ! The 4 corners (x,y) can be mapped to the four corners (l,m) to yield 4 equations. + ! This can be written as vec_x = mat_A * vec_a^T. + ! Then AI is the inverse of the mapping from physical space to the unit square space, + ! and the coefficients of the mapping, aN and bN, can be calculated from: + ! a = matmul(AI,x_planar(0:3)) + ! b = matmul(AI,y_planar(0:3)) + ! But the mapping from (lon,lat) to (x,y) space put corner "4" of the cell at (x4,y4) = (0,0) + ! and corner "3" at (x3,y3) = (d3,0) + ! This ends up making a0 = b0 = b3 = 0, and the equations simplify to the point + ! that it doesn't make sense to encode this tranformation in a matrix. + ! Replace matrix and matmul with simpler direct equations: + a(3,c,cent) = x_planar(3) + a(2,c,cent) = x_planar(1) + a(1,c,cent) = x_planar(2) - x_planar(1) - x_planar(3) + b(2,c,cent) = y_planar(1) + b(1,c,cent) = y_planar(2) - y_planar(1) + + if (cent < 10) then + write(string1,'(A,1p4E12.4)') 'create_cs_grid_arrays: a = ',(a(nbr,c,cent),nbr=1,3) + write(string2,'(A,1p4E12.4)') 'create_cs_grid_arrays: b = ',(b(nbr,c,cent),nbr=1,2) + call error_handler(E_MSG, 'create_cs_grid_arrays', string1, source, revision, revdate,text2=string2) + endif + + if (a(3,c,cent)* a(2,c,cent) *a(1,c,cent) == 0.0_r8) then + write(string1,'(A,2I8,A,1p3E12.4)') 'a(:,',c,cent,') = ',(a(nbr,c,cent),nbr=1,3) + write(string2,'(A,(6X,2F10.6))') 'create_cs_grid: lon, lat for nghr=1-3 = ', & + (lon_rad(sh_corn(nbr)), lat_rad(sh_corn(nbr)), nbr=1,3) + write(string3,'(A,5I7,/31X,4I7)') 'c, 4 corners, shifted = ', & + c,(corners(cent,nbr),nbr=1,4),(sh_corn(nbr),nbr=1,4) + call error_handler(E_MSG, 'create_cs_grid_arrays', string1, source, revision, revdate,text2=string2,text3=string3) + endif + + if (b(2,c,cent) *b(1,c,cent) == 0.0_r8) then + write(string1,'(A,2I8,A,1p3E12.4)') 'b(:,',c,cent,') = ',(b(nbr,c,cent),nbr=1,2) + write(string2,'(A,(6X,2F10.6))') 'create_cs_grid: lon, lat for nghr=1-3 = ', & + (lon_rad(sh_corn(nbr)), lat_rad(sh_corn(nbr)), nbr=1,3) + write(string3,'(A,5I7,/31X,4I7)') 'c, 4 corners, shifted = ', & + c,(corners(cent,nbr),nbr=1,4),(sh_corn(nbr),nbr=1,4) + call error_handler(E_MSG, 'create_cs_grid_arrays', string1, source, revision, revdate,text2=string2,text3=string3) + endif + + enddo Corns +enddo Quads + +! Check that all nodes have at least 3 neighbors and no more than 6. +do col = 1,ncol + if (num_nghbrs(col) < 3 .or. num_nghbrs(col) > max_neighbors) then + write(string1,'(A,I6,A,6I8)') 'num_nghbrs(',col,') <3 or >6: ', num_nghbrs(col) + call error_handler(E_ERR,'create_cs_grid_arrays',string1,source,revision,revdate) + endif +enddo + +! There's code in earlier versions of model_mod to +! reorder the neighbors so that they are sequential around each node +! to make the search for the cell containing an ob faster. + +return + +end subroutine create_cs_grid_arrays + +!----------------------------------------------------------------------- + +subroutine nc_read_cs_grid_file() + +! Read the number of neighbors, corners, centers, a and b coefficients, and x_ax_bearings +! from a netCDF file once for this grid at the beginning of the assimilation. + +integer :: nc_file_ID, max_nghbrs, local_ncol + +! Open the file for reading +nc_file_ID = nc_open_file_readonly(trim(cs_grid_file), 'reading the cs_grid_file') + +! Get the number of centers and number of corners and check the number of columns +ncenters = nc_get_dimension_size(nc_file_ID, 'ncenters') +ncorners = nc_get_dimension_size(nc_file_ID, 'ncorners') +local_ncol = nc_get_dimension_size(nc_file_ID, 'ncol') +max_nghbrs = nc_get_dimension_size(nc_file_ID, 'max_neighbors') + +! Check value against the namelist/parameter value. +if (max_nghbrs /= max_neighbors) then + write(string1, *) trim(cs_grid_file),' max_nghbrs does not match max_neighbors', & + max_nghbrs,max_neighbors + call error_handler(E_ERR,'nc_read_cs_grid_file',string1,source,revision,revdate) +endif + +! Check value against the namelist/parameter value. +if (local_ncol /= ncol) then + write(string1, *) trim(cs_grid_file),' ncol in cs_grid_file does not match the one in caminput.nc', & + local_ncol, ncol + call error_handler(E_ERR,'nc_read_cs_grid_file',string1,source,revision,revdate) +endif + +! Allocate space for all the cs geometry variables +allocate (corners(ncenters, ncorners), num_nghbrs(ncol), centers(max_neighbors, ncol), & + x_ax_bearings(ncorners, ncenters), a(3, ncorners, ncenters), b(2, ncorners, ncenters)) + +! Read in the values for these fields +call nc_get_variable(nc_file_ID, 'corners', corners) +call nc_get_variable(nc_file_ID, 'num_nghbrs', num_nghbrs) +call nc_get_variable(nc_file_ID, 'centers', centers) +call nc_get_variable(nc_file_ID, 'x_ax_bearings', x_ax_bearings) +call nc_get_variable(nc_file_ID, 'a', a) +call nc_get_variable(nc_file_ID, 'b', b) +call nc_close_file(nc_file_ID, 'closing cs_grid_file') + +end subroutine nc_read_cs_grid_file + +!----------------------------------------------------------------------- + +subroutine nc_write_cs_grid_file(cs_grid_file, homme_map_file) + +! Write out the number of neighbors, the neighbors, corners, centers, and bearings +! to a netCDF file once for this grid at the beginning of the assimilation. + +character(len=*), intent(in) :: cs_grid_file +character(len=*), intent(in) :: homme_map_file + +integer :: nc_file_ID + +! Create the file +nc_file_ID = nc_create_file(trim(cs_grid_file), 'creating cs_grid_file') + +! Define the dimensions +call nc_define_dimension(nc_file_ID, 'ncenters', ncenters) +call nc_define_dimension(nc_file_ID, 'ncorners', ncorners) +call nc_define_dimension(nc_file_ID, 'max_neighbors', max_neighbors) +call nc_define_dimension(nc_file_ID, 'ncol', ncol) +call nc_define_dimension(nc_file_ID, 'ncoef_a', 3) +call nc_define_dimension(nc_file_ID, 'ncoef_b', 2) + +! Write Global Attributes +call nc_add_global_attribute(nc_file_ID, 'title', trim(cs_grid_file)) +call nc_add_global_attribute(nc_file_ID, 'model_mod_source', source) +call nc_add_global_attribute(nc_file_ID, 'model_mod_revision', revision) +call nc_add_global_attribute(nc_file_ID, 'model_mod_revdate', revdate) +call nc_add_global_attribute(nc_file_ID, 'elements_per_cube_edge', ne) +call nc_add_global_attribute(nc_file_ID, 'nodes_per_element_edge', np) +call nc_add_global_attribute(nc_file_ID, 'HommeMapping_file', homme_map_file) + +! Create variables and attributes. +call nc_define_integer_variable(nc_file_ID, 'num_nghbrs', 'ncol') +call nc_add_attribute_to_variable(nc_file_ID, 'num_nghbrs', 'long_name', 'number of neighbors of each node/column') +call nc_add_attribute_to_variable(nc_file_ID, 'num_nghbrs', 'units', 'nondimensional') +call nc_add_attribute_to_variable(nc_file_ID, 'num_nghbrs', 'valid_range', (/1, max_neighbors/)) + +call nc_define_integer_variable(nc_file_ID, 'centers', (/'max_neighbors', 'ncol '/)) +call nc_add_attribute_to_variable(nc_file_ID, 'centers', 'long_name', 'cells which use node/column as a corner') +call nc_add_attribute_to_variable(nc_file_ID, 'centers', 'units', 'nondimensional') +call nc_add_attribute_to_variable(nc_file_ID, 'centers', 'valid_range', (/1, ncenters/)) +call nc_add_attribute_to_variable(nc_file_ID, 'centers', 'missing_value', MISSING_I) + +call nc_define_integer_variable(nc_file_ID, 'corners', (/'ncenters', 'ncorners'/)) +call nc_add_attribute_to_variable(nc_file_ID, 'corners', 'long_name', 'corners/nodes of each cell') +call nc_add_attribute_to_variable(nc_file_ID, 'corners', 'units', 'nondimensional') +call nc_add_attribute_to_variable(nc_file_ID, 'corners', 'valid_range', (/1, ncol/)) +call nc_add_attribute_to_variable(nc_file_ID, 'corners', 'missing_value', MISSING_I) + +call nc_define_double_variable(nc_file_ID, 'a', (/'ncoef_a ', 'ncorners', 'ncenters'/)) +call nc_add_attribute_to_variable(nc_file_ID, 'a', 'long_name', & + 'Coefficients of mapping from planar x coord to unit square') +call nc_add_attribute_to_variable(nc_file_ID, 'a', 'units', 'nondimensional') +call nc_add_attribute_to_variable(nc_file_ID, 'a', 'missing_value', MISSING_R8) + +call nc_define_double_variable(nc_file_ID, 'b', (/'ncoef_b ', 'ncorners', 'ncenters'/)) +call nc_add_attribute_to_variable(nc_file_ID, 'b', 'long_name', & + 'Coefficients of mapping from planar y coord to unit square') +call nc_add_attribute_to_variable(nc_file_ID, 'b', 'units', 'nondimensional') +call nc_add_attribute_to_variable(nc_file_ID, 'b', 'missing_value', MISSING_R8) + +call nc_define_double_variable(nc_file_ID, 'x_ax_bearings', (/'ncorners', 'ncenters'/)) +call nc_add_attribute_to_variable(nc_file_ID, 'x_ax_bearings', 'long_name', & + 'bearing (clockwise from North) from origin node(corner 4) of each mapping to corner 3') +call nc_add_attribute_to_variable(nc_file_ID, 'x_ax_bearings', 'units', 'radians') +call nc_add_attribute_to_variable(nc_file_ID, 'x_ax_bearings', 'valid_range', (/-PI, PI/)) +call nc_add_attribute_to_variable(nc_file_ID, 'x_ax_bearings', 'missing_value', MISSING_R8) + +! Fill 'em up +call nc_end_define_mode(nc_file_ID) +call nc_put_variable(nc_file_ID, 'num_nghbrs', num_nghbrs) +call nc_put_variable(nc_file_ID, 'centers', centers) +call nc_put_variable(nc_file_ID, 'corners', corners) +call nc_put_variable(nc_file_ID, 'a', a) +call nc_put_variable(nc_file_ID, 'b', b) +call nc_put_variable(nc_file_ID, 'x_ax_bearings', x_ax_bearings) +call nc_close_file(nc_file_ID) + +end subroutine nc_write_cs_grid_file + +!----------------------------------------------------------------------- + +subroutine coord_ind_cs(obs_loc, obs_kind, cell_corners, l_weight, m_weight) + +! Find the corners of the cell which contains the location. + +! Variables needed by loc_get_close_obs: +type(location_type), intent(inout) :: obs_loc +integer, intent(in) :: obs_kind +integer, intent(out) :: cell_corners(4) +real(r8), intent(out) :: l_weight +real(r8), intent(out) :: m_weight + +! Output from loc_get_close_obs +integer :: num_close + +! SENote: Need to reduce the memory usage for these for standard configurations. Classic notes follow: +! It would be nice if these could be smaller, but I don't know what number would work. +! It has to be large enough to accommodate all of the grid points that might lie +! within 2xcutoff; resolution and location dependent. +! The size must be specified here; (:) yields an error, and 'allocatable' doesn't help. +integer, allocatable :: close_ind(:) +real(r8), allocatable :: dist(:) + +! dist_# in radians (Can't be initialized here or they will get the 'save' property, +! and will not be reset during subsequent entries to this subroutine.) +real(r8) :: dist_1, dist_2 +real(r8) :: lon_lat_lev(3) +integer :: k, k1, k2, closest, closest2, origin +logical :: found_cell + +lon_lat_lev = get_location(obs_loc) + +! See whether this obs_ is a state variable. +! This could be done by 2 calls to minloc(dist), with the 2nd call using a mask +! to prevent finding the closest, which was found in the first call. +! But would those 2 intrinsic searches through dist be faster than my 1 explicit search? + +! Allocate space for the potentially close nodes. +allocate(close_ind(ncol), dist(ncol)) + +! Look for the 2 closest nodes, using slower way of getting all of the close obs +! and searching for the 2 closest. +! -------------- +! FIXME: Nancy has a location_xyz:find_closest_???? which will return the N closest points, +! which may be significantly faster than threed_sphere/location_mod.f90:get_close_obs. +! -------------- +! FIXME; can the closest node not be a corner of the containing cell in grids generated by SQuadGen? +! -------------- +! For a refined grid (from 1 degree to 1/8 degree) loc_get_close_obs is going to return lists +! that are 64x larger in the refined region than in the coarse region + +! obs_'kind' is passed to location.f90:get_close_obs. +! There it is passed to only get_dist, which only uses it if special_vert_norm is used, +! and gc%special_maxdist. +! Model_mod is not using either of those. +!SENote IMPORTANT: This only works with approximate_distance = .false. Somehow this must be overridden from +! Namelist or documented. Note that there is an error trap for failure that recommends changing to +! approximate_distance false below. +call get_close(cs_gc, obs_loc, 1, cs_locs, cs_kinds, & + num_close, close_ind, dist) + +dist_1 = 10.0_r8 +dist_2 = 10.0_r8 +closest = MISSING_I +k1 = MISSING_I + +! Keep track of k1, k2, and distances in this search. +! Assign closest and closest2 afterwards. +if (num_close <= 0) then + write(string1,*) "Can't find enclosing quadrilatersl. Unusable num_close, obs_kind : ",num_close, obs_kind + call write_location(0, obs_loc, charstring=string2) + write(string3,*) 'Setting namelist approximate_distance = .false. might help: dist(1) = ',dist(1) + call error_handler(E_ERR, 'coord_ind_cs', string1,source,revision,revdate,text2=string2, text3=string3) +endif + +do k = 1,num_close + if (dist(k) < dist_2) then + ! Replace 2nd with new one. + k2 = k + dist_2 = dist(k) + if (dist_2 <= dist_1) then + ! Switch 1st and new 2nd. '<=' To make sure k1 is filled, even for the first k. + k2 = k1 + k1 = k + dist_2 = dist_1 + dist_1 = dist(k) + endif + endif +enddo +closest = close_ind(k1) + +if (k2 == MISSING_I) then + write(string1,'(A)') 'Did not find a second closest node to ob:' + write(string2,'(A,3F10.2,3I6,1p2E12.4)') & + 'lon_lat_lev, obs_kind, num_close, closest, dist_1, dist_2 = ', & + lon_lat_lev, obs_kind, num_close, closest, dist_1, dist_2 + call write_location(0, cs_locs(closest), charstring=string3) + string3 = 'Setting namelist approximate_distance = .false. might help: closest node location = '//string3 + call error_handler(E_ERR, 'coord_ind_cs', string1,source,revision,revdate,text2=string2,text3=string3) +else + closest2 = close_ind(k2) +endif + +! Find the cell which contains the ob. +! First search the cells which have 'closest' as 1 corner. +! If that fails, search the cells around closest2. +! The search consists of passing the ob location to unit_square_location +! and letting it determine whether the ob location maps into the unit square. + +! Initial value of success flag. +found_cell = .false. + +! FIXME; debug in verify_namelist +! write(string1,*) 'STARTING Cloop num_nghbrs = ',num_nghbrs(closest) +! call error_handler(E_MSG,'coord_ind_cs',string1,source,revision,revdate) + +Cloop: do k=1,num_nghbrs(closest) + ! centers(k,closest) refers to the cell center name associated with neighboring node k + ! of the closest node. It is used to retrieve mapping coefficients for the cell being tested. + + call unit_square_location(centers(k,closest), closest, obs_loc, & + lon_lat_lev(1), lon_lat_lev(2), found_cell, origin, l_weight, m_weight) + if (found_cell) exit Cloop +enddo Cloop + +! Try the 2nd closest point, if the first failed. +if ((.not.found_cell) .and. closest2 /= MISSING_I) then + + Second_closest: do k=1,num_nghbrs(closest2) + call unit_square_location(centers(k,closest2), closest2, obs_loc, & + lon_lat_lev(1), lon_lat_lev(2), found_cell, origin, l_weight,m_weight) + if (found_cell) then + ! Put '2nd closest' information into 'closest'. + dist_1 = dist_2 + closest = closest2 + + write(string1,'(A,2F10.7,2I8,1p2E12.4)') & + 'Using 2nd closest node to the ob: l, m, closest2, origin2 = ', & + l_weight, m_weight, closest, origin + call error_handler(E_MSG, 'coord_ind_cs', string1,source,revision,revdate) + + exit Second_closest + endif + enddo Second_closest +endif + +if (found_cell) then + ! Need to shift corners according to which was chosen as the origin corner + ! in num_nghbrs loop, above. The weighted interp calculation assumes, as in + ! the create_cs_grid_arrays mapping scheme, that the origin node is corner 4. + cell_corners(1:4) = cshift(corners(centers(k,closest),1:4), origin) + +else + ! Both closest nodes failed; abort + write(string1, '(A,2I8,A,2F10.4)') & + 'Neither of the 2 closest nodes ', closest,closest2, & + ' is a corner of the cell containing ob at ', lon_lat_lev(1),lon_lat_lev(2) + string2 = 'Setting namelist approximate_distance = .false. might help.' + call error_handler(E_ERR, 'coord_ind_cs', string1,source,revision,revdate, text2 = string2) +endif + +deallocate(close_ind, dist) + +end subroutine coord_ind_cs + +!----------------------------------------------------------------------------------------------------- + +subroutine unit_square_location(cell, closest, location, lon_o,lat_o, found_cell, origin, l,m) + +! Subroutine based on http://www.particleincell.com/2012/quad-interpolation/. +! The idea is to derive a mapping from any convex quadrilateral(x,y) onto a unit square (l,m). +! Also map the location of the ob onto that square. +! This is a bilinear interpolation; +! x = a0 + a1*l*m + a2*m + a3*l +! y = b0 + b1*l*m + b2*m + b3*l +! so does not take into account the curvature of the quadrilateral on the sphere. +! +! That has been handled by the intermediate mapping from (lon,lat) to a flat planar +! coordinate system (x,y). The locations of the corners/nodes are converted to +! the distances and directions from one node to the other three. See create_cs_grid_arrays. +! Distances and directions relative to the origin node are preserved, but distances and +! directions between 2 non-origin points are slightly distorted. +! Even these small errors are avoided by defining a planar coordinates system for each corner +! of each cell. +! Then the ob is never near the 'far edges', where distortion could be a problem. +! +! A higher order method exists (Nagata 2005: Simple Local Interpolation of Surfaces +! Using Normal Vectors) to map curved quadrilaterals onto the unit square, +! but the inverse map cannot be done analytically(?), so is not developed here. + +integer, intent(in) :: cell +integer, intent(in) :: closest +type(location_type), intent(in) :: location +real(r8), intent(in) :: lon_o +real(r8), intent(in) :: lat_o +logical, intent(inout) :: found_cell +integer, intent(out) :: origin +real(r8), intent(out) :: l +real(r8), intent(out) :: m + +! Observation location in the planar space. +real(r8) :: x_o, y_o + +real(r8) :: angle, d, bearing_o ! Locations in polar coordinate space (bearing,distance). +real(r8) :: aa, bb, cc ! Coefficients of quadratic equation for m. +real(r8) :: det, m1, m2 ! Determinant and roots. +logical :: neg_root ! helpful logical variable to store usefulness of the -root. +real(r8) :: m_neg, l_neg ! Potential alternate solutions to the m quadratic equation +integer :: oc(1) + +m1 = MISSING_R8 ! first root returned by solve_quadratic +m2 = MISSING_R8 ! second root returned by solve_quadratic +l = MISSING_R8 ! unit square abscissa ('x' coord) +m = MISSING_R8 ! unit square ordinate ('y' coord) +l_neg = MISSING_R8 ! same but for the negative root of the m quadratic equation. +m_neg = MISSING_R8 ! same +neg_root = .false. + +! Map the location of the ob into the planar space + +! Figure out which corner (1,2,3 or 4) of cell is the closest to the ob, +! by comparing the names of the corners to the name of the node/corner closest +! to the ob, which was passed in. +! Used to get the correct x_ax_bearing and a and b coeffs (from the cs_grid_file). + +oc = minloc(corners(cell,:), mask = (corners(cell,:) == closest)) +origin = oc(1) + +! The bearing of the observation relative to the origin/closest corner. +bearing_o = bearing(lon_rad(closest),lat_rad(closest),lon_o*DEG2RAD,lat_o*DEG2RAD ) + +! Calculate the difference of the ob bearing from x_axis of this cell. +! The order is opposite of what might be expected because bearings are measured clockwise, +! while angles are measured counterclockwise. +angle = x_ax_bearings(origin,cell) - bearing_o + +! Normalize angle to -pi 0.0_r8) then + ! Only m values (roots) between 0 and 1 mean that the ob is in this cell. + if (m1 >=0 .and. m1 <= 1) then + m = m1 + elseif (m2 >=0 .and. m2 <= 1) then + m = m2 + else + ! Neither root is a map. Leave m as MISSING_R8 + endif + elseif (m1 /= MISSING_R8 .and. m2 == MISSING_R8 ) then + ! Cell is square; solved the linear equation m*bb + cc = 0 + m = m1 + else + ! aa < 0; Either both or neither roots yield m>0. + ! Start with the +root. +! m = (-bb + sqrt_det)/(2.0_r8*aa) + m = m1 + + if (bb > 0.0_r8) then + ! Both roots yield m > 0. + if (m > 1.0_r8) then + ! The +root didn't yield a usable m. Try the -root. + ! m = (-bb - sqrt_det)/(2.0_r8*aa) + m = m2 + else + ! It could be that both roots yield a usable m. Keep track of both + ! (for testing/debugging only). + m_neg = m2 + endif + + elseif (bb < 0.0_r8) then + ! aa < 0 and bb < 0 yields no roots with m>0. + write(string1,'(A,I6,A)') 'aa < 0 and bb < 0: It appears that cell ',cell, & + ' is a highly distorted quadrilateral' + write(string2,'(A)') & + 'and no mapping is possible. bb = a(3)*b(2) - a(1)*y_o + b(1)*x_o: ' + write(string3,'(1p,(3X,2E12.4))') & + a(3,origin,cell),b(2,origin,cell), & + a(1,origin,cell),y_o, & + b(1,origin,cell),x_o + call error_handler(E_ERR, 'unit_square_location', string1,source,revision,revdate, & + text2=string2, text3=string3) + + elseif (bb == 0.0_r8) then + ! aa < 0 and bb = 0 should be excluded by the non-negativeness test on det, above. + write(string1,'(A,1p,2(1x,E12.4))') & + 'aa < 0 and bb = 0 should have been excluded ',aa,bb + call error_handler(E_ERR, 'unit_square_location', string1,source,revision,revdate) + + endif + + endif + +endif + +! If m (and maybe m_neg) is out of the possible range, return to calling program +! with found_cell still false. +if (m < 0.0_r8 .or. m > 1.0_r8) then + if (.not.found_cell) then + if (m_neg < 0.0_r8 .or. m_neg > 1.0_r8) then + ! This includes m_neg == MISSING_R8, due to only m being assigned above. + return + endif + ! ? Can these 2 sections ever be entered? + else + ! Exit with error if m is outside valid range. + write(string1, *) 'location of ob in unit square is out of bounds m = [0,1] ',m, & + 'but status is "found"' + call error_handler(E_ERR, 'unit_square_location', string1, source, revision, revdate) + endif +endif + +! Use m to calculate the other unit square coordinate value, 'l'. +det = a(3,origin,cell) + a(1,origin,cell) * m +if (det /= 0.0_r8) then + l = (x_o - a(2,origin,cell)*m) / det +else + write(string1,'(A,I6,1X,1p4E12.4)') 'l denominator = 0: cell, angle, d, x_o, y_o',cell, angle, d, x_o, y_o + write(string2,'(A,1X,1p4E12.4)') ' a(3) + a(1)*m = 0 : ', a(3,origin,cell), a(1,origin,cell),m + call error_handler(E_ERR, 'unit_square_location', string1,source,revision,revdate, text2=string2) +endif + +! Repeat for the -root, if it is a possibility. +if (m_neg /= MISSING_R8) then + det = (a(3,origin,cell) + a(1,origin,cell)*m_neg) + if (det /= 0.0_r8) then + l_neg = (x_o -a(2,origin,cell)*m_neg) / det + else + write(string1,'(A,I6,1X,1p4E12.4)') 'l_neg denominator = 0: cell, angle, d, x_o, y_o', & + cell, angle, d, x_o, y_o + write(string2,'(A,1X,1p4E12.4)') ' a(3) + a(1)*m = 0 : ', a(3,origin,cell), a(1,origin,cell),m + call error_handler(E_ERR, 'unit_square_location', string1,source,revision,revdate, text2=string2) + endif + + ! Informational output, if the observation is exactly on the m-axis + if (l_neg == 0.0_r8 .and. my_task_id() == 0) then + write(string1,'(A,I6,1X,1p4E12.4)') 'l_neg cell, x_o - a(2)*m = ',cell, x_o ,a(2,origin,cell),m + call error_handler(E_MSG, 'unit_square_location', string1,source,revision,revdate) + endif + +endif + +! Informational output, if the observation is exactly on the m-axis +!SENote: Why does this message get printed a billion times in CLASSIC? +if (l == 0.0_r8 .and. my_task_id() == 0) then + write(string1,'(A,I6,1X,1p4E12.4)') 'Ob is on x-axis: l-cell, x_o - a(2)*m = ',cell, x_o ,a(2,origin,cell),m + call error_handler(E_MSG, 'unit_square_location', string1,source,revision,revdate) +endif + +! If l (and maybe l_neg) is out of the possible range, return to calling program +! with found_cell still false. +if (l < 0.0_r8 .or. l > 1.0_r8) then + if (.not.found_cell) then + if (l_neg < 0.0_r8 .or. l_neg > 1.0_r8) then + ! This includes m_neg == MISSING_R8, due to only m being assigned above + ! Return with found_cell still = failure (0) to test the next cell. + return + endif + ! ? Can these 2 sections ever be entered? + ! Exit with error if l is outside valid range. + else + ! Exit with error if l is outside valid range. + write(string1, *) 'location of ob in unit square is out of bounds l = [0,1] ',l, & + 'but status is "found"' + call error_handler(E_ERR, 'unit_square_location', string1, source, revision, revdate) + endif +endif + +! If we get this far, then this cell contains the ob. + +! But which root(s) of the m quadratic equation led to the mapping? +! Put the right values in l and m. +neg_root = m_neg >= 0.0_r8 .and. m_neg <= 1.0_r8 .and. & + l_neg >= 0.0_r8 .and. l_neg <= 1.0_r8 +if (m >= 0.0_r8 .and. m <= 1.0_r8 .and. & + l >= 0.0_r8 .and. l <= 1.0_r8 ) then + ! Both roots yield a good mapping. + if (neg_root) then + write(string1, *) 'BOTH roots of the m quadratic yield usable mappings. The +root is being used.' + call error_handler(E_MSG, 'unit_square_location', string1, source, revision, revdate) + endif + +elseif (neg_root) then + ! The -root yields a good mapping. Pass along the -root m and l. + m = m_neg + l = l_neg + write(string1, *) 'The negative root of the m quadratic yielded the only usable mapping.' + call error_handler(E_MSG, 'unit_square_location', string1, source, revision, revdate) +endif + +! Return with found_cell = true; success. +found_cell = .true. + +end subroutine unit_square_location + +!----------------------------------------------------------------------- + +real function bearing(lon1,lat1,lon2,lat2) + +! Calculate the direction along the great circle from point 1 on a sphere +! to point 2, relative to north. +! All inputs should have units of radians. +! Output is radians. +! From http://www.movable-type.co.uk/scripts/latlong.html + +real(r8), intent(in) :: lon1,lat1, lon2,lat2 + +real(r8) :: lon1c,lon2c, cos_lat2, del_lon + +real(r8), parameter :: half_PI = PI*0.5_r8 + +! Make sure the poles are handled consistently: +! If the pole point is the origin point, and the longitude of the pole point is +! defined as 0.0, then the bearing to a nearby point will = the longitude of the point. +! This is consistent/continuous with the bearing from points extremely near +! the pole. +if (half_PI - abs(lat1) < epsilon(lat1)) then + lon1c = 0.0_r8 +else + lon1c = lon1 +endif +if (half_PI - abs(lat2) < epsilon(lat2)) then + lon2c = 0.0_r8 +else + lon2c = lon2 +endif + +cos_lat2 = cos(lat2) +del_lon = lon2c - lon1c + +! Normalize del_lon to -pi<=angle<=pi. +del_lon = mod(del_lon,PI) - PI*int(del_lon/PI) +bearing = atan2(cos_lat2*sin(del_lon), & + cos(lat1)*sin(lat2) - sin(lat1)*cos_lat2*cos(del_lon) ) + +end function bearing + +!----------------------------------------------------------------------- + +subroutine solve_quadratic(a, b, c, r1, r2) +!SENote: This is similar to the version in adaptive_inflation. Should put in utilities. + +real(r8), intent(in) :: a +real(r8), intent(in) :: b +real(r8), intent(in) :: c +real(r8), intent(out) :: r1 +real(r8), intent(out) :: r2 + +real(r8) :: scaling, as, bs, cs, disc + +r1 = MISSING_R8 +r2 = MISSING_R8 + +! Scale the coefficients to get better round-off tolerance +scaling = max(abs(a), abs(b), abs(c)) +as = a / scaling +bs = b / scaling +cs = c / scaling + +if (abs(as) < epsilon(as)) then + ! Solve the linear equation bs*r + cs = 0 + r1 = -cs / bs +else + ! Get discriminant of scaled equation + disc = bs * bs - 4.0_r8 * as * cs + if (disc >= 0.0_r8) then + + ! Calculate the largest root (+ or - determined by sign of bs) + ! Handling of bs = 0 different from pre-review code + ! if(bs > 0.0_r8) then + if(bs >= 0.0_r8) then + r1 = (-bs - sqrt(disc)) / (2.0_r8 * as) + else + r1 = (-bs + sqrt(disc)) / (2.0_r8 * as) + endif + + ! Compute the second root given the larger (not most positive) one + if (r1 == 0.0_r8) then + ! The b AND c must have been 0: solved the equation a*r1^2 = 0 above + ! and there's no 2nd root. + r2 = 0.0_r8 + else + ! 'as' and 'r1' have been tested for 0. + r2 = cs / (as * r1) + endif + endif +endif + +end subroutine solve_quadratic + +!----------------------------------------------------------------------- + + +!----------------------------------------------------------------------------------------------------- +! End of routines for computing horizontal grid box location with cubed sphere spectral element grids +!----------------------------------------------------------------------------------------------------- + + +!=================================================================== +! End of model_mod +!=================================================================== + +end module model_mod diff --git a/models/cam-se/model_mod.nml b/models/cam-se/model_mod.nml new file mode 100644 index 0000000000..796062d403 --- /dev/null +++ b/models/cam-se/model_mod.nml @@ -0,0 +1,46 @@ + +# options for vertical localization: 'PRESSURE', 'HEIGHT', 'SCALEHEIGHT', 'LEVEL' +# options for vertical interpolation (use_log_vertical_scale) = .false., .true. +# +# model top related items (no_obs_assim_above_level, model_damping_ends_at_level) +# are now specified in model level numbers. the top level is 1 and increases +# going down towards the surface. +# +# examples of state_variables, 5 columns per field: +# +# netcdf varname, dart quantity, min allowed value, max allowed value, (no)update this var +# +# state_variables = 'T', 'QTY_TEMPERATURE', 'NA', 'NA', 'UPDATE' +# 'U','QTY_U_WIND_COMPONENT', 'NA', 'NA', 'UPDATE' +# 'V','QTY_V_WIND_COMPONENT', 'NA', 'NA', 'UPDATE' +# 'Q', 'QTY_SPECIFIC_HUMIDITY', 'NA', 'NA', 'UPDATE' +# 'CLDLIQ','QTY_CLOUD_LIQUID_WATER', 'NA', 'NA', 'UPDATE' +# 'CLDICE','QTY_CLOUD_ICE', 'NA', 'NA', 'UPDATE' +# 'PS','QTY_SURFACE_PRESURE', 'NA', 'NA', 'UPDATE' +# 'O', 'QTY_ATOMIC_OXYGEN_MIXING_RATIO', 'NA', 'NA', 'UPDATE' +# 'O2','QTY_MOLEC_OXYGEN_MIXING_RATIO', 'NA', 'NA', 'UPDATE' +# 'H', 'QTY_ATOMIC_H_MIXING_RATIO', 'NA', 'NA', 'UPDATE' +# 'Op','QTY_ION_O_MIXING_RATIO', 'NA', 'NA', 'UPDATE' + +&model_nml + dry_mass_vertical_coordinate = .true. + precise_dry_mass_get_close = .false. + cam_template_filename = 'caminput.nc' + cam_phis_filename = 'cam_phis.nc' + homme_map_file = 'SEMapping.nc' + cs_grid_file = 'SEMapping_cs_grid.nc' + vertical_localization_coord = 'PRESSURE' + use_log_vertical_scale = .false. + assimilation_period_days = 0 + assimilation_period_seconds = 21600 + no_obs_assim_above_level = -1 + model_damping_ends_at_level = -1 + debug_level = 0 + suppress_grid_info_in_output = .false. + custom_routine_to_generate_ensemble = .true. + fields_to_perturb = "" + perturbation_amplitude = 0.0_r8 + using_chemistry = .false. + no_normalization_of_scale_heights = .true. +/ + diff --git a/models/cam-se/work/cam_out_files b/models/cam-se/work/cam_out_files new file mode 100644 index 0000000000..03a974b3e1 --- /dev/null +++ b/models/cam-se/work/cam_out_files @@ -0,0 +1,6 @@ +cam_out_1.nc +cam_out_2.nc +cam_out_3.nc +cam_out_4.nc +cam_out_5.nc +cam_out_6.nc diff --git a/models/cam-se/work/cam_phis.nc b/models/cam-se/work/cam_phis.nc new file mode 100644 index 0000000000..07ba1e4c3e Binary files /dev/null and b/models/cam-se/work/cam_phis.nc differ diff --git a/models/cam-se/work/cross_correlations.txt b/models/cam-se/work/cross_correlations.txt new file mode 100644 index 0000000000..4acc95f8c9 --- /dev/null +++ b/models/cam-se/work/cross_correlations.txt @@ -0,0 +1,63 @@ + +# +# example of how to control the impact of +# chemistry observations on model state +# and vice versa. +# + +GROUP chemistry + ALLQTYS EXCEPT + QTY_O3 + QTY_CO + QTY_NO + QTY_NO2 + QTY_CO01 + QTY_CO02 + QTY_CO03 + QTY_SFCO + QTY_SFCO01 + QTY_SFCO02 + QTY_SFCO03 + QTY_AOD + QTY_CB1 + QTY_CB2 + QTY_OC1 + QTY_OC2 + QTY_CB102 + QTY_CB202 + QTY_OC102 + QTY_OC202 + QTY_SFCB1 + QTY_SFCB2 + QTY_SFOC1 + QTY_SFOC2 + QTY_SFCB102 + QTY_SFCB202 + QTY_SFOC102 + QTY_SFOC202 + QTY_CO2 + QTY_NH3 + QTY_CH4 +END GROUP + +GROUP met + ALLQTYS EXCEPT chemistry +END GROUP + +# actual table to define factors for impacts. +# +# the first column can contain either types or kinds because +# it applies to the current obs being assimilated. +# +# the second column has to be kinds because it applies +# to the state (also unassimilated obs, but states only +# have kinds so that's the most restrictive). +# +# either column can have a group name, but any group used +# in column 2 can contain only kinds. + +IMPACT + met chemistry 0.0 + chemistry met 0.0 +END IMPACT + diff --git a/models/cam-se/work/input.nml b/models/cam-se/work/input.nml new file mode 100644 index 0000000000..ad0bb94580 --- /dev/null +++ b/models/cam-se/work/input.nml @@ -0,0 +1,634 @@ +! This namelist is set up for a single, CAM-SE, assimilation cycle +! using the default values as found in model_mod.f90 and +! DART/cam-fv/shell_scripts/cesm2_1/setup_{hybrid,advanced} +! starting from a single model state, which must be perturbed into an ensemble. +! Comments below give suggestions for setting it up for other assimilations: +! > continuing an assimilation (no perturbations) and/or starting from an ensemble. +! > Setting up a WACCM(-X) assimilation +! > Setting up for perfect_model_obs +! + +! ens_size, num_output_* will be (re)set by the setup script +! To use a pre-existing ensemble, make the following changes +! This applies to the second cycle after starting from a single ensemble member. +! It's not necessary to change any other variables controlling the perturbation +! because this will cause them to be ignored. +! perturb_from_single_instance = .false. +! Other variables of interest +! stages_to_write Controls diagnostic and restart output. Valid values are +! 'input', 'forecast','preassim', 'postassim', 'analysis', and 'output'. +! If only prior inflation is used, then 'postassim' and 'analysis' +! are redundant with 'output'. Just use 'output'. +! If only posterior inflation is used, 'forecast' and 'preassim' +! are redundant with 'input'. +! If you want input_mean and input_sd, you'll +! need to set output_mean and output_sd = .true. +! (and include 'input' in stages_to_write). +! inf_initial_from_restart These should be true because assimilate.csh will create +! inf_sd_from_restart inflation restart files from the values in inf*_initial +! if needed. + +&filter_nml + input_state_files = '' + input_state_file_list = 'cam_init_files' + single_file_in = .false. + perturb_from_single_instance = .true. + init_time_days = -1 + init_time_seconds = -1 + + stages_to_write = 'forecast','output' + + output_state_files = '' + output_state_file_list = 'cam_out_files' + output_mean = .true. + output_sd = .true. + output_members = .true. + num_output_state_members = 3 + single_file_out = .false. + write_all_stages_at_end = .false. + output_interval = 1 + + ens_size = 3 + num_groups = 1 + distributed_state = .true. + + inf_flavor = 5, 0 + inf_initial_from_restart = .true., .false. + inf_initial = 1.0, 1.0 + inf_lower_bound = 0.0, 0.0 + inf_upper_bound = 100.0, 100.0 + inf_sd_initial_from_restart = .true., .false. + inf_sd_initial = 0.6, 0.6 + inf_sd_lower_bound = 0.6, 0.6 + inf_sd_max_change = 1.05, 1.05 + inf_damping = 0.9, 0.9 + inf_deterministic = .true., .true. + + obs_sequence_in_name = 'obs_seq.out' + obs_sequence_out_name = 'obs_seq.final' + num_output_obs_members = 3 + compute_posterior = .false. + + trace_execution = .true. + output_timestamps = .true. + output_forward_op_errors = .false. + silence = .false. + / +! Moha's enhanced (gamma distribution) adaptive: +! inf_flavor = 5, 0 +! inf_lower_bound = 0.0, 0.0 +! flavor 2 +! inf_flavor = 2, 0 +! inf_lower_bound = 1.0, 1.0 + + +! Not used in CAM assims + first_obs_days = -1 + first_obs_seconds = -1 + last_obs_days = -1 + last_obs_seconds = -1 + obs_window_days = -1 + obs_window_seconds = -1 + adv_ens_command = 'no_CESM_advance_script' + tasks_per_model_advance = -1 Used only for models run inside filter. + write_obs_every_cycle = .false. intended for debugging when cycling inside filter. + +&perfect_model_obs_nml + read_input_state_from_file = .true. + input_state_files = "caminput.nc" + init_time_days = -1 + init_time_seconds = -1 + + write_output_state_to_file = .true. + output_state_files = "perfect_restart.nc" + + obs_seq_in_file_name = "obs_seq.in" + obs_seq_out_file_name = "obs_seq.out" + first_obs_days = -1 + first_obs_seconds = -1 + last_obs_days = -1 + last_obs_seconds = -1 + + trace_execution = .true. + output_timestamps = .true. + print_every_nth_obs = 0 + output_forward_op_errors = .false. + / + +#======================================================================== +# Start of CAM-SE dependencies and general discussion. +#======================================================================== +! +! Creation of initial ensemble from a single model state. +! fields_to_perturb lists the DART QTY_s of the state variables to be perturbed to make the ensemble. +! perturbation_amplitude > 0 allows each point of the fields_to_perturb fields of each ens member +! to be randomly perturbed with a standard deviation of perturbation_amplitude. +! Each field can be given a different perturbation_amplitude. +! Used by filter's call to pert_model_copies. +! +! state_variables (5 columns for each variable): +! netcdf varname, dart quantity, min allowed value, max allowed value, (no)update this var +! +! vert_normalization_YYY +! The vert_normalization_scale_height default value was chosen based on +! Pedatella's settling on 1.5 (scale heights/radian), based on tuning experiments. +! This is supported by tuning experiments with CAM5. +! +! use_log_vertical_scale(vertical interpolation only): +! .false. or .true. +! +! no_obs_assim_above_level +! Prevents assimilation of observations whose vertical location is above +! this model level. Note that, if this value is set to a large value, +! it may be within CAM's hybrid coordinate layers instead of in the pure pressure layers. +! This will result in the the observation cutoff height being at different pressure levels +! over mountains versus lower areas. + +! model_damping_ends_at_level +! This controls how much innovations are reduced near the model top, to mitigate the effects +! of the extra diffusion sometimes applied there in CAM and WACCM (see fv_div24del2flag). +! The default value (-1) turns off the damping and relies on the choices of the following +! variables to prevent assimilation from happening in CAM's diffusive top layers: +! no_obs_assim_above_level, +! use_log_vertical_scale, +! vert_normalization_YYY, +! cutoff. +! When it is turned on (> 0), it is the lowest level which will be damped. +! Damping increases with height (smaller level numbers). +! The values given below are the minimums recommended for various models. +! You can start with the minimum and increase it if there seems to be excessive +! noise in the upper layers. +! +! CAM-SE Section +! Model top 220 Pa +! Number of CAM model top levels with extra diffusion, controlled by div24del2: +! 2 = div2 -> 2 levels +! 4,24 = del2 -> 3 levels +! CAM assimilations can use pressure or scale height vertical coordinate. +! We recommend scale height. +! use_log_vertical_scale = .true. +! vert_normalization_scale_height = 1.5 +! vert_normalization_pressure = 20000. +! +! 26 levels (CAM4): +! no_obs_assim_above_level = 5 ! corresponds to ~3700 Pa +! 30 levels (CAM5): +! no_obs_assim_above_level = 5 ! corresponds to ~3800 Pa +! 32 levels (CAM6): +! no_obs_assim_above_level = 5 ! corresponds to ~3600 Pa +! +! WACCM +! The model top for WACCM is (naturally) much higher: 4.5e-4 Pa +! The number of model top levels with extra diffusion is controlled by WACCM's +! fv_div24del2flag: +! 2 = div2 -> 3 levels +! 4,24 = del2 -> 4 levels +! 70 levels (WACCM4): +! no_obs_assim_above_level = 7 ! corresponds to 0.012 Pa +! This values must be used with WACCM assimilations; +! use_log_vertical_scale = .true. +! This is recommended, but your own tuning experiments may support a different value. +! vert_normalization_scale_height = 1.5 +! +!======================================================================== + +&model_nml + cam_template_filename = 'caminput.nc' + cam_phis_filename = 'cam_phis.nc' + custom_routine_to_generate_ensemble = .true. + fields_to_perturb = 'QTY_TEMPERATURE' + perturbation_amplitude = 0.1 + state_variables = 'T', 'QTY_TEMPERATURE', 'NA', 'NA', 'UPDATE' + 'U', 'QTY_U_WIND_COMPONENT', 'NA', 'NA', 'UPDATE' + 'V', 'QTY_V_WIND_COMPONENT', 'NA', 'NA', 'UPDATE' + 'Q', 'QTY_SPECIFIC_HUMIDITY', 'NA', 'NA', 'UPDATE' + 'CLDLIQ','QTY_CLOUD_LIQUID_WATER', 'NA', 'NA', 'UPDATE' + 'CLDICE','QTY_CLOUD_ICE', 'NA', 'NA', 'UPDATE' + 'PS', 'QTY_SURFACE_PRESSURE', 'NA', 'NA', 'UPDATE' + use_log_vertical_scale = .true. + use_variable_mean_mass = .false. + no_normalization_of_scale_heights = .true. + vertical_localization_coord = 'SCALEHEIGHT' + no_obs_assim_above_level = 5 + model_damping_ends_at_level = -1 + using_chemistry = .false. + assimilation_period_days = 0 + assimilation_period_seconds = 21600 + suppress_grid_info_in_output = .false. + debug_level = 0 + / + +! Other fields in the CAM initial file, which could be included in the model state: +! These QTYs should be changed to physically meaningful values before any real assim. +! 'DMS', 'QTY_3D_PARAMETER', 'NA', 'NA', 'UPDATE' +! 'H2O2', 'QTY_3D_PARAMETER', 'NA', 'NA', 'UPDATE' +! 'H2SO4', 'QTY_3D_PARAMETER', 'NA', 'NA', 'UPDATE' +! 'NUMICE','QTY_3D_PARAMETER', 'NA', 'NA', 'UPDATE' +! 'NUMLIQ','QTY_3D_PARAMETER', 'NA', 'NA', 'UPDATE' +! 'NUMRAI','QTY_3D_PARAMETER', 'NA', 'NA', 'UPDATE' +! 'NUMSNO','QTY_3D_PARAMETER', 'NA', 'NA', 'UPDATE' +! 'RAINQM','QTY_3D_PARAMETER', 'NA', 'NA', 'UPDATE' +! 'SNOWQM','QTY_3D_PARAMETER', 'NA', 'NA', 'UPDATE' +! 'SO2', 'QTY_3D_PARAMETER', 'NA', 'NA', 'UPDATE' +! 'SOAG', 'QTY_3D_PARAMETER', 'NA', 'NA', 'UPDATE' +! 'bc_a1', 'QTY_3D_PARAMETER', 'NA', 'NA', 'UPDATE' +! 'bc_a4', 'QTY_3D_PARAMETER', 'NA', 'NA', 'UPDATE' +! 'dst_a1','QTY_3D_PARAMETER', 'NA', 'NA', 'UPDATE' +! 'dst_a2','QTY_3D_PARAMETER', 'NA', 'NA', 'UPDATE' +! 'dst_a3','QTY_3D_PARAMETER', 'NA', 'NA', 'UPDATE' +! 'ncl_a1','QTY_3D_PARAMETER', 'NA', 'NA', 'UPDATE' +! 'ncl_a2','QTY_3D_PARAMETER', 'NA', 'NA', 'UPDATE' +! 'ncl_a3','QTY_3D_PARAMETER', 'NA', 'NA', 'UPDATE' +! 'num_a1','QTY_3D_PARAMETER', 'NA', 'NA', 'UPDATE' +! 'num_a2','QTY_3D_PARAMETER', 'NA', 'NA', 'UPDATE' +! 'num_a3','QTY_3D_PARAMETER', 'NA', 'NA', 'UPDATE' +! 'num_a4','QTY_3D_PARAMETER', 'NA', 'NA', 'UPDATE' +! 'pom_a1','QTY_3D_PARAMETER', 'NA', 'NA', 'UPDATE' +! 'pom_a4','QTY_3D_PARAMETER', 'NA', 'NA', 'UPDATE' +! 'so4_a1','QTY_3D_PARAMETER', 'NA', 'NA', 'UPDATE' +! 'so4_a2','QTY_3D_PARAMETER', 'NA', 'NA', 'UPDATE' +! 'so4_a3','QTY_3D_PARAMETER', 'NA', 'NA', 'UPDATE' +! 'soa_a1','QTY_3D_PARAMETER', 'NA', 'NA', 'UPDATE' +! 'soa_a2','QTY_3D_PARAMETER', 'NA', 'NA', 'UPDATE' +&location_nml + horiz_dist_only = .false. + vert_normalization_pressure = 20000.0 + vert_normalization_height = 10000.0 + vert_normalization_level = 20.0 + vert_normalization_scale_height = 1.5 + approximate_distance = .false. + nlon = 141 + nlat = 72 + output_box_info = .false. + print_box_level = 0 + / + +#======================================================================== +# End of CAM-FV dependencies. +#======================================================================== + +&fill_inflation_restart_nml + write_prior_inf = .true. + prior_inf_mean = 1.01 + prior_inf_sd = 0.6 + + write_post_inf = .false. + post_inf_mean = 1.00 + post_inf_sd = 0.6 + + input_state_files = 'caminput.nc' + single_file = .false. + + verbose = .false. + / + +! to use chemistry or saber temperatures, include the following below. +! '../../../observations/forward_operators/obs_def_CO_Nadir_mod.f90', +! '../../../observations/forward_operators/obs_def_SABER_mod.f90', +! '../../../observations/forward_operators/obs_def_MOPITT_CO_mod.f90', + +&preprocess_nml + overwrite_output = .true. + input_obs_qty_mod_file = '../../../assimilation_code/modules/observations/DEFAULT_obs_kind_mod.F90' + output_obs_qty_mod_file = '../../../assimilation_code/modules/observations/obs_kind_mod.f90' + input_obs_def_mod_file = '../../../observations/forward_operators/DEFAULT_obs_def_mod.F90' + output_obs_def_mod_file = '../../../observations/forward_operators/obs_def_mod.f90' + obs_type_files = '../../../observations/forward_operators/obs_def_gps_mod.f90', + '../../../observations/forward_operators/obs_def_upper_atm_mod.f90', + '../../../observations/forward_operators/obs_def_reanalysis_bufr_mod.f90', + '../../../observations/forward_operators/obs_def_altimeter_mod.f90' + quantity_files = '../../../assimilation_code/modules/observations/atmosphere_quantities_mod.f90', + '../../../assimilation_code/modules/observations/space_quantities_mod.f90', + '../../../assimilation_code/modules/observations/chemistry_quantities_mod.f90' + / + +! Not usually assimilated. No fundamental reason not to. +! 'RADIOSONDE_SPECIFIC_HUMIDITY', +! Available from mid-2006 onward. Build filter with obs_def_gps_mod.f90 +! 'GPSRO_REFRACTIVITY', +! WACCM can use higher observations than CAM. +! An example can be included via obs_def_SABER_mod.f90. +! 'SABER_TEMPERATURE', + +&obs_kind_nml + assimilate_these_obs_types = 'RADIOSONDE_U_WIND_COMPONENT', + 'RADIOSONDE_V_WIND_COMPONENT', + 'RADIOSONDE_TEMPERATURE', + 'AIRCRAFT_U_WIND_COMPONENT', + 'AIRCRAFT_V_WIND_COMPONENT', + 'AIRCRAFT_TEMPERATURE', + 'ACARS_U_WIND_COMPONENT', + 'ACARS_V_WIND_COMPONENT', + 'ACARS_TEMPERATURE', + 'SAT_U_WIND_COMPONENT', + 'SAT_V_WIND_COMPONENT', + 'GPSRO_REFRACTIVITY' + + evaluate_these_obs_types = 'RADIOSONDE_SPECIFIC_HUMIDITY', + / + + +&state_vector_io_nml + buffer_state_io = .false. + single_precision_output = .false. + / + + +! 'layout' and 'tasks_per_node' will be reset by the assimilate.csh script +! to match the number used when laying out the job. + +&ensemble_manager_nml + layout = 2 + tasks_per_node = 16 + / + + +&assim_tools_nml + filter_kind = 1 + cutoff = 0.15 + sort_obs_inc = .false. + spread_restoration = .false. + sampling_error_correction = .true. + adaptive_localization_threshold = -1 + output_localization_diagnostics = .false. + localization_diagnostics_file = 'localization_diagnostics' + convert_all_obs_verticals_first = .true. + convert_all_state_verticals_first = .true. + print_every_nth_obs = 10000 + distribute_mean = .false. + / + + +&cov_cutoff_nml + select_localization = 1 + / + + +®_factor_nml + select_regression = 1 + input_reg_file = 'time_mean_reg' + save_reg_diagnostics = .false. + reg_diagnostics_file = 'reg_diagnostics' + / + + +&obs_sequence_nml + write_binary_obs_sequence = .false. + / + + +&quality_control_nml + input_qc_threshold = 3.0 + outlier_threshold = 3.0 + enable_special_outlier_code = .false. + / + + +&xyz_location_nml + / + + +! : error codes >= TERMLEVEL will cause termination +! E_DBG = -2, E_MSG = -1, E_ALLMSG = 0, E_WARN = 1, E_ERR = 2 +! write_nml default is 'file'. +! write_nml = 'none' reduces printed output. +&utilities_nml + TERMLEVEL = 2 + module_details = .false. + logfilename = 'dart_log.out' + nmlfilename = 'dart_log.nml' + / + + +&mpi_utilities_nml + / + + +&obs_def_gps_nml + max_gpsro_obs = 15000000 + / + + +#======================================================================== +# observation manipulation tools +#======================================================================== + +! other possible obs tool namelist items: +! +! keep only the U and V radiosonde winds: +! obs_types = 'RADIOSONDE_U_WIND_COMPONENT' +! 'RADIOSONDE_V_WIND_COMPONENT' +! keep_types = .true. +! +! remove the U and V radiosonde winds: +! obs_types = 'RADIOSONDE_U_WIND_COMPONENT' +! 'RADIOSONDE_V_WIND_COMPONENT' +! keep_types = .false. +! +! keep only observations with a DART QC of 0: +! qc_metadata = 'Dart quality control' +! min_qc = 0 +! max_qc = 0 +! +! keep only radiosonde temp obs between 250 and 300 K: +! copy_metadata = 'NCEP BUFR observation' +! copy_type = 'RADIOSONDE_TEMPERATURE' +! min_copy = 250.0 +! max_copy = 300.0 + + +&obs_sequence_tool_nml + num_input_files = 2 + filename_seq = 'obs_seq.one', 'obs_seq.two' + filename_out = 'obs_seq.processed' + first_obs_days = -1 + first_obs_seconds = -1 + last_obs_days = -1 + last_obs_seconds = -1 + min_lat = -90.0 + max_lat = 90.0 + min_lon = 0.0 + max_lon = 360.0 + gregorian_cal = .true. + print_only = .false. + / + + +&obs_common_subset_nml + num_to_compare_at_once = 2 + filename_seq = '' + filename_seq_list = '' + filename_out_suffix = '.common' + print_only = .false. + print_every = 10000 + calendar = 'Gregorian' + dart_qc_threshold = 3 + eval_and_assim_can_match = .false. + / + + +&obs_impact_tool_nml + input_filename = 'cross_correlations.txt' + output_filename = 'control_impact_runtime.txt' + debug = .false. + / + + +&smoother_nml + num_lags = 0 + start_from_restart = .false. + output_restart = .false. + restart_in_file_name = 'smoother_ics' + restart_out_file_name = 'smoother_restart' + / + + +#======================================================================== +# diagnostic tools +#======================================================================== + +! The times in the namelist for the obs_diag program are vectors +! that follow the following sequence: +! year month day hour minute second +! max_num_bins can be used to specify a fixed number of bins, +! in which case last_bin_center should be safely in the future. +! +! Acceptable latitudes range from [-90, 90] +! Acceptable longitudes range from [ 0, Inf] +! +! Other available namelist variables, not in the default obs_diag.nml: +! hlevel +! mlevel +! print_obs_locations +! outliers_in_histogram +! plevel_edges +! hlevel_edges +! mlevel_edges +! Standard layers: +! 1000, 925, 850, 700, 600, 500, 400, 300, 250, 200, 150, 100, 70, 50, 30, 20, 10 hPa +! +950(MetOffc) -600(skipped in obs_diag.f90 defaults) -70 and less skipped in obs_diag.f90 +! Corresponding heights (assuming a standard atmosphere) +! 200, 650, 1350, 2900,4100,5480,7090,9080,10280,11700,13520,16100,18358,21060,24640,27480,32330 +! I've changed the height vertical axis in plot_rmse_xxx* to be logarithmic +! in order to make the layers look more like the pressure layers. +! So the bottom edge can't be 0. +! The lowest GPS ob is 200, so that's the new lowest edge +! +! plevel = 1000.,925.,850.,700.,500.,400.,300.,250.,200.,150.,100.,50.,20.,10. +! hlevel = 1000., 2000., 3000., 4000., 5000., 6000., 7000., 8000., 9000., 10000.,11000. +! 0, 1500, 2500, 3500, 4500, 5500, 6500, 7500, 9500, 11500, 13500, 15500 +! +! Defaults +! plevel = 1000.,850.,700.,500.,400.,300.,200.,150.,100. +! Nregions = 4 +! lonlim1 = 0.0, 0.0, 0.0, 235.0 +! lonlim2 = 360.0, 360.0, 360.0, 295.0 +! latlim1 = 20.0, -80.0, -20.0, 25.0 +! latlim2 = 80.0, -20.0, 20.0, 55.0 +! reg_names = 'Northern Hemisphere', 'Southern Hemisphere', 'Tropics', 'North America' +! +! for WACCM you will want to change the plevel to match +! the higher vertical range of the model. +! plevel = 1000.,850.,700.,500.,400.,300.,200.,150.,100. +! these are specified in hectopascals (hPa) + +&obs_diag_nml + obs_sequence_name = 'obs_seq.final' + obs_sequence_list = '' + first_bin_center = BOGUS_YEAR, 1, 1, 0, 0, 0 + last_bin_center = BOGUS_YEAR, 1, 2, 0, 0, 0 + bin_separation = 0, 0, 0, 6, 0, 0 + bin_width = 0, 0, 0, 6, 0, 0 + time_to_skip = 0, 0, 1, 0, 0, 0 + max_num_bins = 1000 + trusted_obs = 'null' + plevel_edges = 1035.5, 962.5, 887.5, 775, 600, 450, 350, 275, 225, 175, 125, 75, 35, 15, 2 + hlevel_edges = 200, 630, 930, 1880,3670,5680,7440,9130,10530,12290, 14650,18220,23560,29490,43000 + Nregions = 3 + reg_names = 'Northern Hemisphere', 'Tropics', 'Southern Hemisphere' + lonlim1 = 0.0, 0.0, 0.0 + lonlim2 = 360.0, 360.0, 360.0 + latlim1 = 20.0, -20.0, -90.0 + latlim2 = 90.0, 20.0, -20.0 + print_mismatched_locs = .false. + create_rank_histogram = .true. + outliers_in_histogram = .true. + use_zero_error_obs = .false. + verbose = .false. + / + + +&schedule_nml + calendar = 'Gregorian' + first_bin_start = 1601, 1, 1, 0, 0, 0 + first_bin_end = 2999, 1, 1, 0, 0, 0 + last_bin_end = 2999, 1, 1, 0, 0, 0 + bin_interval_days = 1000000 + bin_interval_seconds = 0 + max_num_bins = 1000 + print_table = .true. + / + + +&obs_seq_to_netcdf_nml + obs_sequence_name = 'obs_seq.final' + obs_sequence_list = '' + append_to_netcdf = .false. + lonlim1 = 0.0 + lonlim2 = 360.0 + latlim1 = -90.0 + latlim2 = 90.0 + verbose = .false. + / + + +&model_mod_check_nml + input_state_files = 'caminput.nc' + output_state_files = 'mmc_output.nc' + test1thru = 0 + run_tests = 1,2,3,4,5,7 + x_ind = 175001 + + quantity_of_interest = 'QTY_U_WIND_COMPONENT' + loc_of_interest = 254.727854, 39.9768545, 50000.0 + + interp_test_lonrange = 0.0, 360.0 + interp_test_dlon = 1.0 + interp_test_latrange = -90.0, 90.0 + interp_test_dlat = 1.0 + interp_test_vertrange = 10000.0, 90000.0 + interp_test_dvert = 10000.0 + interp_test_vertcoord = 'VERTISPRESSURE' + verbose = .false. + / + + +! different methods to compute 'distance' from mean: +! 1 = simple absolute difference +! 2 = normalized absolute difference +! 3 = simple rmse difference +! 4 = normalized rmse difference + +&closest_member_tool_nml + input_restart_file_list = 'cam_in.txt' + output_file_name = 'closest_restart' + ens_size = 3 + single_restart_file_in = .false. + difference_method = 4 + use_only_qtys = '' + / + + +&perturb_single_instance_nml + ens_size = 3 + input_files = 'caminput.nc' + output_files = 'cam_pert1.nc','cam_pert2.nc','cam_pert3.nc' + output_file_list = '' + perturbation_amplitude = 0.2 + / + + +&quad_interpolate_nml + debug = 0 + / + diff --git a/models/cam-se/work/obs_seq.in b/models/cam-se/work/obs_seq.in new file mode 100644 index 0000000000..8073a63949 --- /dev/null +++ b/models/cam-se/work/obs_seq.in @@ -0,0 +1,389 @@ + obs_sequence +obs_kind_definitions + 14 + 1 RADIOSONDE_U_WIND_COMPONENT + 2 RADIOSONDE_V_WIND_COMPONENT + 3 RADIOSONDE_SURFACE_PRESSURE + 4 RADIOSONDE_TEMPERATURE + 5 RADIOSONDE_SPECIFIC_HUMIDITY + 6 AIRCRAFT_U_WIND_COMPONENT + 7 AIRCRAFT_V_WIND_COMPONENT + 8 AIRCRAFT_TEMPERATURE + 9 ACARS_U_WIND_COMPONENT + 10 ACARS_V_WIND_COMPONENT + 11 ACARS_TEMPERATURE + 20 SAT_U_WIND_COMPONENT + 21 SAT_V_WIND_COMPONENT + 30 GPSRO_REFRACTIVITY + num_copies: 1 num_qc: 1 + num_obs: 32 max_num_obs: 32 +observation +Quality Control + first: 1 last: 32 + OBS 1 + -3.20000000000000 + 2.00000000000000 + -1 2 -1 +obdef +loc3d + 2.12700000000000 -0.59000000000000 50000.00000000000000 2 +kind + 1 + 0 140978 + 1.96000000000000 + OBS 2 + 7.00000000000000 + 2.00000000000000 + 1 3 -1 +obdef +loc3d + 2.12700000000000 -0.59000000000000 60000.00000000000000 2 +kind + 2 + 0 140978 + 1.96000000000000 + OBS 3 + 7.90000000000000 + 2.00000000000000 + 2 4 -1 +obdef +loc3d + 2.12700000000000 -0.59000000000000 81490.00000000000000 2 +kind + 1 + 0 140978 + 2.56000000000000 + OBS 4 + 2.10000000000000 + 2.00000000000000 + 3 5 -1 +obdef +loc3d + 2.12700000000000 -0.59000000000000 81490.00000000000000 2 +kind + 2 + 0 140978 + 2.56000000000000 + OBS 5 + 264.460000000000 + 2.00000000000000 + 4 6 -1 +obdef +loc3d + 2.21700000000000 0.64800000000000 93500.00000000000000 2 +kind + 4 + 0 140978 + 1.00000000000000 + OBS 6 + 1.200000000000000E-003 + 2.00000000000000 + 5 7 -1 +obdef +loc3d + 2.21700000000000 0.64800000000000 93500.00000000000000 2 +kind + 5 + 0 140978 + 1.764000000000000E-007 + OBS 7 + 263.660000000000 + 2.00000000000000 + 6 8 -1 +obdef +loc3d + 2.21700000000000 0.64800000000000 92500.00000000000000 2 +kind + 4 + 0 140978 + 1.00000000000000 + OBS 8 + 1.040000000000000E-003 + 2.00000000000000 + 7 9 -1 +obdef +loc3d + 2.21700000000000 0.64800000000000 92500.00000000000000 2 +kind + 5 + 0 140978 + 1.600000000000000E-007 + OBS 9 + 100200.000000000 + 1.00000000000000 + 8 10 -1 +obdef +loc3d + 0.31300000000000 0.70900000000000 10.00000000000000 -1 +kind + 3 + 0 140978 + 10000.0000000000 + OBS 10 + 15.8000000000000 + 1.00000000000000 + 9 11 -1 +obdef +loc3d + 4.71600000000000 0.72300000000000 27830.00000000000000 2 +kind + 6 + 0 140978 + 12.9600000000000 + OBS 11 + 4.80000000000000 + 1.00000000000000 + 10 12 -1 +obdef +loc3d + 4.71600000000000 0.72300000000000 27830.00000000000000 2 +kind + 7 + 0 140978 + 12.9600000000000 + OBS 12 + 223.160000000000 + 1.00000000000000 + 11 13 -1 +obdef +loc3d + 2.83600000000000 -0.62100000000000 20650.00000000000000 2 +kind + 8 + 0 140978 + 2.89000000000000 + OBS 13 + 15.0000000000000 + 1.00000000000000 + 12 14 -1 +obdef +loc3d + 2.83600000000000 -0.62100000000000 20650.00000000000000 2 +kind + 6 + 0 140978 + 12.9600000000000 + OBS 14 + 11.7000000000000 + 1.00000000000000 + 13 15 -1 +obdef +loc3d + 2.83600000000000 -0.62100000000000 20650.00000000000000 2 +kind + 7 + 0 140978 + 12.9600000000000 + OBS 15 + 227.160000000000 + 1.00000000000000 + 14 16 -1 +obdef +loc3d + 2.84500000000000 -0.37400000000000 20650.00000000000000 2 +kind + 8 + 0 140978 + 2.89000000000000 + OBS 16 + 11.2000000000000 + 1.00000000000000 + 15 17 -1 +obdef +loc3d + 3.54300000000000 0.37600000000000 52750.00000000000000 2 +kind + 9 + 0 140978 + 6.25000000000000 + OBS 17 + -5.20000000000000 + 1.00000000000000 + 16 18 -1 +obdef +loc3d + 3.54300000000000 0.37600000000000 52750.00000000000000 2 +kind + 10 + 0 140978 + 6.25000000000000 + OBS 18 + 272.360000000000 + 1.00000000000000 + 17 19 -1 +obdef +loc3d + 3.54200000000000 0.37600000000000 54920.00000000000728 2 +kind + 11 + 0 140978 + 1.00000000000000 + OBS 19 + 7.80000000000000 + 1.00000000000000 + 18 20 -1 +obdef +loc3d + 3.54200000000000 0.37600000000000 54920.00000000000728 2 +kind + 9 + 0 140978 + 6.25000000000000 + OBS 20 + -2.40000000000000 + 1.00000000000000 + 19 21 -1 +obdef +loc3d + 3.54200000000000 0.37600000000000 54920.00000000000728 2 +kind + 10 + 0 140978 + 6.25000000000000 + OBS 21 + 225.160000000000 + 1.00000000000000 + 20 22 -1 +obdef +loc3d + 4.52800000000000 0.39200000000000 23840.00000000000000 2 +kind + 11 + 0 140978 + 1.00000000000000 + OBS 22 + 7.00000000000000 + 2.00000000000000 + 21 23 -1 +obdef +loc3d + 3.35400000000000 0.41100000000000 86800.00000000000000 2 +kind + 20 + 0 140978 + 14.4400000000000 + OBS 23 + -1.10000000000000 + 2.00000000000000 + 22 24 -1 +obdef +loc3d + 3.35400000000000 0.41100000000000 86800.00000000000000 2 +kind + 21 + 0 140978 + 14.4400000000000 + OBS 24 + -2.90000000000000 + 2.00000000000000 + 23 25 -1 +obdef +loc3d + 3.18200000000000 0.40800000000000 90600.00000000000000 2 +kind + 20 + 0 140978 + 14.4400000000000 + OBS 25 + -5.20000000000000 + 2.00000000000000 + 24 26 -1 +obdef +loc3d + 3.18200000000000 0.40800000000000 90600.00000000000000 2 +kind + 21 + 0 140978 + 14.4400000000000 + OBS 26 + 6.50000000000000 + 2.00000000000000 + 25 27 -1 +obdef +loc3d + 3.31700000000000 0.40000000000000 86800.00000000000000 2 +kind + 20 + 0 140978 + 14.4400000000000 + OBS 27 + 1.00000000000000 + 2.00000000000000 + 26 28 -1 +obdef +loc3d + 3.31700000000000 0.40000000000000 86800.00000000000000 2 +kind + 21 + 0 140978 + 14.4400000000000 + OBS 28 + 155.3600 + 0.0000000E+00 + 27 29 -1 +obdef +loc3d + 5.12599992752075 0.24499998986721 1230.00000000000000 3 +kind + 30 +gpsroref 1 + 6345638. 5000.000 15000.00 0.4606750 -3.9821409E-02 + -0.8866752 GPSEXC + 0 140978 + 3.343818 + OBS 29 + 147.2400 + 0.0000000E+00 + 28 30 -1 +obdef +loc3d + 5.12599992752075 0.24399998784065 1560.00000000000000 3 +kind + 30 +gpsroref 2 + 6345638. 5000.000 15000.00 0.4604562 -3.9050832E-02 + -0.8868231 GPSEXC + 0 140978 + 2.837308 + OBS 30 + 138.5900 + 0.0000000E+00 + 29 31 -1 +obdef +loc3d + 5.12500000000000 0.24199998378754 1930.00000000000000 3 +kind + 30 +gpsroref 3 + 6345638. 5000.000 15000.00 0.4600854 -3.7566423E-02 + -0.8870796 GPSEXC + 0 140978 + 2.353738 + OBS 31 + 129.8800 + 0.0000000E+00 + 30 32 -1 +obdef +loc3d + 5.12500000000000 0.24199998378754 2360.00000000000000 3 +kind + 30 +gpsroref 4 + 6345638. 5000.000 15000.00 0.4600482 -3.7349693E-02 + -0.8871080 GPSEXC + 0 140978 + 1.909799 + OBS 32 + 120.7300 + 0.0000000E+00 + 31 -1 -1 +obdef +loc3d + 5.12500000000000 0.23999997973442 2840.00000000000000 3 +kind + 30 +gpsroref 5 + 6345638. 5000.000 15000.00 0.4597381 -3.6100548E-02 + -0.8873205 GPSEXC + 0 140978 + 1.504648 diff --git a/models/cam-se/work/obs_seq.out b/models/cam-se/work/obs_seq.out new file mode 100644 index 0000000000..ec4627c5f0 --- /dev/null +++ b/models/cam-se/work/obs_seq.out @@ -0,0 +1,417 @@ + obs_sequence +obs_kind_definitions + 14 + 4 GPSRO_REFRACTIVITY + 5 RADIOSONDE_U_WIND_COMPONENT + 6 RADIOSONDE_V_WIND_COMPONENT + 8 RADIOSONDE_SURFACE_PRESSURE + 9 RADIOSONDE_TEMPERATURE + 10 RADIOSONDE_SPECIFIC_HUMIDITY + 16 AIRCRAFT_U_WIND_COMPONENT + 17 AIRCRAFT_V_WIND_COMPONENT + 18 AIRCRAFT_TEMPERATURE + 20 ACARS_U_WIND_COMPONENT + 21 ACARS_V_WIND_COMPONENT + 22 ACARS_TEMPERATURE + 34 SAT_U_WIND_COMPONENT + 35 SAT_V_WIND_COMPONENT + num_copies: 2 num_qc: 1 + num_obs: 32 max_num_obs: 32 +observations +truth +Quality Control + first: 1 last: 32 + OBS 1 + 16.316530634395324 + 16.560642909852696 + 2.0000000000000000 + -1 2 -1 +obdef +loc3d + 2.127000000000000 -0.5900000000000000 50000.00000000000 2 +kind + 5 + 0 140978 + 1.9600000000000000 + OBS 2 + -3.0100968389326992 + -2.5306735370803435 + 2.0000000000000000 + 1 3 -1 +obdef +loc3d + 2.127000000000000 -0.5900000000000000 60000.00000000000 2 +kind + 6 + 0 140978 + 1.9600000000000000 + OBS 3 + 1.8509895506983549 + 0.76263621361770673 + 2.0000000000000000 + 2 4 -1 +obdef +loc3d + 2.127000000000000 -0.5900000000000000 81490.00000000000 2 +kind + 5 + 0 140978 + 2.5600000000000001 + OBS 4 + -1.6138105790692572 + 1.0136042368191853 + 2.0000000000000000 + 3 5 -1 +obdef +loc3d + 2.127000000000000 -0.5900000000000000 81490.00000000000 2 +kind + 6 + 0 140978 + 2.5600000000000001 + OBS 5 + 267.05264114419396 + 265.31758944198020 + 2.0000000000000000 + 4 6 -1 +obdef +loc3d + 2.217000000000000 0.6480000000000000 93500.00000000000 2 +kind + 9 + 0 140978 + 1.0000000000000000 + OBS 6 + 1.7507774932271193E-003 + 1.6115582601651313E-003 + 2.0000000000000000 + 5 7 -1 +obdef +loc3d + 2.217000000000000 0.6480000000000000 93500.00000000000 2 +kind + 10 + 0 140978 + 1.7639999999999999E-007 + OBS 7 + 265.86187976272515 + 264.79402681937967 + 2.0000000000000000 + 6 8 -1 +obdef +loc3d + 2.217000000000000 0.6480000000000000 92500.00000000000 2 +kind + 9 + 0 140978 + 1.0000000000000000 + OBS 8 + 2.1309353525538143E-003 + 1.6024688098786495E-003 + 2.0000000000000000 + 7 9 -1 +obdef +loc3d + 2.217000000000000 0.6480000000000000 92500.00000000000 2 +kind + 10 + 0 140978 + 1.6000000000000000E-007 + OBS 9 + -888888.00000000000 + -888888.00000000000 + 1000.0000000000000 + 8 10 -1 +obdef +loc3d + 0.3130000000000000 0.7090000000000000 10.00000000000000 -1 +kind + 8 + 0 140978 + 10000.000000000000 + OBS 10 + 42.889813595175667 + 47.812266519590437 + 1.0000000000000000 + 9 11 -1 +obdef +loc3d + 4.716000000000000 0.7230000000000000 27830.00000000000 2 +kind + 16 + 0 140978 + 12.960000000000001 + OBS 11 + -33.558425529274281 + -35.821047765652594 + 1.0000000000000000 + 10 12 -1 +obdef +loc3d + 4.716000000000000 0.7230000000000000 27830.00000000000 2 +kind + 17 + 0 140978 + 12.960000000000001 + OBS 12 + 220.23348776777794 + 221.61837942530900 + 1.0000000000000000 + 11 13 -1 +obdef +loc3d + 2.836000000000000 -0.6210000000000000 20650.00000000000 2 +kind + 18 + 0 140978 + 2.8900000000000001 + OBS 13 + 22.264358629204072 + 21.282272164550324 + 1.0000000000000000 + 12 14 -1 +obdef +loc3d + 2.836000000000000 -0.6210000000000000 20650.00000000000 2 +kind + 16 + 0 140978 + 12.960000000000001 + OBS 14 + 20.554007355365613 + 30.243721670435193 + 1.0000000000000000 + 13 15 -1 +obdef +loc3d + 2.836000000000000 -0.6210000000000000 20650.00000000000 2 +kind + 17 + 0 140978 + 12.960000000000001 + OBS 15 + 217.05133777633955 + 217.78475412573167 + 1.0000000000000000 + 14 16 -1 +obdef +loc3d + 2.845000000000000 -0.3740000000000000 20650.00000000000 2 +kind + 18 + 0 140978 + 2.8900000000000001 + OBS 16 + 0.75708200149449567 + 2.0760912377932872 + 1.0000000000000000 + 15 17 -1 +obdef +loc3d + 3.543000000000000 0.3760000000000000 52750.00000000000 2 +kind + 20 + 0 140978 + 6.2500000000000000 + OBS 17 + -1.1810766890862274 + -3.1354780447629311 + 1.0000000000000000 + 16 18 -1 +obdef +loc3d + 3.543000000000000 0.3760000000000000 52750.00000000000 2 +kind + 21 + 0 140978 + 6.2500000000000000 + OBS 18 + 268.36612127806882 + 266.51374789756892 + 1.0000000000000000 + 17 19 -1 +obdef +loc3d + 3.542000000000000 0.3760000000000000 54920.00000000001 2 +kind + 22 + 0 140978 + 1.0000000000000000 + OBS 19 + -6.7375875845977813 + 0.86854536675498217 + 1.0000000000000000 + 18 20 -1 +obdef +loc3d + 3.542000000000000 0.3760000000000000 54920.00000000001 2 +kind + 20 + 0 140978 + 6.2500000000000000 + OBS 20 + -3.2560106744771828 + -3.0708364272696209 + 1.0000000000000000 + 19 21 -1 +obdef +loc3d + 3.542000000000000 0.3760000000000000 54920.00000000001 2 +kind + 21 + 0 140978 + 6.2500000000000000 + OBS 21 + 224.85082947123234 + 225.16847140771696 + 1.0000000000000000 + 20 22 -1 +obdef +loc3d + 4.528000000000000 0.3920000000000000 23840.00000000000 2 +kind + 22 + 0 140978 + 1.0000000000000000 + OBS 22 + -13.928397737949020 + -15.793003269013045 + 2.0000000000000000 + 21 23 -1 +obdef +loc3d + 3.354000000000000 0.4110000000000000 86800.00000000000 2 +kind + 34 + 0 140978 + 14.440000000000000 + OBS 23 + -2.4891449909040140 + 2.7930020907196691 + 2.0000000000000000 + 22 24 -1 +obdef +loc3d + 3.354000000000000 0.4110000000000000 86800.00000000000 2 +kind + 35 + 0 140978 + 14.440000000000000 + OBS 24 + -20.074824268009760 + -17.673439969896815 + 2.0000000000000000 + 23 25 -1 +obdef +loc3d + 3.182000000000000 0.4080000000000000 90600.00000000000 2 +kind + 34 + 0 140978 + 14.440000000000000 + OBS 25 + -7.1527525806560135 + -1.5215749901377678 + 2.0000000000000000 + 24 26 -1 +obdef +loc3d + 3.182000000000000 0.4080000000000000 90600.00000000000 2 +kind + 35 + 0 140978 + 14.440000000000000 + OBS 26 + -21.498859770508609 + -16.012168025428029 + 2.0000000000000000 + 25 27 -1 +obdef +loc3d + 3.317000000000000 0.4000000000000000 86800.00000000000 2 +kind + 34 + 0 140978 + 14.440000000000000 + OBS 27 + -4.3145699587744613 + 2.9204548678423303 + 2.0000000000000000 + 26 28 -1 +obdef +loc3d + 3.317000000000000 0.4000000000000000 86800.00000000000 2 +kind + 35 + 0 140978 + 14.440000000000000 + OBS 28 + 151.06900215018791 + 149.90459022228066 + 0.0000000000000000 + 27 29 -1 +obdef +loc3d + 5.125999927520750 0.2449999898672100 1230.000000000000 3 +kind + 4 +gpsroref 1 + 6345638.0000000000 5000.0000000000000 15000.000000000000 0.46067500000000000 -3.9821409000000002E-002 -0.88667520000000000 GPSEXC + 0 140978 + 3.3438180000000002 + OBS 29 + 143.08309475125654 + 142.51656404010652 + 0.0000000000000000 + 28 30 -1 +obdef +loc3d + 5.125999927520750 0.2439999878406500 1560.000000000000 3 +kind + 4 +gpsroref 2 + 6345638.0000000000 5000.0000000000000 15000.000000000000 0.46045619999999998 -3.9050832000000001E-002 -0.88682309999999998 GPSEXC + 0 140978 + 2.8373080000000002 + OBS 30 + 134.61047373971687 + 134.18262570089769 + 0.0000000000000000 + 29 31 -1 +obdef +loc3d + 5.125000000000000 0.2419999837875400 1930.000000000000 3 +kind + 4 +gpsroref 3 + 6345638.0000000000 5000.0000000000000 15000.000000000000 0.46008539999999998 -3.7566423000000002E-002 -0.88707959999999997 GPSEXC + 0 140978 + 2.3537379999999999 + OBS 31 + 124.35858594600661 + 124.00325129004048 + 0.0000000000000000 + 30 32 -1 +obdef +loc3d + 5.125000000000000 0.2419999837875400 2360.000000000000 3 +kind + 4 +gpsroref 4 + 6345638.0000000000 5000.0000000000000 15000.000000000000 0.46004820000000002 -3.7349693000000003E-002 -0.88710800000000001 GPSEXC + 0 140978 + 1.9097990000000000 + OBS 32 + 114.58632514225754 + 113.49226253086518 + 0.0000000000000000 + 31 -1 -1 +obdef +loc3d + 5.125000000000000 0.2399999797344200 2840.000000000000 3 +kind + 4 +gpsroref 5 + 6345638.0000000000 5000.0000000000000 15000.000000000000 0.45973809999999998 -3.6100548000000003E-002 -0.88732049999999996 GPSEXC + 0 140978 + 1.5046480000000000 diff --git a/models/cam-se/work/quickbuild.sh b/models/cam-se/work/quickbuild.sh new file mode 100755 index 0000000000..3757e17d86 --- /dev/null +++ b/models/cam-se/work/quickbuild.sh @@ -0,0 +1,61 @@ +#!/usr/bin/env bash + +# DART software - Copyright UCAR. This open source software is provided +# by UCAR, "as is", without charge, subject to all terms of use at +# http://www.image.ucar.edu/DAReS/DART/DART_download + +main() { + +export DART=$(git rev-parse --show-toplevel) +source "$DART"/build_templates/buildfunctions.sh + +MODEL=cam-se +LOCATION=threed_sphere +EXTRA=$DART/models/cam-common-code + + +programs=( +closest_member_tool +filter +model_mod_check +perfect_model_obs +perturb_single_instance +wakeup_filter +) + +serial_programs=( +advance_time +create_fixed_network_seq +create_obs_sequence +fill_inflation_restart +obs_common_subset +obs_diag +obs_impact_tool +obs_selection +obs_seq_coverage +obs_seq_to_netcdf +obs_seq_verify +obs_sequence_tool +) + +model_serial_programs=( +column_rand +) + +arguments "$@" + +# clean the directory +\rm -f -- *.o *.mod Makefile .cppdefs + +# build and run preprocess before making any other DART executables +buildpreprocess + +# build DART +buildit + +# clean up +\rm -f -- *.o *.mod + +} + +main "$@"