From 972ef5d46c07ff287e9c13b1c7b343ae34c44f96 Mon Sep 17 00:00:00 2001 From: Jeff Anderson Date: Wed, 29 Oct 2025 14:05:40 -0400 Subject: [PATCH 01/24] aether cubed sphere model_mod New qty: QTY_SLANT_GPS_VTEC New fwd-op: get_expected_slant_gps_vtec. Note sections in code "THIS SUBROUTINE NEEDS ADDITIONAL INPUT FROM AETHER SCIENTISTS" developer test: test_aether_grid matlab tools for aether cubed sphere: perutb, plot lat lon, plot filter. text file of demo documentation (taught at Michigan?) debugging routines for quad_utils --- .../observations/space_quantities_mod.f90 | 1 + .../aether_grid/test_aether_grid.f90 | 15 + developer_tests/aether_grid/work/input.nml | 254 +++++ .../aether_grid/work/quickbuild.sh | 50 + index.rst | 1 + models/README.rst | 2 + models/aether_cube_sphere/aether_to_dart.f90 | 48 + .../create_obs_sequence.input | 58 ++ .../cube_sphere_grid_tools.f90 | 886 ++++++++++++++++++ models/aether_cube_sphere/dart_to_aether.f90 | 48 + models/aether_cube_sphere/model_mod.f90 | 868 +++++++++++++++++ .../perturb_aether_ensemble.m | 107 +++ .../aether_cube_sphere/plot_aether_lat_lon.m | 132 +++ .../aether_cube_sphere/plot_filter_lat_lon.m | 104 ++ models/aether_cube_sphere/readme.rst | 208 ++++ .../transform_state_mod.f90 | 871 +++++++++++++++++ .../work/demo_documentation.txt | 69 ++ .../work/filter_input_files.txt | 20 + .../work/filter_output_files.txt | 20 + models/aether_cube_sphere/work/input.nml | 254 +++++ models/aether_cube_sphere/work/obs_seq.in | 69 ++ models/aether_cube_sphere/work/quickbuild.sh | 61 ++ models/utilities/quad_utils_mod.f90 | 5 +- .../obs_def_upper_atm_mod.f90 | 352 ++++++- 24 files changed, 4491 insertions(+), 12 deletions(-) create mode 100644 developer_tests/aether_grid/test_aether_grid.f90 create mode 100644 developer_tests/aether_grid/work/input.nml create mode 100755 developer_tests/aether_grid/work/quickbuild.sh create mode 100644 models/aether_cube_sphere/aether_to_dart.f90 create mode 100644 models/aether_cube_sphere/create_obs_sequence.input create mode 100644 models/aether_cube_sphere/cube_sphere_grid_tools.f90 create mode 100644 models/aether_cube_sphere/dart_to_aether.f90 create mode 100644 models/aether_cube_sphere/model_mod.f90 create mode 100644 models/aether_cube_sphere/perturb_aether_ensemble.m create mode 100644 models/aether_cube_sphere/plot_aether_lat_lon.m create mode 100644 models/aether_cube_sphere/plot_filter_lat_lon.m create mode 100644 models/aether_cube_sphere/readme.rst create mode 100644 models/aether_cube_sphere/transform_state_mod.f90 create mode 100644 models/aether_cube_sphere/work/demo_documentation.txt create mode 100644 models/aether_cube_sphere/work/filter_input_files.txt create mode 100644 models/aether_cube_sphere/work/filter_output_files.txt create mode 100644 models/aether_cube_sphere/work/input.nml create mode 100644 models/aether_cube_sphere/work/obs_seq.in create mode 100755 models/aether_cube_sphere/work/quickbuild.sh diff --git a/assimilation_code/modules/observations/space_quantities_mod.f90 b/assimilation_code/modules/observations/space_quantities_mod.f90 index 521225e69b..1c5e26d825 100644 --- a/assimilation_code/modules/observations/space_quantities_mod.f90 +++ b/assimilation_code/modules/observations/space_quantities_mod.f90 @@ -111,6 +111,7 @@ ! QTY_VELOCITY_VERTICAL_N4S ! QTY_VELOCITY_VERTICAL_NO ! QTY_GND_GPS_VTEC +! QTY_SLANT_GPS_VTEC ! ! END DART PREPROCESS QUANTITY DEFINITIONS diff --git a/developer_tests/aether_grid/test_aether_grid.f90 b/developer_tests/aether_grid/test_aether_grid.f90 new file mode 100644 index 0000000000..c7c7444387 --- /dev/null +++ b/developer_tests/aether_grid/test_aether_grid.f90 @@ -0,0 +1,15 @@ +program test_aether_grid + +use mpi_utilities_mod, only : initialize_mpi_utilities, finalize_mpi_utilities +use model_mod, only : test_grid_box +use assim_model_mod, only : static_init_assim_model + +call initialize_mpi_utilities('test_aether_grid') + +call static_init_assim_model() + +call test_grid_box + +call finalize_mpi_utilities + +end program test_aether_grid diff --git a/developer_tests/aether_grid/work/input.nml b/developer_tests/aether_grid/work/input.nml new file mode 100644 index 0000000000..4fd10ad50d --- /dev/null +++ b/developer_tests/aether_grid/work/input.nml @@ -0,0 +1,254 @@ +&probit_transform_nml + / + +&algorithm_info_nml + qceff_table_filename = '' + / + +&perfect_model_obs_nml + read_input_state_from_file = .true., + single_file_in = .false. + input_state_files = "filter_input_0001.nc" + + write_output_state_to_file = .false., + single_file_out = .false. + output_state_files = "perfect_output.nc" + output_interval = 1, + + async = 0, + adv_ens_command = "./advance_model.csh", + + obs_seq_in_file_name = "obs_seq.in", + obs_seq_out_file_name = "obs_seq.out", + init_time_days = 0, + init_time_seconds = 0, + first_obs_days = -1, + first_obs_seconds = -1, + last_obs_days = -1, + last_obs_seconds = -1, + + trace_execution = .false., + output_timestamps = .false., + print_every_nth_obs = -1, + output_forward_op_errors = .false., + silence = .false., + / + +&filter_nml + single_file_in = .false., + input_state_files = '' + input_state_file_list = 'filter_input_files.txt' + + stages_to_write = 'preassim', 'analysis', 'output' + + single_file_out = .false., + output_state_files = '' + output_state_file_list = 'filter_output_files.txt' + output_interval = 1, + output_members = .true. + num_output_state_members = 20, + output_mean = .true. + output_sd = .true. + write_all_stages_at_end = .false. + compute_posterior = .true. + + ens_size = 10, + num_groups = 1, + perturb_from_single_instance = .false., + perturbation_amplitude = 0.2, + distributed_state = .true. + + async = 4, + adv_ens_command = "./advance_model.csh", + + obs_sequence_in_name = "obs_seq.out", + obs_sequence_out_name = "obs_seq.final", + num_output_obs_members = 20, + init_time_days = 0, + init_time_seconds = 0, + first_obs_days = -1, + first_obs_seconds = -1, + last_obs_days = -1, + last_obs_seconds = -1, + + inf_flavor = 5, 0, + inf_initial_from_restart = .false., .false., + inf_sd_initial_from_restart = .false., .false., + inf_deterministic = .true., .true., + inf_initial = 1.0, 1.0, + inf_lower_bound = 0.0, 1.0, + inf_upper_bound = 100.0, 1000000.0, + inf_damping = 1.0, 1.0, + inf_sd_initial = 0.6, 0.0, + inf_sd_lower_bound = 0.6, 0.0, + inf_sd_max_change = 1.05, 1.05, + + trace_execution = .false., + output_timestamps = .false., + output_forward_op_errors = .false., + silence = .false., + / + + +&ensemble_manager_nml + / + +&assim_tools_nml + cutoff = 0.4 + sort_obs_inc = .false., + spread_restoration = .false., + sampling_error_correction = .false., + adaptive_localization_threshold = -1, + distribute_mean = .false. + output_localization_diagnostics = .false., + localization_diagnostics_file = 'localization_diagnostics', + print_every_nth_obs = 0 + / + +&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. + / + +&obs_kind_nml + assimilate_these_obs_types = 'GND_GPS_VTEC', + 'SLANT_GPS_VTEC', + 'SAT_TEMPERATURE', + 'SAT_DENSITY_ION_O2P', + 'SAT_DENSITY_NEUTRAL_O2', + 'SAT_DENSITY_ION_N2P' + / + +&model_nml + template_file = '../../../models/aether_cube_sphere/work/filter_input_0001.nc' + time_step_days = 0, + time_step_seconds = 3600 + variables = 'Temperature','QTY_TEMPERATURE', '0.0', 'NA', 'UPDATE', + 'O2+', 'QTY_DENSITY_ION_O2P', '0.0', 'NA', 'UPDATE', + 'O2', 'QTY_DENSITY_NEUTRAL_O2', '0.0', 'NA', 'UPDATE', + 'N2+', 'QTY_DENSITY_ION_N2P', '0.0', 'NA', 'UPDATE', + 'ION_E', 'QTY_DENSITY_ION_E', '0.0', 'NA', 'UPDATE', + '2D_F10.7', 'QTY_1D_PARAMETER', '0.0', 'NA', 'UPDATE' + / + +&utilities_nml + TERMLEVEL = 1, + module_details = .false., + logfilename = 'dart_log.out', + nmlfilename = 'dart_log.nml', + write_nml = 'none' + / + +&preprocess_nml + 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_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' + obs_type_files = '../../../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', + '../../../observations/forward_operators/obs_def_metar_mod.f90', + '../../../observations/forward_operators/obs_def_dew_point_mod.f90', + '../../../observations/forward_operators/obs_def_rel_humidity_mod.f90', + '../../../observations/forward_operators/obs_def_gps_mod.f90', + '../../../observations/forward_operators/obs_def_vortex_mod.f90', + '../../../observations/forward_operators/obs_def_gts_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' + / + +&obs_sequence_tool_nml + 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, + print_only = .false., + gregorian_cal = .false. + / + +&obs_diag_nml + obs_sequence_name = 'obs_seq.final', + bin_width_days = -1, + bin_width_seconds = -1, + init_skip_days = 0, + init_skip_seconds = 0, + Nregions = 3, + trusted_obs = 'null', + lonlim1 = 0.00, 0.00, 0.50 + lonlim2 = 1.01, 0.50, 1.01 + reg_names = 'whole', 'yin', 'yang' + create_rank_histogram = .true., + outliers_in_histogram = .true., + use_zero_error_obs = .false., + verbose = .false. + / + +&state_vector_io_nml + / + +&model_mod_check_nml + input_state_files = 'filter_input_0001.nc' + output_state_files = 'mmc_output.nc' + test1thru = 0 + run_tests = 1,2,3,4,5,6,7 + x_ind = 12 + loc_of_interest = 98.5, 85.5, 96344 + quantity_of_interest = 'QTY_TEMPERATURE' + interp_test_dlon = 4.0 + interp_test_lonrange = 0.0, 360.0 + interp_test_dlat = 4.0 + interp_test_latrange = -90.0, 90.0 + interp_test_dvert = 2000.0 + interp_test_vertrange = 100000.0, 106000.0 + interp_test_vertcoord = 'VERTISHEIGHT' + verbose = .true. + / + +&quality_control_nml + input_qc_threshold = 3.0, + outlier_threshold = -1.0, +/ + +&location_nml + horiz_dist_only = .false. + vert_normalization_pressure = 20000.0 + vert_normalization_height = 100000.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 + / + +&aether_to_dart_nml + aether_file_directory = '../TEST_INPUT/' + dart_file_directory = './' + / + +&dart_to_aether_nml + dart_file_directory = './' + aether_file_directory = '../TEST_OUTPUT/' + + / + +&transform_state_nml + np = 18 + nblocks = 6 + nhalos = 2 + scalar_f10_7 = .false. + / diff --git a/developer_tests/aether_grid/work/quickbuild.sh b/developer_tests/aether_grid/work/quickbuild.sh new file mode 100755 index 0000000000..1b83a9ad85 --- /dev/null +++ b/developer_tests/aether_grid/work/quickbuild.sh @@ -0,0 +1,50 @@ +#!/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="aether_cube_sphere" +LOCATION="threed_sphere" +dev_test=1 +TEST="aether_grid" + + +programs=( +test_aether_grid +) + +serial_programs=( +) + +model_programs=( +) + +model_serial_programs=( +aether_to_dart +dart_to_aether +) + +# quickbuild arguments +arguments "$@" + +# clean the directory +\rm -f -- *.o *.mod Makefile .cppdefs + +# build and run preprocess before making any other DART executables +buildpreprocess + +# build +buildit + +# clean up +\rm -f -- *.o *.mod + +} + +main "$@" diff --git a/index.rst b/index.rst index b824c35f91..ab36d13475 100644 --- a/index.rst +++ b/index.rst @@ -392,6 +392,7 @@ References models/9var/readme models/aether_lat-lon/readme + models/aether_cube_sphere/readme models/am2/readme models/bgrid_solo/readme models/cam-fv/readme diff --git a/models/README.rst b/models/README.rst index d86bf7a5ed..5fd8a609d6 100644 --- a/models/README.rst +++ b/models/README.rst @@ -6,6 +6,8 @@ Supported Models DART supported models: - :doc:`9var/readme` +- :doc:`aether_lat-lon/readme` +- :doc:`aether_cube_sphere/readme` - :doc:`am2/readme` - :doc:`bgrid_solo/readme` - :doc:`cam-fv/readme` diff --git a/models/aether_cube_sphere/aether_to_dart.f90 b/models/aether_cube_sphere/aether_to_dart.f90 new file mode 100644 index 0000000000..fda4b9f682 --- /dev/null +++ b/models/aether_cube_sphere/aether_to_dart.f90 @@ -0,0 +1,48 @@ +! 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$ + +! Converts aether restart block files to a DART filter input file + +program aether_to_dart + +use utilities_mod, only : initialize_utilities, finalize_utilities, & + find_namelist_in_file, check_namelist_read + +use transform_state_mod, only : initialize_transform_state_mod, model_to_dart, & + get_ensemble_range_from_command_line + +implicit none + +character(len=256) :: aether_file_directory, dart_file_directory + +namelist /aether_to_dart_nml / aether_file_directory, dart_file_directory + +integer :: iunit, io +integer :: ens, start_ens, end_ens + +!---------------------------------------------------------------- + +call initialize_utilities(progname='aether_to_dart') + +! Read the namelist +call find_namelist_in_file('input.nml', 'aether_to_dart_nml', iunit) +read(iunit, nml = aether_to_dart_nml, iostat = io) +call check_namelist_read(iunit, io, 'aether_to_dart_nml') + +call initialize_transform_state_mod() + +! Do the conversion for a range of ensemble members +call get_ensemble_range_from_command_line(start_ens, end_ens) + +! The DART SE team has pointed out concerns about having the loop in the program +! Loop through the ensemble members and transform each +do ens = start_ens, end_ens + call model_to_dart(aether_file_directory, dart_file_directory, ens) +end do + +call finalize_utilities('aether_to_dart') + +end program aether_to_dart diff --git a/models/aether_cube_sphere/create_obs_sequence.input b/models/aether_cube_sphere/create_obs_sequence.input new file mode 100644 index 0000000000..ba1558e569 --- /dev/null +++ b/models/aether_cube_sphere/create_obs_sequence.input @@ -0,0 +1,58 @@ +6 +0 +0 +0 +SAT_TEMPERATURE +3 +110000 +90 +45 +0 0 +1.2 +0 +SAT_DENSITY_ION_O2P +3 +180000 +90 +-45 +0 0 +1.3 +0 +SAT_DENSITY_ION_N2P +3 +250000 +270 +30 +0 0 +1.4 +0 +SAT_DENSITY_NEUTRAL_O2 +3 +350000 +270 +-30 +0 0 +1.5 +0 +GND_GPS_VTEC +-2 +180 +60 +0 0 +0.1 +0 +SLANT_GPS_VTEC +160 +50 +345678 +170 +45 +111 +-2 +180 +-10 +0 0 +0.25 +obs_seq.in + + diff --git a/models/aether_cube_sphere/cube_sphere_grid_tools.f90 b/models/aether_cube_sphere/cube_sphere_grid_tools.f90 new file mode 100644 index 0000000000..486ed3d0e3 --- /dev/null +++ b/models/aether_cube_sphere/cube_sphere_grid_tools.f90 @@ -0,0 +1,886 @@ +! 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 +! + +module cube_sphere_grid_tools_mod + +! This module provides tools that know about the horizontal geometry and relation to +! storage patterns for the Aether cube sphere grid. + +use types_mod, only : r8, PI + +use utilities_mod, only : error_handler, E_ERR + +implicit none +private + +public :: lat_lon_to_col_index, col_index_to_lat_lon, get_bounding_box, & + is_point_in_triangle, is_point_in_quad, lat_lon_to_xyz, & + grid_to_lat_lon, lat_lon_to_grid, get_face, fix_face, get_corners, & + get_grid_delta + +! version controlled file description for error handling, do not edit +character(len=*), parameter :: source = "$URL$" +character(len=*), parameter :: revision = "$Revision$" +character(len=*), parameter :: revdate = "$Date$" + +contains + +!------------------------------------------------------------------ + +! Compute the spacing between grid rows on a face + +subroutine get_grid_delta(np, del, half_del) + +integer, intent(in) :: np +real(r8), intent(out) :: del, half_del + +real(r8) :: cube_side + +! Cube side is divided into np-1 interior intervals of width 2sqrt(1/3) / np and +! two exterior intervals of half width, sqrt(1/3) / np +cube_side = 2.0_r8 * sqrt(1.0_r8 / 3.0_r8) +! Get the spacing of the grid points +del = cube_side / np +half_del = del / 2.0_r8 + +end subroutine get_grid_delta + +!------------------------------------------------------------------ + +! Given the face (from 0 to 5) the number of lons/lats on a face (np) and +! the i and j indices of the grid point, returns the latitude and longitude of the point + +subroutine grid_to_lat_lon(face, lat_ind, lon_ind, del, half_del, lat, lon) + +integer, intent(in) :: face, lat_ind, lon_ind +real(r8), intent(in) :: del, half_del +real(r8), intent(out) :: lat, lon + +real(r8) :: x, y, blon, blat, rot_angle +real(r8) :: vect(3), rot_vect(3), RZ(3, 3) + +! Get the x and y positions on the face +x = sqrt(1.0_r8/3.0_r8) - (half_del + del * (lon_ind - 1)) +if(face == 5) then + y = sqrt(1.0_r8/3.0_r8) - (half_del + del * (lat_ind - 1)) +else + y = -sqrt(1.0_r8/3.0_r8) + (half_del + del * (lat_ind - 1)) +endif + +! These are the faces tangent to the equator +if(face < 4) then + blon = atan2(sqrt(1.0_r8 / 3.0_r8), x) + blat = atan2(y, sqrt(1.0_r8/3.0_r8 + x**2.0_r8)) + blon = blon - PI/4.0_r8 + + ! Above is for face 0; add PI/2 for each additional face tangent to equator + lon = blon + PI/2.0_r8 * face; + lat = blat; +elseif(face == 4 .or. face == 5) then + ! Face 4 is tangent to south pole + lon = atan2(y, x) + lat = atan2(sqrt(1.0_r8/3.0_r8), sqrt(x**2.0_r8 + y**2.0_r8)) + + if(face == 4) lat = -lat + + ! Get ready for rotation + vect = lat_lon_to_xyz(lat, lon) + + ! Then rotate 45 degrees around Z + rot_angle = -PI/4.0_r8; + + ! Create the rotation matrix + RZ(1, 1:3) = [cos(rot_angle), sin(rot_angle), 0.0_r8] + RZ(2, 1:3) = [-sin(rot_angle), cos(rot_angle), 0.0_r8] + RZ(3, 1:3) = [0.0_r8, 0.0_r8, 1.0_r8] + rot_vect = matmul(RZ, vect) + + lat = asin(rot_vect(3)) + lon = atan2(rot_vect(2), rot_vect(1)) + ! There are inconsistent treatments of the value near longitude + ! 0 in the grid files for Aether. Some points have a value near or just less + ! than 2PI, other points have values just greater than 0. This code + ! avoids values near to 2PI and converts to near 0 instead. + if(lon < 0.0_r8) lon = lon + 2.0_r8*PI + if(lon >= 2.0_r8*PI) lon = 0.0_r8 + +endif + +end subroutine grid_to_lat_lon + +!----------------------------------------------------------------------- + +! Convert from latitude longitude, to the face and indices on the face +! of a correpsonding grid point + +subroutine lat_lon_to_grid(lat, lon, del, half_del, face, lat_ind, lon_ind) + +real(r8), intent(in) :: lat, lon, del, half_del +integer, intent(out) :: face, lat_ind, lon_ind + +real(r8) :: len(2) + +! Get the face and the length along the two imbedded cube faces for the point +call get_face(lat, lon, face, len); + +! Figure out which interval this is in along each cube face; This gives 0 to np grid indices +lon_ind = nint((len(1) + half_del) / del) +lat_ind = nint((len(2) + half_del) / del) + +end subroutine lat_lon_to_grid + +!----------------------------------------------------------------------- + +! For points past the edge of a face, finds the corresponding points on the adjacent face + +subroutine fix_face(face, lat_grid, lon_grid, np, f_face, f_lat_grid, f_lon_grid, edge, corner) + +integer, intent(in) :: face, lat_grid, lon_grid, np +integer, intent(out) :: f_face, f_lat_grid, f_lon_grid +logical, intent(out) :: edge, corner + +integer :: left_neighbor(6), right_neighbor(6) +integer :: bottom_neighbor(6), top_neighbor(6) +integer :: left_lon_grid(6), right_lon_grid(6) +integer :: left_lat_grid(6), right_lat_grid(6) +integer :: bottom_lon_grid(6), top_lon_grid(6) +integer :: bottom_lat_grid(6), top_lat_grid(6) + +! Default is not a corner or an edge +corner = .false. +edge = .false. + +! Just return if no edge +if(lon_grid > 0 .and. lon_grid < np + 1 .and. lat_grid > 0 .and. lat_grid < np + 1) then + f_face = face + f_lon_grid = lon_grid + f_lat_grid = lat_grid + return +endif + +! Return illegal value for face information if on a corner +if((lat_grid == 0 .or. lat_grid == np + 1) .and. (lon_grid == 0 .or. lon_grid == np + 1)) then + corner = .true. + f_face = -99 + f_lon_grid = -99 + f_lat_grid = -99 + return +endif + +! Otherwise, on an edge +edge = .true. +! Deal with each side of faces separately +if(lon_grid == 0) then + ! On left edge + left_neighbor = [3, 0, 1, 2, 0, 0] + f_face = left_neighbor(face + 1) + left_lon_grid = [np, np, np, np, lat_grid, np+1-lat_grid] + f_lon_grid = left_lon_grid(face + 1) + left_lat_grid = [lat_grid, lat_grid, lat_grid, lat_grid, 1, np] + f_lat_grid = left_lat_grid(face + 1) +elseif(lon_grid == np + 1) then + ! On right edge + right_neighbor = [1, 2, 3, 0, 2, 2] + f_face = right_neighbor(face + 1) + right_lon_grid = [1, 1, 1, 1, np+1-lat_grid, lat_grid] + f_lon_grid = right_lon_grid(face + 1) + right_lat_grid = [lat_grid, lat_grid, lat_grid, lat_grid, 1, np] + f_lat_grid = right_lat_grid(face + 1) +elseif(lat_grid == 0) then + ! On bottom edge + bottom_neighbor = [4, 4, 4, 4, 3, 1] + f_face = bottom_neighbor(face + 1) + bottom_lon_grid = [1, lon_grid, np, np+1-lon_grid, np+1-lon_grid, lon_grid] + f_lon_grid = bottom_lon_grid(face + 1) + bottom_lat_grid = [lon_grid, np, np+1-lon_grid, 1, 1, np] + f_lat_grid = bottom_lat_grid(face + 1) +elseif(lat_grid == np + 1) then + ! On top edge + top_neighbor = [5, 5, 5, 5, 1, 3] + f_face = top_neighbor(face + 1) + top_lon_grid = [1, lon_grid, np, np+1-lon_grid, lon_grid, np+1-lon_grid] + f_lon_grid = top_lon_grid(face + 1) + top_lat_grid = [np+1-lon_grid, 1, lon_grid, np, 1, np] + f_lat_grid = top_lat_grid(face + 1) +endif + +end subroutine fix_face + +!----------------------------------------------------------------------- + +! Returns which face contains (lat, lon_in) and the length from the edge of the point +! along each of the great circle axes. + +subroutine get_face(lat, lon_in, face, len) + +real(r8), intent(in) :: lat, lon_in +integer, intent(out) :: face +real(r8), intent(out) :: len(2) + +integer :: side, rside, rside2 +real(r8) :: inv_sqrt_2, rlon, rlon2, gama, gamb, lon +real(r8) :: vec(3), rot_vec(3), rot_vec2(3), rot(3, 3), rot2(3, 3), lon_grid(2), lon_grid_m(2) + +! Range adjustment due to Aether roundoff around 2 PI +lon = lon_in +if(lon >= 2.0_r8*PI) lon = 0.0_r8 + +! Convert lat lon to x y z on unit sphere +vec = lat_lon_to_xyz(lat, lon) + +! Get the longitudes for this point in the two rotated spaces + +!==================================================================== +! Following code shows individual rotations; +! Can collapse these to a single rotation vector for efficiency +! Rotation 90 degrees around y to put pole on equator +!RY = [cosd(90) 0 -sind(90); 0 1 0; sind(90) 0 cosd(90)]; +! Rotate 45 degrees around x +!RX = [1 0 0; 0 cosd(45) sind(45); 0 -sind(45) cosd(45)]; +! Then rotate 45 degrees around Z +!RZ = [cosd(45) sind(45) 0; -sind(45) cosd(45) 0; 0 0 1]; +! Get longitude in the two rotated spaces +!rot_vec = RZ * RX * RY * vec; +!==================================================================== +inv_sqrt_2 = 1.0_r8 / sqrt(2.0_r8); +rot(1, 1:3) = [0.5_r8, 0.5_r8, -inv_sqrt_2] +rot(2, 1:3) = [0.5_r8, 0.5_r8, inv_sqrt_2 ] +rot(3, 1:3) = [inv_sqrt_2, -inv_sqrt_2, 0.0_r8 ] +rot_vec = matmul(rot, vec) +! Compute the longitude in the rotated space +rlon = atan2(rot_vec(2), rot_vec(1)) +if(rlon < 0.0_r8) rlon = rlon + 2.0_r8*PI + +!==================================================================== +! Can collapse these to a single rotation vector for efficiency +! Rotation 90 degrees around y to put pole on equator +!RY = [cosd(90) 0 -sind(90); 0 1 0; sind(90) 0 cosd(90)]; +! Rotate -45 degrees around x +!RX2 = [1 0 0; 0 cosd(-45) sind(-45); 0 -sind(-45) cosd(-45)]; +! Then rotate 45 degrees around Z +!RZ = [cosd(45) sind(45) 0; -sind(45) cosd(45) 0; 0 0 1]; +! Get longitude in the two rotated spaces +!rot_vec2 = RZ * RX2 * RY * vec; +!==================================================================== +rot2(1, 1:3) = [-0.5_r8, 0.5_r8, -inv_sqrt_2] +rot2(2, 1:3) = [-0.5_r8, 0.5_r8, inv_sqrt_2 ] +rot2(3, 1:3) = [inv_sqrt_2, inv_sqrt_2, 0.0_r8 ] +rot_vec2 = matmul(rot2, vec) +! Compute the longitude in the rotated space +rlon2 = atan2(rot_vec2(2), rot_vec2(1)) +if(rlon2 < 0.0_r8) rlon2 = rlon2 + 2.0_r8*PI + +! Which non-polar side could we be on, 1 to 4 +side = floor(lon / (PI/2.0_r8)) + 1.0_r8 +! Which rotated 1 side are we on +rside = floor(rlon / (PI/2.0_r8)) + 1.0_r8 +! Which rotated 2 side +rside2 = floor(rlon2 / (PI/2.0_r8)) + 1.0_r8 + +! Figure out the face from here (0 to 5, 4 is south, 5 is north) +! These are consistent with the numbering on Aether grid files for the cubed sphere +if ( side == 1 .and. rside == 1) then + face = 0; lon_grid(1) = lon; lon_grid(2) = rlon +elseif( side == 2 .and. rside2 == 1) then + face = 1; lon_grid(1) = lon; lon_grid(2) = rlon2 +elseif( side == 3 .and. rside == 3) then + face = 2; lon_grid(1) = lon; lon_grid(2) = rlon +elseif( side == 4 .and. rside2 == 3) then + face = 3; lon_grid(1) = lon; lon_grid(2) = rlon2 +elseif(rside == 4 .and. rside2 == 4) then + face = 4; lon_grid(1) = rlon; lon_grid(2) = rlon2 +elseif(rside == 2 .and. rside2 == 2) then + face = 5; lon_grid(1) = rlon; lon_grid(2) = rlon2 +endif + +! Can use the fact that the projection is equidistant on the imbedded cube to get what fraction +! across the imbedded rectangle we are +! Take the longitudes and turn them into a number between -sqrt(1/3) and sqrt(1/3) +lon_grid_m = mod(lon_grid, PI/2.0_r8) + +! Use law of sines to go from lon back to position along edge of imbedded cube +! The triangle of interest has a side of length 2sqrt(1/3) (1/2 of the planar diagonal of the imbedded cube) +! The angles adjacent to this side are the longitude and 45 degrees +! The angle opposite the side of length 2sqrt(1/3) is PI - (longitude + PI/4) +! The side opposite the longitude is how far along the side of the cube +! The cube side is 2sqrt(1/3), so the length along the side is between zero and this value +gama = PI - (PI/4.0_r8 + lon_grid_m(1)) +len(1) = sqrt(2.0_r8/3.0_r8) * sin(lon_grid_m(1)) / sin(gama) + +gamb = PI - (PI/4 + lon_grid_m(2)) +len(2) = sqrt(2.0_r8/3.0_r8) * sin(lon_grid_m(2)) / sin(gamb) + +! If we are on sides 2 or 3, the lengths need to be modified because the grid storage +! for Aether goes from smallest latitude to largest and the longitudes of the shifted +! poles are going the opposite way +if(face == 2 .or. face == 3) len(2) = 2.0_r8 * sqrt(1.0_r8/3.0_r8) - len(2) + +! Same for face 4 (the bottom) but it's the other coordinate that's reversed +if(face == 4) len(1) = 2.0_r8*sqrt(1.0_r8/3.0_r8) - len(1) + +end subroutine get_face + +!----------------------------------------------------------------------- + +! Checks to see if the point under consideration is at a corner +! If it is, return the face, lat_index, and lon_index for each of the three bounding points + +subroutine get_corners(face, lat_grid, lon_grid, np, lat, lon, del, half_del, & + f_face, f_lat_grid, f_lon_grid, num_bound_points) + +integer, intent(in) :: face, lat_grid, lon_grid, np +real(r8), intent(in) :: lat, lon, del, half_del +integer, intent(out) :: f_face(4), f_lat_grid(4), f_lon_grid(4), num_bound_points + +integer :: corner, quad, i +integer :: quad_lon_grid(3, 4), quad_lat_grid(3, 4), quad_face(3, 4) +real(r8) :: pxyz(3), qxyz(4, 3), grid_pt_lat, grid_pt_lon + +! Default is to find a triangle +num_bound_points = 3 + +if(face == 0) then + if (lat_grid == 0 .and. lon_grid == 0 ) then + corner = 1 + elseif(lat_grid == 0 .and. lon_grid == np+1) then + corner = 2 + elseif(lat_grid == np+1 .and. lon_grid == 0 ) then + corner = 5 + else + corner = 6; + endif +elseif(face == 1) then + if (lat_grid == 0 .and. lon_grid == 0 ) then + corner = 2 + elseif(lat_grid == 0 .and. lon_grid == np+1) then + corner = 3 + elseif(lat_grid == np+1 .and. lon_grid == 0 ) then + corner = 6 + else + corner = 7 + endif +elseif(face == 2) then + if (lat_grid == 0 .and. lon_grid == 0 ) then + corner = 3 + elseif(lat_grid == 0 .and. lon_grid == np+1) then + corner = 4 + elseif(lat_grid == np+1 .and. lon_grid == 0 ) then + corner = 7 + else + corner = 8 + endif +elseif(face == 3) then + if (lat_grid == 0 .and. lon_grid == 0 ) then + corner = 4 + elseif(lat_grid == 0 .and. lon_grid == np+1) then + corner = 1 + elseif(lat_grid == np+1 .and. lon_grid == 0 ) then + corner = 8 + else + corner = 5; + endif +elseif(face == 4) then + if (lat_grid == 0 .and. lon_grid == 0 ) then + corner = 1 + elseif(lat_grid == 0 .and. lon_grid == np+1) then + corner = 4 + elseif(lat_grid == np+1 .and. lon_grid == 0 ) then + corner = 2 + else + corner = 3 + endif +elseif(face == 5) then + if (lat_grid == 0 .and. lon_grid == 0 ) then + corner = 6 + elseif(lat_grid == 0 .and. lon_grid == np+1) then + corner = 7 + elseif(lat_grid == np+1 .and. lon_grid == 0 ) then + corner = 5 + else + corner = 8; + endif +endif + +! Harvest the information on the grid points bounding the appropriate corner +! Arrays of info for adjacent quads for bulges (three of them, first index) +quad_lon_grid(1:3, 1:4) = -99 +quad_lat_grid(1:3, 1:4) = -99 +quad_face(1:3, 1:4) = -99 + +if(corner == 1) then + f_face(1:3) = [3, 0, 4] + f_lon_grid(1:3) = [np, 1, 1] + f_lat_grid(1:3) = [1, 1, 1] + quad_face(1, 1:4) = [3, 0, 0, 3] + quad_face(2, 1:4) = [0, 0, 4, 4] + quad_face(3, 1:4) = [3, 3, 4, 4] + quad_lat_grid(1, 1:4) = [1, 1, 2, 2] + quad_lat_grid(2, 1:4) = [1, 1, 1, 2] + quad_lat_grid(3, 1:4) = [1, 1, 1, 1] + quad_lon_grid(1, 1:4) = [np, 1, 1, np] + quad_lon_grid(2, 1:4) = [1, 2, 1, 1 ] + quad_lon_grid(3, 1:4) = [np-1, np, 1, 2 ] +elseif(corner == 2) then + f_face(1:3) = [0, 1, 4 ] + f_lon_grid(1:3) = [np, 1, 1 ] + f_lat_grid(1:3) = [1, 1, np] + quad_face(1, 1:4) = [0, 1, 1, 0] + quad_face(2, 1:4) = [1, 1, 4, 4] + quad_face(3, 1:4) = [0, 0, 4, 4] + quad_lat_grid(1, 1:4) = [1, 1, 2, 2 ] + quad_lat_grid(2, 1:4) = [1, 1, np, np ] + quad_lat_grid(3, 1:4) = [1, 1, np, np-1] + quad_lon_grid(1, 1:4) = [np, 1, 1, np] + quad_lon_grid(2, 1:4) = [1, 2, 2, 1 ] + quad_lon_grid(3, 1:4) = [np-1, np, 1, 1 ] +elseif(corner == 3) then + f_face(1:3) = [1, 2, 4 ] + f_lon_grid(1:3) = [np, 1, np] + f_lat_grid(1:3) = [1, 1, np] + quad_face(1, 1:4) = [1, 2, 2, 1] + quad_face(2, 1:4) = [2, 2, 4, 4] + quad_face(3, 1:4) = [1, 1, 4, 4] + quad_lat_grid(1, 1:4) = [1, 1, 2, 2 ] + quad_lat_grid(2, 1:4) = [1, 1, np-1, np] + quad_lat_grid(3, 1:4) = [1, 1, np, np] + quad_lon_grid(1, 1:4) = [np, 1, 1, np ] + quad_lon_grid(2, 1:4) = [1, 2, np, np ] + quad_lon_grid(3, 1:4) = [np-1, np, np, np-1] +elseif(corner == 4) then + f_face(1:3) = [2, 3, 4 ] + f_lon_grid(1:3) = [np, 1, np] + f_lat_grid(1:3) = [1, 1, 1 ] + quad_face(1, 1:4) = [2, 3, 3, 2] + quad_face(2, 1:4) = [3, 3, 4, 4] + quad_face(3, 1:4) = [2, 2, 4, 4] + quad_lat_grid(1, 1:4) = [1, 1, 2, 2] + quad_lat_grid(2, 1:4) = [1, 1, 1, 1] + quad_lat_grid(3, 1:4) = [1, 1, 1, 2] + quad_lon_grid(1, 1:4) = [np, 1, 1, np] + quad_lon_grid(2, 1:4) = [1, 2, np-1, np] + quad_lon_grid(3, 1:4) = [np-1, np, np, np] +elseif(corner == 5) then + f_face(1:3) = [3, 0, 5 ] + f_lon_grid(1:3) = [np, 1, 1 ] + f_lat_grid(1:3) = [np, np, np] + quad_face(1, 1:4) = [3, 0, 0, 3] + quad_face(2, 1:4) = [0, 0, 5, 5] + quad_face(3, 1:4) = [3, 3, 5, 5] + quad_lat_grid(1, 1:4) = [np-1, np-1, np, np ] + quad_lat_grid(2, 1:4) = [np, np, np, np-1] + quad_lat_grid(3, 1:4) = [np, np, np, np ] + quad_lon_grid(1, 1:4) = [np, 1, 1, np] + quad_lon_grid(2, 1:4) = [1, 2, 1, 1 ] + quad_lon_grid(3, 1:4) = [np-1, np, 1, 2 ] +elseif(corner == 6) then + f_face(1:3) = [0, 1, 5 ] + f_lon_grid(1:3) = [np, 1, 1] + f_lat_grid(1:3) = [np, np, 1] + quad_face(1, 1:4) = [0, 1, 1, 0] + quad_face(2, 1:4) = [1, 1, 5, 5] + quad_face(3, 1:4) = [0, 0, 5, 5] + quad_lat_grid(1, 1:4) = [np-1, np-1, np, np] + quad_lat_grid(2, 1:4) = [np, np, 1, 1 ] + quad_lat_grid(3, 1:4) = [np, np, 1, 2 ] + quad_lon_grid(1, 1:4) = [np, 1, 1, np] + quad_lon_grid(2, 1:4) = [1, 2, 2, 1 ] + quad_lon_grid(3, 1:4) = [np-1, np, 1, 1 ] +elseif(corner == 7) then + f_face(1:3) = [1, 2, 5 ] + f_lon_grid(1:3) = [np, 1, np] + f_lat_grid(1:3) = [np, np, 1 ] + quad_face(1, 1:4) = [1, 2, 2, 1] + quad_face(2, 1:4) = [2, 2, 5, 5] + quad_face(3, 1:4) = [1, 1, 5, 5] + quad_lat_grid(1, 1:4) = [np-1, np-1, np, np] + quad_lat_grid(2, 1:4) = [np, np, 1, 2] + quad_lat_grid(3, 1:4) = [np, np, 1, 1] + quad_lon_grid(1, 1:4) = [np, 1, 1, np ] + quad_lon_grid(2, 1:4) = [1, 2, np, np ] + quad_lon_grid(3, 1:4) = [np-1, np, np, np-1] +elseif(corner == 8) then + f_face(1:3) = [2, 3, 5 ] + f_lon_grid(1:3) = [np, 1, np] + f_lat_grid(1:3) = [np, np, np] + quad_face(1, 1:4) = [2, 3, 3, 2] + quad_face(2, 1:4) = [3, 3, 5, 5] + quad_face(3, 1:4) = [2, 2, 5, 5]; + quad_lat_grid(1, 1:4) = [np-1, np-1, np, np ] + quad_lat_grid(2, 1:4) = [np, np, np, np ] + quad_lat_grid(3, 1:4) = [np, np, np, np-1] + quad_lon_grid(1, 1:4) = [np, 1, 1, np] + quad_lon_grid(2, 1:4) = [1, 2, np-1, np] + quad_lon_grid(3, 1:4) = [np-1, np, np, np] +endif + +! Load up the array for the point +pxyz = lat_lon_to_xyz(lat, lon) + +! Get lats and lons of the triangle vertices +do i = 1, 3 + call grid_to_lat_lon(f_face(i), f_lat_grid(i), f_lon_grid(i), & + del, half_del, grid_pt_lat, grid_pt_lon) + ! Convert to x, y, z coords to check for whether points are in tris/quads + qxyz(i, 1:3) = lat_lon_to_xyz(grid_pt_lat, grid_pt_lon) +enddo + +! See if the point is in the triangle; if so, all is good +if(is_point_in_triangle(qxyz(1, :), qxyz(2, :), qxyz(3, :), pxyz)) return + +! If it's not in the triangle, have to check the three adjacent quads at the corner +! This can happen because edges are really on great circles +num_bound_points = 4 + +do quad = 1, 3 + ! Compute lat and lon for a quad + do i = 1, 4 + call grid_to_lat_lon(quad_face(quad, i), quad_lat_grid(quad, i), quad_lon_grid(quad, i), & + del, half_del, grid_pt_lat, grid_pt_lon) + ! Convert to x, y, z coords to check for whether points are in tris/quads + qxyz(i, 1:3) = lat_lon_to_xyz(grid_pt_lat, grid_pt_lon) + enddo + + ! See if the point is inside this quad + if(is_point_in_quad(qxyz, pxyz)) then + f_face = quad_face(quad, 1:4) + f_lat_grid = quad_lat_grid(quad, 1:4) + f_lon_grid = quad_lon_grid(quad, 1:4) + return + endif +enddo + +! Falling of the end should not happen; +call error_handler(E_ERR, 'get_corners', 'Reached end of subroutine get_corners', & + source, revision, revdate, 'This should not be possible') + +end subroutine get_corners + +!----------------------------------------------------------------------- + +! Given the latitude and longitude of a point, returns the face, array indices, latitude +! and longitude of the bounding three or four grid points along the number of points +! (3 triangle; 4 quad). np is the number of grid points across each face of the cube sphere. + +subroutine get_bounding_box(lat, lon, del, half_del, np, & + grid_face, grid_lat_ind, grid_lon_ind, grid_pt_lat, grid_pt_lon, num_bound_points) + +integer, intent(in) :: np +real(r8), intent(in) :: lat, lon, del, half_del +integer, intent(out) :: grid_face(4), grid_lat_ind(4), grid_lon_ind(4), num_bound_points +real(r8), intent(out) :: grid_pt_lat(4), grid_pt_lon(4) + +integer :: face, low_grid(2), hi_grid(2), i, my_pt, corner_index +integer :: lat_grid(4), lon_grid(4), face1_pts(2), face2_pts(2), face1_count, face2_count +real(r8) :: len(2), qxyz(4, 3), pxyz(3) +logical :: on_edge, edge, corner + +! Get the face and the length along the two imbedded cube faces for the point +call get_face(lat, lon, face, len); + +! Figure out which interval this is in along each cube face; This gives 0 to np grid indices +low_grid(1) = floor((len(1) + half_del) / del) +low_grid(2) = floor((len(2) + half_del) / del) +hi_grid = low_grid + 1 + +! Get the indices for the lat and lon directions: Points go counterclockwise starting from lower left +! For now assume this is a quad, but will correct below if it is a triangle +lat_grid(1) = low_grid(2); lat_grid(2) = hi_grid(2); lat_grid(3) = lat_grid(2); lat_grid(4) = lat_grid(1) +lon_grid(1) = low_grid(1); lon_grid(2) = lon_grid(1); lon_grid(3) = hi_grid(1); lon_grid(4) = lon_grid(3) + +! If points are on the edge map to adjacent faces +on_edge = .false. +do i = 1, 4 + call fix_face(face, lat_grid(i), lon_grid(i), np, & + grid_face(i), grid_lat_ind(i), grid_lon_ind(i), edge, corner) + ! If any point is on an edge, on_edge is true + if(edge) on_edge = .true. + if(corner) then + corner_index = i + exit + endif +enddo + +! If it's at a corner, need to find the triangles in a different fashion +! It is possible that the point initially looks like it is in a corner due to the fact +! that the edges of the grid are on great circles from the corresponding faces, but the +! grid points at the edge are not connected by these great circles. +if(corner) then + call get_corners(face, lat_grid(corner_index), lon_grid(corner_index), np, & + lat, lon, del, half_del, grid_face, grid_lat_ind, grid_lon_ind, num_bound_points) + if(num_bound_points == 4) corner = .false. +else + ! If not initially at a corner it's definitely in a quad + num_bound_points = 4 +endif + +! Compute the lat and lon corresponding to these point +do i = 1, num_bound_points + call grid_to_lat_lon(grid_face(i), grid_lat_ind(i), grid_lon_ind(i), & + del, half_del, grid_pt_lat(i), grid_pt_lon(i)) +enddo + +! Make on_edge true only if we are on an edge but not at a corner +on_edge = (on_edge .and. .not. corner) + +if(on_edge) then + ! If this is an edge, may need to revise box selection + ! See if the point is in the box (approximately) + ! Load up the arrays for the vertex points + do i = 1, num_bound_points + ! Convert to x, y, z coords to check for whether points are in tris/quads + qxyz(i, 1:3) = lat_lon_to_xyz(grid_pt_lat(i), grid_pt_lon(i)) + enddo + + ! Convert point to xyz + pxyz = lat_lon_to_xyz(lat, lon); + + if(.not. is_point_in_quad(qxyz, pxyz)) then + ! Not in this box, need to move 'equatorward' + ! Find indices (from 1 to 4) of points on the same face + face1_pts(1:2) = 0; face2_pts(1:2) = 0; + face1_count = 0; face2_count = 0; + do i = 1, 4 + if(grid_face(i) == grid_face(1)) then + face1_count = face1_count + 1; face1_pts(face1_count) = i + else + face2_count = face2_count + 1; face2_pts(face2_count) = i + endif + enddo + + ! First process points of the first face + ! Are the latitudes or the longitudes on the edge + if(grid_lon_ind(face1_pts(1)) == grid_lon_ind(face1_pts(2))) then + ! Adjust the face1 latitudes + do i = 1, 2 + my_pt = face1_pts(i) + if(grid_lat_ind(my_pt) > np/2) then + grid_lat_ind(my_pt) = grid_lat_ind(my_pt) - 1 + else + grid_lat_ind(my_pt) = grid_lat_ind(my_pt) + 1 + endif + enddo + else + ! Adjust the face1 longitudes + do i = 1, 2 + my_pt = face1_pts(i) + if(grid_lon_ind(my_pt) > np/2) then + grid_lon_ind(my_pt) = grid_lon_ind(my_pt) - 1 + else + grid_lon_ind(my_pt) = grid_lon_ind(my_pt) + 1 + endif + enddo + endif + + ! Do the same thing for face2 + ! Are the latitudes or the longitudes on the edge + if(grid_lon_ind(face2_pts(1)) == grid_lon_ind(face2_pts(2))) then + ! Adjust the face2 latitudes + do i = 1, 2 + my_pt = face2_pts(i); + if(grid_lat_ind(my_pt) > np/2) then + grid_lat_ind(my_pt) = grid_lat_ind(my_pt) - 1 + else + grid_lat_ind(my_pt) = grid_lat_ind(my_pt) + 1 + endif + enddo + else + ! Adjust the face2 longitudes + do i = 1, 2 + my_pt = face2_pts(i); + if(grid_lon_ind(my_pt) > np/2) then + grid_lon_ind(my_pt) = grid_lon_ind(my_pt) - 1 + else + grid_lon_ind(my_pt) = grid_lon_ind(my_pt) + 1 + endif + enddo + endif + + ! Compute the lat and lon corresponding to these point + do i = 1, num_bound_points + call grid_to_lat_lon(grid_face(i), grid_lat_ind(i), grid_lon_ind(i), & + del, half_del, grid_pt_lat(i), grid_pt_lon(i)) + enddo + endif + +endif + +end subroutine get_bounding_box + +!----------------------------------------------------------------------- + +! Given the index of a horizontal column, returns the latitude and longitude in radians + +subroutine col_index_to_lat_lon(col_index, np, del, half_del, lat, lon) + +integer, intent(in) :: col_index, np +real(r8), intent(in) :: del, half_del +real(r8), intent(out) :: lat, lon + +integer :: face, resid, lat_ind, lon_ind + +! Which face are we on? np**2 points per face +face = (col_index - 1) / (np**2) +resid = col_index - face * np**2 + +! Get latitude index +lat_ind = (resid - 1) / np + 1 + +lon_ind = resid - (lat_ind - 1) * np + +! Get the corresponding latitude and longitude +call grid_to_lat_lon(face, lat_ind, lon_ind, del, half_del, lat, lon) + +end subroutine col_index_to_lat_lon + +!----------------------------------------------------------------------- + +! Given a latitude and longitude, return corresponding model column index + +function lat_lon_to_col_index(lat, lon, del, half_del, np) + +integer :: lat_lon_to_col_index +real(r8), intent(in) :: lat, lon, del, half_del +integer, intent(in) :: np + +integer :: face, lat_ind, lon_ind + +! Get the face, lat_ind and lon_ind +call lat_lon_to_grid(lat, lon, del, half_del, face, lat_ind, lon_ind) + +! Confirm that this duplicates the version that requires initialization; +lat_lon_to_col_index = face * np * np + (lat_ind - 1) * np + lon_ind + +end function lat_lon_to_col_index + +!----------------------------------------------------------------------- + +! Convert latitude and longitude to 3D x,y,z + +function lat_lon_to_xyz(lat, lon) + +real(r8) :: lat_lon_to_xyz(3) +real(r8), intent(in) :: lat, lon + +lat_lon_to_xyz(1) = cos(lat) * cos(lon) +lat_lon_to_xyz(2) = cos(lat) * sin(lon) +lat_lon_to_xyz(3) = sin(lat) + +end function lat_lon_to_xyz + +!----------------------------------------------------------------------- + +! Determines if the projection of a point p onto the plane of a triangle with vertices +! v1, v2 and v3 is inside the triangle or not. Computes the areas of each of the triangles +! between p and a pair of vertices. These should sum to the area of the triangle if p +! is inside and be larger than that if p is outside. + +function is_point_in_triangle(v1, v2, v3, p) + +logical :: is_point_in_triangle +real(r8), intent(in) :: v1(3), v2(3), v3(3), p(3) + +real(r8) :: a(3), b(3), perp(3), unit_perp(3), p_proj(3) +real(r8) :: offset, len_s1, len_s2, len_s3, len_p1, len_p2, len_p3, at, at1, at2, at3 +real(r8) :: area_dif, dif_frac, threshold + +! Get the projection of the point p onto the plane containing the triangle +! Start by getting perpendicular vector to plane by cross product +a = v1 - v2 +b = v2 - v3 +perp(1) = a(2) * b(3) - a(3) * b(2) +perp(2) = a(3) * b(1) - a(1) * b(3) +perp(3) = a(1) * b(2) - a(2) * b(1) +! Get unit vector in direction of perp +unit_perp = perp / sqrt(dot_product(perp, perp)) +! Projection of vector from v1 to p on the unit perp vector is how much to move to get to plane +offset = dot_product((p-v1), unit_perp) +p_proj = p - offset * unit_perp + +! Compute lengths of the sides +len_s1 = sqrt(dot_product(v1-v2, v1-v2)) +len_s2 = sqrt(dot_product(v3-v2, v3-v2)) +len_s3 = sqrt(dot_product(v1-v3, v1-v3)) + +! Compute the lengths from the point p +len_p1 = sqrt(dot_product(p_proj-v1, p_proj-v1)) +len_p2 = sqrt(dot_product(p_proj-v2, p_proj-v2)) +len_p3 = sqrt(dot_product(p_proj-v3, p_proj-v3)) + +! Area of triangle +at = heron(len_s1, len_s2, len_s3) + +! Compute areas of sub triangles +at1 = heron(len_p1, len_p2, len_s1) +at2 = heron(len_p2, len_p3, len_s2) +at3 = heron(len_p3, len_p1, len_s3) + +! Difference between sub triangles and the triangle area +area_dif = at1 + at2 + at3 - at + +! Quadrilaterals on the interior of the cube sphere sides are really spherical quads, +! Their sides are great circles. This routine assumes that the triangles composing the quads +! have straight sides in regular space. The algorithm finds points that are inside the +! spherical quads. These quads actually 'bulge' out compared to the regular sides, so it is possible +! to have points that are inside the spherical quad but just barely outside of the regular +! quads. This threshold is tuned so that these points still show as inside. The tuning is for +! np = 18 (number of points along a grid face is 18). Fewer points might require a larger +! threshold while more points might be okay with a smaller one. +threshold = 0.002_r8 + +dif_frac = area_dif / at +is_point_in_triangle = abs(dif_frac) < threshold + +end function is_point_in_triangle + +!----------------------------------------------------------------------- + +! Returns true if point p is in quadrilateral with vertices v + +function is_point_in_quad(v, p) + +logical :: is_point_in_quad +real(r8), intent(in) :: v(4, 3), p(3) + +logical :: inside_t(4) + +integer :: i + +! See if the point is inside this quad; it's inside if it's in one or more contained triangles +inside_t(1) = is_point_in_triangle(v(1, :), v(2, :), v(3, :), p) +inside_t(2) = is_point_in_triangle(v(1, :), v(2, :), v(4, :), p) +inside_t(3) = is_point_in_triangle(v(1, :), v(3, :), v(4, :), p) +inside_t(4) = is_point_in_triangle(v(2, :), v(3, :), v(4, :), p) + +is_point_in_quad = any(inside_t) + +end function is_point_in_quad + +!----------------------------------------------------------------------- + +! Computes Herons formula to get area of triangle from lenghts of sides +! Super accuracy is not needed in the area calculation here + +function heron(a, b, c) + +real(r8) :: heron +real(r8), intent(in) :: a, b, c + +real(r8) :: s, arg + +s = (a + b + c) /2 +arg = (s * (s - a) * (s - b) * (s - c)) + +! Make sure we don't roundoff to a negative +if(arg <= 0.0_r8) then + heron = 0.0_r8 +else + heron = sqrt(arg) +endif + +end function heron + +!----------------------------------------------------------------------- + +end module cube_sphere_grid_tools_mod diff --git a/models/aether_cube_sphere/dart_to_aether.f90 b/models/aether_cube_sphere/dart_to_aether.f90 new file mode 100644 index 0000000000..5dfd317424 --- /dev/null +++ b/models/aether_cube_sphere/dart_to_aether.f90 @@ -0,0 +1,48 @@ +! 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$ + +! Convert DART filter files to Aether block restart files + +program dart_to_aether + +use utilities_mod, only : initialize_utilities, finalize_utilities, & + find_namelist_in_file, check_namelist_read + +use transform_state_mod, only : initialize_transform_state_mod, dart_to_model, & + get_ensemble_range_from_command_line + +implicit none + +character(len=256) :: dart_file_directory, aether_file_directory + +namelist /dart_to_aether_nml / dart_file_directory, aether_file_directory + +integer :: iunit, io +integer :: ens, start_ens, end_ens + +!---------------------------------------------------------------- + +call initialize_utilities(progname='dart_to_aether') + +! Read the namelist +call find_namelist_in_file('input.nml', 'dart_to_aether_nml', iunit) +read(iunit, nml = dart_to_aether_nml, iostat = io) +call check_namelist_read(iunit, io, 'dart_to_aether_nml') + +call initialize_transform_state_mod() + +! Convert for a range of ensemble members +call get_ensemble_range_from_command_line(start_ens, end_ens) + +! The DART SE team has pointed out concerns about having the loop in the program +! Loop through the ensemble members and transform each +do ens = start_ens, end_ens + call dart_to_model(dart_file_directory, aether_file_directory, ens) +end do + +call finalize_utilities('dart_to_aether') + +end program dart_to_aether diff --git a/models/aether_cube_sphere/model_mod.f90 b/models/aether_cube_sphere/model_mod.f90 new file mode 100644 index 0000000000..f595b523a5 --- /dev/null +++ b/models/aether_cube_sphere/model_mod.f90 @@ -0,0 +1,868 @@ +! 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 +! + +module model_mod + +use netcdf + +use types_mod, only : r8, i8, MISSING_R8, vtablenamelength, DEG2RAD, RAD2DEG + +use time_manager_mod, only : time_type, set_time, get_time + +use location_mod, only : location_type, get_close_type, get_dist, & + loc_get_close_obs => get_close_obs, & + loc_get_close_state => get_close_state, & + set_location, query_location, & + get_location, VERTISHEIGHT, VERTISUNDEF, & + VERTISLEVEL + +use utilities_mod, only : register_module, error_handler, E_ERR, E_MSG, & + nmlfileunit, do_nml_file, do_nml_term, & + find_namelist_in_file, check_namelist_read, to_upper, & + find_enclosing_indices + +use obs_kind_mod, only : get_index_for_quantity, QTY_GEOMETRIC_HEIGHT + +use netcdf_utilities_mod, only : nc_add_global_attribute, nc_synchronize_file, & + nc_add_global_creation_time, nc_begin_define_mode, & + nc_end_define_mode, nc_open_file_readonly, nc_close_file + +use distributed_state_mod, only : get_state + +use state_structure_mod, only : add_domain, get_dart_vector_index, get_domain_size, & + get_model_variable_indices, get_varid_from_kind, & + get_variable_name + +use ensemble_manager_mod, only : ensemble_type + +use cube_sphere_grid_tools_mod, only : is_point_in_triangle, is_point_in_quad, grid_to_lat_lon, & + lat_lon_to_xyz, col_index_to_lat_lon, lat_lon_to_grid, & + get_bounding_box, lat_lon_to_col_index, get_grid_delta + +! These routines are passed through from default_model_mod. +use default_model_mod, only : pert_model_copies, read_model_time, write_model_time, & + init_time => fail_init_time, & + init_conditions => fail_init_conditions, & + convert_vertical_obs, convert_vertical_state, adv_1step + +implicit none +private + +! routines required by DART code - will be called from filter and other DART executables. +public :: get_model_size, & + get_state_meta_data, & + model_interpolate, & + end_model, & + static_init_model, & + nc_write_model_atts, & + get_close_obs, & + get_close_state, & + pert_model_copies, & + convert_vertical_obs, & + convert_vertical_state, & + read_model_time, & + adv_1step, & + init_time, & + init_conditions, & + shortest_time_between_assimilations, & + write_model_time + +! Routine for comprehensive test of interpolation +public :: test_grid_box + +! version controlled file description for error handling, do not edit +character(len=*), parameter :: source = "$URL$" +character(len=*), parameter :: revision = "$Revision$" +character(len=*), parameter :: revdate = "$Date$" + +! Error codes +integer, parameter :: INVALID_VERT_COORD_ERROR_CODE = 15 +integer, parameter :: INVALID_ALTITUDE_VAL_ERROR_CODE = 17 +integer, parameter :: INVALID_MODEL_LEVEL_ERROR_CODE = 18 +integer, parameter :: UNKNOWN_OBS_QTY_ERROR_CODE = 20 + +! Error message strings +character(len=512) :: string1 +character(len=512) :: string2 + +integer :: iunit, io + +logical :: module_initialized = .false. +integer :: dom_id ! used to access the state structure +type(time_type) :: assimilation_time_step + +! Geometry variables that are used throughout the module; read from a template file +integer :: np ! Number of grid rows across a face +real(r8) :: del, half_del ! Grid row spacing and half of that +integer :: ncenter_altitudes ! The number of altitudes and the altitudes +real(r8), allocatable :: center_altitude(:) + +! Current model time needed for computing location for scalar F10.7 +type(time_type) :: state_time + +! Horizontal column dimension rather than being direct functions of latitude and longitude. +integer :: no_third_dimension = -99 + +type :: var_type + integer :: count + character(len=64), allocatable :: names(:) + integer, allocatable :: qtys(:) + real(r8), allocatable :: clamp_values(:, :) + logical, allocatable :: updates(:) +end type var_type + +! This is redundant with type defined in transform_state_mod +type :: file_type + character(len=256) :: file_path + integer :: ncid, ncstatus, unlimitedDimId + integer :: nDimensions, nVariables, nAttributes, formatNum +end type file_type + +! Namelist for options to be set at runtime. +character(len=256) :: template_file = 'filter_input_0001.nc' +integer :: time_step_days = 0 +integer :: time_step_seconds = 3600 +integer, parameter :: MAX_STATE_VARIABLES = 100 +integer, parameter :: NUM_STATE_TABLE_COLUMNS = 5 +character(len=vtablenamelength) :: variables(NUM_STATE_TABLE_COLUMNS,MAX_STATE_VARIABLES) = '' + +namelist /model_nml/ template_file, time_step_days, time_step_seconds, variables + +contains + +!------------------------------------------------------------------ +! +! Called to do one time initialization of the model. + +subroutine static_init_model() + +type(var_type) :: var + +module_initialized = .true. + +! Print module information to log file and stdout. +call register_module(source) + +! Read the namelist contents +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) + +! This time is both the minimum time you can ask the model to advance +! (for models that can be advanced by filter) and it sets the assimilation +! window. All observations within +/- 1/2 this interval from the current +! model time will be assimilated. +assimilation_time_step = set_time(time_step_seconds, time_step_days) + +! Load the table of variable metadata +var = assign_var(variables, MAX_STATE_VARIABLES) +! Define which variables are in the model state +dom_id = add_domain(template_file, var%count, var%names, var%qtys, & + var%clamp_values, var%updates) + +! Get the altitudes and the number of grid rows +call read_template_file() + +! Get the grid spacing; these quantities are in module storage +call get_grid_delta(np, del, half_del) + +! NOTE TO AETHER MODELERS +! Need a way to get time from Aether for scalar F10.7 location definition +! Just set to arbitrary time for now +state_time = set_time(0, 1) + +end subroutine static_init_model + +!------------------------------------------------------------------ + +! Returns the number of items in the state vector 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(dom_id) + +end function get_model_size + +!------------------------------------------------------------------ + +! Given a state handle, a location, and a state quantity, +! interpolates the state variable fields to that location and returns +! the values in expected_obs. The istatus variables should be returned as +! 0 unless there is some problem in computing the interpolation in +! which case a positive istatus should be returned. + +subroutine model_interpolate(state_handle, ens_size, location, qty, expected_obs, istatus) + +type(ensemble_type), intent(in) :: state_handle +integer, intent(in) :: ens_size +type(location_type), intent(in) :: location +integer, intent(in) :: qty +real(r8), intent(out) :: expected_obs(ens_size) !< array of interpolated values +integer, intent(out) :: istatus(ens_size) + + +! Vertical interpolation variables +integer :: below_index, above_index, enclosing_status, which_vertical, level +integer :: grid_face(4), grid_lat_ind(4), grid_lon_ind(4), num_bound_points, var_id, i +integer(i8) :: bounding_state_index(4, 2) + +real(r8) :: lon_lat_alt(3), fract +real(r8) :: grid_pt_lat(4), grid_pt_lon(4), pt_lat, pt_lon, bounding_value(4, 2, ens_size) +real(r8) :: below_values(ens_size), above_values(ens_size) + +! Initialize module if not already done +if(.not. module_initialized ) call static_init_model + +! Set all obs to MISSING_R8 initially +expected_obs(:) = MISSING_R8 +! Successful return status default +istatus(:) = 0 + +! Determine the vertical location type +lon_lat_alt = get_location(location) +pt_lat = lon_lat_alt(2) * DEG2RAD +pt_lon = lon_lat_alt(1) * DEG2RAD +which_vertical = nint(query_location(location, 'WHICH_VERT')) + +! Only heights currently supported for observations; fail if other is selected +if (.not. (which_vertical == VERTISHEIGHT .or. which_vertical == VERTISLEVEL )) then + istatus = INVALID_VERT_COORD_ERROR_CODE + return +endif + +! Geometric height is a special case +if(qty == QTY_GEOMETRIC_HEIGHT) then + level = nint(lon_lat_alt(3)) + if(level < 1 .or. level > ncenter_altitudes) then + istatus = INVALID_MODEL_LEVEL_ERROR_CODE + else + expected_obs = center_altitude(nint(lon_lat_alt(3))) + endif + return +endif + +! See if the state contains the obs quantity +var_id = get_varid_from_kind(dom_id, qty) +if(var_id <= 0) then + istatus = UNKNOWN_OBS_QTY_ERROR_CODE + return +endif + +! Find the bounding vertical levels and the fractional distance between +if(which_vertical == VERTISHEIGHT) then + call find_enclosing_indices(ncenter_altitudes, center_altitude, lon_lat_alt(3), & + below_index, above_index, fract, enclosing_status) + if (enclosing_status /= 0) then + istatus = INVALID_ALTITUDE_VAL_ERROR_CODE + return + endif +else + ! If VERTISLEVEL, bounds are both the vertical level + ! This does twice the needed computation, could get rid of this + above_index = abs(nint(lon_lat_alt(3))) + ! Fail if level is outside of model bounds + if(above_index < 1 .or. above_index > ncenter_altitudes) then + istatus = INVALID_MODEL_LEVEL_ERROR_CODE + return + endif + below_index = above_index +endif + +! If the vertical location is acceptable, then do the horizontal interpolation +! Find the enclosing triangle or quad +call get_bounding_box(pt_lat, pt_lon, del, half_del, np, grid_face, & + grid_lat_ind, grid_lon_ind, grid_pt_lat, grid_pt_lon, num_bound_points) + +! Map grid_face, latitude index and longitude index to 1D index used in the state vector +! Then get the state values +do i = 1, num_bound_points + bounding_state_index(i, 1) = get_state_index(grid_face(i), grid_lat_ind(i), & + grid_lon_ind(i), below_index, var_id) + bounding_value(i, 1, :) = get_state(bounding_state_index(i, 1), state_handle) + bounding_state_index(i, 2) = get_state_index(grid_face(i), grid_lat_ind(i), & + grid_lon_ind(i), above_index, var_id) + bounding_value(i, 2, :) = get_state(bounding_state_index(i, 2), state_handle) +enddo + +! Do inverse distance weighted horizontal interpolation on both levels +below_values = idw_interp(ens_size, RAD2DEG*pt_lat, RAD2DEG*pt_lon, & + RAD2DEG*grid_pt_lat, RAD2DEG*grid_pt_lon, bounding_value(:, 1, :), num_bound_points) +above_values = idw_interp(ens_size, RAD2DEG*pt_lat, RAD2DEG*pt_lon, & + RAD2DEG*grid_pt_lat, RAD2DEG*grid_pt_lon, bounding_value(:, 2, :), num_bound_points) + +! Do the vertical interpolation, linear in height to get final +call vert_interp(ens_size, below_values, above_values, fract, expected_obs) + +end subroutine model_interpolate + +!------------------------------------------------------------------ + +! Returns the smallest increment in time that the model is capable +! of advancing the state in a given implementation, or the shortest +! time you want the model to advance between assimilations. + +function shortest_time_between_assimilations() + +type(time_type) :: shortest_time_between_assimilations + +if(.not. module_initialized) call static_init_model + +shortest_time_between_assimilations = assimilation_time_step + +end function shortest_time_between_assimilations + +!------------------------------------------------------------------ + +! Given an integer index into the state vector, returns the +! associated location and optionally the physical quantity. + +subroutine get_state_meta_data(index_in, location, qty) + +integer(i8), intent(in) :: index_in +type(location_type), intent(out) :: location +integer, intent(out), optional :: qty + +! Local variables + +integer :: lev_index, col_index, my_var_id, my_qty, dom_id +real(r8) :: lat, lon +integer :: seconds, days ! for f10.7 location +real(r8) :: longitude ! for f10.7 location + +if(.not. module_initialized) call static_init_model + +call get_model_variable_indices(index_in, col_index, lev_index, & + no_third_dimension, var_id=my_var_id, dom_id=dom_id, kind_index=my_qty) + +! F10.7 scalar location does not have a column +if(trim(get_variable_name(dom_id, my_var_id)) == 'SCALAR_F10.7') then + ! AETHER MODELERS SHOULD REFINE THIS AS NEEDED + ! Set the location as per TIEGCM example for now + ! f10_7 is most accurately located at local noon at equator. + ! 360.0 degrees in 86400 seconds, 43200 secs == 12:00 UTC == longitude 0.0 + call get_time(state_time, seconds, days) + longitude = 360.0_r8 * real(seconds,r8) / 86400.0_r8 - 180.0_r8 + if (longitude < 0.0_r8) longitude = longitude + 360.0_r8 + write(*, *) 'longitude for F10.7 is ', longitude + location = set_location(longitude, 0.0_r8, 400000.0_r8, VERTISUNDEF) + return +end if + +! Get the latitude and longitude of this columm; These are in radians +call col_index_to_lat_lon(col_index, np, del, half_del, lat, lon) + +! Set the location type, lat and lon converted to degrees +location = set_location(RAD2DEG*lon, RAD2DEG*lat, & + center_altitude(lev_index), VERTISHEIGHT) + +! Set the physical quantity, e.g. QTY_TEMPERATURE +if(present(qty)) qty = my_qty + +end subroutine get_state_meta_data + +!------------------------------------------------------------------ + +! Any model specific distance calcualtion can be done here +subroutine get_close_obs(gc, base_loc, base_type, locs, loc_qtys, loc_types, & + num_close, close_ind, dist, ens_handle) + +type(get_close_type), intent(in) :: gc ! handle to a get_close structure +integer, intent(in) :: base_type ! observation TYPE +type(location_type), intent(inout) :: base_loc ! location of interest +type(location_type), intent(inout) :: locs(:) ! obs locations +integer, intent(in) :: loc_qtys(:) ! QTYS for obs +integer, intent(in) :: loc_types(:) ! TYPES for obs +integer, intent(out) :: num_close ! how many are close +integer, intent(out) :: close_ind(:) ! incidies into the locs array +real(r8), optional, intent(out) :: dist(:) ! distances in radians +type(ensemble_type), optional, intent(in) :: ens_handle + +character(len=*), parameter :: routine = 'get_close_obs' + +call loc_get_close_obs(gc, base_loc, base_type, locs, loc_qtys, loc_types, & + num_close, close_ind, dist, ens_handle) + +end subroutine get_close_obs + +!------------------------------------------------------------------ + +! Any model specific distance calcualtion can be done here +subroutine get_close_state(gc, base_loc, base_type, locs, loc_qtys, loc_indx, & + num_close, close_ind, dist, ens_handle) + +type(get_close_type), intent(in) :: gc ! handle to a get_close structure +type(location_type), intent(inout) :: base_loc ! location of interest +integer, intent(in) :: base_type ! observation TYPE +type(location_type), intent(inout) :: locs(:) ! state locations +integer, intent(in) :: loc_qtys(:) ! QTYs for state +integer(i8), intent(in) :: loc_indx(:) ! indices into DART state vector +integer, intent(out) :: num_close ! how many are close +integer, intent(out) :: close_ind(:) ! indices into the locs array +real(r8), optional, intent(out) :: dist(:) ! distances in radians +type(ensemble_type), optional, intent(in) :: ens_handle + +character(len=*), parameter :: routine = 'get_close_state' + +call loc_get_close_state(gc, base_loc, base_type, locs, loc_qtys, loc_indx, & + num_close, close_ind, dist, ens_handle) + +end subroutine get_close_state + +!------------------------------------------------------------------ + +! Does any shutdown and clean-up needed for model. Can be a NULL +! INTERFACE if the model has no need to clean up storage, etc. + +subroutine end_model() + +end subroutine end_model + +!------------------------------------------------------------------ + +! write any additional attributes to the output and diagnostic files + +subroutine nc_write_model_atts(ncid, domain_id) + +integer, intent(in) :: ncid ! netCDF file identifier +integer, intent(in) :: domain_id + +if(.not. module_initialized) call static_init_model + +! put file into define mode. + +call nc_begin_define_mode(ncid) + +call nc_add_global_creation_time(ncid) + +call nc_add_global_attribute(ncid, "model_source", source ) +call nc_add_global_attribute(ncid, "model", "template") + +call nc_end_define_mode(ncid) + +! Flush the buffer and leave netCDF file open +call nc_synchronize_file(ncid) + +end subroutine nc_write_model_atts + +!----------------------------------------------------------------------- + +! Parse the table of variables characteristics into arrays for easier access. + +function assign_var(variables, MAX_STATE_VARIABLES) result(var) + +character(len=vtablenamelength), intent(in) :: variables(:, :) +integer, intent(in) :: MAX_STATE_VARIABLES + +type(var_type) :: var +integer :: ivar +character(len=vtablenamelength) :: table_entry + +!----------------------------------------------------------------------- +! Codes for interpreting the NUM_STATE_TABLE_COLUMNS of the variables table +integer, parameter :: NAME_INDEX = 1 ! ... variable name +integer, parameter :: QTY_INDEX = 2 ! ... DART qty +integer, parameter :: MIN_VAL_INDEX = 3 ! ... minimum value if any +integer, parameter :: MAX_VAL_INDEX = 4 ! ... maximum value if any +integer, parameter :: UPDATE_INDEX = 5 ! ... update (state) or not + +! Loop through the variables array to get the actual count of the number of variables +do ivar = 1, MAX_STATE_VARIABLES + ! If the element is an empty string, the loop has exceeded the extent of the variables + if(variables(1, ivar) == '') then + var%count = ivar-1 + exit + endif +enddo + +! Allocate the arrays in the var derived type +allocate(var%names(var%count), var%qtys(var%count), & + var%clamp_values(var%count, 2), var%updates(var%count)) + +! Load the table for each variable +do ivar = 1, var%count + var%names(ivar) = trim(variables(NAME_INDEX, ivar)) + + table_entry = variables(QTY_INDEX, ivar) + call to_upper(table_entry) + + var%qtys(ivar) = get_index_for_quantity(table_entry) + + if(variables(MIN_VAL_INDEX, ivar) /= 'NA') then + read(variables(MIN_VAL_INDEX, ivar), '(d16.8)') var%clamp_values(ivar,1) + else + var%clamp_values(ivar,1) = MISSING_R8 + endif + + if(variables(MAX_VAL_INDEX, ivar) /= 'NA') then + read(variables(MAX_VAL_INDEX, ivar), '(d16.8)') var%clamp_values(ivar,2) + else + var%clamp_values(ivar,2) = MISSING_R8 + endif + + table_entry = variables(UPDATE_INDEX, ivar) + call to_upper(table_entry) + + if(table_entry == 'UPDATE') then + var%updates(ivar) = .true. + else + var%updates(ivar) = .false. + endif + +enddo + +end function assign_var + +!----------------------------------------------------------------------- + +subroutine read_template_file() + +integer :: dimid, varid, number_of_columns +character(len=256) :: name +type(file_type) :: templatefile + +! Gets altitudes and number of points per face row from a filter template file +templatefile%file_path = trim(template_file) +templatefile%ncid = nc_open_file_readonly(templatefile%file_path) + +! Get the number of vertical levels +templatefile%ncstatus = nf90_inq_dimid(templatefile%ncid, 'z', dimid) +templatefile%ncstatus = nf90_inquire_dimension(templatefile%ncid, dimid, & + name, ncenter_altitudes) + +! Allocate space for vertical levels +allocate(center_altitude(ncenter_altitudes)) + +! Get the vertical levels +templatefile%ncstatus = nf90_inq_varid(templatefile%ncid, 'alt', varid) +templatefile%ncstatus = nf90_get_var(templatefile%ncid, varid, center_altitude) + +! Get the number of columns +templatefile%ncstatus = nf90_inq_dimid(templatefile%ncid, 'col', dimid) +templatefile%ncstatus = nf90_inquire_dimension(templatefile%ncid, dimid, & + name, number_of_columns) + +call nc_close_file(templatefile%ncid) + +! Compute the number of grid rows across a face +np = nint(sqrt(number_of_columns / 6.0_r8)) + +end subroutine read_template_file + +!----------------------------------------------------------------------- + +! Testing subroutine for grid definition and interpolation tools +! This is not designed to be run with more than one process + +subroutine test_grid_box + +integer :: i, j, num_bound_points, qty, lon_count, lat_count +integer :: grid_face(4), grid_lat_ind(4), grid_lon_ind(4) +integer :: my_face, my_level, my_qty, my_lon_ind, my_lat_ind +integer :: test_face, test_lat_ind, test_lon_ind, col_index, test_col_index +integer :: num_test_lats, num_test_lons +integer(i8) :: state_index +real(r8) :: pt_lon_d, pt_lat_d, pt_lon, pt_lat +real(r8) :: qxyz(4, 3), pxyz(3), grid_pt_lat(4), grid_pt_lon(4) +real(r8) :: lon_lat_hgt(3), my_lat, my_lon, base_dist, dist_sum +logical :: inside + +type(location_type) :: location + +! Test that grid_to_lat_lon and lat_lon_to_grid are inverses of each other +do my_face = 0, 5 + do my_lat_ind = 1, np + do my_lon_ind = 1, np + call grid_to_lat_lon(my_face, my_lat_ind, my_lon_ind, del, half_del, pt_lat, pt_lon) + call lat_lon_to_grid(pt_lat, pt_lon, del, half_del, test_face, test_lat_ind, test_lon_ind) + if(my_face /= test_face .or. my_lat_ind /= test_lat_ind .or. my_lon_ind /= test_lon_ind) then + write(string1, *) 'Test failed: lat_lon_to_grid is not inverse of grid_to_lat_lon' + write(string2, *) my_face, test_face, my_lat_ind, test_lat_ind, my_lon_ind, test_lon_ind + call error_handler(E_ERR, 'test_grid_box', string1, & + source, revision, revdate, text2=string2) + endif + + ! Test that col_index_to_lat_lon and lat_lon_to_col_index are inverses of each other + col_index = my_lon_ind + (my_lat_ind - 1) * np + my_face * np*np + call col_index_to_lat_lon(col_index, np, del, half_del, pt_lat, pt_lon) + test_col_index = lat_lon_to_col_index(pt_lat, pt_lon, del, half_del, np) + if(col_index /= test_col_index) then + write(string1, *) 'Test failed: lat_lon_to_col_index is not inverse of col_index_to_lat_lon' + write(string2, *) my_face, my_lat_ind, my_lon_ind, col_index, test_col_index + call error_handler(E_ERR, 'test_grid_box', string1, & + source, revision, revdate, text2=string2) + endif + enddo + enddo +enddo + +! Test points for the following: +! 1. Does the bounding box found contain the observed point? +! 2. Are the computed vertex latitudes and longitudes the same as those in the Aether grid files? + +! Largest edges are on the quads in the center of a face +! Get distance, base_dist, along side of center quad +do i = 1, 2 + ! Traverse half of the rows (each np across), plus halfway across the next row + state_index = (np/2)*np + np/2 + i - 1 + call get_state_meta_data(state_index, location, qty) + lon_lat_hgt = get_location(location) + qxyz(i, 1:3) = lat_lon_to_xyz(DEG2RAD*lon_lat_hgt(2), DEG2RAD*lon_lat_hgt(1)) +enddo +base_dist = sqrt(sum((qxyz(1, :) - qxyz(2, :))**2)) + +! Loop through many longitude and latitude points for testing +num_test_lons = 3600 +do lon_count = 0, num_test_lons + pt_lon_d = lon_count * (360.0_r8 / num_test_lons) + num_test_lats = 1800 + do lat_count = -900, 900 + pt_lat_d = lat_count * (180.0_r8 / num_test_lats) + + ! Convert to radians + pt_lon = DEG2RAD * pt_lon_d + pt_lat = DEG2RAD * pt_lat_d + + ! Get the x, y, z coords for this point + pxyz = lat_lon_to_xyz(pt_lat, pt_lon); + + call get_bounding_box(pt_lat, pt_lon, del, half_del, np, & + grid_face, grid_lat_ind, grid_lon_ind, grid_pt_lat, grid_pt_lon, num_bound_points) + + do i = 1, num_bound_points + ! Convert to x, y, z coords to check for whether points are in tri/quad + qxyz(i, 1:3) = lat_lon_to_xyz(grid_pt_lat(i), grid_pt_lon(i)); + enddo + + ! Get latitude longitude of bounding points from get_state_meta_data as confirmation test + do i = 1, num_bound_points + state_index = get_state_index(grid_face(i), grid_lat_ind(i), grid_lon_ind(i), 1, 1) + call get_state_meta_data(state_index, location, qty) + lon_lat_hgt = get_location(location) + ! Deal with Aether file round off + if(abs(lon_lat_hgt(1) - 360.0_r8) < 0.0001) lon_lat_hgt(1) = 0.0_r8 + if(abs(RAD2DEG*grid_pt_lat(i) - lon_lat_hgt(2)) > 0.0001_r8 .or. & + abs(RAD2DEG*grid_pt_lon(i) - lon_lat_hgt(1)) > 0.0001_r8) then + write(string1, *) 'Test failed: Aether files grid points inconsistent with get_state_meta_data' + write(string2, *) grid_pt_lat(i), grid_pt_lon(i), lon_lat_hgt(2), lon_lat_hgt(1) + call error_handler(E_ERR, 'test_grid_box', string1, & + source, revision, revdate, text2=string2) + endif + enddo + + if(num_bound_points == 3) then + ! See if the point is inside a local approximately tangent triangle + inside = is_point_in_triangle(qxyz(1, :), qxyz(2, :), qxyz(3, :), pxyz); + else + ! Or quadrilateral + inside = is_point_in_quad(qxyz, pxyz); + endif + + if(.not. inside) then + write(string1, *) 'Test failed: Point is not inside the triangle or quadrilateral' + write(string2, *) pt_lat, pt_lon, num_bound_points + call error_handler(E_ERR, 'test_grid_box', string1, & + source, revision, revdate, text2=string2) + endif + + ! Also check on distance to vertices; this greatly reduces the possibility that + ! bounding boxes that are bigger than they should be are being found + dist_sum = 0.0_r8 + do i = 1, num_bound_points + ! Compute sum of distances between point and each of the vertices + dist_sum = dist_sum + sqrt(sum((qxyz(i, :) - pxyz)**2)) + end do + + if(num_bound_points == 4) then + ! For quad, sum should be less than 3.5 times the baseline + if(dist_sum / base_dist > 3.5_r8) then + write(string1, *) 'Test failed: Ratio of sum of distances to vertices is too large for quad' + ! Additional info that could be helpful + !!!do i = 1, num_bound_points + !!!write(*, *) 'grid ', i, grid_pt_lat(i), grid_pt_lon(i) + !!!write(*, *) 'grid xyz ', i, qxyz(i, :) + !!!enddo + write(string2, *) 'point ', pt_lat, pt_lon, 'point xyz ', pxyz + call error_handler(E_ERR, 'test_grid_box', string1, & + source, revision, revdate, text2=string2) + endif + elseif(num_bound_points == 3) then + ! For triangle, sum should be less than 3 times the baseline + if(dist_sum / base_dist > 3.0_r8) then + write(string1, *) 'Test failed: ratio of sum of distances to vertices is too large for triangle' + call error_handler(E_ERR, 'test_grid_box', string1, & + source, revision, revdate) + endif + endif + enddo +enddo + +!------------------- +! Block that loops through all state variables and confirms that the algorithms for mapping +! state vector (face/lon/lat) indices and get_state_meta_data correcty match up. +do my_qty = 1, 2 + do my_level = 1, ncenter_altitudes + do my_face = 0, 5 + do my_lat_ind = 1, np + do my_lon_ind = 1, np + state_index = get_state_index(my_face, my_lat_ind, my_lon_ind, & + my_level, my_qty) + call get_state_meta_data(state_index, location, qty) + lon_lat_hgt = get_location(location) + + ! Want to compare the lat lon directly from code to that from get_state_meta_data + call grid_to_lat_lon(my_face, my_lat_ind, my_lon_ind, del, half_del, my_lat, my_lon) + + ! ROUNDOFF FROM AETHER + if(abs(lon_lat_hgt(1) - 360.0_r8) < 0.0001) lon_lat_hgt(1) = 0.0_r8 + + ! Check that things are consistent + if(abs(RAD2DEG*my_lat - lon_lat_hgt(2)) > 0.0001_r8 .or. & + abs(RAD2DEG*my_lon - lon_lat_hgt(1)) > 0.0001_r8) then + write(string1, *) 'Test Failed: Grid points not appropriately mapping' + write(string2, *) my_face, my_qty, my_level, my_lat_ind, my_lon_ind + call error_handler(E_ERR, 'test_grid_box', string1, & + source, revision, revdate) + endif + + enddo + enddo + enddo + enddo +enddo + +write(string1, *) 'ALL TESTS PASSED' +call error_handler(E_MSG, 'test_grid_box', string1, source, revision, revdate) + +end subroutine test_grid_box + +!----------------------------------------------------------------------- + +function get_state_index(face, lat_ind, lon_ind, lev_ind, var_ind) + +integer :: get_state_index +integer, intent(in) :: face, lat_ind, lon_ind, lev_ind, var_ind + +! Given the cube face, latitude (first) index, longitude (second) index on the face, +! the level index and the variable index, returns the state index for use +! by get_state_meta_data. Needs to know the number of lat and lon points across the face, np. + +! This function makes the explicit assumption that the state is mapped to +! the state index in the following fashion: +! From fastest to slowest varying index: +! 1. longitude index : 1 to np +! 2. latitude index : 1 to np +! 3. face : 0 to 5 consistent with Aether defs +! 4. level index : 1 to n_lev +! 4. variable index : 1 to number of variables + +integer :: column + +! Get the index of the column in DART storage +column = lon_ind + np * ((lat_ind - 1) + np * face) +get_state_index = get_dart_vector_index(column, lev_ind, no_third_dimension, dom_id, var_ind) + +end function get_state_index + +!----------------------------------------------------------------------- + +! Performs IDW interpolation using great-circle distances for a triangle or quad +! Modified quad_idw_interp imported from the cice model_mod +! This should eventually be in its own module + +function idw_interp(ens_size, lat, lon, y_corners, x_corners, p, num_corners) + +real(r8) :: idw_interp(ens_size) ! Interpolated value at (lat, lon). +integer, intent(in) :: ens_size +real(r8), intent(in) :: lat, lon ! Interpolation point (latitude, longitude) in degrees +real(r8), intent(in) :: y_corners(:), x_corners(:) ! corner points (latitude, longitude) in degrees +real(r8), intent(in) :: p(:, :) ! Values at the quadrilaterals corner points, second dimension is ens_size +integer, intent(in) :: num_corners + +! Set the power for the inverse distances +real(r8), parameter :: power = 2.0_r8 ! Power for IDW (squared distance) + +! This value of epsilon radians is a distance of approximately 1 mm on the earth's surface +real(r8), parameter :: epsilon_radians = 1.56e-11_r8 + +type(location_type) :: corner(num_corners), point +real(r8) :: distances(num_corners), inv_power_dist(num_corners) + +integer :: i, n + +! Compute the distances from the point to each corner +point = set_location(lon, lat, MISSING_R8, VERTISUNDEF) +do i = 1, num_corners + corner(i) = set_location(x_corners(i), y_corners(i), MISSING_R8, VERTISUNDEF) + distances(i) = get_dist(point, corner(i), no_vert=.true.) +end do + +if(minval(distances) < epsilon_radians) then + ! To avoid any round off issues, if smallest distance is less than epsilon radians + ! just assign the value at the closest gridpoint to the interpolant + idw_interp = p(minloc(distances, 1), :) + return +else + ! Get the inverse distances raised to the power + inv_power_dist = 1.0_r8 / (distances ** power) + + ! Calculate the weights for each grid point and sum up weighted values + do n = 1, ens_size + idw_interp(n) = sum(inv_power_dist(1:num_corners) * p(1:num_corners, n)) / sum(inv_power_dist) + end do +endif + +! Round-off can lead to result being outside of range of gridpoints +! Test for now and fix if this happens +do n = 1, ens_size + ! If all vertices have the same value, just return that value + ! This avoids some issues with roundoff leading to interpolated being outside of range + if(all(p(2:num_corners, n) == p(1, n))) then + idw_interp(n) = p(1, n) + elseif(idw_interp(n) < minval(p(:, n)) .or. idw_interp(n) > maxval(p(:, n))) then + write(string1,*)'IDW interpolation result is outside of range of grid point values' + write(string2, *) 'Interpolated value, min and max are: ', & + idw_interp(n), minval(p(:, n)), maxval(p(:, n)) + call error_handler(E_MSG, 'idw_interp', string1, & + source, revision, revdate, text2=string2) + + ! Fixing out of range + idw_interp(n) = max(idw_interp(n), minval(p(:, n))) + idw_interp(n) = min(idw_interp(n), maxval(p(:, n))) + endif + +end do + +end function idw_interp + +!----------------------------------------------------------------------- +! 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_fract, out_vals) + +integer, intent(in) :: nitems +real(r8), intent(in) :: levs1(nitems), levs2(nitems), vert_fract +real(r8), intent(out) :: out_vals(nitems) + +out_vals(:) = levs1(:) * (1.0_r8 - vert_fract) + levs2(:) * vert_fract + +end subroutine vert_interp + +!----------------------------------------------------------------------- + +!=================================================================== +! End of model_mod +!=================================================================== +end module model_mod diff --git a/models/aether_cube_sphere/perturb_aether_ensemble.m b/models/aether_cube_sphere/perturb_aether_ensemble.m new file mode 100644 index 0000000000..fffb62d206 --- /dev/null +++ b/models/aether_cube_sphere/perturb_aether_ensemble.m @@ -0,0 +1,107 @@ +% Do some straightforward perturbing of aether ensemble files +% found in the TEST_INPUT directory +% The perturbations are all constant scaled fields; resulting correlations are all 1. + +% Number of blocks for default aether restart files +nblocks = 6; +% Size of ensemble to create +ens_size = 10; + +% Directory containing files to be perturbed +pert_dir = 'TEST_INPUT'; +g_base_name = strcat(pert_dir, '/grid_g'); +n_base_name = strcat(pert_dir, '/neutrals_m'); +i_base_name = strcat(pert_dir, '/ions_m'); + +% Loop through the blocks +for block = 0:nblocks -1 + block_prelim = int2str(10000 + block); + block_final = block_prelim(2:5); + g_file_name = strcat(g_base_name, block_final, '.nc'); + + % Get the lat and lon for more advanced perturbing + lat = ncread(g_file_name, 'Latitude'); + lon = ncread(g_file_name, 'Longitude'); + + ens_prelim = int2str(10000 + 0); + ens_final = ens_prelim(2:5); + % File names for neutral and ions ensemble member 0 + n_file_name_0 = strcat(n_base_name, ens_final, '_g', block_final, '.nc'); + i_file_name_0 = strcat(i_base_name, ens_final, '_g', block_final, '.nc'); + + % Loop through all the variables in the neutrals files to perturb + nc_info = ncinfo(n_file_name_0); + % Number of total variables (including time) + nvars = size(nc_info.Variables, 2); + + % Loop through the non-time variables + for ivar = 2:nvars + var_name = nc_info.Variables(ivar).Name; + + % Get the base variable from the first ensemble member, the current file name + var = ncread(n_file_name_0, var_name); + + % Loop through the rest of the ensemble members and perturb + for ens = 1:ens_size - 1 + + ens_prelim = int2str(10000 + ens); + ens_final = ens_prelim(2:5); + n_file_name = strcat(n_base_name, ens_final, '_g', block_final, '.nc'); + + % Copy the ensemble member 0 file to the ensemble ens using the shell; first ivar only + if(ivar == 2) copyfile(n_file_name_0, n_file_name); end + + % Compute a normalized range for perturbation size + if(block == 0) + neutrals_var_range(ivar) = range(var, 'all'); + if(neutrals_var_range(ivar) == 0) + neutrals_var_range(ivar) = var(1, 1, 1); + end + end + + % Perturb the variable + pert_var = var + neutrals_var_range(ivar) * 0.01 * ens; + + % Write the variable + ncwrite(n_file_name, var_name, pert_var); + end + end + + % --------- Loop through the variables for the ions files -------- + nc_info = ncinfo(i_file_name_0); + % Number of total variables (including time) + nvars = size(nc_info.Variables, 2); + + % Loop through the non-time variables + for ivar = 2:nvars + var_name = nc_info.Variables(ivar).Name; + + % Get the base variable from the first ensemble member, the current file name + var = ncread(i_file_name_0, var_name); + + % Loop through the rest of the ensemble members and perturb + for ens = 1:ens_size - 1 + + ens_prelim = int2str(10000 + ens); + ens_final = ens_prelim(2:5); + i_file_name = strcat(i_base_name, ens_final, '_g', block_final, '.nc'); + + % Copy the ensemble member 0 file to the ensemble 1 using the shell + if(ivar == 2) copyfile(i_file_name_0, i_file_name); end + + % Compute a normalized range for perturbation size + if(block == 0) + ions_var_range(ivar) = range(var, 'all'); + if(ions_var_range(ivar) == 0) + ions_var_range(ivar) = var(1, 1, 1); + end + end + + % Perturb the variable + pert_var = var + ions_var_range(ivar) * 0.01 * ens; + + % Write the variable + ncwrite(i_file_name, var_name, pert_var); + end + end +end diff --git a/models/aether_cube_sphere/plot_aether_lat_lon.m b/models/aether_cube_sphere/plot_aether_lat_lon.m new file mode 100644 index 0000000000..4626070c14 --- /dev/null +++ b/models/aether_cube_sphere/plot_aether_lat_lon.m @@ -0,0 +1,132 @@ +% Plots the difference between aether_cube_sphere input and output +% restart block files. +% The user can select level, ensemble member, +% and one of four variables that are in the default test aether +% restart files. The variables are located at a set of vertical columns +% defined by the cube sphere grid. The plotting is quite primitive, +% just putting a symbol with a color scaled by the range of the +% values on the plot at the given point. +% +% This script is designed to be run in the aether_cube_sphere directory +% while the filter files are in the TEST_INPUT and TEST_OUTPUT directories +% below this. + +% Specify the number of block files and halo rows for the default +% restart files. +nblocks = 6; +nhalos = 2; + +% Level to be plotted +level = input('Input level to plot (integer)'); + +% Ensemble member to be plotted +ens = input('Input ensemble member to plot (integer)'); +ens_prelim = int2str(10000 + ens); +ens_final = ens_prelim(2:5); + +% Get a valid field_num from user +for i = 1:1000 + field_num = 0; + % Input field name + field_num = input('Input 1 for O2+; 2 for O2; 3 for N2+; 4 for Temp.'); + +% Get the name and determine whether this is in the ions or neutrals files + if(field_num == 1) + file_type = 1; + field_name = 'O2+'; break + elseif(field_num == 2) + file_type = 2; + field_name = 'O2'; break + elseif(field_num == 3) + file_type = 1; + field_name = 'N2+'; break + elseif(field_num == 4) + file_type = 2; + field_name = 'Temperature'; break + end +end + +% Input file directory (grid files must be here, too +input_base_name = 'TEST_INPUT/'; +% Output file directory +output_base_name = 'TEST_OUTPUT/'; + +% The grid files have the metadata +g_base_name = strcat(input_base_name, 'grid_g'); +% Neutrals and ions files have the data +if(file_type == 1) + input_base_name = strcat(input_base_name, 'ions_m', ens_final, '_g'); + output_base_name = strcat(output_base_name, 'ions_m', ens_final, '_g'); +else + input_base_name = strcat(input_base_name, 'neutrals_m', ens_final, '_g'); + output_base_name = strcat(output_base_name, 'neutrals_m', ens_final, '_g'); +end + +% Loop through the fields from each block first to get min and max for plot colors +for i = 0:nblocks - 1 + num_prelim = int2str(10000 + i); + num_end = num_prelim(2:5); + + % Create strings with the input and output file for this block + input_file_name = strcat(input_base_name, num_end, '.nc'); + output_file_name = strcat(output_base_name, num_end, '.nc'); + + % Read in the fields from input and output files + in_field = ncread(input_file_name, field_name); + out_field = ncread(output_file_name, field_name); + field = out_field - in_field; + + % Range of grid values that are not in the halo + nx = size(field, 3); + xs = nhalos + 1; + xe = nx - nhalos; + + % Looking for the range of the values over all of the block files + if(i == 0) + n_min = min(min(field(level, xs:xe, xs:xe))); + n_max = max(max(field(level, xs:xe, xs:xe))); + else + t_min = min(min(field(level, xs:xe, xs:xe))); + t_max = max(max(field(level, xs:xe, xs:xe))); + n_min = min(t_min, n_min); + n_max = max(t_max, n_max); + end +end + +% Loop through the blocks again and plot each point with +% a color proportional the range normalized value +for i = 0:nblocks -1 + num_prelim = int2str(10000 + i); + num_end = num_prelim(2:5); + g_file_name = strcat(g_base_name, num_end, '.nc'); + + input_file_name = strcat(input_base_name, num_end, '.nc'); + output_file_name = strcat(output_base_name, num_end, '.nc'); + + % Read the grid file lat and lons + lat = ncread(g_file_name, 'Latitude'); + lon = ncread(g_file_name, 'Longitude'); + + % Read in the fields from input and output files + in_field = ncread(input_file_name, field_name); + out_field = ncread(output_file_name, field_name); + field = out_field - in_field; + + % Get color range index + range = n_max - n_min; + color_range = 256; + col = colormap; + + % Loop to plot each point from this block + for i = nhalos+1:size(field, 2) - nhalos + for j = nhalos+1:size(field, 3) - nhalos + frac = (field(level, i, j) - n_min) / range; + color_index = floor(frac * color_range) + 1; + color_index = min(color_index, 256); + plot(lon(level, i, j), lat(level, i, j), 'o', 'markersize', ... + 10, 'color', col(color_index, :), 'linewidth', 20); + set(gca, 'fontsize', 16) + hold on + end + end +end diff --git a/models/aether_cube_sphere/plot_filter_lat_lon.m b/models/aether_cube_sphere/plot_filter_lat_lon.m new file mode 100644 index 0000000000..cebe42baf7 --- /dev/null +++ b/models/aether_cube_sphere/plot_filter_lat_lon.m @@ -0,0 +1,104 @@ +% Plots the difference between aether_cube_sphere filter_input and +% filter_output files along with the input and output fields. +% The user can select level, ensemble member, +% and one of four variables that are in the default test aether +% restart files. The variables are located at a set of vertical columns +% defined by the cube sphere grid. The plotting is quite primitive, +% just putting a symbol with a color scaled by the range of the +% values on the plot at the given point. +% +% This script is designed to be run in the aether_cube_sphere directory +% while the filter files are in the work directory below this. + +% Level to be plotted +level = input('Input level to plot (integer)'); + +% Ensemble member to be plotted +ens = input('Input ensemble member to plot (integer)'); +ens_prelim = int2str(10000 + ens); +ens_final = ens_prelim(2:5); + +% Get a valid field index from user +for i = 1:1000 + field_num = 0; + % Input field name + field_num = input('Input 1 for O2+; 2 for O2; 3 for N2+; 4 for Temp.'); + + if(field_num == 1) + field_name = 'O2+'; break + elseif(field_num == 2) + field_name = 'O2'; break + elseif(field_num == 3) + field_name = 'N2+'; break + elseif(field_num == 4) + field_name = 'Temperature'; break + end +end + +% Create text strings for the input and output filter files +in_file_name = strcat('work/filter_input_', ens_final, '.nc'); +out_file_name = strcat('work/filter_output_', ens_final, '.nc'); + +% Get the metadata latitude, longitude and altitude for each column +lat = ncread(in_file_name, 'lat'); +lon = ncread(in_file_name, 'lon'); +alt = ncread(in_file_name, 'alt'); + +% Read the field data from the input and output files +in_field = ncread(in_file_name, field_name); +out_field = ncread(out_file_name, field_name); + +% Compute the increments +field = out_field - in_field; + +% Get color range index so that scale spans the values in the field +range = max(field(:, level)) - min(field(:, level)); +color_range = 256; +col = colormap; + +% Loop to plot each point for the increments +for i = 1:size(lat, 1) + frac(i) = (field(i, level) - min(field(:, level))) / range; + color_index(i) = floor(frac(i) * color_range) + 1; + color_index(i) = min(color_index(i), 256); + plot(lon(i), lat(i), 'o', 'markersize', 10, 'color', col(color_index(i), :), 'linewidth', 28); + set(gca, 'fontsize', 16) + hold on +end + +% Plot the input field in the same way +figure(2) +field = in_field; +% Get color range index +range = max(field(:, level)) - min(field(:, level)); +color_range = 256; +col = colormap; + +% Loop to get colors +for i = 1:size(lat, 1) + frac(i) = (field(i, level) - min(field(:, level))) / range; + color_index(i) = floor(frac(i) * color_range) + 1; + color_index(i) = min(color_index(i), 256); + plot(lon(i), lat(i), 'o', 'markersize', 10, 'color', col(color_index(i), :), 'linewidth', 28); + set(gca, 'fontsize', 16) + hold on +end + +% Plot the output field in the same way +figure(3) +field = out_field; +% Get color range index +range = max(field(:, level)) - min(field(:, level)); +color_range = 256; +col = colormap; + +% Loop to get colors +for i = 1:size(lat, 1) + frac(i) = (field(i, level) - min(field(:, level))) / range; + color_index(i) = floor(frac(i) * color_range) + 1; + color_index(i) = min(color_index(i), 256); + plot(lon(i), lat(i), 'o', 'markersize', 10, 'color', col(color_index(i), :), 'linewidth', 28); + set(gca, 'fontsize', 16) + hold on +end + diff --git a/models/aether_cube_sphere/readme.rst b/models/aether_cube_sphere/readme.rst new file mode 100644 index 0000000000..f8ba52d983 --- /dev/null +++ b/models/aether_cube_sphere/readme.rst @@ -0,0 +1,208 @@ +Aether Cube Sphere +================== + +This document describes the DART interface to the Aether ionosphere-thermosphere model in its cube +sphere implementation. + +In addition to the standard DART programs associated with a given model, this interface creates +two additional programs for the Aether cube sphere: ``aether_to_dart``, and ``dart_to_aether``. +It also has a program in the ``developer_tests directory``, ``test_aether_grid`` +that tests the geometry related aspects of the grid, +verifies model interpolation assumptions, and compares to a template filter_input_file. + +aether_to_dart +-------------- + +This program reads Aether restart files and combines them into a single filter input file for +DART. This program reads entries from two namelists in ``input.nml``: + +In ``&aether_to_dart_nml``: + +- ``aether_file_directory`` Path to the Aether restart files +- ``dart_file_directory`` Path to the where ``filter_input`` files will be created + +In ``&transform_state_nml``: + +- ``np`` Number of grid points across each cube sphere face (no halos) +- ``nblocks`` Total number of Aether grid files +- ``nhalos`` Number of Aether halo rows +- ``scalar_f10_7`` True if F10.7 is a scalar in the DART state vector, false means it is has a value at each column. + +Using aether_to_dart +~~~~~~~~~~~~~~~~~~~~ + +When executing ``aether_to_dart`` a range of ensemble members must be specified as +command line arguments: + +.. code-block:: + + aether_to_dart 1 10 + +This example would translate ensemble members 1 to 10. There are three types of Aether netcdf +restart files required in the Aether input directory. The first are grid files that include the +metadata that defines the location of Aether grid points and halos for each block. These file +are named ``grid_g####.nc`` where #### is the number of the block, starting from 0000. The second +are neutrals files that contain the data for neutral quantities. There is one file for each +block for each ensemble member. These are named ``neutrals_m&&&&_g####`` where &&&& is the ensemble +member starting from 0000 and #### is the block. The third are ions files named +``ions_m&&&&_g####`` with the same numbering as the neutrals files. A single filter input file is +created for each ensemble with the name ``filter_input_&&&&`` where &&&& is the ensemble number +starting at 0001 (note the offset in numbering from the Aether files). + +dart_to_aether +-------------- + +This program reads filter output files and inserts the data into Aether block restart files. +This program reads entries from two namelists in ``input.nml``" + +In ``&dart_to_aether_nml``: + +- ``dart_file_directory`` Path to the ``filter_output`` files that are read +- ``aether_file_directory`` Path to the Aether restart files that will be modified + +In ``&transform_state_nml``: + +- ``np`` Number of grid points across each cube sphere face (no halos) +- ``nblocks`` Total number of Aether grid files +- ``nhalos`` Number of Aether halo rows +- ``scalar_f10_7`` True if F10.7 is a scalar in the DART state vector, false means it is has a + +Using dart_to_aether +~~~~~~~~~~~~~~~~~~~~ + +When executing ``dart_to_aether`` a range of ensemble members must be specified as +command line arguments: + + ``./dart_to_aether 1 10`` + +This example would translate ensemble members 1 to 10. A single filter input file is +read for each ensemble with the name ``filter_output_&&&&`` where &&&& is the ensemble number +starting at 0001. The results are written into previously created aether neutrals and ions files +that are named as described above for ``aether_to_dart``. The Aether directory must also contain +grid files that contain the metadata for the Aether restarts. It is possible to overwrite the +Aether files in the same directory that was used for input to ``aether_to_dart``, or to copy the files +from that directory to a new directory to be updated by ``dart_to_aether``. + +Using perfect_model_obs or filter with the aether model_mod +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + +Simple example workflow +~~~~~~~~~~~~~~~~~~~~~~~ +This section describes a simple workflow that demonstrates and tests the capabilities of +the DART/Aether system. To do this simple example, you will need to contact +Jeff Anderson, jla@ucar.edu, or dart@ucar.edu to request a copy of the file ``TEST_INPUT.tar.gz``. +Place this file in the ``models/aether_cube_sphere/`` directory and execute the command +``tar -xzvf TEST_INPUT.tar.gz`` to create the ``TEST_INPUT`` directory. +that contains a small set of Aether grid input files. +There are 6 blocks, one covering each face of the cubed sphere. +The neutrals files contain two variables, O2 and Temperature. The ions files contain two variables, +O2+ and N2+. The ``TEST_INPUT`` directory only contains a single ensemble member for the ions and +neutrals files. + +Demonstration steps: + +1. In the models/aether_cube_sphere directory, execute the matlab script +``perturb_aether_ensemble.m``. This generates 10 ensemble members in the ``TEST_INPUT`` +directory. All variables are perturbed +so that the prior correlations between any two variables are one. + +2. In the ``aether_cube_sphere`` direcctory, copy the ``TEST_INPUT`` directory to the +``TEST_OUTPUT`` directory, ``cp -rf TEST_INPUT TEST_OUTPUT``. + +3. Build all of the DART programs by executing ``quickbuild.sh nompi`` in the +``aether_cube_sphere/work`` directory. + +4. Run ``aether_to_dart 1 10`` in the ``aether_cube_sphere/work`` directory. + +5. Run ``perfect_model_obs`` in the ``aether_cube_sphere/work`` directory. This creates +synthetic observations using the file ``obs_seq.in`` for metadata and creating the file +``obs_seq.out``. + +6. Run ``filter`` in the ``work`` directory to do a single step ensemble assimilation. + +7. Run ``dart_to_aether 1 10`` in the ``work`` directory to create updated aether restart +files in the ``aether_cube_sphere/TEST_OUTPUT`` directory. + +8. Use matlab script ``plot_filter_lat_lon.m`` in the ``aether_cube_sphere`` directory to +interactively view the increments for different variables for the DART +``filter_input_&&&&.nc`` and ``filter_output_&&&&.nc`` files + +9. Use matlab script ``plot_aether_lat_lon.m`` in the ``aether_cube_sphere`` directory to +view increments between the input aether restart files in the ``TEST_INPUT`` directory +and the updated aether restart filtes in the ``TEST_OUTPUT`` directory. + +The ``obs_seq.in`` file defines the observations that are created by ``perfect_model_obs`` and +then assimilated by ``filter``. In this case, there are 6 observations, one each of +temperature, density of O2, density of O2P, density of N2P, a ground station GPS +vertical total electron content, and a slant GPS total electron content. Each is at +a different horizontal location and the first 4 are at different vertical locations. + +The file ``create_obs_seq.input`` in the ``aether_cube_sphere`` directory contains input that +can be read by the program ``create_obs_sequence`` to create the default ``obs_seq.in`` file + +Work in Progress +~~~~~~~~~~~~~~~~ + +**Time:** +The method by which model time is read into DART has not been finalized at this time. All tests +to date use time that is manually inserted into the ``perfect_model_obs`` and ``filter`` namelist entries +``init_time_days`` and ``init_time_seconds``. The specifics of the how time is included in Aether input +files needs to be clarified so that the model_mod can read this directly from the filter restart +files. Aether is not currently using time that is consistent with any calendar supported by DART, +so this may require code in ``aether_to_dart.f90`` that translates the aether time to a time that +DART understands. + +**F10.7:** +Aether restart netcdf files do not currently include parameter values like F10.7. For now, +the ``aether_to_dart`` and ``dart_to_aether`` programs do not do not do input/output with Aether, +but obvious hooks are available in ``transform_state_mod.f90``. This module implements the +basics of two ways to do F10.7 estimation. The first is to have a single scalar value of +F10.7 in the DART state. Subroutine ``get_state_meta_data`` provides some initial suggestions for +the location associated with a scalar F10.7 that are taken from Alexey Morozov's work in +GITM. Because this requires the time, which is not yet available from Aether, this requires +additional implementation. Aether scientists also need to confirm that the subsolar point +is the right choice for a location. Alexey also implemented a different localization +algorithm for F10.7 in GITM. Aether scientists should work with DART experts to determine +if and how this would be implemented in Aether. Under namelist control, ``aether_to_dart`` +can also treat F10.7 as a horizontally distributed variable, basically copying the same value +of F10.7 to each horizontal column. The value at each column is updated and ``dart_to_aether`` +currently just averages the posterior values. Other choices for weighted averages are +scientifically interesting and could be explored by aether/DART collaborations. + + +**VTEC:** +The established forward operator for vertically integrated electron content in DART is found in +the ``observations/forward_operators/obs_def_upper_atm_mod.f90``. It assumes that the DART state +includes a 3D field with quantity ``QTY_DENSITY_ION_E`` and that the state also includes the +geometric height of each grid point in ``QTY_GEOMETRIC_HEIGHT``. The subroutine +``get_expected_gnd_gps_vtec`` integrates the density in a column. This subroutine was originally +developed for GITM and then extended for TIEGCM. Unlike GITM, Aether does not include the +ION density in its restart netcdf files. The ``aether_to_dart.f90`` sums up the density of all +variables in the ions files that have units of /m3 and puts this into the filter_input file that +is created. Aether model experts should verify both the creation of the density field and the +way that a vertical integral is computed to confirm that these are consistent with the model +and the available observations. Note that there are other electron content forward operators +that may also need to be evaluated by model experts before use. + +**Slant VTEC:** +There is a subroutine called ``get_expected_slant_gps_vtec`` in +``/observations/forward_operators/obs_def_upper_atm_mod.f90``. It does exaclty the same thing +as the vtec described above. However, it includes extended metadata in the obs_seq files. +These are two locations descriptions, one for the satellite postion (lon, lat, height), +and one for a ground point (lon, lat, height). One way to implement a slant vtec forward +operator would be to trace a ray between the satellite and the ground and get the density +at each level along the ray. Other ways of describing the geometry of the ray may be more +appropriate. Aether developers and observation experts should be able to use the example +code to easily implement the forward operator once the exact method for tracing the ray +from the satellite is implemented. + +Testing the grid computations +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The program ``test_aether_grid`` in ``developer_tests/aether_grid`` can be run +with the namelist setting used for a ``filter`` run to +verify the geometry in the ``model_mod`` and to confirm consistency with the aether template file +selected by the ``template_file`` entry in the ``model_nml`` namelist. Note that an aether template +filter file must have been created in the ``aether_cube_sphere/work`` directory before this test +is run. + diff --git a/models/aether_cube_sphere/transform_state_mod.f90 b/models/aether_cube_sphere/transform_state_mod.f90 new file mode 100644 index 0000000000..59123863ff --- /dev/null +++ b/models/aether_cube_sphere/transform_state_mod.f90 @@ -0,0 +1,871 @@ +! 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$ + +! Provides tools to do transforms from Aether block files to DART filter files +! and back. + +module transform_state_mod + +use netcdf +use types_mod, only : r4, r8, varnamelength, RAD2DEG +use netcdf_utilities_mod, only : nc_open_file_readonly, nc_open_file_readwrite, & + nc_close_file, nc_create_file, nc_end_define_mode +use utilities_mod, only : find_namelist_in_file, check_namelist_read, & + error_handler, E_ERR, string_to_integer + +use cube_sphere_grid_tools_mod, only : lat_lon_to_col_index, get_grid_delta + +implicit none +private + +public :: initialize_transform_state_mod, model_to_dart, dart_to_model, & + get_ensemble_range_from_command_line + +integer :: iunit, io + +! version controlled file description for error handling, do not edit +character(len=*), parameter :: source = 'aether_cube_sphere/transform_state_mod.f90' +character(len=*), parameter :: revision = '' +character(len=*), parameter :: revdate = '' + +type :: file_type + character(len=256) :: file_path + integer :: ncid, unlimitedDimId, nDimensions, nVariables, nAttributes, formatNum +end type file_type + +! It would be nice to get this information from the Aether input files, not possible for now +integer :: np, nblocks, nhalos + +! Switch between scalar and horizontal f10.7 +logical :: scalar_f10_7 = .true. + +namelist /transform_state_nml/ np, nblocks, nhalos, scalar_f10_7 + +contains + +!--------------------------------------------------------------- + +subroutine initialize_transform_state_mod() + +! Just read the namelist +call find_namelist_in_file('input.nml', 'transform_state_nml', iunit) +read(iunit, nml = transform_state_nml, iostat = io) +call check_namelist_read(iunit, io, 'transform_state_nml') + +end subroutine initialize_transform_state_mod + +!--------------------------------------------------------------- + +subroutine model_to_dart(aether_block_file_dir, dart_file_dir, ensemble_number) + +character(len=*), intent(in) :: aether_block_file_dir, dart_file_dir +integer, intent(in) :: ensemble_number + +integer :: iblock, dimid, length, ncols, dart_dimid(3), varid, xtype, nDimensions, nAtts +integer :: param_dimid(2), nparams +integer :: ix, iy, iz, icol, ncstatus +integer :: ntimes(nblocks), nxs(nblocks), nys(nblocks) +integer :: ions_ntimes(nblocks), ions_nxs(nblocks), ions_nys(nblocks) +integer :: neutrals_ntimes(nblocks), neutrals_nxs(nblocks), neutrals_nys(nblocks) +integer :: haloed_nxs(nblocks), haloed_nys(nblocks) +integer :: final_nzs, ions_final_nzs, neutrals_final_nzs +integer :: filter_time_id, filter_alt_id, filter_lat_id, filter_lon_id +integer :: grid_alt_id, grid_lat_id, grid_lon_id +integer :: electron_varid, f10_7_varid +integer :: dimids(NF90_MAX_VAR_DIMS) +real(r8) :: blat, blon, del, half_del, f10_7_val +real(r8) :: time_array(1) +logical :: add_to_electrons +character(len = 4) :: ensemble_string +character(len=NF90_MAX_NAME) :: name, attribute +integer, allocatable :: col_index(:, :, :), filter_ions_ids(:), filter_neutrals_ids(:) +! File for reading in variables from block file; These can be R4 +real(r4), allocatable :: spatial_array(:), variable_array(:, :, :), electron_array(:, :) +real(r4), allocatable :: block_array(:, :, :), block_lats(:, :, :), block_lons(:, :, :) +type(file_type), allocatable :: ions_files(:), neutrals_files(:), grid_files(:) +type(file_type) :: filter_file + +! Open the grid and ions and neutrals files here for now with fixed directory names +ions_files = assign_block_file_names(nblocks, aether_block_file_dir, & + 'ions', ensemble_number) + +neutrals_files = assign_block_file_names(nblocks, aether_block_file_dir, & + 'neutrals', ensemble_number) + +grid_files = assign_block_file_names(nblocks, aether_block_file_dir, 'grid') + +! Get grid spacing from number of points across each face +call get_grid_delta(np, del, half_del) + +!======================== Get info on x, y and z dimensions from grid files + +do iblock = 1, nblocks + ! Open the grid files, read only + grid_files(iblock)%ncid = nc_open_file_readonly(grid_files(iblock)%file_path) +end do + +call get_aether_block_dimensions(grid_files, nblocks, nhalos, nxs, nys, final_nzs) +! Get the full dimension size with the halos for all blocks +haloed_nxs = nxs + 2*nhalos +haloed_nys = nys + 2*nhalos + +! Compute the number of columns (without haloes) +ncols = sum(nxs(1:nblocks) * nys(1:nblocks)) + +!=============================== Check that ions files are consistent with grids ========= + +do iblock = 1, nblocks + ! Open the ions block files, read only, and get the metadata + ions_files(iblock)%ncid = nc_open_file_readonly(ions_files(iblock)%file_path) +end do + +call get_aether_block_dimensions(ions_files, nblocks, nhalos, ions_nxs, ions_nys, ions_final_nzs) + +! Check for inconsistent number of vertical levels in ion and grid files +if(ions_final_nzs /= final_nzs) & + call error_handler(E_ERR, 'model_to_dart', & + 'Number of altitudes in grid and ions files differs', source, revision, revdate) + +! Make sure ions and grid files have same horizontal sizes +if(any(ions_nxs /= nxs) .or. any(ions_nys /= nys)) & + call error_handler(E_ERR, 'model_to_dart', & + 'Number of Latitudes and Longitudes in grid and ions files differ', source, revision, revdate) + +!=============================== Check that neutrals files are consistent with grids ========= + +do iblock = 1, nblocks + ! Open the neutrals block files, read only, and get the metadata + neutrals_files(iblock)%ncid = nc_open_file_readonly(neutrals_files(iblock)%file_path) +end do + +call get_aether_block_dimensions(neutrals_files, nblocks, nhalos, neutrals_nxs, neutrals_nys, & + neutrals_final_nzs) + +! Check for inconsistent number of vertical levels in neutral and grid files +if(neutrals_final_nzs /= final_nzs) & + call error_handler(E_ERR, 'model_to_dart', & + 'Number of altitudes in grid and neutrals files differs', source, revision, revdate) + +! Make sure neutrals and grid files have same horizontal sizes +if(any(neutrals_nxs /= nxs) .or. any(neutrals_nys /= nys)) & + call error_handler(E_ERR, 'model_to_dart', & + 'Number of Latitudes and Longitudes in grid and neutrals files differ', source, revision, revdate) + +!==================================== Write dimensions in the filter nc file ======== + +! Initialize the filter file that will be created +ensemble_string = zero_fill(integer_to_string(ensemble_number), 4) +filter_file%file_path = trim(dart_file_dir) // 'filter_input_' // & + ensemble_string // '.nc' + +! Create the filter netcdf file +filter_file%ncid = nc_create_file(filter_file%file_path) + +! Create dimensions in filter_file; save for use during variable definition +ncstatus = nf90_def_dim(filter_file%ncid, 'time', NF90_UNLIMITED, dart_dimid(3)) +ncstatus = nf90_def_dim(filter_file%ncid, 'z', final_nzs, dart_dimid(2)) +ncstatus = nf90_def_dim(filter_file%ncid, 'col', ncols, dart_dimid(1)) + +! Add a parameter axis for F10.7 +nparams = 1 +ncstatus = nf90_def_dim(filter_file%ncid, 'param', nparams, param_dimid(1)) +param_dimid(2) = dart_dimid(3) + +!========================================================= +! Create the variables from the grid files; time, alt, lat, lon + +! Loop through the aether grid files to find the three needed fields +do varid = 1, 4 + ncstatus = nf90_inquire_variable(grid_files(1)%ncid, varid, name, xtype, nDimensions, dimids, nAtts) + if (trim(name) == 'time') then + ncstatus = nf90_def_var(filter_file%ncid, name, xtype, dart_dimid(3), filter_time_id) + else if (trim(name) == 'Altitude') then + ! Rename the 'z' variable as 'alt' so there isn't a dimension and a variable with the same name + ncstatus = nf90_def_var(filter_file%ncid, 'alt', xtype, dart_dimid(2), filter_alt_id) + ncstatus = nf90_put_att(filter_file%ncid, filter_alt_id, 'units', 'm') + ncstatus = nf90_put_att(filter_file%ncid, filter_alt_id, 'long_name', & + 'height above mean sea level') + grid_alt_id = varid + else if (trim(name) == 'Latitude') then + ncstatus = nf90_def_var(filter_file%ncid, 'lat', xtype, dart_dimid(1), filter_lat_id) + ncstatus = nf90_put_att(filter_file%ncid, filter_lat_id, 'units', 'degrees_north') + ncstatus = nf90_put_att(filter_file%ncid, filter_lat_id, 'long_name', 'latitude') + grid_lat_id = varid + else if (trim(name) == 'Longitude') then + ncstatus = nf90_def_var(filter_file%ncid, 'lon', xtype, dart_dimid(1), filter_lon_id) + ncstatus = nf90_put_att(filter_file%ncid, filter_lon_id, 'units', 'degrees_east') + ncstatus = nf90_put_att(filter_file%ncid, filter_lon_id, 'long_name', 'longitude') + grid_lon_id = varid + else + call error_handler(E_ERR, 'model_to_dart', & + 'Unexpected variable name in grid file ' // trim(name), source, revision, revdate) + end if +end do + +!========================================================= + +! Allocate storage + +! Pointers to the different data fields in the filter nc file +allocate(filter_ions_ids(ions_files(1)%nVariables)) +! Pointers to the different data fields in the filter nc file +allocate(filter_neutrals_ids(neutrals_files(1)%nVariables)) +! Allocate ncols size temporary storage +allocate(spatial_array(ncols), variable_array(ncols, final_nzs, 1), electron_array(ncols, final_nzs)) + +! The col_index array will keep track of mapping from x and y for each block to final columns +allocate(col_index(nblocks, maxval(nys), maxval(nxs))) + +! Allocate storage for the latitude and longitude from the blocks +allocate(block_lats (final_nzs, maxval(haloed_nys), maxval(haloed_nxs)), & + block_lons (final_nzs, maxval(haloed_nys), maxval(haloed_nxs)), & + block_array(final_nzs, maxval(haloed_nys), maxval(haloed_nxs))) + +!========================================================= + +! Get the metadata for variable fields from the ions block files +! The ions files have time and all their physical variables, but not latitude, longitude, or altitude + +! Illegal value of filter file index for default +filter_ions_ids = -99 + +! The filter_file is still in define mode. Create all of the variables before entering data mode. +do varid = 1, ions_files(1)%nVariables + ncstatus = nf90_inquire_variable(ions_files(1)%ncid, varid, name, xtype, nDimensions, dimids, nAtts) + ! Find the physcial field + if (trim(name) /= 'time') then + ncstatus = nf90_def_var(filter_file%ncid, name, xtype, dart_dimid, filter_ions_ids(varid)) + + ! Add the units, same in all files so just get from the first + ncstatus = nf90_get_att(ions_files(1)%ncid, varid, 'units', attribute) + ncstatus = nf90_put_att(filter_file%ncid, filter_ions_ids(varid), 'units', attribute) + end if +end do + +!========================================================= + +! Get the metadata for variable fields from the neutrals block files +! The neutrals files have time and all their physical variables, but not latitude, longitude, or altitude + +! Illegal value of filter file index for default +filter_neutrals_ids = -99 + +! The filter_file is still in define mode. Create all of the variables before entering data mode. +do varid = 1, neutrals_files(1)%nVariables + ncstatus = nf90_inquire_variable(neutrals_files(1)%ncid, varid, name, xtype, nDimensions, dimids, nAtts) + ! Find the physcial fields + if (trim(name) /= 'time') then + ncstatus = nf90_def_var(filter_file%ncid, name, xtype, dart_dimid, filter_neutrals_ids(varid)) + + ! Add the units, same in all files so just get from the first + ncstatus = nf90_get_att(neutrals_files(1)%ncid, varid, 'units', attribute) + ncstatus = nf90_put_att(filter_file%ncid, filter_neutrals_ids(varid), 'units', attribute) + end if +end do + +!========================================================= + +! Add a derived vertical total electron content field +! xtype is currently set to value of last field from neutrals file +ncstatus = nf90_def_var(filter_file%ncid, 'ION_E', xtype, dart_dimid, electron_varid) +ncstatus = nf90_put_att(filter_file%ncid, electron_varid, 'units', '/m3') + +! NOTE TO AETHER MODELERS: F10.7 needs to come from one of the restart files +if(scalar_f10_7) then + ! Add a scalar F10.7 + ncstatus = nf90_def_var(filter_file%ncid, 'SCALAR_F10.7', xtype, param_dimid, f10_7_varid) + ncstatus = nf90_put_att(filter_file%ncid, f10_7_varid, 'units', 'sfu: W/m^2/Hz') + ncstatus = nf90_put_att(filter_file%ncid, f10_7_varid, 'long_name', 'Solar Radio Flux at 10.7 cm') +else + ! Add a two-dimensional F10.7 + ncstatus = nf90_def_var(filter_file%ncid, '2D_F10.7', xtype, & + dart_dimid(1:3:2), f10_7_varid) + ncstatus = nf90_put_att(filter_file%ncid, f10_7_varid, 'units', 'sfu: W/m^2/Hz') + ncstatus = nf90_put_att(filter_file%ncid, f10_7_varid, 'long_name', 'Solar Radio Flux at 10.7 cm') +endif + +! End of define mode for filter nc file, ready to add data +call nc_end_define_mode(filter_file%ncid) + +!=========== Block to get lat lon and alt data from grid files ================= + +! Loop through all the blocks for this variable +do iblock = 1, nblocks + ! Get the latitude and longitude full arrays + ncstatus = nf90_get_var(grid_files(iblock)%ncid, grid_lat_id, block_lats) + ncstatus = nf90_get_var(grid_files(iblock)%ncid, grid_lon_id, block_lons) + + ! Compute the col_index for each of the horizontal locations in this block + do ix = 1, nxs(iblock) + do iy = 1, nys(iblock) + blat = block_lats(1, nhalos + iy, nhalos + ix); + blon = block_lons(1, nhalos + iy, nhalos + ix); + col_index(iblock, iy, ix) = lat_lon_to_col_index(blat, blon, del, half_del, np) + end do + end do +end do + +! Only need altitude from 1 block +ncstatus = nf90_get_var(grid_files(1)%ncid, grid_alt_id, block_array) +ncstatus = nf90_put_var(filter_file%ncid, filter_alt_id, block_array(:,1,1)) + +! Loop through blocks to get lat values +do iblock = 1, nblocks + ! Get lat values for this block + ncstatus = nf90_get_var(grid_files(iblock)%ncid, grid_lat_id, block_array) + do iy = 1, nys(iblock) + do ix = 1, nxs(iblock) + icol = col_index(iblock, iy, ix) + ! DART wants latitude in degrees + spatial_array(icol) = block_array(1, nhalos+iy, nhalos+ix) * RAD2DEG + end do + end do +end do +ncstatus = nf90_put_var(filter_file%ncid, filter_lat_id, spatial_array) + +! Loop through blocks to get lon values +do iblock = 1, nblocks + ! Get lon values for this block + ncstatus = nf90_get_var(grid_files(iblock)%ncid, grid_lon_id, block_array) + do iy = 1, nys(iblock) + do ix = 1, nxs(iblock) + icol = col_index(iblock, iy, ix) + ! DART wants longitude in degrees + spatial_array(icol) = block_array(1, nhalos+iy, nhalos+ix) * RAD2DEG + end do + end do +end do +ncstatus = nf90_put_var(filter_file%ncid, filter_lon_id, spatial_array) + +!=========== Copy data from ions files ================= + +! Electron density is sum of all the ion densities; sum them up +electron_array = 0.0_r8 + +! Will get full spatial field for one variable at a time +do varid = 1, ions_files(1)%nVariables + ! Get metadata for this variable from first block file + ncstatus = nf90_inquire_variable(ions_files(1)%ncid, & + varid, name, xtype, nDimensions, dimids, nAtts) + + ! NOTE TO AETHER MODELERS: Make sure this is the correct way to get total + ! See if this is a density; if so, needs to be added into electrons + ncstatus = nf90_get_att(ions_files(1)%ncid, varid, 'units', attribute) + add_to_electrons = trim(attribute) == '/m3' + + if(trim(name) == 'time') then + ! Time must be the same in all files, so just deal with it from the first one + ncstatus = nf90_get_var(ions_files(1)%ncid, varid, time_array) + ncstatus = nf90_put_var(filter_file%ncid, filter_time_id, time_array) + else + ! Loop through all the blocks for this variable + do iblock = 1, nblocks + ! Read into the full 3Dblock array + ncstatus = nf90_get_var(ions_files(iblock)%ncid, varid, block_array) + + ! Transfer data to columns array + do iy = 1, nys(iblock) + do ix = 1, nxs(iblock) + icol = col_index(iblock, iy, ix) + do iz = 1, final_nzs + variable_array(icol, iz, 1) = block_array(iz, nhalos+iy, nhalos+ix) + ! Add into electrons if it is a density + if(add_to_electrons) electron_array(icol, iz) = & + electron_array(icol, iz) + variable_array(icol, iz, 1) + end do + end do + end do + + end do + ncstatus = nf90_put_var(filter_file%ncid, filter_ions_ids(varid), variable_array) + end if + +end do + +!=========== Copy data from neutrals files ================= + +! Will get full spatial field for one variable at a time +do varid = 1, neutrals_files(1)%nVariables + ! Get metadata for this variable from first block file + ncstatus = nf90_inquire_variable(neutrals_files(1)%ncid, & + varid, name, xtype, nDimensions, dimids, nAtts) + + ! Already got time from ions files + if(trim(name) /= 'time') then + ! Loop through all the blocks for this variable + do iblock = 1, nblocks + ! Read into the full 3Dblock array + ncstatus = nf90_get_var(neutrals_files(iblock)%ncid, varid, block_array) + + do iy = 1, nys(iblock) + do ix = 1, nxs(iblock) + icol = col_index(iblock, iy, ix) + do iz = 1, final_nzs + variable_array(icol, iz, 1) = block_array(iz, nhalos+iy, nhalos+ix) + end do + end do + end do + + end do + ncstatus = nf90_put_var(filter_file%ncid, filter_neutrals_ids(varid), variable_array) + end if + +end do + +!===================== Add in the additional variables ================== +! Write out the electron density field +variable_array(:, :, 1) = electron_array +ncstatus = nf90_put_var(filter_file%ncid, electron_varid, variable_array) + +if(scalar_f10_7) then + ! Add in f10.7 as a zero_dimensional field + ncstatus = nf90_put_var(filter_file%ncid, f10_7_varid, 1.0_r8 * ensemble_number) +else + ! Add in f10.7 as a two-dimensional field + f10_7_val = 1.0_r8 * ensemble_number + variable_array(:, 1, 1) = f10_7_val + ncstatus = nf90_put_var(filter_file%ncid, f10_7_varid, variable_array(:, 1, 1)) +endif + +!=============================================================== + +! Close files and release storage +call nc_close_file(filter_file%ncid) +do iblock = 1, nblocks + ! Close the grid files and ions and neutrals files + call nc_close_file(grid_files(iblock)%ncid) + call nc_close_file(ions_files(iblock)%ncid) + call nc_close_file(neutrals_files(iblock)%ncid) +end do + +deallocate(block_lats, block_lons, block_array, spatial_array, variable_array) +deallocate(electron_array, col_index, filter_ions_ids, filter_neutrals_ids) + +end subroutine model_to_dart + +!--------------------------------------------------------------- + +subroutine dart_to_model(dart_file_dir, aether_block_file_dir, ensemble_number) + +character(len=*), intent(in) :: dart_file_dir, aether_block_file_dir +integer, intent(in) :: ensemble_number + +real(r8) :: blat, blon, del, half_del, f10_7_scalar +integer :: iblock, dimid, length, ncols, varid, xtype, nDimensions, nAtts +integer :: ix, iy, iz, icol, ncstatus, filter_varid +integer :: nxs(nblocks), nys(nblocks), final_nzs +integer :: ions_nxs(nblocks), ions_nys(nblocks), ions_final_nzs +integer :: neutrals_nxs(nblocks), neutrals_nys(nblocks), neutrals_final_nzs +integer :: haloed_nxs(nblocks), haloed_nys(nblocks) +integer :: grid_alt_id, grid_lat_id, grid_lon_id +integer :: dimids(NF90_MAX_VAR_DIMS) +character(len = 4) :: ensemble_string +character(len=NF90_MAX_NAME) :: name, attribute +integer, allocatable :: col_index(:, :, :) +! File for reading in variables from block file; These can be R4 +real(r4), allocatable :: variable_array(:, :, :) +real(r4), allocatable :: block_array(:, :, :), block_lats(:, :, :), block_lons(:, :, :) +type(file_type), allocatable :: ions_files(:), neutrals_files(:), grid_files(:) +type(file_type) :: filter_file + +! Open the grid and ions and neutrals files here for now with fixed directory names +ions_files = assign_block_file_names(nblocks, aether_block_file_dir, & + 'ions', ensemble_number) + +neutrals_files = assign_block_file_names(nblocks, aether_block_file_dir, & + 'neutrals', ensemble_number) + +grid_files = assign_block_file_names(nblocks, aether_block_file_dir, 'grid') + +! Get grid spacing from number of points across each face +call get_grid_delta(np, del, half_del) + +!======================== Get info on x, y and z dimensions from grid files +do iblock = 1, nblocks + ! Open the grid files, read only + grid_files(iblock)%ncid = nc_open_file_readonly(grid_files(iblock)%file_path) +end do + +call get_aether_block_dimensions(grid_files, nblocks, nhalos, nxs, nys, final_nzs) +! Get the full dimension size with the halos for all blocks +haloed_nxs = nxs + 2*nhalos +haloed_nys = nys + 2*nhalos + +! Compute the number of columns (without haloes) +ncols = sum(nxs(1:nblocks) * nys(1:nblocks)) + +!==================================== Open and check dimensions for ions files + +! The ions block files need to be open read write +do iblock = 1, nblocks + ions_files(iblock)%ncid = nc_open_file_readwrite(ions_files(iblock)%file_path) +end do + +! Check that ions files are consistent with grids +call get_aether_block_dimensions(ions_files, nblocks, nhalos, ions_nxs, ions_nys, ions_final_nzs) + +! Check for inconsistent number of vertical levels in ion and grid files +if(ions_final_nzs /= final_nzs) & + call error_handler(E_ERR, 'model_to_dart', & + 'Number of altitudes in grid and ions files differs', source, revision, revdate) + +! Make sure ions and grid files have same horizontal sizes +if(any(ions_nxs /= nxs) .or. any(ions_nys /= nys)) & + call error_handler(E_ERR, 'model_to_dart', & + 'Number of Latitudes and Longitudes in grid and ion files differ', source, revision, revdate) + +!==================================== Open and check dimensions for neutrals files + +! The neutrals block files need to be open read write +do iblock = 1, nblocks + neutrals_files(iblock)%ncid = nc_open_file_readwrite(neutrals_files(iblock)%file_path) +end do + +! Check that neutrals files are consistent with grids +call get_aether_block_dimensions(neutrals_files, nblocks, nhalos, neutrals_nxs, neutrals_nys, neutrals_final_nzs) + +! Check for inconsistent number of vertical levels in neutrals and grid files +if(neutrals_final_nzs /= final_nzs) & + call error_handler(E_ERR, 'model_to_dart', & + 'Number of altitudes in grid and neutrals files differs', source, revision, revdate) + +! Make sure neutrals and grid files have same horizontal sizes +if(any(neutrals_nxs /= nxs) .or. any(neutrals_nys /= nys)) & + call error_handler(E_ERR, 'model_to_dart', & + 'Number of Latitudes and Longitudes in grid and neutrals files differ', source, revision, revdate) + +!=========== Get alt lat and lon from grid files ================= + +! Find the latitude and longitude information from the grid files and get the column mapping +ncstatus = nf90_inq_varid(grid_files(1)%ncid, 'Altitude', grid_alt_id) +ncstatus = nf90_inq_varid(grid_files(1)%ncid, 'Latitude', grid_lat_id) +ncstatus = nf90_inq_varid(grid_files(1)%ncid, 'Longitude', grid_lon_id) + +! Allocate storage for the latitude and longitude from the blocks +allocate(col_index(nblocks, maxval(nys), maxval(nxs)), & + variable_array(ncols, final_nzs, 1), & + block_lats(final_nzs, maxval(haloed_nys), maxval(haloed_nxs)), & + block_lons(final_nzs, maxval(haloed_nys), maxval(haloed_nxs)), & + block_array(final_nzs, maxval(haloed_nys), maxval(haloed_nxs))) + +! Loop through all the blocks +do iblock = 1, nblocks + ! Get the latitude and longitude full arrays + ncstatus = nf90_get_var(grid_files(iblock)%ncid, grid_lat_id, block_lats) + ncstatus = nf90_get_var(grid_files(iblock)%ncid, grid_lon_id, block_lons) + + ! Compute the col_index for each of the horizontal locations in this block + do ix = 1, nxs(iblock) + do iy = 1, nys(iblock) + blat = block_lats(1, nhalos + iy, nhalos + ix); + blon = block_lons(1, nhalos + iy, nhalos + ix); + col_index(iblock, iy, ix) = lat_lon_to_col_index(blat, blon, del, half_del, np) + end do + end do +end do + +! Open the filter file that will be read +ensemble_string = zero_fill(integer_to_string(ensemble_number), 4) +filter_file%file_path = trim(dart_file_dir) // 'filter_output_' // & + ensemble_string // '.nc' +! Open the filter netcdf file +filter_file%ncid = nc_open_file_readonly(filter_file%file_path) + +!========================================================================== +! Loop through ions fields and replace with values from filter_file +! Note that this preserves all fields in the ions and neutrals files that +! were not part of the DART state + +ncstatus = nf90_inquire(ions_files(1)%ncid, ions_files(1)%nDimensions, & + ions_files(1)%nVariables, ions_files(1)%nAttributes, ions_files(1)%unlimitedDimId, & + ions_files(1)%formatNum) + +! Get full spatial field for one variable at a time +do varid = 1, ions_files(1)%nVariables + ! Get metadata for this variable from first block file + ncstatus = nf90_inquire_variable(ions_files(1)%ncid, & + varid, name, xtype, nDimensions, dimids, nAtts) + if(trim(name) /= 'time' .and. trim(name) /= 'Altitude' .and. trim(name) /= 'Latitude' & + .and. trim(name) /= 'Longitude') then + ! See if this variable is also in the filter output file + ncstatus = nf90_inq_varid(filter_file%ncid, trim(name), filter_varid) + ! Check on failed ncstatus. 0 is successful but should use the proper name + if(ncstatus == 0) then + ! Read this field from filter file + ncstatus = nf90_get_var(filter_file%ncid, filter_varid, variable_array) + +! CAN WE UPDATE THE HALOS TOO WHEN WRITING BACK??? + ! Loop through all the blocks for this variable + block_array = 0.0_r8 + do iblock = 1, nblocks + do iy = 1, nys(iblock) + do ix = 1, nxs(iblock) + icol = col_index(iblock, iy, ix) + do iz = 1, final_nzs + block_array(iz, nhalos+iy, nhalos+ix) = variable_array(icol, iz, 1) + end do + end do + end do + ! Write into the full file for this block + ncstatus = nf90_put_var(ions_files(iblock)%ncid, varid, block_array) + end do + endif + end if +end do + +!========================================================================== +! Loop through neutrals fields and replace with values from filter + +ncstatus = nf90_inquire(neutrals_files(1)%ncid, neutrals_files(1)%nDimensions, & + neutrals_files(1)%nVariables, neutrals_files(1)%nAttributes, neutrals_files(1)%unlimitedDimId, & + neutrals_files(1)%formatNum) + +! Get full spatial field for one variable at a time +do varid = 1, neutrals_files(1)%nVariables + ! Get metadata for this variable from first block file + ncstatus = nf90_inquire_variable(neutrals_files(1)%ncid, & + varid, name, xtype, nDimensions, dimids, nAtts) + if(trim(name) /= 'time' .and. trim(name) /= 'Altitude' .and. trim(name) /= 'Latitude' & + .and. trim(name) /= 'Longitude') then + ! See if this variable is also in the filter output file + ncstatus = nf90_inq_varid(filter_file%ncid, trim(name), filter_varid) + ! Check on failed ncstatus. 0 is successful but should use the proper name + if(ncstatus == 0) then + ! Read this field from filter file + ncstatus = nf90_get_var(filter_file%ncid, filter_varid, variable_array) + + ! Loop through all the blocks for this variable + block_array = 0.0_r8 + do iblock = 1, nblocks + do iy = 1, nys(iblock) + do ix = 1, nxs(iblock) + icol = col_index(iblock, iy, ix) + do iz = 1, final_nzs + block_array(iz, nhalos+iy, nhalos+ix) = variable_array(icol, iz, 1) + end do + end do + end do + ! Write into the full file for this block + ncstatus = nf90_put_var(neutrals_files(iblock)%ncid, varid, block_array) + end do + endif + end if +end do + +!============================================================================== + +! NOTE FOR AETHER MODELERS: +! Need more information about where F10.7 will be in Aether input files to complete copy back +ncstatus = nf90_inq_varid(filter_file%ncid, 'F10.7', filter_varid) +if(scalar_f10_7) then + ! Read a scalar f10_7 value + ncstatus = nf90_get_var(filter_file%ncid, filter_varid, f10_7_scalar) +else + ! Read a column sized f10_7 value + ncstatus = nf90_get_var(filter_file%ncid, filter_varid, variable_array(:, 1, 1)) + ! Average the updated value over all the columns + f10_7_scalar = sum(variable_array(:, 1, 1)) / ncols +endif +! Write the updated F10.7 to the appropriate Aether file + +!============================================================================== + +! Free storage and close files +deallocate(col_index, variable_array, block_lats, block_lons, block_array) + +! Close the netcdf files +call nc_close_file(filter_file%ncid) +do iblock = 1, nblocks + ! Close the grid files and ions and neutrals files + call nc_close_file(grid_files(iblock)%ncid) + call nc_close_file(ions_files(iblock)%ncid) + call nc_close_file(neutrals_files(iblock)%ncid) +end do + +end subroutine dart_to_model + +!-------------------------------------------------------------------- + +subroutine get_aether_block_dimensions(files, nblocks, nhalos, nxs, nys, nzs) + +! Gets the dimesions of the aether block files and the overall grid +! Does consistency checks across the blocks + +integer, intent(in) :: nblocks, nhalos +type(file_type), intent(inout) :: files(nblocks) +integer, intent(out) :: nxs(nblocks), nys(nblocks), nzs + +integer :: iblock, b_nzs(nblocks), ncstatus, dimid, length +character(len=NF90_MAX_NAME) :: name + +! Look at each block +do iblock = 1, nblocks + ! Get info about the block file + ncstatus = nf90_inquire(files(iblock)%ncid, files(iblock)%nDimensions, & + files(iblock)%nVariables, files(iblock)%nAttributes, & + files(iblock)%unlimitedDimId, files(iblock)%formatNum) + + ! Verify that a single time level exists + ncstatus = nf90_inq_dimid(files(iblock)%ncid, 'time', dimid) + ncstatus = nf90_inquire_dimension(files(iblock)%ncid, dimid, name, length) + if(length /= 1 .or. ncstatus /= 0) & + call error_handler(E_ERR, 'get_aether_block_dimensions', & + 'Number of times in input block files should be 1', source, revision, revdate) + + ! Get the length of x dimension + ncstatus = nf90_inq_dimid(files(iblock)%ncid, 'x', dimid) + ncstatus = nf90_inquire_dimension(files(iblock)%ncid, dimid, name, length) + if(ncstatus /= 0) & + call error_handler(E_ERR, 'get_aether_block_dimensions', & + 'input block files must have x dimension', source, revision, revdate) + nxs(iblock) = length-2*nhalos + + ! Get the length of y dimension + ncstatus = nf90_inq_dimid(files(iblock)%ncid, 'y', dimid) + ncstatus = nf90_inquire_dimension(files(iblock)%ncid, dimid, name, length) + if(ncstatus /= 0) & + call error_handler(E_ERR, 'get_aether_block_dimensions', & + 'input block files must have y dimension', source, revision, revdate) + nys(iblock) = length-2*nhalos + + ! Get the length of z dimension + ncstatus = nf90_inq_dimid(files(iblock)%ncid, 'z', dimid) + ncstatus = nf90_inquire_dimension(files(iblock)%ncid, dimid, name, length) + if(ncstatus /= 0) & + call error_handler(E_ERR, 'get_aether_block_dimensions', & + 'input block files must have z dimension', source, revision, revdate) + b_nzs(iblock) = length + +end do + +! Make sure all blocks have same number of vertical levels +if(any(b_nzs - b_nzs(1) /= 0)) then + call error_handler(E_ERR, 'model_to_dart', & + 'block files have different lengths for z dimension', source, revision, revdate) +else + nzs = b_nzs(1) +endif + +! Make sure all block files have the same number of attributes +if(any(files(:)%nAttributes /= files(1)%nAttributes)) & + call error_handler(E_ERR, 'model_to_dart', & + 'All blocks must have same nunber of variables', source, revision, revdate) + +end subroutine get_aether_block_dimensions + +!--------------------------------------------------------------- + +subroutine get_ensemble_range_from_command_line(start_ensemble, end_ensemble) + +integer, intent(out) :: start_ensemble, end_ensemble + +! Gets the first and last ensemble members to be converted from command line + +character(len=4) :: start_ensemble_string, end_ensemble_string +integer :: nargs + +nargs = command_argument_count() + +if (nargs /= 2) & + call error_handler(E_ERR, 'get_ensemble_range_from_command_line', & + 'starting and ending ensemble members must be in command line argument') + +call get_command_argument(1, start_ensemble_string) +call get_command_argument(2, end_ensemble_string) + +! Convert these to integer values +read(start_ensemble_string, *) start_ensemble +read(end_ensemble_string, *) end_ensemble + +! Not prepared to deal with more than 4 digit ensemble count +if(start_ensemble > 9999 .or. end_ensemble > 9999) & + call error_handler(E_ERR, 'get_ensemble_range_from_command_line', & + 'Ensemble numbers on command line must be less than 10000') + +end subroutine get_ensemble_range_from_command_line + +!--------------------------------------------------------------- + +function assign_block_file_names(nblocks, directory, & + file_prefix, ensemble_number) result(block_files) + +! Gets the file information for blocks + +integer, intent(in) :: nblocks +character(len=*), intent(in) :: directory +character(len=*), intent(in) :: file_prefix +integer, intent(in), optional :: ensemble_number +type(file_type), allocatable :: block_files(:) + +character(len=256) :: file +character(len=4) :: block_num, ensemble_string +integer :: iblock + +! Storage for each block +allocate(block_files(nblocks)) + +! Grid files don't have ensembles +if(present(ensemble_number)) then + ensemble_string = zero_fill(integer_to_string(ensemble_number - 1), 4) +endif + +! Get the name for each block +do iblock = 1, nblocks + block_num = zero_fill(integer_to_string(iblock - 1), 4) + file = trim(directory) // trim(file_prefix) + ! Add in ensemble member if needed + if(present(ensemble_number)) then + file = trim(file) // '_m' // ensemble_string + endif + block_files(iblock)%file_path = trim(file) // '_g' // block_num // '.nc' +end do + +end function assign_block_file_names + +!--------------------------------------------------------------- + +function integer_to_string(int) result(string) + +integer, intent(in) :: int +character(len=varnamelength) :: string + +write(string,'(I0)') int +string = trim(string) + +end function integer_to_string + +!--------------------------------------------------------------- + +function zero_fill(string, desired_length) result(filled_string) + +character(len=*), intent(in) :: string +integer, intent(in) :: desired_length + +integer :: length_of_string +integer :: string_index, difference_of_string_lengths +character(len=varnamelength) :: filled_string + +filled_string = '' +length_of_string = len_trim(string) +difference_of_string_lengths = desired_length - length_of_string + +if (difference_of_string_lengths < 0) then + call error_handler(E_ERR, 'zero_fill', & + 'Input string is longer than desired output => ensemble size too large', & + source, revision, revdate) +else if (difference_of_string_lengths > 0) then + do string_index = 1, difference_of_string_lengths + filled_string(string_index:string_index) = '0' + end do +end if + +filled_string(difference_of_string_lengths+1:desired_length) = trim(string) + +end function zero_fill + +!--------------------------------------------------------------- + +end module transform_state_mod diff --git a/models/aether_cube_sphere/work/demo_documentation.txt b/models/aether_cube_sphere/work/demo_documentation.txt new file mode 100644 index 0000000000..cbea9f9171 --- /dev/null +++ b/models/aether_cube_sphere/work/demo_documentation.txt @@ -0,0 +1,69 @@ +This file provides step-by-step instructions for testing the Aether/DART +system with a variety of test restart files available from the University of +Michigan. + +Check out aether_michigan branch of dart + git clone https://github.com/NCAR/DART.git + git checkout aether_michigan + +Set an appropriate build template + In build_templates/ directory, copy appropriate template (mkmf.template.gfortran) + to mkfm.template + +Build the DART software: + Go to directory models/aether_cube_sphere/work + quickbuild.sh nompi + +Get the sample aether restart gz files + mkdir B24_AETHER_INPUT_FILES + mkdir B24_AETHER_OUTPUT_FILES + mkdir B6_AETHER_INPUT_FILES + mkdir B6_AETHER_OUTPUT_FILES + + Put the gz files from Aaron in the appropriate input files directory + +Make an increments directory under the model directory + mkdir increments + + + + +End to end procedure to make aether cube sphere demo work + +1. Remove all netcdf files from the work directory +2. Remove all netcdf files from the increments directory +3. Remove all netcdf files from the aether output directory +4. Remove the aether input directory at the level below the gz file +5. Untar the gz file, use the finder +6. Perturb_aether_ensemble.m from the model directory to generate perturbations +7. Run aether_to_dart 1, ens_size to transform to filter_input files in work directory +8. If looking at filter posteriors, copy each filter_input nc file to a filter_output + cp filter_input_0001.nc filter_output_0001.nc, for all ensemble members +9. Run filter in work directory +10. Copy all files from the aether input directory to the aether output directory +11. Run dart_to_aether 1, ens_size in work directory +12. Matlab get_aether_incs in model directory +13. Run plot_aether_lat_lon programs to verify increments in model directory + +Changing resolution for tests: +1. Remove all nc files from the work directory +2. Delete the aether input directory and then recreate by unpacking gz +3. In perturb_aether_ensemble.m: + a. Change the input file directory + b. Change nblocks +4. Run perturb_aether_ensemble +5. Copy all the files from the aether input directory to the aether output directory +6. In input.nml, change the input directory for aether files in aether_to_dart_nml and dart_to_aether_nml. Also change the np and nblocks in transform_state_nml +7. Run aether_to_dart 1, ens_size +8. Cp filter_input files to filter_output files if you want to do diagnostics in dart state space +8a. Run perfect_model_obs +9. Run filter +10. Run dart_to_aether 1, ens_size +11. In get_aether_incs.m + a. Change nblocks + b. Change the directory for the input and output files +12. Run get_aether_incs +13. In plot_aether_lat_lon.m: + a. Change nblocks + b. Change the directory for input grid files + diff --git a/models/aether_cube_sphere/work/filter_input_files.txt b/models/aether_cube_sphere/work/filter_input_files.txt new file mode 100644 index 0000000000..c5891b8e29 --- /dev/null +++ b/models/aether_cube_sphere/work/filter_input_files.txt @@ -0,0 +1,20 @@ +filter_input_0001.nc +filter_input_0002.nc +filter_input_0003.nc +filter_input_0004.nc +filter_input_0005.nc +filter_input_0006.nc +filter_input_0007.nc +filter_input_0008.nc +filter_input_0009.nc +filter_input_0010.nc +filter_input_0011.nc +filter_input_0012.nc +filter_input_0013.nc +filter_input_0014.nc +filter_input_0015.nc +filter_input_0016.nc +filter_input_0017.nc +filter_input_0018.nc +filter_input_0019.nc +filter_input_0020.nc diff --git a/models/aether_cube_sphere/work/filter_output_files.txt b/models/aether_cube_sphere/work/filter_output_files.txt new file mode 100644 index 0000000000..1b23ee7982 --- /dev/null +++ b/models/aether_cube_sphere/work/filter_output_files.txt @@ -0,0 +1,20 @@ +filter_output_0001.nc +filter_output_0002.nc +filter_output_0003.nc +filter_output_0004.nc +filter_output_0005.nc +filter_output_0006.nc +filter_output_0007.nc +filter_output_0008.nc +filter_output_0009.nc +filter_output_0010.nc +filter_output_0011.nc +filter_output_0012.nc +filter_output_0013.nc +filter_output_0014.nc +filter_output_0015.nc +filter_output_0016.nc +filter_output_0017.nc +filter_output_0018.nc +filter_output_0019.nc +filter_output_0020.nc diff --git a/models/aether_cube_sphere/work/input.nml b/models/aether_cube_sphere/work/input.nml new file mode 100644 index 0000000000..c423e872f7 --- /dev/null +++ b/models/aether_cube_sphere/work/input.nml @@ -0,0 +1,254 @@ +&probit_transform_nml + / + +&algorithm_info_nml + qceff_table_filename = '' + / + +&perfect_model_obs_nml + read_input_state_from_file = .true., + single_file_in = .false. + input_state_files = "filter_input_0001.nc" + + write_output_state_to_file = .false., + single_file_out = .false. + output_state_files = "perfect_output.nc" + output_interval = 1, + + async = 0, + adv_ens_command = "./advance_model.csh", + + obs_seq_in_file_name = "obs_seq.in", + obs_seq_out_file_name = "obs_seq.out", + init_time_days = 0, + init_time_seconds = 0, + first_obs_days = -1, + first_obs_seconds = -1, + last_obs_days = -1, + last_obs_seconds = -1, + + trace_execution = .false., + output_timestamps = .false., + print_every_nth_obs = -1, + output_forward_op_errors = .false., + silence = .false., + / + +&filter_nml + single_file_in = .false., + input_state_files = '' + input_state_file_list = 'filter_input_files.txt' + + stages_to_write = 'preassim', 'analysis', 'output' + + single_file_out = .false., + output_state_files = '' + output_state_file_list = 'filter_output_files.txt' + output_interval = 1, + output_members = .true. + num_output_state_members = 20, + output_mean = .true. + output_sd = .true. + write_all_stages_at_end = .false. + compute_posterior = .true. + + ens_size = 10, + num_groups = 1, + perturb_from_single_instance = .false., + perturbation_amplitude = 0.2, + distributed_state = .true. + + async = 4, + adv_ens_command = "./advance_model.csh", + + obs_sequence_in_name = "obs_seq.out", + obs_sequence_out_name = "obs_seq.final", + num_output_obs_members = 20, + init_time_days = 0, + init_time_seconds = 0, + first_obs_days = -1, + first_obs_seconds = -1, + last_obs_days = -1, + last_obs_seconds = -1, + + inf_flavor = 5, 0, + inf_initial_from_restart = .false., .false., + inf_sd_initial_from_restart = .false., .false., + inf_deterministic = .true., .true., + inf_initial = 1.0, 1.0, + inf_lower_bound = 0.0, 1.0, + inf_upper_bound = 100.0, 1000000.0, + inf_damping = 1.0, 1.0, + inf_sd_initial = 0.6, 0.0, + inf_sd_lower_bound = 0.6, 0.0, + inf_sd_max_change = 1.05, 1.05, + + trace_execution = .false., + output_timestamps = .false., + output_forward_op_errors = .false., + silence = .false., + / + + +&ensemble_manager_nml + / + +&assim_tools_nml + cutoff = 0.4 + sort_obs_inc = .false., + spread_restoration = .false., + sampling_error_correction = .false., + adaptive_localization_threshold = -1, + distribute_mean = .false. + output_localization_diagnostics = .false., + localization_diagnostics_file = 'localization_diagnostics', + print_every_nth_obs = 0 + / + +&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. + / + +&obs_kind_nml + assimilate_these_obs_types = 'GND_GPS_VTEC', + 'SLANT_GPS_VTEC', + 'SAT_TEMPERATURE', + 'SAT_DENSITY_ION_O2P', + 'SAT_DENSITY_NEUTRAL_O2', + 'SAT_DENSITY_ION_N2P' + / + +&model_nml + template_file = 'filter_input_0001.nc' + time_step_days = 0, + time_step_seconds = 3600 + variables = 'Temperature','QTY_TEMPERATURE', '0.0', 'NA', 'UPDATE', + 'O2+', 'QTY_DENSITY_ION_O2P', '0.0', 'NA', 'UPDATE', + 'O2', 'QTY_DENSITY_NEUTRAL_O2', '0.0', 'NA', 'UPDATE', + 'N2+', 'QTY_DENSITY_ION_N2P', '0.0', 'NA', 'UPDATE', + 'ION_E', 'QTY_DENSITY_ION_E', '0.0', 'NA', 'UPDATE', + '2D_F10.7', 'QTY_1D_PARAMETER', '0.0', 'NA', 'UPDATE' + / + +&utilities_nml + TERMLEVEL = 1, + module_details = .false., + logfilename = 'dart_log.out', + nmlfilename = 'dart_log.nml', + write_nml = 'none' + / + +&preprocess_nml + 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_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' + obs_type_files = '../../../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', + '../../../observations/forward_operators/obs_def_metar_mod.f90', + '../../../observations/forward_operators/obs_def_dew_point_mod.f90', + '../../../observations/forward_operators/obs_def_rel_humidity_mod.f90', + '../../../observations/forward_operators/obs_def_gps_mod.f90', + '../../../observations/forward_operators/obs_def_vortex_mod.f90', + '../../../observations/forward_operators/obs_def_gts_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' + / + +&obs_sequence_tool_nml + 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, + print_only = .false., + gregorian_cal = .false. + / + +&obs_diag_nml + obs_sequence_name = 'obs_seq.final', + bin_width_days = -1, + bin_width_seconds = -1, + init_skip_days = 0, + init_skip_seconds = 0, + Nregions = 3, + trusted_obs = 'null', + lonlim1 = 0.00, 0.00, 0.50 + lonlim2 = 1.01, 0.50, 1.01 + reg_names = 'whole', 'yin', 'yang' + create_rank_histogram = .true., + outliers_in_histogram = .true., + use_zero_error_obs = .false., + verbose = .false. + / + +&state_vector_io_nml + / + +&model_mod_check_nml + input_state_files = 'filter_input_0001.nc' + output_state_files = 'mmc_output.nc' + test1thru = 0 + run_tests = 1,2,3,4,5,6,7 + x_ind = 12 + loc_of_interest = 98.5, 85.5, 196344 + quantity_of_interest = 'QTY_TEMPERATURE' + interp_test_dlon = 4.0 + interp_test_lonrange = 0.0, 360.0 + interp_test_dlat = 4.0 + interp_test_latrange = -90.0, 90.0 + interp_test_dvert = 2000.0 + interp_test_vertrange = 100000.0, 106000.0 + interp_test_vertcoord = 'VERTISHEIGHT' + verbose = .true. + / + +&quality_control_nml + input_qc_threshold = 3.0, + outlier_threshold = -1.0, +/ + +&location_nml + horiz_dist_only = .false. + vert_normalization_pressure = 20000.0 + vert_normalization_height = 100000.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 + / + +&aether_to_dart_nml + aether_file_directory = '../TEST_INPUT/' + dart_file_directory = './' + / + +&dart_to_aether_nml + dart_file_directory = './' + aether_file_directory = '../TEST_OUTPUT/' + + / + +&transform_state_nml + np = 18 + nblocks = 6 + nhalos = 2 + scalar_f10_7 = .false. + / diff --git a/models/aether_cube_sphere/work/obs_seq.in b/models/aether_cube_sphere/work/obs_seq.in new file mode 100644 index 0000000000..77ef8529da --- /dev/null +++ b/models/aether_cube_sphere/work/obs_seq.in @@ -0,0 +1,69 @@ + obs_sequence +obs_type_definitions + 6 + 1 SAT_TEMPERATURE + 5 SAT_DENSITY_NEUTRAL_O2 + 16 SAT_DENSITY_ION_O2P + 17 SAT_DENSITY_ION_N2P + 40 GND_GPS_VTEC + 41 SLANT_GPS_VTEC + num_copies: 0 num_qc: 0 + num_obs: 6 max_num_obs: 6 + first: 1 last: 6 + OBS 1 + -1 2 -1 +obdef +loc3d + 1.570796326794897 0.7853981633974483 110000.0000000000 3 +kind + 1 + 0 0 + 1.2000000000000000 + OBS 2 + 1 3 -1 +obdef +loc3d + 1.570796326794897 -0.7853981633974483 180000.0000000000 3 +kind + 16 + 0 0 + 1.3000000000000000 + OBS 3 + 2 4 -1 +obdef +loc3d + 4.712388980384690 0.5235987755982988 250000.0000000000 3 +kind + 17 + 0 0 + 1.3999999999999999 + OBS 4 + 3 5 -1 +obdef +loc3d + 4.712388980384690 -0.5235987755982988 350000.0000000000 3 +kind + 5 + 0 0 + 1.5000000000000000 + OBS 5 + 4 6 -1 +obdef +loc3d + 3.141592653589793 1.047197551196598 -888888.0000000000 -2 +kind + 40 + 0 0 + 0.10000000000000001 + OBS 6 + 5 -1 -1 +obdef +loc3d + 3.141592653589793 -0.1745329251994329 -888888.0000000000 -2 +kind + 41 + 160.00000000000000 50.000000000000000 345678.00000000000 + 170.00000000000000 45.000000000000000 111.00000000000000 + 1 + 0 0 + 0.25000000000000000 diff --git a/models/aether_cube_sphere/work/quickbuild.sh b/models/aether_cube_sphere/work/quickbuild.sh new file mode 100755 index 0000000000..8e155a0618 --- /dev/null +++ b/models/aether_cube_sphere/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=aether_cube_sphere +LOCATION=threed_sphere + + +programs=( +closest_member_tool +filter +model_mod_check +perfect_model_obs +) + +serial_programs=( +create_fixed_network_seq +create_obs_sequence +fill_inflation_restart +integrate_model +obs_common_subset +obs_diag +obs_sequence_tool +) + +model_programs=( +) + +model_serial_programs=( +aether_to_dart +dart_to_aether +) + +# quickbuild arguments +arguments "$@" + +# clean the directory +\rm -f -- *.o *.mod Makefile .cppdefs + +# build any NetCDF files from .cdl files +cdl_to_netcdf + +# build and run preprocess before making any other DART executables +buildpreprocess + +# build +buildit + +# clean up +\rm -f -- *.o *.mod + +} + +main "$@" diff --git a/models/utilities/quad_utils_mod.f90 b/models/utilities/quad_utils_mod.f90 index b9d11e6334..d7173aeb33 100644 --- a/models/utilities/quad_utils_mod.f90 +++ b/models/utilities/quad_utils_mod.f90 @@ -78,7 +78,10 @@ module quad_utils_mod QUAD_LOCATED_CELL_CORNERS, & get_quad_grid_size, & get_quad_global, & - print_quad_handle ! debug + print_quad_handle, & ! debug + in_quad, & + quad_bilinear_interp, & + line_intercept ! version controlled file description for error handling, do not edit diff --git a/observations/forward_operators/obs_def_upper_atm_mod.f90 b/observations/forward_operators/obs_def_upper_atm_mod.f90 index 3e3c13addd..502ebc6f9c 100644 --- a/observations/forward_operators/obs_def_upper_atm_mod.f90 +++ b/observations/forward_operators/obs_def_upper_atm_mod.f90 @@ -47,6 +47,7 @@ ! GPS_PROFILE, QTY_ELECTRON_DENSITY, COMMON_CODE ! COSMIC_ELECTRON_DENSITY, QTY_ELECTRON_DENSITY ! GND_GPS_VTEC, QTY_GND_GPS_VTEC +! SLANT_GPS_VTEC, QTY_SLANT_GPS_VTEC ! CHAMP_DENSITY, QTY_DENSITY ! MIDAS_TEC, QTY_VERTICAL_TEC, COMMON_CODE ! SSUSI_O_N2_RATIO, QTY_O_N2_COLUMN_DENSITY_RATIO @@ -58,6 +59,8 @@ ! BEGIN DART PREPROCESS USE OF SPECIAL OBS_DEF MODULE ! use obs_def_upper_atm_mod, only : get_expected_upper_atm_density ! use obs_def_upper_atm_mod, only : get_expected_gnd_gps_vtec +! use obs_def_upper_atm_mod, only : get_expected_slant_gps_vtec, write_slant_gps_vtec, & +! read_slant_gps_vtec, interactive_slant_gps_vtec ! use obs_def_upper_atm_mod, only : get_expected_O_N2_ratio ! use obs_def_upper_atm_mod, only : get_expected_electron_density ! END DART PREPROCESS USE OF SPECIAL OBS_DEF MODULE @@ -69,6 +72,8 @@ ! call get_expected_upper_atm_density(state_handle, ens_size, location, expected_obs, istatus) ! case(GND_GPS_VTEC) ! call get_expected_gnd_gps_vtec(state_handle, ens_size, location, expected_obs, istatus) +! case(SLANT_GPS_VTEC) +! call get_expected_slant_gps_vtec(state_handle, ens_size, location, obs_def%key, expected_obs, istatus) ! case(SSUSI_O_N2_RATIO) ! call get_expected_O_N2_ratio(state_handle, ens_size, location, expected_obs, istatus) ! case(COSMIC_ELECTRON_DENSITY) @@ -82,6 +87,8 @@ ! continue ! case(GND_GPS_VTEC) ! continue +! case(SLANT_GPS_VTEC) +! call read_slant_gps_vtec(obs_def%key, ifile, fform) ! case(SSUSI_O_N2_RATIO) ! continue ! case(COSMIC_ELECTRON_DENSITY) @@ -95,6 +102,8 @@ ! continue ! case(GND_GPS_VTEC) ! continue +! case(SLANT_GPS_VTEC) +! call write_slant_gps_vtec(obs_def%key, ifile, fform) ! case(SSUSI_O_N2_RATIO) ! continue ! case(COSMIC_ELECTRON_DENSITY) @@ -108,6 +117,8 @@ ! continue ! case(GND_GPS_VTEC) ! continue +! case(SLANT_GPS_VTEC) +! call interactive_slant_gps_vtec(obs_def%key) ! case(SSUSI_O_N2_RATIO) ! continue ! case(COSMIC_ELECTRON_DENSITY) @@ -118,7 +129,7 @@ module obs_def_upper_atm_mod use types_mod, only : r8, MISSING_R8 -use utilities_mod, only : register_module, error_handler, E_ERR, E_MSG +use utilities_mod, only : register_module, error_handler, E_ERR, E_MSG, ascii_file_format use location_mod, only : location_type, get_location, set_location, & VERTISHEIGHT, VERTISLEVEL use assim_model_mod, only : interpolate @@ -132,6 +143,7 @@ module obs_def_upper_atm_mod QTY_DENSITY_ION_E, & QTY_ELECTRON_DENSITY, & QTY_GND_GPS_VTEC, & + QTY_SLANT_GPS_VTEC, & QTY_GEOPOTENTIAL_HEIGHT, & QTY_GEOMETRIC_HEIGHT, & QTY_O_N2_COLUMN_DENSITY_RATIO @@ -142,6 +154,8 @@ module obs_def_upper_atm_mod private public :: get_expected_upper_atm_density, & get_expected_gnd_gps_vtec, & + get_expected_slant_gps_vtec, read_slant_gps_vtec, & + write_slant_gps_vtec, interactive_slant_gps_vtec, & get_expected_O_N2_ratio, & get_expected_electron_density @@ -165,6 +179,12 @@ module obs_def_upper_atm_mod integer, parameter :: MAXLEVELS = 300 ! more than max levels expected in the model (waccm-x has 126) character(len=512) :: string1, string2, string3 +! Storage for special information needed for slant gps vtec observations +integer :: num_slant_gps_vtec_obs = 0 ! current count of obs +integer :: max_slant_gps_vtec_obs = 100000 ! allocation size limit +real(r8), allocatable :: sat_position(:, :) ! Satellite lat, lon, heights +real(r8), allocatable :: ground_position(:, :) ! Ground point lat, lon, heightd + contains !----------------------------------------------------------------------------- @@ -174,6 +194,10 @@ subroutine initialize_module call register_module(source, revision, revdate) module_initialized = .true. +! Allocate space for the metadata for the slant gps vtec observations +allocate(sat_position(3, max_slant_gps_vtec_obs), & + ground_position(3, max_slant_gps_vtec_obs)) + end subroutine initialize_module !----------------------------------------------------------------------------- @@ -242,12 +266,8 @@ end subroutine get_expected_upper_atm_density !----------------------------------------------------------------------------- -! Given DART state vector and a location, -! it computes ground GPS vertical total electron content -! The istatus variable should be returned as 0 unless there is a problem -!>@todo Is the logic correct in this code on the Trunk -!> Should you return from the subroutine instead of exiting -!> the loop at exit LEVELS +! THIS SUBROUTINE NEEDS ADDITIONAL INPUT FROM AETHER SCIENTISTS + subroutine get_expected_gnd_gps_vtec(state_handle, ens_size, location, obs_val, istatus) type(ensemble_type), intent(in) :: state_handle @@ -261,7 +281,6 @@ subroutine get_expected_gnd_gps_vtec(state_handle, ens_size, location, obs_val, ! integrated column from an instrument looking straight down at the tangent point. ! 'istatus' is the return code. 0 is success; any positive value signals an ! error (different values can be used to indicate different error types). -! Negative istatus values are reserved for internal use only by DART. integer :: nAlts, iAlt, this_istatus(ens_size) real(r8), dimension(ens_size, MAXLEVELS) :: ALT, IDensityS_ie ! num_ens by num levels @@ -308,12 +327,13 @@ subroutine get_expected_gnd_gps_vtec(state_handle, ens_size, location, obs_val, nAlts = nAlts+1 enddo LEVELS -! failed first time through loop - no values to return. +! failed first time through loop - no values to return. istatus was set to non-zero in loop. if (nAlts == 0) then obs_val(:) = MISSING_R8 return endif +! This is redundant but makes it clear that there are no errors at this point istatus(:) = 0 do i=1,ens_size @@ -323,8 +343,8 @@ subroutine get_expected_gnd_gps_vtec(state_handle, ens_size, location, obs_val, end if end do -! clear the error from the last level and start again? -tec=0.0_r8 !start with zero for the summation +! Set all ensemble members tec to zero for summation +tec=0.0_r8 do iAlt = 1, nAlts-1 !approximate the integral over the altitude as a sum of trapezoids !area of a trapezoid: A = (h2-h1) * (f2+f1)/2 @@ -342,6 +362,280 @@ end subroutine get_expected_gnd_gps_vtec !----------------------------------------------------------------------------- +! THIS SUBROUTINE NEEDS ADDITIONAL INPUT FROM AETHER SCIENTISTS +! The current version has access to two additional triples of numbers that are a lon/lat/height, +! but makes no use of those. Need to decide what the appropriate additional metadata is to +! describe a slant tec obs and then implement ray-tracing given that. For now, this just duplicates +! the plain vtec forward operator above. + +subroutine get_expected_slant_gps_vtec(state_handle, ens_size, location, igrkey, obs_val, istatus) + +type(ensemble_type), intent(in) :: state_handle +integer, intent(in) :: ens_size +type(location_type), intent(in) :: location +integer, intent(in) :: igrkey +real(r8), intent(out) :: obs_val(ens_size) +integer, intent(out) :: istatus(ens_size) + +! For now, this is just the same as vtec. +! Given a location and the state vector from one of the ensemble members, +! compute the model-predicted total electron content that would be in the +! integrated column from an instrument looking straight down at the tangent point. +! 'istatus' is the return code. 0 is success; any positive value signals an +! error (different values can be used to indicate different error types). + +integer :: nAlts, iAlt, this_istatus(ens_size) +real(r8), dimension(ens_size, MAXLEVELS) :: ALT, IDensityS_ie ! num_ens by num levels +real(r8) :: loc_vals(3) +real(r8) :: tec(ens_size) +real(r8) :: sat_pos(3), ground_pos(3) +type(location_type) :: probe +logical :: return_now +integer :: i + +if ( .not. module_initialized ) call initialize_module + +istatus = 0 ! must be 0 to use track_status() + +loc_vals = get_location(location) + +! Get the information about the satellite and ground point +! The interactive input defines these as longitude in degrees, latitude in degrees, and height in meters +sat_pos = sat_position(1:3, igrkey) +ground_pos = ground_position(1:3, igrkey) + +nAlts = 0 +LEVELS: do iAlt=1, size(ALT,2)+1 + ! loop over levels. if we get to one more than the allocated array size, + ! this model must have more levels than we expected. increase array sizes, + ! recompile, and try again. + + if (iAlt > size(ALT,2)) then + write(string1,'(''more than '',i4,'' levels in the model.'')') MAXLEVELS + string2='increase MAXLEVELS in obs_def_upper_atm_mod.f90, rerun preprocess and recompile.' + call error_handler(E_ERR, 'get_expected_slant_gps_vtec', string1, & + source, revision, revdate, text2=string2) + endif + + ! At each altitude interpolate the 2D IDensityS_ie to the lon-lat where data + ! point is located. After this loop we will have a column centered at the data + ! point's lon-lat and at all model altitudes. + probe = set_location(loc_vals(1), loc_vals(2), real(iAlt, r8), VERTISLEVEL) !probe is where we have data + + call interpolate(state_handle, ens_size, probe, QTY_DENSITY_ION_E, IDensityS_ie(:, iAlt), this_istatus) + call track_status(ens_size, this_istatus, obs_val, istatus, return_now) + if (any(istatus /= 0)) exit LEVELS + + call interpolate(state_handle, ens_size, probe, QTY_GEOMETRIC_HEIGHT, ALT(:, iAlt), this_istatus) + + call track_status(ens_size, this_istatus, obs_val, istatus, return_now) + + if (any(istatus /= 0)) exit LEVELS + + nAlts = nAlts+1 +enddo LEVELS + +! failed first time through loop - no values to return. +if (nAlts == 0) then + obs_val(:) = MISSING_R8 + return +endif + +istatus(:) = 0 + +do i=1,ens_size + if (any(IDensityS_ie(i,1:nAlts) == MISSING_R8) .or. any(ALT(i,1:nAlts) == MISSING_R8)) then + ! mark the ensemble member as having failed + istatus(i) = 1 + end if +end do + +! Set all ensemble members tec to zero for summation +tec=0.0_r8 + +do iAlt = 1, nAlts-1 !approximate the integral over the altitude as a sum of trapezoids + !area of a trapezoid: A = (h2-h1) * (f2+f1)/2 + where (istatus == 0) & + tec = tec + ( ALT(:, iAlt+1)-ALT(:, iAlt) ) * ( IDensityS_ie(:, iAlt+1)+IDensityS_ie(:, iAlt) ) /2.0_r8 +enddo + +where (istatus == 0) + obs_val = tec * 10.0**(-16) !units of TEC are "10^16" #electron/m^2 instead of just "1" #electron/m^2 +elsewhere + obs_val = MISSING_R8 +end where + +end subroutine get_expected_slant_gps_vtec + +!----------------------------------------------------------------------------- + +subroutine write_slant_gps_vtec(igrkey, ifile, fform) + +integer, intent(in) :: igrkey, ifile +character(len=*), intent(in), optional :: fform + +! Write out the additional data associated with this observation. +! The obs is identified by the incoming 'key' argument. + +logical :: is_ascii + +if ( .not. module_initialized ) call initialize_module + +! Make sure key value is within valid range -- it will be used as an index below. +call check_valid_key(igrkey, 'GIVEN', 'write_slant_gps_vtec') + +is_ascii = ascii_file_format(fform) + +! Write out the half_width, num_points, and localization_type for each +! observation embedded in the observation. The old key is written out +! for tracking/debug use if needed. + +if (is_ascii) then + write(ifile, *) sat_position(1:3, igrkey) + write(ifile, *) ground_position(1:3, igrkey) + write(ifile, *) igrkey +else + write(ifile) sat_position(1:3, igrkey) + write(ifile) ground_position(1:3, igrkey) + write(ifile) igrkey +endif + +end subroutine write_slant_gps_vtec + +!---------------------------------------------------------------------- + +subroutine read_slant_gps_vtec(igrkey, ifile, fform) +integer, intent(out) :: igrkey +integer, intent(in) :: ifile +character(len=*), intent(in), optional :: fform + +! Read in the additional data associated with this observation. +! The key value in the file will be read and then discarded, and a new key +! will be generated based on the next available index in the metadata arrays. +! Notice that key is intent(out) here, not (in) as in some other routines. + +logical :: is_ascii +integer :: ignored_igrkey + +if ( .not. module_initialized ) call initialize_module + +! Increment the counter so all key values are unique +num_slant_gps_vtec_obs = num_slant_gps_vtec_obs + 1 + +! Set the return value for the key, and use it as the index below +igrkey = num_slant_gps_vtec_obs + +! Make sure key is within valid range +call check_valid_key(igrkey, 'GENERATED', 'read_slant_gps_vtec') + +is_ascii = ascii_file_format(fform) + +! Read in the additional metadata for this observation, and discard the old key. +if (is_ascii) then + read(ifile, *) sat_position(1:3, igrkey) + read(ifile, *) ground_position(1:3, igrkey) + read(ifile, *) ignored_igrkey +else + read(ifile) sat_position(1:3, igrkey) + read(ifile) ground_position(1:3, igrkey) + read(ifile) ignored_igrkey +endif + +end subroutine read_slant_gps_vtec + +!---------------------------------------------------------------------- + +subroutine interactive_slant_gps_vtec(igrkey) + integer, intent(out) :: igrkey + +! Initializes the specialized part of a slant gps vtec observation +! A new key will be generated based on the next available index +! in the metadata arrays. + +if ( .not. module_initialized ) call initialize_module + +! Increment the counter so all key values are unique +num_slant_gps_vtec_obs = num_slant_gps_vtec_obs + 1 + +! Set the return value for the key, and use it as the index below +igrkey = num_slant_gps_vtec_obs + +! Make sure key is within valid range +call check_valid_key(igrkey, 'GENERATED', 'interactive_slant_gps_vtec') + +! Prompt for input for the three required metadata items +write(*, *) 'Creating an interactive_slant_gps_vtec observation' + +! Get the longitude of satellite +do + write(*, *) 'Input the longitude of the satellite in degrees from 0 to 360' + read(*, *) sat_position(1, igrkey) + if(sat_position(1, igrkey) < 0 .or. sat_position(1, igrkey) > 360) then + write(*, *) 'Value must be from 0 to 360' + else + exit + endif +enddo + +! Get latitude of satellite +do + write(*, *) 'Input the latitude of the satellite in degrees from -90 to 90' + read(*, *) sat_position(2, igrkey) + if(sat_position(2, igrkey) < -90 .or. sat_position(2, igrkey) > 90) then + write(*, *) 'Value must be from -90 to 90' + else + exit + endif +enddo + +! Get height of satellite +do + write(*, *) 'Input the height of the satellite in meters' + read(*, *) sat_position(3, igrkey) + if(sat_position(3, igrkey) < 0) then + write(*, *) 'Value must be non-negative' + else + exit + endif +enddo + +! Get the longitude of ground point +do + write(*, *) 'Input the longitude of the ground point in degrees from 0 to 360' + read(*, *) ground_position(1, igrkey) + if(ground_position(1, igrkey) < 0 .or. ground_position(1, igrkey) > 360) then + write(*, *) 'Value must be from 0 to 360' + else + exit + endif +enddo + +! Get latitude of ground point +do + write(*, *) 'Input the latitude of the ground point in degrees from -90 to 90' + read(*, *) ground_position(2, igrkey) + if(ground_position(2, igrkey) < -90 .or. ground_position(2, igrkey) > 90) then + write(*, *) 'Value must be from -90 to 90' + else + exit + endif +enddo + +! Get height of ground point +do + write(*, *) 'Input the height of the ground point in meters' + read(*, *) ground_position(3, igrkey) + if(ground_position(3, igrkey) < 0) then + write(*, *) 'Value must be non-negative' + else + exit + endif +enddo + +end subroutine interactive_slant_gps_vtec + +!----------------------------------------------------------------------------- + ! First, find the number of levels in the model. ! Then, loop down through the levels to create a top-down vertical profile. ! As we do that, we accumulate the amount of N2 and O, stopping when @@ -640,6 +934,42 @@ subroutine get_expected_oxygen_ion_density(state_handle, ens_size, location, obs end subroutine get_expected_oxygen_ion_density + +!---------------------------------------------------------------------- + +subroutine check_valid_key(igrkey, what, fromwhere) + integer, intent(in) :: igrkey + character(len=*), intent(in) :: what, fromwhere + +! Internal subroutine that verifies that we haven't incremented the key value +! past the size of the allocated space, or that a routine hasn't been called +! with a out-of-range key (which would indicate an internal error of some kind). +! If an error is found, a fatal message is printed and this routine doesn't return. +! The 'what' argument is either 'GIVEN' for a key value that's passed in from +! another routine; or 'GENERATED' for one we have just made and are planning to +! return to the caller. The 'fromwhere' argument is the name of the calling +! subroutine so the error message can report where it was called from. + +character(len=128) :: msgstring + +if (igrkey <= 0 .or. igrkey > max_slant_gps_vtec_obs) then + if (what == 'GENERATED' .and. igrkey > max_slant_gps_vtec_obs) then + ! generating a new key and ran out of space + write(msgstring, *)'Out of space, max_slant_gps_vtec_obs limit ',max_slant_gps_vtec_obs + call error_handler(E_ERR,trim(fromwhere),msgstring,source,revision,revdate, & + text2='Increase value of max_slant_gps_vtec_obs in obs_def_1d_state_mod') + else + ! called with a bad key or a negative key generated somehow. "shouldn't happen". + write(msgstring, *)'Key is ',igrkey,' must be between 1 and ',max_slant_gps_vtec_obs + call error_handler(E_ERR,trim(fromwhere),msgstring,source,revision,revdate, & + text2='Internal error: Invalid key value in RAW_STATE_1D_INTEGRAL obs') + endif +endif + +end subroutine check_valid_key +!---------------------------------------------------------------------- + + end module obs_def_upper_atm_mod ! END DART PREPROCESS MODULE CODE From 01241aecdbded6baa13e3a9b04e37d67e64fa48f Mon Sep 17 00:00:00 2001 From: Jeff Anderson Date: Thu, 30 Oct 2025 14:19:20 -0600 Subject: [PATCH 02/24] Removed legacy svn text from headers. --- models/aether_cube_sphere/aether_to_dart.f90 | 2 -- models/aether_cube_sphere/dart_to_aether.f90 | 2 -- models/aether_cube_sphere/transform_state_mod.f90 | 2 -- 3 files changed, 6 deletions(-) diff --git a/models/aether_cube_sphere/aether_to_dart.f90 b/models/aether_cube_sphere/aether_to_dart.f90 index fda4b9f682..372a54db08 100644 --- a/models/aether_cube_sphere/aether_to_dart.f90 +++ b/models/aether_cube_sphere/aether_to_dart.f90 @@ -1,8 +1,6 @@ ! 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$ ! Converts aether restart block files to a DART filter input file diff --git a/models/aether_cube_sphere/dart_to_aether.f90 b/models/aether_cube_sphere/dart_to_aether.f90 index 5dfd317424..adf137cad9 100644 --- a/models/aether_cube_sphere/dart_to_aether.f90 +++ b/models/aether_cube_sphere/dart_to_aether.f90 @@ -1,8 +1,6 @@ ! 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$ ! Convert DART filter files to Aether block restart files diff --git a/models/aether_cube_sphere/transform_state_mod.f90 b/models/aether_cube_sphere/transform_state_mod.f90 index 59123863ff..342b50fc3f 100644 --- a/models/aether_cube_sphere/transform_state_mod.f90 +++ b/models/aether_cube_sphere/transform_state_mod.f90 @@ -1,8 +1,6 @@ ! 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$ ! Provides tools to do transforms from Aether block files to DART filter files ! and back. From bff79b5f54735419fb9920218588648e7297df30 Mon Sep 17 00:00:00 2001 From: Jeff Anderson Date: Thu, 30 Oct 2025 14:32:13 -0600 Subject: [PATCH 03/24] Removed legacy svn revision and revdate and fixed the source string. Updated calls to error_handler that used these. --- .../cube_sphere_grid_tools.f90 | 6 ++-- models/aether_cube_sphere/model_mod.f90 | 30 ++++++---------- .../transform_state_mod.f90 | 34 +++++++++---------- 3 files changed, 28 insertions(+), 42 deletions(-) diff --git a/models/aether_cube_sphere/cube_sphere_grid_tools.f90 b/models/aether_cube_sphere/cube_sphere_grid_tools.f90 index 486ed3d0e3..462515f18f 100644 --- a/models/aether_cube_sphere/cube_sphere_grid_tools.f90 +++ b/models/aether_cube_sphere/cube_sphere_grid_tools.f90 @@ -21,9 +21,7 @@ module cube_sphere_grid_tools_mod get_grid_delta ! version controlled file description for error handling, do not edit -character(len=*), parameter :: source = "$URL$" -character(len=*), parameter :: revision = "$Revision$" -character(len=*), parameter :: revdate = "$Date$" +character(len=*), parameter :: source = "cube_sphere_grid_tools" contains @@ -553,7 +551,7 @@ subroutine get_corners(face, lat_grid, lon_grid, np, lat, lon, del, half_del, & ! Falling of the end should not happen; call error_handler(E_ERR, 'get_corners', 'Reached end of subroutine get_corners', & - source, revision, revdate, 'This should not be possible') + source, 'This should not be possible') end subroutine get_corners diff --git a/models/aether_cube_sphere/model_mod.f90 b/models/aether_cube_sphere/model_mod.f90 index f595b523a5..c3264d7092 100644 --- a/models/aether_cube_sphere/model_mod.f90 +++ b/models/aether_cube_sphere/model_mod.f90 @@ -73,9 +73,7 @@ module model_mod public :: test_grid_box ! version controlled file description for error handling, do not edit -character(len=*), parameter :: source = "$URL$" -character(len=*), parameter :: revision = "$Revision$" -character(len=*), parameter :: revdate = "$Date$" +character(len=*), parameter :: source = "aether_cube_sphere/model_mod" ! Error codes integer, parameter :: INVALID_VERT_COORD_ERROR_CODE = 15 @@ -587,8 +585,7 @@ subroutine test_grid_box if(my_face /= test_face .or. my_lat_ind /= test_lat_ind .or. my_lon_ind /= test_lon_ind) then write(string1, *) 'Test failed: lat_lon_to_grid is not inverse of grid_to_lat_lon' write(string2, *) my_face, test_face, my_lat_ind, test_lat_ind, my_lon_ind, test_lon_ind - call error_handler(E_ERR, 'test_grid_box', string1, & - source, revision, revdate, text2=string2) + call error_handler(E_ERR, 'test_grid_box', string1, source, text2=string2) endif ! Test that col_index_to_lat_lon and lat_lon_to_col_index are inverses of each other @@ -598,8 +595,7 @@ subroutine test_grid_box if(col_index /= test_col_index) then write(string1, *) 'Test failed: lat_lon_to_col_index is not inverse of col_index_to_lat_lon' write(string2, *) my_face, my_lat_ind, my_lon_ind, col_index, test_col_index - call error_handler(E_ERR, 'test_grid_box', string1, & - source, revision, revdate, text2=string2) + call error_handler(E_ERR, 'test_grid_box', string1, source, text2=string2) endif enddo enddo @@ -654,8 +650,7 @@ subroutine test_grid_box abs(RAD2DEG*grid_pt_lon(i) - lon_lat_hgt(1)) > 0.0001_r8) then write(string1, *) 'Test failed: Aether files grid points inconsistent with get_state_meta_data' write(string2, *) grid_pt_lat(i), grid_pt_lon(i), lon_lat_hgt(2), lon_lat_hgt(1) - call error_handler(E_ERR, 'test_grid_box', string1, & - source, revision, revdate, text2=string2) + call error_handler(E_ERR, 'test_grid_box', string1, source, text2=string2) endif enddo @@ -670,8 +665,7 @@ subroutine test_grid_box if(.not. inside) then write(string1, *) 'Test failed: Point is not inside the triangle or quadrilateral' write(string2, *) pt_lat, pt_lon, num_bound_points - call error_handler(E_ERR, 'test_grid_box', string1, & - source, revision, revdate, text2=string2) + call error_handler(E_ERR, 'test_grid_box', string1, source, text2=string2) endif ! Also check on distance to vertices; this greatly reduces the possibility that @@ -692,15 +686,13 @@ subroutine test_grid_box !!!write(*, *) 'grid xyz ', i, qxyz(i, :) !!!enddo write(string2, *) 'point ', pt_lat, pt_lon, 'point xyz ', pxyz - call error_handler(E_ERR, 'test_grid_box', string1, & - source, revision, revdate, text2=string2) + call error_handler(E_ERR, 'test_grid_box', string1, source, text2=string2) endif elseif(num_bound_points == 3) then ! For triangle, sum should be less than 3 times the baseline if(dist_sum / base_dist > 3.0_r8) then write(string1, *) 'Test failed: ratio of sum of distances to vertices is too large for triangle' - call error_handler(E_ERR, 'test_grid_box', string1, & - source, revision, revdate) + call error_handler(E_ERR, 'test_grid_box', string1, source) endif endif enddo @@ -730,8 +722,7 @@ subroutine test_grid_box abs(RAD2DEG*my_lon - lon_lat_hgt(1)) > 0.0001_r8) then write(string1, *) 'Test Failed: Grid points not appropriately mapping' write(string2, *) my_face, my_qty, my_level, my_lat_ind, my_lon_ind - call error_handler(E_ERR, 'test_grid_box', string1, & - source, revision, revdate) + call error_handler(E_ERR, 'test_grid_box', string1, source) endif enddo @@ -741,7 +732,7 @@ subroutine test_grid_box enddo write(string1, *) 'ALL TESTS PASSED' -call error_handler(E_MSG, 'test_grid_box', string1, source, revision, revdate) +call error_handler(E_MSG, 'test_grid_box', string1, source) end subroutine test_grid_box @@ -832,8 +823,7 @@ function idw_interp(ens_size, lat, lon, y_corners, x_corners, p, num_corners) write(string1,*)'IDW interpolation result is outside of range of grid point values' write(string2, *) 'Interpolated value, min and max are: ', & idw_interp(n), minval(p(:, n)), maxval(p(:, n)) - call error_handler(E_MSG, 'idw_interp', string1, & - source, revision, revdate, text2=string2) + call error_handler(E_MSG, 'idw_interp', string1, source, text2=string2) ! Fixing out of range idw_interp(n) = max(idw_interp(n), minval(p(:, n))) diff --git a/models/aether_cube_sphere/transform_state_mod.f90 b/models/aether_cube_sphere/transform_state_mod.f90 index 342b50fc3f..3d16064e53 100644 --- a/models/aether_cube_sphere/transform_state_mod.f90 +++ b/models/aether_cube_sphere/transform_state_mod.f90 @@ -26,8 +26,6 @@ module transform_state_mod ! version controlled file description for error handling, do not edit character(len=*), parameter :: source = 'aether_cube_sphere/transform_state_mod.f90' -character(len=*), parameter :: revision = '' -character(len=*), parameter :: revdate = '' type :: file_type character(len=256) :: file_path @@ -125,12 +123,12 @@ subroutine model_to_dart(aether_block_file_dir, dart_file_dir, ensemble_number) ! Check for inconsistent number of vertical levels in ion and grid files if(ions_final_nzs /= final_nzs) & call error_handler(E_ERR, 'model_to_dart', & - 'Number of altitudes in grid and ions files differs', source, revision, revdate) + 'Number of altitudes in grid and ions files differs', source) ! Make sure ions and grid files have same horizontal sizes if(any(ions_nxs /= nxs) .or. any(ions_nys /= nys)) & call error_handler(E_ERR, 'model_to_dart', & - 'Number of Latitudes and Longitudes in grid and ions files differ', source, revision, revdate) + 'Number of Latitudes and Longitudes in grid and ions files differ', source) !=============================== Check that neutrals files are consistent with grids ========= @@ -145,12 +143,12 @@ subroutine model_to_dart(aether_block_file_dir, dart_file_dir, ensemble_number) ! Check for inconsistent number of vertical levels in neutral and grid files if(neutrals_final_nzs /= final_nzs) & call error_handler(E_ERR, 'model_to_dart', & - 'Number of altitudes in grid and neutrals files differs', source, revision, revdate) + 'Number of altitudes in grid and neutrals files differs', source) ! Make sure neutrals and grid files have same horizontal sizes if(any(neutrals_nxs /= nxs) .or. any(neutrals_nys /= nys)) & call error_handler(E_ERR, 'model_to_dart', & - 'Number of Latitudes and Longitudes in grid and neutrals files differ', source, revision, revdate) + 'Number of Latitudes and Longitudes in grid and neutrals files differ', source) !==================================== Write dimensions in the filter nc file ======== @@ -199,7 +197,7 @@ subroutine model_to_dart(aether_block_file_dir, dart_file_dir, ensemble_number) grid_lon_id = varid else call error_handler(E_ERR, 'model_to_dart', & - 'Unexpected variable name in grid file ' // trim(name), source, revision, revdate) + 'Unexpected variable name in grid file ' // trim(name), source) end if end do @@ -508,12 +506,12 @@ subroutine dart_to_model(dart_file_dir, aether_block_file_dir, ensemble_number) ! Check for inconsistent number of vertical levels in ion and grid files if(ions_final_nzs /= final_nzs) & call error_handler(E_ERR, 'model_to_dart', & - 'Number of altitudes in grid and ions files differs', source, revision, revdate) + 'Number of altitudes in grid and ions files differs', source) ! Make sure ions and grid files have same horizontal sizes if(any(ions_nxs /= nxs) .or. any(ions_nys /= nys)) & call error_handler(E_ERR, 'model_to_dart', & - 'Number of Latitudes and Longitudes in grid and ion files differ', source, revision, revdate) + 'Number of Latitudes and Longitudes in grid and ion files differ', source) !==================================== Open and check dimensions for neutrals files @@ -528,12 +526,12 @@ subroutine dart_to_model(dart_file_dir, aether_block_file_dir, ensemble_number) ! Check for inconsistent number of vertical levels in neutrals and grid files if(neutrals_final_nzs /= final_nzs) & call error_handler(E_ERR, 'model_to_dart', & - 'Number of altitudes in grid and neutrals files differs', source, revision, revdate) + 'Number of altitudes in grid and neutrals files differs', source) ! Make sure neutrals and grid files have same horizontal sizes if(any(neutrals_nxs /= nxs) .or. any(neutrals_nys /= nys)) & call error_handler(E_ERR, 'model_to_dart', & - 'Number of Latitudes and Longitudes in grid and neutrals files differ', source, revision, revdate) + 'Number of Latitudes and Longitudes in grid and neutrals files differ', source) !=========== Get alt lat and lon from grid files ================= @@ -711,14 +709,14 @@ subroutine get_aether_block_dimensions(files, nblocks, nhalos, nxs, nys, nzs) ncstatus = nf90_inquire_dimension(files(iblock)%ncid, dimid, name, length) if(length /= 1 .or. ncstatus /= 0) & call error_handler(E_ERR, 'get_aether_block_dimensions', & - 'Number of times in input block files should be 1', source, revision, revdate) + 'Number of times in input block files should be 1', source) ! Get the length of x dimension ncstatus = nf90_inq_dimid(files(iblock)%ncid, 'x', dimid) ncstatus = nf90_inquire_dimension(files(iblock)%ncid, dimid, name, length) if(ncstatus /= 0) & call error_handler(E_ERR, 'get_aether_block_dimensions', & - 'input block files must have x dimension', source, revision, revdate) + 'input block files must have x dimension', source) nxs(iblock) = length-2*nhalos ! Get the length of y dimension @@ -726,7 +724,7 @@ subroutine get_aether_block_dimensions(files, nblocks, nhalos, nxs, nys, nzs) ncstatus = nf90_inquire_dimension(files(iblock)%ncid, dimid, name, length) if(ncstatus /= 0) & call error_handler(E_ERR, 'get_aether_block_dimensions', & - 'input block files must have y dimension', source, revision, revdate) + 'input block files must have y dimension', source) nys(iblock) = length-2*nhalos ! Get the length of z dimension @@ -734,7 +732,7 @@ subroutine get_aether_block_dimensions(files, nblocks, nhalos, nxs, nys, nzs) ncstatus = nf90_inquire_dimension(files(iblock)%ncid, dimid, name, length) if(ncstatus /= 0) & call error_handler(E_ERR, 'get_aether_block_dimensions', & - 'input block files must have z dimension', source, revision, revdate) + 'input block files must have z dimension', source) b_nzs(iblock) = length end do @@ -742,7 +740,7 @@ subroutine get_aether_block_dimensions(files, nblocks, nhalos, nxs, nys, nzs) ! Make sure all blocks have same number of vertical levels if(any(b_nzs - b_nzs(1) /= 0)) then call error_handler(E_ERR, 'model_to_dart', & - 'block files have different lengths for z dimension', source, revision, revdate) + 'block files have different lengths for z dimension', source) else nzs = b_nzs(1) endif @@ -750,7 +748,7 @@ subroutine get_aether_block_dimensions(files, nblocks, nhalos, nxs, nys, nzs) ! Make sure all block files have the same number of attributes if(any(files(:)%nAttributes /= files(1)%nAttributes)) & call error_handler(E_ERR, 'model_to_dart', & - 'All blocks must have same nunber of variables', source, revision, revdate) + 'All blocks must have same nunber of variables', source) end subroutine get_aether_block_dimensions @@ -853,7 +851,7 @@ function zero_fill(string, desired_length) result(filled_string) if (difference_of_string_lengths < 0) then call error_handler(E_ERR, 'zero_fill', & 'Input string is longer than desired output => ensemble size too large', & - source, revision, revdate) + source) else if (difference_of_string_lengths > 0) then do string_index = 1, difference_of_string_lengths filled_string(string_index:string_index) = '0' From 9de0f8c1535dfcdce26c6ea05d08a2f9395a3a50 Mon Sep 17 00:00:00 2001 From: Jeff Anderson Date: Thu, 30 Oct 2025 16:49:21 -0600 Subject: [PATCH 04/24] Moved test_aether_grid to aether directory and removed it and supporting files from the developer_tests directory. Changed the quickbuild.sh in aether_cube_sphere/work to include test_aether_grid as a sequential program. Moved the test_grid_box subroutine from model_mod to test_aether_grid. Made three additional public entities in model_mod that are needed for test_grid_box. These are the grid geometry basic quantities np and ncenter_altitudes and the routine get_state_index. Changed to using utilities instead of mpi_utilities in test_aether_grid. --- .../aether_grid/test_aether_grid.f90 | 15 -- developer_tests/aether_grid/work/input.nml | 254 ------------------ .../aether_grid/work/quickbuild.sh | 50 ---- models/aether_cube_sphere/model_mod.f90 | 187 +------------ .../aether_cube_sphere/test_aether_grid.f90 | 228 ++++++++++++++++ models/aether_cube_sphere/work/quickbuild.sh | 1 + 6 files changed, 233 insertions(+), 502 deletions(-) delete mode 100644 developer_tests/aether_grid/test_aether_grid.f90 delete mode 100644 developer_tests/aether_grid/work/input.nml delete mode 100755 developer_tests/aether_grid/work/quickbuild.sh create mode 100644 models/aether_cube_sphere/test_aether_grid.f90 diff --git a/developer_tests/aether_grid/test_aether_grid.f90 b/developer_tests/aether_grid/test_aether_grid.f90 deleted file mode 100644 index c7c7444387..0000000000 --- a/developer_tests/aether_grid/test_aether_grid.f90 +++ /dev/null @@ -1,15 +0,0 @@ -program test_aether_grid - -use mpi_utilities_mod, only : initialize_mpi_utilities, finalize_mpi_utilities -use model_mod, only : test_grid_box -use assim_model_mod, only : static_init_assim_model - -call initialize_mpi_utilities('test_aether_grid') - -call static_init_assim_model() - -call test_grid_box - -call finalize_mpi_utilities - -end program test_aether_grid diff --git a/developer_tests/aether_grid/work/input.nml b/developer_tests/aether_grid/work/input.nml deleted file mode 100644 index 4fd10ad50d..0000000000 --- a/developer_tests/aether_grid/work/input.nml +++ /dev/null @@ -1,254 +0,0 @@ -&probit_transform_nml - / - -&algorithm_info_nml - qceff_table_filename = '' - / - -&perfect_model_obs_nml - read_input_state_from_file = .true., - single_file_in = .false. - input_state_files = "filter_input_0001.nc" - - write_output_state_to_file = .false., - single_file_out = .false. - output_state_files = "perfect_output.nc" - output_interval = 1, - - async = 0, - adv_ens_command = "./advance_model.csh", - - obs_seq_in_file_name = "obs_seq.in", - obs_seq_out_file_name = "obs_seq.out", - init_time_days = 0, - init_time_seconds = 0, - first_obs_days = -1, - first_obs_seconds = -1, - last_obs_days = -1, - last_obs_seconds = -1, - - trace_execution = .false., - output_timestamps = .false., - print_every_nth_obs = -1, - output_forward_op_errors = .false., - silence = .false., - / - -&filter_nml - single_file_in = .false., - input_state_files = '' - input_state_file_list = 'filter_input_files.txt' - - stages_to_write = 'preassim', 'analysis', 'output' - - single_file_out = .false., - output_state_files = '' - output_state_file_list = 'filter_output_files.txt' - output_interval = 1, - output_members = .true. - num_output_state_members = 20, - output_mean = .true. - output_sd = .true. - write_all_stages_at_end = .false. - compute_posterior = .true. - - ens_size = 10, - num_groups = 1, - perturb_from_single_instance = .false., - perturbation_amplitude = 0.2, - distributed_state = .true. - - async = 4, - adv_ens_command = "./advance_model.csh", - - obs_sequence_in_name = "obs_seq.out", - obs_sequence_out_name = "obs_seq.final", - num_output_obs_members = 20, - init_time_days = 0, - init_time_seconds = 0, - first_obs_days = -1, - first_obs_seconds = -1, - last_obs_days = -1, - last_obs_seconds = -1, - - inf_flavor = 5, 0, - inf_initial_from_restart = .false., .false., - inf_sd_initial_from_restart = .false., .false., - inf_deterministic = .true., .true., - inf_initial = 1.0, 1.0, - inf_lower_bound = 0.0, 1.0, - inf_upper_bound = 100.0, 1000000.0, - inf_damping = 1.0, 1.0, - inf_sd_initial = 0.6, 0.0, - inf_sd_lower_bound = 0.6, 0.0, - inf_sd_max_change = 1.05, 1.05, - - trace_execution = .false., - output_timestamps = .false., - output_forward_op_errors = .false., - silence = .false., - / - - -&ensemble_manager_nml - / - -&assim_tools_nml - cutoff = 0.4 - sort_obs_inc = .false., - spread_restoration = .false., - sampling_error_correction = .false., - adaptive_localization_threshold = -1, - distribute_mean = .false. - output_localization_diagnostics = .false., - localization_diagnostics_file = 'localization_diagnostics', - print_every_nth_obs = 0 - / - -&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. - / - -&obs_kind_nml - assimilate_these_obs_types = 'GND_GPS_VTEC', - 'SLANT_GPS_VTEC', - 'SAT_TEMPERATURE', - 'SAT_DENSITY_ION_O2P', - 'SAT_DENSITY_NEUTRAL_O2', - 'SAT_DENSITY_ION_N2P' - / - -&model_nml - template_file = '../../../models/aether_cube_sphere/work/filter_input_0001.nc' - time_step_days = 0, - time_step_seconds = 3600 - variables = 'Temperature','QTY_TEMPERATURE', '0.0', 'NA', 'UPDATE', - 'O2+', 'QTY_DENSITY_ION_O2P', '0.0', 'NA', 'UPDATE', - 'O2', 'QTY_DENSITY_NEUTRAL_O2', '0.0', 'NA', 'UPDATE', - 'N2+', 'QTY_DENSITY_ION_N2P', '0.0', 'NA', 'UPDATE', - 'ION_E', 'QTY_DENSITY_ION_E', '0.0', 'NA', 'UPDATE', - '2D_F10.7', 'QTY_1D_PARAMETER', '0.0', 'NA', 'UPDATE' - / - -&utilities_nml - TERMLEVEL = 1, - module_details = .false., - logfilename = 'dart_log.out', - nmlfilename = 'dart_log.nml', - write_nml = 'none' - / - -&preprocess_nml - 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_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' - obs_type_files = '../../../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', - '../../../observations/forward_operators/obs_def_metar_mod.f90', - '../../../observations/forward_operators/obs_def_dew_point_mod.f90', - '../../../observations/forward_operators/obs_def_rel_humidity_mod.f90', - '../../../observations/forward_operators/obs_def_gps_mod.f90', - '../../../observations/forward_operators/obs_def_vortex_mod.f90', - '../../../observations/forward_operators/obs_def_gts_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' - / - -&obs_sequence_tool_nml - 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, - print_only = .false., - gregorian_cal = .false. - / - -&obs_diag_nml - obs_sequence_name = 'obs_seq.final', - bin_width_days = -1, - bin_width_seconds = -1, - init_skip_days = 0, - init_skip_seconds = 0, - Nregions = 3, - trusted_obs = 'null', - lonlim1 = 0.00, 0.00, 0.50 - lonlim2 = 1.01, 0.50, 1.01 - reg_names = 'whole', 'yin', 'yang' - create_rank_histogram = .true., - outliers_in_histogram = .true., - use_zero_error_obs = .false., - verbose = .false. - / - -&state_vector_io_nml - / - -&model_mod_check_nml - input_state_files = 'filter_input_0001.nc' - output_state_files = 'mmc_output.nc' - test1thru = 0 - run_tests = 1,2,3,4,5,6,7 - x_ind = 12 - loc_of_interest = 98.5, 85.5, 96344 - quantity_of_interest = 'QTY_TEMPERATURE' - interp_test_dlon = 4.0 - interp_test_lonrange = 0.0, 360.0 - interp_test_dlat = 4.0 - interp_test_latrange = -90.0, 90.0 - interp_test_dvert = 2000.0 - interp_test_vertrange = 100000.0, 106000.0 - interp_test_vertcoord = 'VERTISHEIGHT' - verbose = .true. - / - -&quality_control_nml - input_qc_threshold = 3.0, - outlier_threshold = -1.0, -/ - -&location_nml - horiz_dist_only = .false. - vert_normalization_pressure = 20000.0 - vert_normalization_height = 100000.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 - / - -&aether_to_dart_nml - aether_file_directory = '../TEST_INPUT/' - dart_file_directory = './' - / - -&dart_to_aether_nml - dart_file_directory = './' - aether_file_directory = '../TEST_OUTPUT/' - - / - -&transform_state_nml - np = 18 - nblocks = 6 - nhalos = 2 - scalar_f10_7 = .false. - / diff --git a/developer_tests/aether_grid/work/quickbuild.sh b/developer_tests/aether_grid/work/quickbuild.sh deleted file mode 100755 index 1b83a9ad85..0000000000 --- a/developer_tests/aether_grid/work/quickbuild.sh +++ /dev/null @@ -1,50 +0,0 @@ -#!/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="aether_cube_sphere" -LOCATION="threed_sphere" -dev_test=1 -TEST="aether_grid" - - -programs=( -test_aether_grid -) - -serial_programs=( -) - -model_programs=( -) - -model_serial_programs=( -aether_to_dart -dart_to_aether -) - -# quickbuild arguments -arguments "$@" - -# clean the directory -\rm -f -- *.o *.mod Makefile .cppdefs - -# build and run preprocess before making any other DART executables -buildpreprocess - -# build -buildit - -# clean up -\rm -f -- *.o *.mod - -} - -main "$@" diff --git a/models/aether_cube_sphere/model_mod.f90 b/models/aether_cube_sphere/model_mod.f90 index c3264d7092..1feb69f56a 100644 --- a/models/aether_cube_sphere/model_mod.f90 +++ b/models/aether_cube_sphere/model_mod.f90 @@ -69,9 +69,6 @@ module model_mod shortest_time_between_assimilations, & write_model_time -! Routine for comprehensive test of interpolation -public :: test_grid_box - ! version controlled file description for error handling, do not edit character(len=*), parameter :: source = "aether_cube_sphere/model_mod" @@ -97,6 +94,10 @@ module model_mod integer :: ncenter_altitudes ! The number of altitudes and the altitudes real(r8), allocatable :: center_altitude(:) +! The basic geometry variables need to be accessed by the test_grid_box routine +! Also need get_state_index +public :: np, ncenter_altitudes, get_state_index + ! Current model time needed for computing location for scalar F10.7 type(time_type) :: state_time @@ -558,186 +559,6 @@ end subroutine read_template_file !----------------------------------------------------------------------- -! Testing subroutine for grid definition and interpolation tools -! This is not designed to be run with more than one process - -subroutine test_grid_box - -integer :: i, j, num_bound_points, qty, lon_count, lat_count -integer :: grid_face(4), grid_lat_ind(4), grid_lon_ind(4) -integer :: my_face, my_level, my_qty, my_lon_ind, my_lat_ind -integer :: test_face, test_lat_ind, test_lon_ind, col_index, test_col_index -integer :: num_test_lats, num_test_lons -integer(i8) :: state_index -real(r8) :: pt_lon_d, pt_lat_d, pt_lon, pt_lat -real(r8) :: qxyz(4, 3), pxyz(3), grid_pt_lat(4), grid_pt_lon(4) -real(r8) :: lon_lat_hgt(3), my_lat, my_lon, base_dist, dist_sum -logical :: inside - -type(location_type) :: location - -! Test that grid_to_lat_lon and lat_lon_to_grid are inverses of each other -do my_face = 0, 5 - do my_lat_ind = 1, np - do my_lon_ind = 1, np - call grid_to_lat_lon(my_face, my_lat_ind, my_lon_ind, del, half_del, pt_lat, pt_lon) - call lat_lon_to_grid(pt_lat, pt_lon, del, half_del, test_face, test_lat_ind, test_lon_ind) - if(my_face /= test_face .or. my_lat_ind /= test_lat_ind .or. my_lon_ind /= test_lon_ind) then - write(string1, *) 'Test failed: lat_lon_to_grid is not inverse of grid_to_lat_lon' - write(string2, *) my_face, test_face, my_lat_ind, test_lat_ind, my_lon_ind, test_lon_ind - call error_handler(E_ERR, 'test_grid_box', string1, source, text2=string2) - endif - - ! Test that col_index_to_lat_lon and lat_lon_to_col_index are inverses of each other - col_index = my_lon_ind + (my_lat_ind - 1) * np + my_face * np*np - call col_index_to_lat_lon(col_index, np, del, half_del, pt_lat, pt_lon) - test_col_index = lat_lon_to_col_index(pt_lat, pt_lon, del, half_del, np) - if(col_index /= test_col_index) then - write(string1, *) 'Test failed: lat_lon_to_col_index is not inverse of col_index_to_lat_lon' - write(string2, *) my_face, my_lat_ind, my_lon_ind, col_index, test_col_index - call error_handler(E_ERR, 'test_grid_box', string1, source, text2=string2) - endif - enddo - enddo -enddo - -! Test points for the following: -! 1. Does the bounding box found contain the observed point? -! 2. Are the computed vertex latitudes and longitudes the same as those in the Aether grid files? - -! Largest edges are on the quads in the center of a face -! Get distance, base_dist, along side of center quad -do i = 1, 2 - ! Traverse half of the rows (each np across), plus halfway across the next row - state_index = (np/2)*np + np/2 + i - 1 - call get_state_meta_data(state_index, location, qty) - lon_lat_hgt = get_location(location) - qxyz(i, 1:3) = lat_lon_to_xyz(DEG2RAD*lon_lat_hgt(2), DEG2RAD*lon_lat_hgt(1)) -enddo -base_dist = sqrt(sum((qxyz(1, :) - qxyz(2, :))**2)) - -! Loop through many longitude and latitude points for testing -num_test_lons = 3600 -do lon_count = 0, num_test_lons - pt_lon_d = lon_count * (360.0_r8 / num_test_lons) - num_test_lats = 1800 - do lat_count = -900, 900 - pt_lat_d = lat_count * (180.0_r8 / num_test_lats) - - ! Convert to radians - pt_lon = DEG2RAD * pt_lon_d - pt_lat = DEG2RAD * pt_lat_d - - ! Get the x, y, z coords for this point - pxyz = lat_lon_to_xyz(pt_lat, pt_lon); - - call get_bounding_box(pt_lat, pt_lon, del, half_del, np, & - grid_face, grid_lat_ind, grid_lon_ind, grid_pt_lat, grid_pt_lon, num_bound_points) - - do i = 1, num_bound_points - ! Convert to x, y, z coords to check for whether points are in tri/quad - qxyz(i, 1:3) = lat_lon_to_xyz(grid_pt_lat(i), grid_pt_lon(i)); - enddo - - ! Get latitude longitude of bounding points from get_state_meta_data as confirmation test - do i = 1, num_bound_points - state_index = get_state_index(grid_face(i), grid_lat_ind(i), grid_lon_ind(i), 1, 1) - call get_state_meta_data(state_index, location, qty) - lon_lat_hgt = get_location(location) - ! Deal with Aether file round off - if(abs(lon_lat_hgt(1) - 360.0_r8) < 0.0001) lon_lat_hgt(1) = 0.0_r8 - if(abs(RAD2DEG*grid_pt_lat(i) - lon_lat_hgt(2)) > 0.0001_r8 .or. & - abs(RAD2DEG*grid_pt_lon(i) - lon_lat_hgt(1)) > 0.0001_r8) then - write(string1, *) 'Test failed: Aether files grid points inconsistent with get_state_meta_data' - write(string2, *) grid_pt_lat(i), grid_pt_lon(i), lon_lat_hgt(2), lon_lat_hgt(1) - call error_handler(E_ERR, 'test_grid_box', string1, source, text2=string2) - endif - enddo - - if(num_bound_points == 3) then - ! See if the point is inside a local approximately tangent triangle - inside = is_point_in_triangle(qxyz(1, :), qxyz(2, :), qxyz(3, :), pxyz); - else - ! Or quadrilateral - inside = is_point_in_quad(qxyz, pxyz); - endif - - if(.not. inside) then - write(string1, *) 'Test failed: Point is not inside the triangle or quadrilateral' - write(string2, *) pt_lat, pt_lon, num_bound_points - call error_handler(E_ERR, 'test_grid_box', string1, source, text2=string2) - endif - - ! Also check on distance to vertices; this greatly reduces the possibility that - ! bounding boxes that are bigger than they should be are being found - dist_sum = 0.0_r8 - do i = 1, num_bound_points - ! Compute sum of distances between point and each of the vertices - dist_sum = dist_sum + sqrt(sum((qxyz(i, :) - pxyz)**2)) - end do - - if(num_bound_points == 4) then - ! For quad, sum should be less than 3.5 times the baseline - if(dist_sum / base_dist > 3.5_r8) then - write(string1, *) 'Test failed: Ratio of sum of distances to vertices is too large for quad' - ! Additional info that could be helpful - !!!do i = 1, num_bound_points - !!!write(*, *) 'grid ', i, grid_pt_lat(i), grid_pt_lon(i) - !!!write(*, *) 'grid xyz ', i, qxyz(i, :) - !!!enddo - write(string2, *) 'point ', pt_lat, pt_lon, 'point xyz ', pxyz - call error_handler(E_ERR, 'test_grid_box', string1, source, text2=string2) - endif - elseif(num_bound_points == 3) then - ! For triangle, sum should be less than 3 times the baseline - if(dist_sum / base_dist > 3.0_r8) then - write(string1, *) 'Test failed: ratio of sum of distances to vertices is too large for triangle' - call error_handler(E_ERR, 'test_grid_box', string1, source) - endif - endif - enddo -enddo - -!------------------- -! Block that loops through all state variables and confirms that the algorithms for mapping -! state vector (face/lon/lat) indices and get_state_meta_data correcty match up. -do my_qty = 1, 2 - do my_level = 1, ncenter_altitudes - do my_face = 0, 5 - do my_lat_ind = 1, np - do my_lon_ind = 1, np - state_index = get_state_index(my_face, my_lat_ind, my_lon_ind, & - my_level, my_qty) - call get_state_meta_data(state_index, location, qty) - lon_lat_hgt = get_location(location) - - ! Want to compare the lat lon directly from code to that from get_state_meta_data - call grid_to_lat_lon(my_face, my_lat_ind, my_lon_ind, del, half_del, my_lat, my_lon) - - ! ROUNDOFF FROM AETHER - if(abs(lon_lat_hgt(1) - 360.0_r8) < 0.0001) lon_lat_hgt(1) = 0.0_r8 - - ! Check that things are consistent - if(abs(RAD2DEG*my_lat - lon_lat_hgt(2)) > 0.0001_r8 .or. & - abs(RAD2DEG*my_lon - lon_lat_hgt(1)) > 0.0001_r8) then - write(string1, *) 'Test Failed: Grid points not appropriately mapping' - write(string2, *) my_face, my_qty, my_level, my_lat_ind, my_lon_ind - call error_handler(E_ERR, 'test_grid_box', string1, source) - endif - - enddo - enddo - enddo - enddo -enddo - -write(string1, *) 'ALL TESTS PASSED' -call error_handler(E_MSG, 'test_grid_box', string1, source) - -end subroutine test_grid_box - -!----------------------------------------------------------------------- - function get_state_index(face, lat_ind, lon_ind, lev_ind, var_ind) integer :: get_state_index diff --git a/models/aether_cube_sphere/test_aether_grid.f90 b/models/aether_cube_sphere/test_aether_grid.f90 new file mode 100644 index 0000000000..d38c65d14c --- /dev/null +++ b/models/aether_cube_sphere/test_aether_grid.f90 @@ -0,0 +1,228 @@ +! 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 + +program test_aether_grid + +use utilities_mod, only : initialize_utilities, finalize_utilities + +use assim_model_mod, only : static_init_assim_model + +use types_mod, only : r8, i8, DEG2RAD, RAD2DEG + +use location_mod, only : location_type, get_location + +use utilities_mod, only : error_handler, E_ERR, E_MSG + +use cube_sphere_grid_tools_mod, only : is_point_in_triangle, is_point_in_quad, grid_to_lat_lon, & + lat_lon_to_xyz, col_index_to_lat_lon, lat_lon_to_grid, & + get_bounding_box, lat_lon_to_col_index, get_grid_delta + +! Need basic grid description read from template file by model_mod +use model_mod, only : np, ncenter_altitudes, get_state_index, get_state_meta_data + +! version controlled file description for error handling, do not edit +character(len=*), parameter :: source = "test_aether_grid" + + +call initialize_utilities(source) + +call static_init_assim_model() + +call test_grid_box() + +call finalize_utilities + +!------------------------------------------------------------ + +contains + + +! Testing subroutine for grid definition and interpolation tools +! This is not designed to be run with more than one process + +subroutine test_grid_box + +integer :: i, j, num_bound_points, qty, lon_count, lat_count +integer :: grid_face(4), grid_lat_ind(4), grid_lon_ind(4) +integer :: my_face, my_level, my_qty, my_lon_ind, my_lat_ind +integer :: test_face, test_lat_ind, test_lon_ind, col_index, test_col_index +integer :: num_test_lats, num_test_lons +integer(i8) :: state_index +real(r8) :: del, half_del ! Grid row spacing and half of that +real(r8) :: pt_lon_d, pt_lat_d, pt_lon, pt_lat +real(r8) :: qxyz(4, 3), pxyz(3), grid_pt_lat(4), grid_pt_lon(4) +real(r8) :: lon_lat_hgt(3), my_lat, my_lon, base_dist, dist_sum +logical :: inside + +type(location_type) :: location + +! Error message strings +character(len=512) :: string1, string2 + +! Get the rest of the geometry, np read by static_init_model +call get_grid_delta(np, del, half_del) + +! Test that grid_to_lat_lon and lat_lon_to_grid are inverses of each other +do my_face = 0, 5 + do my_lat_ind = 1, np + do my_lon_ind = 1, np + call grid_to_lat_lon(my_face, my_lat_ind, my_lon_ind, del, half_del, pt_lat, pt_lon) + call lat_lon_to_grid(pt_lat, pt_lon, del, half_del, test_face, test_lat_ind, test_lon_ind) + if(my_face /= test_face .or. my_lat_ind /= test_lat_ind .or. my_lon_ind /= test_lon_ind) then + write(string1, *) 'Test failed: lat_lon_to_grid is not inverse of grid_to_lat_lon' + write(string2, *) my_face, test_face, my_lat_ind, test_lat_ind, my_lon_ind, test_lon_ind + call error_handler(E_ERR, 'test_grid_box', string1, source, text2=string2) + endif + + ! Test that col_index_to_lat_lon and lat_lon_to_col_index are inverses of each other + col_index = my_lon_ind + (my_lat_ind - 1) * np + my_face * np*np + call col_index_to_lat_lon(col_index, np, del, half_del, pt_lat, pt_lon) + test_col_index = lat_lon_to_col_index(pt_lat, pt_lon, del, half_del, np) + if(col_index /= test_col_index) then + write(string1, *) 'Test failed: lat_lon_to_col_index is not inverse of col_index_to_lat_lon' + write(string2, *) my_face, my_lat_ind, my_lon_ind, col_index, test_col_index + call error_handler(E_ERR, 'test_grid_box', string1, source, text2=string2) + endif + enddo + enddo +enddo + +! Test points for the following: +! 1. Does the bounding box found contain the observed point? +! 2. Are the computed vertex latitudes and longitudes the same as those in the Aether grid files? + +! Largest edges are on the quads in the center of a face +! Get distance, base_dist, along side of center quad +do i = 1, 2 + ! Traverse half of the rows (each np across), plus halfway across the next row + state_index = (np/2)*np + np/2 + i - 1 + call get_state_meta_data(state_index, location, qty) + lon_lat_hgt = get_location(location) + qxyz(i, 1:3) = lat_lon_to_xyz(DEG2RAD*lon_lat_hgt(2), DEG2RAD*lon_lat_hgt(1)) +enddo +base_dist = sqrt(sum((qxyz(1, :) - qxyz(2, :))**2)) + +! Loop through many longitude and latitude points for testing +num_test_lons = 3600 +do lon_count = 0, num_test_lons + pt_lon_d = lon_count * (360.0_r8 / num_test_lons) + num_test_lats = 1800 + do lat_count = -900, 900 + pt_lat_d = lat_count * (180.0_r8 / num_test_lats) + + ! Convert to radians + pt_lon = DEG2RAD * pt_lon_d + pt_lat = DEG2RAD * pt_lat_d + + ! Get the x, y, z coords for this point + pxyz = lat_lon_to_xyz(pt_lat, pt_lon); + + call get_bounding_box(pt_lat, pt_lon, del, half_del, np, & + grid_face, grid_lat_ind, grid_lon_ind, grid_pt_lat, grid_pt_lon, num_bound_points) + + do i = 1, num_bound_points + ! Convert to x, y, z coords to check for whether points are in tri/quad + qxyz(i, 1:3) = lat_lon_to_xyz(grid_pt_lat(i), grid_pt_lon(i)); + enddo + + ! Get latitude longitude of bounding points from get_state_meta_data as confirmation test + do i = 1, num_bound_points + state_index = get_state_index(grid_face(i), grid_lat_ind(i), grid_lon_ind(i), 1, 1) + call get_state_meta_data(state_index, location, qty) + lon_lat_hgt = get_location(location) + ! Deal with Aether file round off + if(abs(lon_lat_hgt(1) - 360.0_r8) < 0.0001) lon_lat_hgt(1) = 0.0_r8 + if(abs(RAD2DEG*grid_pt_lat(i) - lon_lat_hgt(2)) > 0.0001_r8 .or. & + abs(RAD2DEG*grid_pt_lon(i) - lon_lat_hgt(1)) > 0.0001_r8) then + write(string1, *) 'Test failed: Aether files grid points inconsistent with get_state_meta_data' + write(string2, *) grid_pt_lat(i), grid_pt_lon(i), lon_lat_hgt(2), lon_lat_hgt(1) + call error_handler(E_ERR, 'test_grid_box', string1, source, text2=string2) + endif + enddo + + if(num_bound_points == 3) then + ! See if the point is inside a local approximately tangent triangle + inside = is_point_in_triangle(qxyz(1, :), qxyz(2, :), qxyz(3, :), pxyz); + else + ! Or quadrilateral + inside = is_point_in_quad(qxyz, pxyz); + endif + + if(.not. inside) then + write(string1, *) 'Test failed: Point is not inside the triangle or quadrilateral' + write(string2, *) pt_lat, pt_lon, num_bound_points + call error_handler(E_ERR, 'test_grid_box', string1, source, text2=string2) + endif + + ! Also check on distance to vertices; this greatly reduces the possibility that + ! bounding boxes that are bigger than they should be are being found + dist_sum = 0.0_r8 + do i = 1, num_bound_points + ! Compute sum of distances between point and each of the vertices + dist_sum = dist_sum + sqrt(sum((qxyz(i, :) - pxyz)**2)) + end do + + if(num_bound_points == 4) then + ! For quad, sum should be less than 3.5 times the baseline + if(dist_sum / base_dist > 3.5_r8) then + write(string1, *) 'Test failed: Ratio of sum of distances to vertices is too large for quad' + ! Additional info that could be helpful + !!!do i = 1, num_bound_points + !!!write(*, *) 'grid ', i, grid_pt_lat(i), grid_pt_lon(i) + !!!write(*, *) 'grid xyz ', i, qxyz(i, :) + !!!enddo + write(string2, *) 'point ', pt_lat, pt_lon, 'point xyz ', pxyz + call error_handler(E_ERR, 'test_grid_box', string1, source, text2=string2) + endif + elseif(num_bound_points == 3) then + ! For triangle, sum should be less than 3 times the baseline + if(dist_sum / base_dist > 3.0_r8) then + write(string1, *) 'Test failed: ratio of sum of distances to vertices is too large for triangle' + call error_handler(E_ERR, 'test_grid_box', string1, source) + endif + endif + enddo +enddo + +!------------------- +! Block that loops through all state variables and confirms that the algorithms for mapping +! state vector (face/lon/lat) indices and get_state_meta_data correcty match up. +do my_qty = 1, 2 + do my_level = 1, ncenter_altitudes + do my_face = 0, 5 + do my_lat_ind = 1, np + do my_lon_ind = 1, np + state_index = get_state_index(my_face, my_lat_ind, my_lon_ind, & + my_level, my_qty) + call get_state_meta_data(state_index, location, qty) + lon_lat_hgt = get_location(location) + + ! Want to compare the lat lon directly from code to that from get_state_meta_data + call grid_to_lat_lon(my_face, my_lat_ind, my_lon_ind, del, half_del, my_lat, my_lon) + + ! ROUNDOFF FROM AETHER + if(abs(lon_lat_hgt(1) - 360.0_r8) < 0.0001) lon_lat_hgt(1) = 0.0_r8 + + ! Check that things are consistent + if(abs(RAD2DEG*my_lat - lon_lat_hgt(2)) > 0.0001_r8 .or. & + abs(RAD2DEG*my_lon - lon_lat_hgt(1)) > 0.0001_r8) then + write(string1, *) 'Test Failed: Grid points not appropriately mapping' + write(string2, *) my_face, my_qty, my_level, my_lat_ind, my_lon_ind + call error_handler(E_ERR, 'test_grid_box', string1, source) + endif + + enddo + enddo + enddo + enddo +enddo + +write(string1, *) 'ALL TESTS PASSED' +call error_handler(E_MSG, 'test_grid_box', string1, source) + +end subroutine test_grid_box + +!----------------------------------------------------------------------- + +end program test_aether_grid diff --git a/models/aether_cube_sphere/work/quickbuild.sh b/models/aether_cube_sphere/work/quickbuild.sh index 8e155a0618..441fdb2655 100755 --- a/models/aether_cube_sphere/work/quickbuild.sh +++ b/models/aether_cube_sphere/work/quickbuild.sh @@ -36,6 +36,7 @@ model_programs=( model_serial_programs=( aether_to_dart dart_to_aether +test_aether_grid ) # quickbuild arguments From 875c67e8dd2849787b059ba886cf6f2b8e5a55ef Mon Sep 17 00:00:00 2001 From: Jeff Anderson Date: Mon, 3 Nov 2025 13:54:50 -0700 Subject: [PATCH 05/24] Minor changes to model_mod to use error handler, fix comment, fix compatabilty with ifort. --- models/aether_cube_sphere/model_mod.f90 | 12 +++++------- 1 file changed, 5 insertions(+), 7 deletions(-) diff --git a/models/aether_cube_sphere/model_mod.f90 b/models/aether_cube_sphere/model_mod.f90 index 1feb69f56a..e03115cf9c 100644 --- a/models/aether_cube_sphere/model_mod.f90 +++ b/models/aether_cube_sphere/model_mod.f90 @@ -141,9 +141,6 @@ subroutine static_init_model() module_initialized = .true. -! Print module information to log file and stdout. -call register_module(source) - ! Read the namelist contents call find_namelist_in_file('input.nml', 'model_nml', iunit) read(iunit, nml = model_nml, iostat = io) @@ -351,8 +348,9 @@ subroutine get_state_meta_data(index_in, location, qty) ! 360.0 degrees in 86400 seconds, 43200 secs == 12:00 UTC == longitude 0.0 call get_time(state_time, seconds, days) longitude = 360.0_r8 * real(seconds,r8) / 86400.0_r8 - 180.0_r8 - if (longitude < 0.0_r8) longitude = longitude + 360.0_r8 - write(*, *) 'longitude for F10.7 is ', longitude + if (longitude < 0.0_r8) longitude = longitude + 30.0_r8 + write(string1,*)'Longitude assigned for F10.7 state variable is', longitude + call error_handler(E_MSG, 'get_state_meta_data', string1, source) location = set_location(longitude, 0.0_r8, 400000.0_r8, VERTISUNDEF) return end if @@ -529,7 +527,7 @@ subroutine read_template_file() character(len=256) :: name type(file_type) :: templatefile -! Gets altitudes and number of points per face row from a filter template file +! Gets altitudes and number of points per face row from an Aether template file templatefile%file_path = trim(template_file) templatefile%ncid = nc_open_file_readonly(templatefile%file_path) @@ -593,8 +591,8 @@ end function get_state_index function idw_interp(ens_size, lat, lon, y_corners, x_corners, p, num_corners) -real(r8) :: idw_interp(ens_size) ! Interpolated value at (lat, lon). integer, intent(in) :: ens_size +real(r8) :: idw_interp(ens_size) ! Interpolated value at (lat, lon). real(r8), intent(in) :: lat, lon ! Interpolation point (latitude, longitude) in degrees real(r8), intent(in) :: y_corners(:), x_corners(:) ! corner points (latitude, longitude) in degrees real(r8), intent(in) :: p(:, :) ! Values at the quadrilaterals corner points, second dimension is ens_size From 6bb958718a73724d419352e29ee0fa35db7e9062 Mon Sep 17 00:00:00 2001 From: Jeff Anderson Date: Mon, 3 Nov 2025 14:39:11 -0700 Subject: [PATCH 06/24] Used the parse_variables_clamp routine from default_model_mod to get the list of state variables and their clamping ranges from the namelist. --- models/aether_cube_sphere/model_mod.f90 | 92 ++----------------------- 1 file changed, 7 insertions(+), 85 deletions(-) diff --git a/models/aether_cube_sphere/model_mod.f90 b/models/aether_cube_sphere/model_mod.f90 index e03115cf9c..a755e3f472 100644 --- a/models/aether_cube_sphere/model_mod.f90 +++ b/models/aether_cube_sphere/model_mod.f90 @@ -7,7 +7,8 @@ module model_mod use netcdf -use types_mod, only : r8, i8, MISSING_R8, vtablenamelength, DEG2RAD, RAD2DEG +use types_mod, only : r8, i8, MISSING_R8, vtablenamelength, DEG2RAD, RAD2DEG, & + vtablenamelength use time_manager_mod, only : time_type, set_time, get_time @@ -45,7 +46,8 @@ module model_mod use default_model_mod, only : pert_model_copies, read_model_time, write_model_time, & init_time => fail_init_time, & init_conditions => fail_init_conditions, & - convert_vertical_obs, convert_vertical_state, adv_1step + convert_vertical_obs, convert_vertical_state, adv_1step, & + parse_variables_clamp, MAX_STATE_VARIABLE_FIELDS_CLAMP implicit none private @@ -104,14 +106,6 @@ module model_mod ! Horizontal column dimension rather than being direct functions of latitude and longitude. integer :: no_third_dimension = -99 -type :: var_type - integer :: count - character(len=64), allocatable :: names(:) - integer, allocatable :: qtys(:) - real(r8), allocatable :: clamp_values(:, :) - logical, allocatable :: updates(:) -end type var_type - ! This is redundant with type defined in transform_state_mod type :: file_type character(len=256) :: file_path @@ -125,7 +119,8 @@ module model_mod integer :: time_step_seconds = 3600 integer, parameter :: MAX_STATE_VARIABLES = 100 integer, parameter :: NUM_STATE_TABLE_COLUMNS = 5 -character(len=vtablenamelength) :: variables(NUM_STATE_TABLE_COLUMNS,MAX_STATE_VARIABLES) = '' +character(len=vtablenamelength) :: & + variables(MAX_STATE_VARIABLE_FIELDS_CLAMP) = ' ' ! Table of state variables and associated metadata namelist /model_nml/ template_file, time_step_days, time_step_seconds, variables @@ -137,8 +132,6 @@ module model_mod subroutine static_init_model() -type(var_type) :: var - module_initialized = .true. ! Read the namelist contents @@ -156,11 +149,8 @@ subroutine static_init_model() ! model time will be assimilated. assimilation_time_step = set_time(time_step_seconds, time_step_days) -! Load the table of variable metadata -var = assign_var(variables, MAX_STATE_VARIABLES) ! Define which variables are in the model state -dom_id = add_domain(template_file, var%count, var%names, var%qtys, & - var%clamp_values, var%updates) +dom_id = add_domain(template_file, parse_variables_clamp(variables)) ! Get the altitudes and the number of grid rows call read_template_file() @@ -453,74 +443,6 @@ end subroutine nc_write_model_atts !----------------------------------------------------------------------- -! Parse the table of variables characteristics into arrays for easier access. - -function assign_var(variables, MAX_STATE_VARIABLES) result(var) - -character(len=vtablenamelength), intent(in) :: variables(:, :) -integer, intent(in) :: MAX_STATE_VARIABLES - -type(var_type) :: var -integer :: ivar -character(len=vtablenamelength) :: table_entry - -!----------------------------------------------------------------------- -! Codes for interpreting the NUM_STATE_TABLE_COLUMNS of the variables table -integer, parameter :: NAME_INDEX = 1 ! ... variable name -integer, parameter :: QTY_INDEX = 2 ! ... DART qty -integer, parameter :: MIN_VAL_INDEX = 3 ! ... minimum value if any -integer, parameter :: MAX_VAL_INDEX = 4 ! ... maximum value if any -integer, parameter :: UPDATE_INDEX = 5 ! ... update (state) or not - -! Loop through the variables array to get the actual count of the number of variables -do ivar = 1, MAX_STATE_VARIABLES - ! If the element is an empty string, the loop has exceeded the extent of the variables - if(variables(1, ivar) == '') then - var%count = ivar-1 - exit - endif -enddo - -! Allocate the arrays in the var derived type -allocate(var%names(var%count), var%qtys(var%count), & - var%clamp_values(var%count, 2), var%updates(var%count)) - -! Load the table for each variable -do ivar = 1, var%count - var%names(ivar) = trim(variables(NAME_INDEX, ivar)) - - table_entry = variables(QTY_INDEX, ivar) - call to_upper(table_entry) - - var%qtys(ivar) = get_index_for_quantity(table_entry) - - if(variables(MIN_VAL_INDEX, ivar) /= 'NA') then - read(variables(MIN_VAL_INDEX, ivar), '(d16.8)') var%clamp_values(ivar,1) - else - var%clamp_values(ivar,1) = MISSING_R8 - endif - - if(variables(MAX_VAL_INDEX, ivar) /= 'NA') then - read(variables(MAX_VAL_INDEX, ivar), '(d16.8)') var%clamp_values(ivar,2) - else - var%clamp_values(ivar,2) = MISSING_R8 - endif - - table_entry = variables(UPDATE_INDEX, ivar) - call to_upper(table_entry) - - if(table_entry == 'UPDATE') then - var%updates(ivar) = .true. - else - var%updates(ivar) = .false. - endif - -enddo - -end function assign_var - -!----------------------------------------------------------------------- - subroutine read_template_file() integer :: dimid, varid, number_of_columns From 0cca0661fec9d05e6bef34857f44d122276d1a55 Mon Sep 17 00:00:00 2001 From: Jeff Anderson Date: Fri, 7 Nov 2025 11:57:25 -0700 Subject: [PATCH 07/24] Converted to DART netcdf utilities as much as possible for model_to_dart. --- .../transform_state_mod.f90 | 166 ++++++++---------- 1 file changed, 71 insertions(+), 95 deletions(-) diff --git a/models/aether_cube_sphere/transform_state_mod.f90 b/models/aether_cube_sphere/transform_state_mod.f90 index 3d16064e53..f868ed3a60 100644 --- a/models/aether_cube_sphere/transform_state_mod.f90 +++ b/models/aether_cube_sphere/transform_state_mod.f90 @@ -10,7 +10,13 @@ module transform_state_mod use netcdf use types_mod, only : r4, r8, varnamelength, RAD2DEG use netcdf_utilities_mod, only : nc_open_file_readonly, nc_open_file_readwrite, & - nc_close_file, nc_create_file, nc_end_define_mode + nc_close_file, nc_create_file, nc_end_define_mode, & + nc_add_attribute_to_variable, & + nc_get_attribute_from_variable, & + nc_define_double_scalar, nc_define_double_variable, & + nc_get_variable, nc_put_variable, & + nc_define_dimension, nc_define_unlimited_dimension + use utilities_mod, only : find_namelist_in_file, check_namelist_read, & error_handler, E_ERR, string_to_integer @@ -32,6 +38,9 @@ module transform_state_mod integer :: ncid, unlimitedDimId, nDimensions, nVariables, nAttributes, formatNum end type file_type +! Dimension name strings for dart filter files +character(len=4), parameter :: dart_dimnames(3) = (/"col ", "z ", "time"/) + ! It would be nice to get this information from the Aether input files, not possible for now integer :: np, nblocks, nhalos @@ -60,24 +69,21 @@ subroutine model_to_dart(aether_block_file_dir, dart_file_dir, ensemble_number) character(len=*), intent(in) :: aether_block_file_dir, dart_file_dir integer, intent(in) :: ensemble_number -integer :: iblock, dimid, length, ncols, dart_dimid(3), varid, xtype, nDimensions, nAtts -integer :: param_dimid(2), nparams +integer :: iblock, dimid, length, ncols, varid, xtype, nDimensions, nAtts +integer :: nparams integer :: ix, iy, iz, icol, ncstatus integer :: ntimes(nblocks), nxs(nblocks), nys(nblocks) integer :: ions_ntimes(nblocks), ions_nxs(nblocks), ions_nys(nblocks) integer :: neutrals_ntimes(nblocks), neutrals_nxs(nblocks), neutrals_nys(nblocks) integer :: haloed_nxs(nblocks), haloed_nys(nblocks) integer :: final_nzs, ions_final_nzs, neutrals_final_nzs -integer :: filter_time_id, filter_alt_id, filter_lat_id, filter_lon_id -integer :: grid_alt_id, grid_lat_id, grid_lon_id -integer :: electron_varid, f10_7_varid integer :: dimids(NF90_MAX_VAR_DIMS) real(r8) :: blat, blon, del, half_del, f10_7_val real(r8) :: time_array(1) logical :: add_to_electrons character(len = 4) :: ensemble_string character(len=NF90_MAX_NAME) :: name, attribute -integer, allocatable :: col_index(:, :, :), filter_ions_ids(:), filter_neutrals_ids(:) +integer, allocatable :: col_index(:, :, :) ! File for reading in variables from block file; These can be R4 real(r4), allocatable :: spatial_array(:), variable_array(:, :, :), electron_array(:, :) real(r4), allocatable :: block_array(:, :, :), block_lats(:, :, :), block_lons(:, :, :) @@ -161,54 +167,32 @@ subroutine model_to_dart(aether_block_file_dir, dart_file_dir, ensemble_number) filter_file%ncid = nc_create_file(filter_file%file_path) ! Create dimensions in filter_file; save for use during variable definition -ncstatus = nf90_def_dim(filter_file%ncid, 'time', NF90_UNLIMITED, dart_dimid(3)) -ncstatus = nf90_def_dim(filter_file%ncid, 'z', final_nzs, dart_dimid(2)) -ncstatus = nf90_def_dim(filter_file%ncid, 'col', ncols, dart_dimid(1)) +call nc_define_unlimited_dimension(filter_file%ncid, 'time') +call nc_define_dimension(filter_file%ncid, 'z', final_nzs) +call nc_define_dimension(filter_file%ncid, 'col', ncols) + +! Create the axis variables; time, alt, lat, lon +call nc_define_double_variable(filter_file%ncid, 'time', 'time') +call nc_define_double_variable(filter_file%ncid, 'alt', 'z') +call nc_define_double_variable(filter_file%ncid, 'lat', 'col') +call nc_define_double_variable(filter_file%ncid, 'lon', 'col') + +! Add variable attributes +call nc_add_attribute_to_variable(filter_file%ncid, 'alt', 'units', 'm') +call nc_add_attribute_to_variable(filter_file%ncid, 'alt', 'long_name', 'height above mean sea level') +call nc_add_attribute_to_variable(filter_file%ncid, 'lat', 'units', 'degrees_north') +call nc_add_attribute_to_variable(filter_file%ncid, 'lat', 'long_name', 'latitude') +call nc_add_attribute_to_variable(filter_file%ncid, 'lon', 'units', 'degrees_east') +call nc_add_attribute_to_variable(filter_file%ncid, 'lon', 'long_name', 'longitude') ! Add a parameter axis for F10.7 nparams = 1 -ncstatus = nf90_def_dim(filter_file%ncid, 'param', nparams, param_dimid(1)) -param_dimid(2) = dart_dimid(3) - -!========================================================= -! Create the variables from the grid files; time, alt, lat, lon - -! Loop through the aether grid files to find the three needed fields -do varid = 1, 4 - ncstatus = nf90_inquire_variable(grid_files(1)%ncid, varid, name, xtype, nDimensions, dimids, nAtts) - if (trim(name) == 'time') then - ncstatus = nf90_def_var(filter_file%ncid, name, xtype, dart_dimid(3), filter_time_id) - else if (trim(name) == 'Altitude') then - ! Rename the 'z' variable as 'alt' so there isn't a dimension and a variable with the same name - ncstatus = nf90_def_var(filter_file%ncid, 'alt', xtype, dart_dimid(2), filter_alt_id) - ncstatus = nf90_put_att(filter_file%ncid, filter_alt_id, 'units', 'm') - ncstatus = nf90_put_att(filter_file%ncid, filter_alt_id, 'long_name', & - 'height above mean sea level') - grid_alt_id = varid - else if (trim(name) == 'Latitude') then - ncstatus = nf90_def_var(filter_file%ncid, 'lat', xtype, dart_dimid(1), filter_lat_id) - ncstatus = nf90_put_att(filter_file%ncid, filter_lat_id, 'units', 'degrees_north') - ncstatus = nf90_put_att(filter_file%ncid, filter_lat_id, 'long_name', 'latitude') - grid_lat_id = varid - else if (trim(name) == 'Longitude') then - ncstatus = nf90_def_var(filter_file%ncid, 'lon', xtype, dart_dimid(1), filter_lon_id) - ncstatus = nf90_put_att(filter_file%ncid, filter_lon_id, 'units', 'degrees_east') - ncstatus = nf90_put_att(filter_file%ncid, filter_lon_id, 'long_name', 'longitude') - grid_lon_id = varid - else - call error_handler(E_ERR, 'model_to_dart', & - 'Unexpected variable name in grid file ' // trim(name), source) - end if -end do +call nc_define_dimension(filter_file%ncid, 'param', nparams) !========================================================= ! Allocate storage -! Pointers to the different data fields in the filter nc file -allocate(filter_ions_ids(ions_files(1)%nVariables)) -! Pointers to the different data fields in the filter nc file -allocate(filter_neutrals_ids(neutrals_files(1)%nVariables)) ! Allocate ncols size temporary storage allocate(spatial_array(ncols), variable_array(ncols, final_nzs, 1), electron_array(ncols, final_nzs)) @@ -225,19 +209,15 @@ subroutine model_to_dart(aether_block_file_dir, dart_file_dir, ensemble_number) ! Get the metadata for variable fields from the ions block files ! The ions files have time and all their physical variables, but not latitude, longitude, or altitude -! Illegal value of filter file index for default -filter_ions_ids = -99 - -! The filter_file is still in define mode. Create all of the variables before entering data mode. do varid = 1, ions_files(1)%nVariables + ! I do not know the names and it looks like the nc utilities don't have a way to find those ncstatus = nf90_inquire_variable(ions_files(1)%ncid, varid, name, xtype, nDimensions, dimids, nAtts) ! Find the physcial field if (trim(name) /= 'time') then - ncstatus = nf90_def_var(filter_file%ncid, name, xtype, dart_dimid, filter_ions_ids(varid)) - + call nc_define_double_variable(filter_file%ncid, name, dart_dimnames) ! Add the units, same in all files so just get from the first - ncstatus = nf90_get_att(ions_files(1)%ncid, varid, 'units', attribute) - ncstatus = nf90_put_att(filter_file%ncid, filter_ions_ids(varid), 'units', attribute) + call nc_get_attribute_from_variable(ions_files(1)%ncid, name, 'units', attribute) + call nc_add_attribute_to_variable(filter_file%ncid, name, 'units', attribute) end if end do @@ -246,19 +226,15 @@ subroutine model_to_dart(aether_block_file_dir, dart_file_dir, ensemble_number) ! Get the metadata for variable fields from the neutrals block files ! The neutrals files have time and all their physical variables, but not latitude, longitude, or altitude -! Illegal value of filter file index for default -filter_neutrals_ids = -99 - ! The filter_file is still in define mode. Create all of the variables before entering data mode. do varid = 1, neutrals_files(1)%nVariables ncstatus = nf90_inquire_variable(neutrals_files(1)%ncid, varid, name, xtype, nDimensions, dimids, nAtts) ! Find the physcial fields if (trim(name) /= 'time') then - ncstatus = nf90_def_var(filter_file%ncid, name, xtype, dart_dimid, filter_neutrals_ids(varid)) - + call nc_define_double_variable(filter_file%ncid, name, dart_dimnames) ! Add the units, same in all files so just get from the first - ncstatus = nf90_get_att(neutrals_files(1)%ncid, varid, 'units', attribute) - ncstatus = nf90_put_att(filter_file%ncid, filter_neutrals_ids(varid), 'units', attribute) + call nc_get_attribute_from_variable(neutrals_files(1)%ncid, name, 'units', attribute) + call nc_add_attribute_to_variable(filter_file%ncid, name, 'units', attribute) end if end do @@ -266,21 +242,22 @@ subroutine model_to_dart(aether_block_file_dir, dart_file_dir, ensemble_number) ! Add a derived vertical total electron content field ! xtype is currently set to value of last field from neutrals file -ncstatus = nf90_def_var(filter_file%ncid, 'ION_E', xtype, dart_dimid, electron_varid) -ncstatus = nf90_put_att(filter_file%ncid, electron_varid, 'units', '/m3') +call nc_define_double_variable(filter_file%ncid, 'ION_E', dart_dimnames) +call nc_add_attribute_to_variable(filter_file%ncid, 'ION_E', 'units', '/m3') ! NOTE TO AETHER MODELERS: F10.7 needs to come from one of the restart files if(scalar_f10_7) then ! Add a scalar F10.7 - ncstatus = nf90_def_var(filter_file%ncid, 'SCALAR_F10.7', xtype, param_dimid, f10_7_varid) - ncstatus = nf90_put_att(filter_file%ncid, f10_7_varid, 'units', 'sfu: W/m^2/Hz') - ncstatus = nf90_put_att(filter_file%ncid, f10_7_varid, 'long_name', 'Solar Radio Flux at 10.7 cm') + call nc_define_double_scalar(filter_file%ncid, 'SCALAR_F10.7') + call nc_add_attribute_to_variable(filter_file%ncid, 'SCALAR_F10.7', 'units', 'sfu: W/m^2/Hz') + call nc_add_attribute_to_variable(filter_file%ncid, 'SCALAR_F10.7', 'long_name', & + 'Solar Radio Flux at 10.7 cm') else ! Add a two-dimensional F10.7 - ncstatus = nf90_def_var(filter_file%ncid, '2D_F10.7', xtype, & - dart_dimid(1:3:2), f10_7_varid) - ncstatus = nf90_put_att(filter_file%ncid, f10_7_varid, 'units', 'sfu: W/m^2/Hz') - ncstatus = nf90_put_att(filter_file%ncid, f10_7_varid, 'long_name', 'Solar Radio Flux at 10.7 cm') + call nc_define_double_variable(filter_file%ncid, '2D_F10.7', dart_dimnames(1:3:2)) + call nc_add_attribute_to_variable(filter_file%ncid, '2D_F10.7', 'units', 'sfu: W/m^2/Hz') + call nc_add_attribute_to_variable(filter_file%ncid, '2D_F10.7', 'long_name', & + 'Solar Radio Flux at 10.7 cm') endif ! End of define mode for filter nc file, ready to add data @@ -291,8 +268,8 @@ subroutine model_to_dart(aether_block_file_dir, dart_file_dir, ensemble_number) ! Loop through all the blocks for this variable do iblock = 1, nblocks ! Get the latitude and longitude full arrays - ncstatus = nf90_get_var(grid_files(iblock)%ncid, grid_lat_id, block_lats) - ncstatus = nf90_get_var(grid_files(iblock)%ncid, grid_lon_id, block_lons) + call nc_get_variable(grid_files(iblock)%ncid, 'Latitude', block_lats) + call nc_get_variable(grid_files(iblock)%ncid, 'Longitude', block_lons) ! Compute the col_index for each of the horizontal locations in this block do ix = 1, nxs(iblock) @@ -305,13 +282,13 @@ subroutine model_to_dart(aether_block_file_dir, dart_file_dir, ensemble_number) end do ! Only need altitude from 1 block -ncstatus = nf90_get_var(grid_files(1)%ncid, grid_alt_id, block_array) -ncstatus = nf90_put_var(filter_file%ncid, filter_alt_id, block_array(:,1,1)) +call nc_get_variable(grid_files(1)%ncid, 'Altitude', block_array) +call nc_put_variable(filter_file%ncid, 'alt', block_array(:, 1, 1)) ! Loop through blocks to get lat values do iblock = 1, nblocks ! Get lat values for this block - ncstatus = nf90_get_var(grid_files(iblock)%ncid, grid_lat_id, block_array) + call nc_get_variable(grid_files(iblock)%ncid, 'Latitude', block_array) do iy = 1, nys(iblock) do ix = 1, nxs(iblock) icol = col_index(iblock, iy, ix) @@ -320,12 +297,12 @@ subroutine model_to_dart(aether_block_file_dir, dart_file_dir, ensemble_number) end do end do end do -ncstatus = nf90_put_var(filter_file%ncid, filter_lat_id, spatial_array) +call nc_put_variable(filter_file%ncid, 'lat', spatial_array) ! Loop through blocks to get lon values do iblock = 1, nblocks ! Get lon values for this block - ncstatus = nf90_get_var(grid_files(iblock)%ncid, grid_lon_id, block_array) + call nc_get_variable(grid_files(iblock)%ncid, 'Longitude', block_array) do iy = 1, nys(iblock) do ix = 1, nxs(iblock) icol = col_index(iblock, iy, ix) @@ -334,7 +311,7 @@ subroutine model_to_dart(aether_block_file_dir, dart_file_dir, ensemble_number) end do end do end do -ncstatus = nf90_put_var(filter_file%ncid, filter_lon_id, spatial_array) +call nc_put_variable(filter_file%ncid, 'lon', spatial_array) !=========== Copy data from ions files ================= @@ -347,20 +324,20 @@ subroutine model_to_dart(aether_block_file_dir, dart_file_dir, ensemble_number) ncstatus = nf90_inquire_variable(ions_files(1)%ncid, & varid, name, xtype, nDimensions, dimids, nAtts) - ! NOTE TO AETHER MODELERS: Make sure this is the correct way to get total - ! See if this is a density; if so, needs to be added into electrons - ncstatus = nf90_get_att(ions_files(1)%ncid, varid, 'units', attribute) - add_to_electrons = trim(attribute) == '/m3' - if(trim(name) == 'time') then ! Time must be the same in all files, so just deal with it from the first one - ncstatus = nf90_get_var(ions_files(1)%ncid, varid, time_array) - ncstatus = nf90_put_var(filter_file%ncid, filter_time_id, time_array) + call nc_get_variable(ions_files(1)%ncid, 'time', time_array) + call nc_put_variable(filter_file%ncid, 'time', time_array) else + ! NOTE TO AETHER MODELERS: Make sure this is the correct way to get total + ! See if this is a density; if so, needs to be added into electrons + call nc_get_attribute_from_variable(ions_files(1)%ncid, name, 'units', attribute) + add_to_electrons = trim(attribute) == '/m3' + ! Loop through all the blocks for this variable do iblock = 1, nblocks ! Read into the full 3Dblock array - ncstatus = nf90_get_var(ions_files(iblock)%ncid, varid, block_array) + call nc_get_variable(ions_files(iblock)%ncid, name, block_array) ! Transfer data to columns array do iy = 1, nys(iblock) @@ -376,7 +353,7 @@ subroutine model_to_dart(aether_block_file_dir, dart_file_dir, ensemble_number) end do end do - ncstatus = nf90_put_var(filter_file%ncid, filter_ions_ids(varid), variable_array) + call nc_put_variable(filter_file%ncid, name, variable_array) end if end do @@ -394,7 +371,7 @@ subroutine model_to_dart(aether_block_file_dir, dart_file_dir, ensemble_number) ! Loop through all the blocks for this variable do iblock = 1, nblocks ! Read into the full 3Dblock array - ncstatus = nf90_get_var(neutrals_files(iblock)%ncid, varid, block_array) + call nc_get_variable(neutrals_files(iblock)%ncid, name, block_array) do iy = 1, nys(iblock) do ix = 1, nxs(iblock) @@ -406,24 +383,23 @@ subroutine model_to_dart(aether_block_file_dir, dart_file_dir, ensemble_number) end do end do - ncstatus = nf90_put_var(filter_file%ncid, filter_neutrals_ids(varid), variable_array) + call nc_put_variable(filter_file%ncid, name, variable_array) end if end do !===================== Add in the additional variables ================== ! Write out the electron density field -variable_array(:, :, 1) = electron_array -ncstatus = nf90_put_var(filter_file%ncid, electron_varid, variable_array) +call nc_put_variable(filter_file%ncid, 'ION_E', electron_array) if(scalar_f10_7) then ! Add in f10.7 as a zero_dimensional field - ncstatus = nf90_put_var(filter_file%ncid, f10_7_varid, 1.0_r8 * ensemble_number) + call nc_put_variable(filter_file%ncid, 'SCALAR_F10.7', 1.0_r8 * ensemble_number) else ! Add in f10.7 as a two-dimensional field f10_7_val = 1.0_r8 * ensemble_number variable_array(:, 1, 1) = f10_7_val - ncstatus = nf90_put_var(filter_file%ncid, f10_7_varid, variable_array(:, 1, 1)) + call nc_put_variable(filter_file%ncid, '2D_F10.7', variable_array(:, 1, 1)) endif !=============================================================== @@ -438,7 +414,7 @@ subroutine model_to_dart(aether_block_file_dir, dart_file_dir, ensemble_number) end do deallocate(block_lats, block_lons, block_array, spatial_array, variable_array) -deallocate(electron_array, col_index, filter_ions_ids, filter_neutrals_ids) +deallocate(electron_array, col_index) end subroutine model_to_dart From 5b4e24d5ef07df841a3f1cc6accf110462183f36 Mon Sep 17 00:00:00 2001 From: Jeff Anderson Date: Mon, 10 Nov 2025 08:43:40 -0700 Subject: [PATCH 08/24] Converted dart_to_model to use as many routines from the netcdf_utilities_mod as possible. Tests show that this bitwise duplicates the results from the old aether_michigan branch in the final Aether ions/neutrals file space. The filter_input and filter_output files are not bitwise because they now use double variables and the order of various fields has been changed. --- .../transform_state_mod.f90 | 69 +++++++++---------- 1 file changed, 34 insertions(+), 35 deletions(-) diff --git a/models/aether_cube_sphere/transform_state_mod.f90 b/models/aether_cube_sphere/transform_state_mod.f90 index f868ed3a60..ae3f79c13d 100644 --- a/models/aether_cube_sphere/transform_state_mod.f90 +++ b/models/aether_cube_sphere/transform_state_mod.f90 @@ -7,8 +7,8 @@ module transform_state_mod -use netcdf use types_mod, only : r4, r8, varnamelength, RAD2DEG + use netcdf_utilities_mod, only : nc_open_file_readonly, nc_open_file_readwrite, & nc_close_file, nc_create_file, nc_end_define_mode, & nc_add_attribute_to_variable, & @@ -17,8 +17,13 @@ module transform_state_mod nc_get_variable, nc_put_variable, & nc_define_dimension, nc_define_unlimited_dimension +use netcdf, only : NF90_MAX_VAR_DIMS, NF90_MAX_NAME, nf90_noerr, & + nf90_inquire_variable, nf90_inquire, & + nf90_inq_varid, nf90_inq_dimid, & + nf90_inquire_dimension + use utilities_mod, only : find_namelist_in_file, check_namelist_read, & - error_handler, E_ERR, string_to_integer + error_handler, E_ERR use cube_sphere_grid_tools_mod, only : lat_lon_to_col_index, get_grid_delta @@ -69,7 +74,7 @@ subroutine model_to_dart(aether_block_file_dir, dart_file_dir, ensemble_number) character(len=*), intent(in) :: aether_block_file_dir, dart_file_dir integer, intent(in) :: ensemble_number -integer :: iblock, dimid, length, ncols, varid, xtype, nDimensions, nAtts +integer :: iblock, length, ncols, varid, xtype, nDimensions, nAtts integer :: nparams integer :: ix, iy, iz, icol, ncstatus integer :: ntimes(nblocks), nxs(nblocks), nys(nblocks) @@ -213,7 +218,7 @@ subroutine model_to_dart(aether_block_file_dir, dart_file_dir, ensemble_number) ! I do not know the names and it looks like the nc utilities don't have a way to find those ncstatus = nf90_inquire_variable(ions_files(1)%ncid, varid, name, xtype, nDimensions, dimids, nAtts) ! Find the physcial field - if (trim(name) /= 'time') then + if (name /= 'time') then call nc_define_double_variable(filter_file%ncid, name, dart_dimnames) ! Add the units, same in all files so just get from the first call nc_get_attribute_from_variable(ions_files(1)%ncid, name, 'units', attribute) @@ -230,7 +235,7 @@ subroutine model_to_dart(aether_block_file_dir, dart_file_dir, ensemble_number) do varid = 1, neutrals_files(1)%nVariables ncstatus = nf90_inquire_variable(neutrals_files(1)%ncid, varid, name, xtype, nDimensions, dimids, nAtts) ! Find the physcial fields - if (trim(name) /= 'time') then + if (name /= 'time') then call nc_define_double_variable(filter_file%ncid, name, dart_dimnames) ! Add the units, same in all files so just get from the first call nc_get_attribute_from_variable(neutrals_files(1)%ncid, name, 'units', attribute) @@ -324,7 +329,7 @@ subroutine model_to_dart(aether_block_file_dir, dart_file_dir, ensemble_number) ncstatus = nf90_inquire_variable(ions_files(1)%ncid, & varid, name, xtype, nDimensions, dimids, nAtts) - if(trim(name) == 'time') then + if(name == 'time') then ! Time must be the same in all files, so just deal with it from the first one call nc_get_variable(ions_files(1)%ncid, 'time', time_array) call nc_put_variable(filter_file%ncid, 'time', time_array) @@ -332,7 +337,7 @@ subroutine model_to_dart(aether_block_file_dir, dart_file_dir, ensemble_number) ! NOTE TO AETHER MODELERS: Make sure this is the correct way to get total ! See if this is a density; if so, needs to be added into electrons call nc_get_attribute_from_variable(ions_files(1)%ncid, name, 'units', attribute) - add_to_electrons = trim(attribute) == '/m3' + add_to_electrons = attribute == '/m3' ! Loop through all the blocks for this variable do iblock = 1, nblocks @@ -367,7 +372,7 @@ subroutine model_to_dart(aether_block_file_dir, dart_file_dir, ensemble_number) varid, name, xtype, nDimensions, dimids, nAtts) ! Already got time from ions files - if(trim(name) /= 'time') then + if(name /= 'time') then ! Loop through all the blocks for this variable do iblock = 1, nblocks ! Read into the full 3Dblock array @@ -426,13 +431,12 @@ subroutine dart_to_model(dart_file_dir, aether_block_file_dir, ensemble_number) integer, intent(in) :: ensemble_number real(r8) :: blat, blon, del, half_del, f10_7_scalar -integer :: iblock, dimid, length, ncols, varid, xtype, nDimensions, nAtts +integer :: iblock, length, ncols, varid, xtype, nDimensions, nAtts integer :: ix, iy, iz, icol, ncstatus, filter_varid integer :: nxs(nblocks), nys(nblocks), final_nzs integer :: ions_nxs(nblocks), ions_nys(nblocks), ions_final_nzs integer :: neutrals_nxs(nblocks), neutrals_nys(nblocks), neutrals_final_nzs integer :: haloed_nxs(nblocks), haloed_nys(nblocks) -integer :: grid_alt_id, grid_lat_id, grid_lon_id integer :: dimids(NF90_MAX_VAR_DIMS) character(len = 4) :: ensemble_string character(len=NF90_MAX_NAME) :: name, attribute @@ -511,11 +515,6 @@ subroutine dart_to_model(dart_file_dir, aether_block_file_dir, ensemble_number) !=========== Get alt lat and lon from grid files ================= -! Find the latitude and longitude information from the grid files and get the column mapping -ncstatus = nf90_inq_varid(grid_files(1)%ncid, 'Altitude', grid_alt_id) -ncstatus = nf90_inq_varid(grid_files(1)%ncid, 'Latitude', grid_lat_id) -ncstatus = nf90_inq_varid(grid_files(1)%ncid, 'Longitude', grid_lon_id) - ! Allocate storage for the latitude and longitude from the blocks allocate(col_index(nblocks, maxval(nys), maxval(nxs)), & variable_array(ncols, final_nzs, 1), & @@ -526,8 +525,8 @@ subroutine dart_to_model(dart_file_dir, aether_block_file_dir, ensemble_number) ! Loop through all the blocks do iblock = 1, nblocks ! Get the latitude and longitude full arrays - ncstatus = nf90_get_var(grid_files(iblock)%ncid, grid_lat_id, block_lats) - ncstatus = nf90_get_var(grid_files(iblock)%ncid, grid_lon_id, block_lons) + call nc_get_variable(grid_files(iblock)%ncid, 'Latitude', block_lats) + call nc_get_variable(grid_files(iblock)%ncid, 'Longitude', block_lons) ! Compute the col_index for each of the horizontal locations in this block do ix = 1, nxs(iblock) @@ -551,6 +550,7 @@ subroutine dart_to_model(dart_file_dir, aether_block_file_dir, ensemble_number) ! Note that this preserves all fields in the ions and neutrals files that ! were not part of the DART state +! Get number of variables in the ions files ncstatus = nf90_inquire(ions_files(1)%ncid, ions_files(1)%nDimensions, & ions_files(1)%nVariables, ions_files(1)%nAttributes, ions_files(1)%unlimitedDimId, & ions_files(1)%formatNum) @@ -560,16 +560,16 @@ subroutine dart_to_model(dart_file_dir, aether_block_file_dir, ensemble_number) ! Get metadata for this variable from first block file ncstatus = nf90_inquire_variable(ions_files(1)%ncid, & varid, name, xtype, nDimensions, dimids, nAtts) - if(trim(name) /= 'time' .and. trim(name) /= 'Altitude' .and. trim(name) /= 'Latitude' & - .and. trim(name) /= 'Longitude') then + if(name /= 'time' .and. name /= 'Altitude' .and. name /= 'Latitude' & + .and. name /= 'Longitude') then ! See if this variable is also in the filter output file - ncstatus = nf90_inq_varid(filter_file%ncid, trim(name), filter_varid) - ! Check on failed ncstatus. 0 is successful but should use the proper name - if(ncstatus == 0) then + ncstatus = nf90_inq_varid(filter_file%ncid, name, filter_varid) + ! Check for successful return status + if(ncstatus == nf90_noerr) then ! Read this field from filter file - ncstatus = nf90_get_var(filter_file%ncid, filter_varid, variable_array) + call nc_get_variable(filter_file%ncid, name, variable_array) -! CAN WE UPDATE THE HALOS TOO WHEN WRITING BACK??? +! WE COULD UPDATE THE HALOS TOO WHEN WRITING BACK ! Loop through all the blocks for this variable block_array = 0.0_r8 do iblock = 1, nblocks @@ -582,7 +582,7 @@ subroutine dart_to_model(dart_file_dir, aether_block_file_dir, ensemble_number) end do end do ! Write into the full file for this block - ncstatus = nf90_put_var(ions_files(iblock)%ncid, varid, block_array) + call nc_put_variable(ions_files(iblock)%ncid, name, block_array) end do endif end if @@ -600,14 +600,14 @@ subroutine dart_to_model(dart_file_dir, aether_block_file_dir, ensemble_number) ! Get metadata for this variable from first block file ncstatus = nf90_inquire_variable(neutrals_files(1)%ncid, & varid, name, xtype, nDimensions, dimids, nAtts) - if(trim(name) /= 'time' .and. trim(name) /= 'Altitude' .and. trim(name) /= 'Latitude' & - .and. trim(name) /= 'Longitude') then + if(name /= 'time' .and. name /= 'Altitude' .and. name /= 'Latitude' & + .and. name /= 'Longitude') then ! See if this variable is also in the filter output file - ncstatus = nf90_inq_varid(filter_file%ncid, trim(name), filter_varid) - ! Check on failed ncstatus. 0 is successful but should use the proper name - if(ncstatus == 0) then + ncstatus = nf90_inq_varid(filter_file%ncid, name, filter_varid) + ! Check for successful return status + if(ncstatus == nf90_noerr) then ! Read this field from filter file - ncstatus = nf90_get_var(filter_file%ncid, filter_varid, variable_array) + call nc_get_variable(filter_file%ncid, name, variable_array) ! Loop through all the blocks for this variable block_array = 0.0_r8 @@ -621,7 +621,7 @@ subroutine dart_to_model(dart_file_dir, aether_block_file_dir, ensemble_number) end do end do ! Write into the full file for this block - ncstatus = nf90_put_var(neutrals_files(iblock)%ncid, varid, block_array) + call nc_put_variable(neutrals_files(iblock)%ncid, name, block_array) end do endif end if @@ -631,13 +631,12 @@ subroutine dart_to_model(dart_file_dir, aether_block_file_dir, ensemble_number) ! NOTE FOR AETHER MODELERS: ! Need more information about where F10.7 will be in Aether input files to complete copy back -ncstatus = nf90_inq_varid(filter_file%ncid, 'F10.7', filter_varid) if(scalar_f10_7) then ! Read a scalar f10_7 value - ncstatus = nf90_get_var(filter_file%ncid, filter_varid, f10_7_scalar) + call nc_get_variable(filter_file%ncid, 'F10.7', f10_7_scalar) else ! Read a column sized f10_7 value - ncstatus = nf90_get_var(filter_file%ncid, filter_varid, variable_array(:, 1, 1)) + call nc_get_variable(filter_file%ncid, '2D_F10.7', variable_array(:, 1, 1)) ! Average the updated value over all the columns f10_7_scalar = sum(variable_array(:, 1, 1)) / ncols endif From 2539d43f87a2a6619b876cd72f5807dddf72cc6e Mon Sep 17 00:00:00 2001 From: Jeff Anderson Date: Mon, 10 Nov 2025 08:58:45 -0700 Subject: [PATCH 09/24] Made all variables that go in filter files R8 instead of R4. Since we don't know much about roundoff sensitivity for Aether at this point, this made sense as a scientific precaution. If file size became an issue, this could be changed back. There are now a handful of last bit differences in the final aether ions and neutrals files. --- models/aether_cube_sphere/transform_state_mod.f90 | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/models/aether_cube_sphere/transform_state_mod.f90 b/models/aether_cube_sphere/transform_state_mod.f90 index ae3f79c13d..6b03d4a921 100644 --- a/models/aether_cube_sphere/transform_state_mod.f90 +++ b/models/aether_cube_sphere/transform_state_mod.f90 @@ -7,7 +7,7 @@ module transform_state_mod -use types_mod, only : r4, r8, varnamelength, RAD2DEG +use types_mod, only : r8, varnamelength, RAD2DEG use netcdf_utilities_mod, only : nc_open_file_readonly, nc_open_file_readwrite, & nc_close_file, nc_create_file, nc_end_define_mode, & @@ -89,9 +89,9 @@ subroutine model_to_dart(aether_block_file_dir, dart_file_dir, ensemble_number) character(len = 4) :: ensemble_string character(len=NF90_MAX_NAME) :: name, attribute integer, allocatable :: col_index(:, :, :) -! File for reading in variables from block file; These can be R4 -real(r4), allocatable :: spatial_array(:), variable_array(:, :, :), electron_array(:, :) -real(r4), allocatable :: block_array(:, :, :), block_lats(:, :, :), block_lons(:, :, :) +! File for reading in variables from block file +real(r8), allocatable :: spatial_array(:), variable_array(:, :, :), electron_array(:, :) +real(r8), allocatable :: block_array(:, :, :), block_lats(:, :, :), block_lons(:, :, :) type(file_type), allocatable :: ions_files(:), neutrals_files(:), grid_files(:) type(file_type) :: filter_file @@ -441,9 +441,9 @@ subroutine dart_to_model(dart_file_dir, aether_block_file_dir, ensemble_number) character(len = 4) :: ensemble_string character(len=NF90_MAX_NAME) :: name, attribute integer, allocatable :: col_index(:, :, :) -! File for reading in variables from block file; These can be R4 -real(r4), allocatable :: variable_array(:, :, :) -real(r4), allocatable :: block_array(:, :, :), block_lats(:, :, :), block_lons(:, :, :) +! File for reading in variables from block file +real(r8), allocatable :: variable_array(:, :, :) +real(r8), allocatable :: block_array(:, :, :), block_lats(:, :, :), block_lons(:, :, :) type(file_type), allocatable :: ions_files(:), neutrals_files(:), grid_files(:) type(file_type) :: filter_file From 5de7b9b0409970d6366067e2ffed3aa7a124f46c Mon Sep 17 00:00:00 2001 From: Jeff Anderson Date: Mon, 10 Nov 2025 09:34:06 -0700 Subject: [PATCH 10/24] Added error checks for all nf90_ netcdf calls. --- .../transform_state_mod.f90 | 27 ++++++++++++++----- 1 file changed, 20 insertions(+), 7 deletions(-) diff --git a/models/aether_cube_sphere/transform_state_mod.f90 b/models/aether_cube_sphere/transform_state_mod.f90 index 6b03d4a921..d8e3481741 100644 --- a/models/aether_cube_sphere/transform_state_mod.f90 +++ b/models/aether_cube_sphere/transform_state_mod.f90 @@ -9,17 +9,17 @@ module transform_state_mod use types_mod, only : r8, varnamelength, RAD2DEG -use netcdf_utilities_mod, only : nc_open_file_readonly, nc_open_file_readwrite, & - nc_close_file, nc_create_file, nc_end_define_mode, & - nc_add_attribute_to_variable, & - nc_get_attribute_from_variable, & +use netcdf_utilities_mod, only : nc_open_file_readonly, nc_open_file_readwrite, & + nc_close_file, nc_create_file, nc_end_define_mode, & + nc_add_attribute_to_variable, nc_check, & + nc_get_attribute_from_variable, & nc_define_double_scalar, nc_define_double_variable, & - nc_get_variable, nc_put_variable, & + nc_get_variable, nc_put_variable, & nc_define_dimension, nc_define_unlimited_dimension use netcdf, only : NF90_MAX_VAR_DIMS, NF90_MAX_NAME, nf90_noerr, & - nf90_inquire_variable, nf90_inquire, & - nf90_inq_varid, nf90_inq_dimid, & + nf90_inquire_variable, nf90_inquire, & + nf90_inq_varid, nf90_inq_dimid, & nf90_inquire_dimension use utilities_mod, only : find_namelist_in_file, check_namelist_read, & @@ -217,6 +217,7 @@ subroutine model_to_dart(aether_block_file_dir, dart_file_dir, ensemble_number) do varid = 1, ions_files(1)%nVariables ! I do not know the names and it looks like the nc utilities don't have a way to find those ncstatus = nf90_inquire_variable(ions_files(1)%ncid, varid, name, xtype, nDimensions, dimids, nAtts) + call nc_check(ncstatus, 'model_to_dart', 'nf90_inquire for ions files') ! Find the physcial field if (name /= 'time') then call nc_define_double_variable(filter_file%ncid, name, dart_dimnames) @@ -234,6 +235,7 @@ subroutine model_to_dart(aether_block_file_dir, dart_file_dir, ensemble_number) ! The filter_file is still in define mode. Create all of the variables before entering data mode. do varid = 1, neutrals_files(1)%nVariables ncstatus = nf90_inquire_variable(neutrals_files(1)%ncid, varid, name, xtype, nDimensions, dimids, nAtts) + call nc_check(ncstatus, 'model_to_dart', 'nf90_inquire for neutrals files') ! Find the physcial fields if (name /= 'time') then call nc_define_double_variable(filter_file%ncid, name, dart_dimnames) @@ -328,6 +330,7 @@ subroutine model_to_dart(aether_block_file_dir, dart_file_dir, ensemble_number) ! Get metadata for this variable from first block file ncstatus = nf90_inquire_variable(ions_files(1)%ncid, & varid, name, xtype, nDimensions, dimids, nAtts) + call nc_check(ncstatus, 'model_to_dart', 'nf90_inquire_variable for ions files') if(name == 'time') then ! Time must be the same in all files, so just deal with it from the first one @@ -370,6 +373,7 @@ subroutine model_to_dart(aether_block_file_dir, dart_file_dir, ensemble_number) ! Get metadata for this variable from first block file ncstatus = nf90_inquire_variable(neutrals_files(1)%ncid, & varid, name, xtype, nDimensions, dimids, nAtts) + call nc_check(ncstatus, 'model_to_dart', 'nf90_inquire_variable for neutrals files') ! Already got time from ions files if(name /= 'time') then @@ -554,12 +558,14 @@ subroutine dart_to_model(dart_file_dir, aether_block_file_dir, ensemble_number) ncstatus = nf90_inquire(ions_files(1)%ncid, ions_files(1)%nDimensions, & ions_files(1)%nVariables, ions_files(1)%nAttributes, ions_files(1)%unlimitedDimId, & ions_files(1)%formatNum) +call nc_check(ncstatus, 'dart_to_model', 'nf90_inquire for ions files') ! Get full spatial field for one variable at a time do varid = 1, ions_files(1)%nVariables ! Get metadata for this variable from first block file ncstatus = nf90_inquire_variable(ions_files(1)%ncid, & varid, name, xtype, nDimensions, dimids, nAtts) + call nc_check(ncstatus, 'dart_to_model', 'nf90_inquire_variable for ions files') if(name /= 'time' .and. name /= 'Altitude' .and. name /= 'Latitude' & .and. name /= 'Longitude') then ! See if this variable is also in the filter output file @@ -594,12 +600,14 @@ subroutine dart_to_model(dart_file_dir, aether_block_file_dir, ensemble_number) ncstatus = nf90_inquire(neutrals_files(1)%ncid, neutrals_files(1)%nDimensions, & neutrals_files(1)%nVariables, neutrals_files(1)%nAttributes, neutrals_files(1)%unlimitedDimId, & neutrals_files(1)%formatNum) + call nc_check(ncstatus, 'dart_to_model', 'nf90_inquire for neutrals files') ! Get full spatial field for one variable at a time do varid = 1, neutrals_files(1)%nVariables ! Get metadata for this variable from first block file ncstatus = nf90_inquire_variable(neutrals_files(1)%ncid, & varid, name, xtype, nDimensions, dimids, nAtts) + call nc_check(ncstatus, 'dart_to_model', 'nf90_inquire_variable for neutrals files') if(name /= 'time' .and. name /= 'Altitude' .and. name /= 'Latitude' & .and. name /= 'Longitude') then ! See if this variable is also in the filter output file @@ -678,9 +686,11 @@ subroutine get_aether_block_dimensions(files, nblocks, nhalos, nxs, nys, nzs) ncstatus = nf90_inquire(files(iblock)%ncid, files(iblock)%nDimensions, & files(iblock)%nVariables, files(iblock)%nAttributes, & files(iblock)%unlimitedDimId, files(iblock)%formatNum) + call nc_check(ncstatus, 'get_aether_block_dimensions', 'nf90_inquire') ! Verify that a single time level exists ncstatus = nf90_inq_dimid(files(iblock)%ncid, 'time', dimid) + call nc_check(ncstatus, 'get_aether_block_dimensions', 'nf90_inq_dimid') ncstatus = nf90_inquire_dimension(files(iblock)%ncid, dimid, name, length) if(length /= 1 .or. ncstatus /= 0) & call error_handler(E_ERR, 'get_aether_block_dimensions', & @@ -688,6 +698,7 @@ subroutine get_aether_block_dimensions(files, nblocks, nhalos, nxs, nys, nzs) ! Get the length of x dimension ncstatus = nf90_inq_dimid(files(iblock)%ncid, 'x', dimid) + call nc_check(ncstatus, 'get_aether_block_dimensions', 'nf90_inq_dimid') ncstatus = nf90_inquire_dimension(files(iblock)%ncid, dimid, name, length) if(ncstatus /= 0) & call error_handler(E_ERR, 'get_aether_block_dimensions', & @@ -696,6 +707,7 @@ subroutine get_aether_block_dimensions(files, nblocks, nhalos, nxs, nys, nzs) ! Get the length of y dimension ncstatus = nf90_inq_dimid(files(iblock)%ncid, 'y', dimid) + call nc_check(ncstatus, 'get_aether_block_dimensions', 'nf90_inq_dimid') ncstatus = nf90_inquire_dimension(files(iblock)%ncid, dimid, name, length) if(ncstatus /= 0) & call error_handler(E_ERR, 'get_aether_block_dimensions', & @@ -704,6 +716,7 @@ subroutine get_aether_block_dimensions(files, nblocks, nhalos, nxs, nys, nzs) ! Get the length of z dimension ncstatus = nf90_inq_dimid(files(iblock)%ncid, 'z', dimid) + call nc_check(ncstatus, 'get_aether_block_dimensions', 'nf90_inq_dimid') ncstatus = nf90_inquire_dimension(files(iblock)%ncid, dimid, name, length) if(ncstatus /= 0) & call error_handler(E_ERR, 'get_aether_block_dimensions', & From a9dc59137ef3d6149956c163c688d05b8bb4f091 Mon Sep 17 00:00:00 2001 From: Jeff Anderson Date: Mon, 10 Nov 2025 11:29:38 -0700 Subject: [PATCH 11/24] Removed use of unneeded type for reading in the template file and changed to more direct netcdf_utilities calls for that read. --- models/aether_cube_sphere/model_mod.f90 | 32 ++++++++----------------- 1 file changed, 10 insertions(+), 22 deletions(-) diff --git a/models/aether_cube_sphere/model_mod.f90 b/models/aether_cube_sphere/model_mod.f90 index a755e3f472..6e9ae949cb 100644 --- a/models/aether_cube_sphere/model_mod.f90 +++ b/models/aether_cube_sphere/model_mod.f90 @@ -28,7 +28,8 @@ module model_mod use netcdf_utilities_mod, only : nc_add_global_attribute, nc_synchronize_file, & nc_add_global_creation_time, nc_begin_define_mode, & - nc_end_define_mode, nc_open_file_readonly, nc_close_file + nc_end_define_mode, nc_open_file_readonly, nc_close_file, & + nc_get_dimension_size, nc_get_variable use distributed_state_mod, only : get_state @@ -106,13 +107,6 @@ module model_mod ! Horizontal column dimension rather than being direct functions of latitude and longitude. integer :: no_third_dimension = -99 -! This is redundant with type defined in transform_state_mod -type :: file_type - character(len=256) :: file_path - integer :: ncid, ncstatus, unlimitedDimId - integer :: nDimensions, nVariables, nAttributes, formatNum -end type file_type - ! Namelist for options to be set at runtime. character(len=256) :: template_file = 'filter_input_0001.nc' integer :: time_step_days = 0 @@ -445,32 +439,26 @@ end subroutine nc_write_model_atts subroutine read_template_file() -integer :: dimid, varid, number_of_columns -character(len=256) :: name -type(file_type) :: templatefile +integer :: dimid, varid, number_of_columns, ncid, ncstatus +character(len=256) :: name, file_path ! Gets altitudes and number of points per face row from an Aether template file -templatefile%file_path = trim(template_file) -templatefile%ncid = nc_open_file_readonly(templatefile%file_path) +file_path = trim(template_file) +ncid = nc_open_file_readonly(file_path) ! Get the number of vertical levels -templatefile%ncstatus = nf90_inq_dimid(templatefile%ncid, 'z', dimid) -templatefile%ncstatus = nf90_inquire_dimension(templatefile%ncid, dimid, & - name, ncenter_altitudes) +ncenter_altitudes = nc_get_dimension_size(ncid, 'z') ! Allocate space for vertical levels allocate(center_altitude(ncenter_altitudes)) ! Get the vertical levels -templatefile%ncstatus = nf90_inq_varid(templatefile%ncid, 'alt', varid) -templatefile%ncstatus = nf90_get_var(templatefile%ncid, varid, center_altitude) +call nc_get_variable(ncid, 'alt', center_altitude) ! Get the number of columns -templatefile%ncstatus = nf90_inq_dimid(templatefile%ncid, 'col', dimid) -templatefile%ncstatus = nf90_inquire_dimension(templatefile%ncid, dimid, & - name, number_of_columns) +number_of_columns = nc_get_dimension_size(ncid, 'col') -call nc_close_file(templatefile%ncid) +call nc_close_file(ncid) ! Compute the number of grid rows across a face np = nint(sqrt(number_of_columns / 6.0_r8)) From 35243edda6b63350523bd35a61d3cc76c00dbdbe Mon Sep 17 00:00:00 2001 From: Jeff Anderson Date: Mon, 10 Nov 2025 14:00:04 -0700 Subject: [PATCH 12/24] Simplified file_type definition to remove unneeded fields. --- .../transform_state_mod.f90 | 20 ++++++++++--------- 1 file changed, 11 insertions(+), 9 deletions(-) diff --git a/models/aether_cube_sphere/transform_state_mod.f90 b/models/aether_cube_sphere/transform_state_mod.f90 index d8e3481741..95ff290738 100644 --- a/models/aether_cube_sphere/transform_state_mod.f90 +++ b/models/aether_cube_sphere/transform_state_mod.f90 @@ -40,7 +40,7 @@ module transform_state_mod type :: file_type character(len=256) :: file_path - integer :: ncid, unlimitedDimId, nDimensions, nVariables, nAttributes, formatNum + integer :: ncid, nVariables, nAttributes end type file_type ! Dimension name strings for dart filter files @@ -442,6 +442,7 @@ subroutine dart_to_model(dart_file_dir, aether_block_file_dir, ensemble_number) integer :: neutrals_nxs(nblocks), neutrals_nys(nblocks), neutrals_final_nzs integer :: haloed_nxs(nblocks), haloed_nys(nblocks) integer :: dimids(NF90_MAX_VAR_DIMS) +integer :: temp_nDimensions, temp_unlimitedDimId, temp_formatNum character(len = 4) :: ensemble_string character(len=NF90_MAX_NAME) :: name, attribute integer, allocatable :: col_index(:, :, :) @@ -555,9 +556,9 @@ subroutine dart_to_model(dart_file_dir, aether_block_file_dir, ensemble_number) ! were not part of the DART state ! Get number of variables in the ions files -ncstatus = nf90_inquire(ions_files(1)%ncid, ions_files(1)%nDimensions, & - ions_files(1)%nVariables, ions_files(1)%nAttributes, ions_files(1)%unlimitedDimId, & - ions_files(1)%formatNum) +ncstatus = nf90_inquire(ions_files(1)%ncid, temp_nDimensions, & + ions_files(1)%nVariables, ions_files(1)%nAttributes, temp_unlimitedDimId, & + temp_formatNum) call nc_check(ncstatus, 'dart_to_model', 'nf90_inquire for ions files') ! Get full spatial field for one variable at a time @@ -597,9 +598,9 @@ subroutine dart_to_model(dart_file_dir, aether_block_file_dir, ensemble_number) !========================================================================== ! Loop through neutrals fields and replace with values from filter -ncstatus = nf90_inquire(neutrals_files(1)%ncid, neutrals_files(1)%nDimensions, & - neutrals_files(1)%nVariables, neutrals_files(1)%nAttributes, neutrals_files(1)%unlimitedDimId, & - neutrals_files(1)%formatNum) +ncstatus = nf90_inquire(neutrals_files(1)%ncid, temp_nDimensions, & + neutrals_files(1)%nVariables, neutrals_files(1)%nAttributes, temp_unlimitedDimId, & + temp_formatNum) call nc_check(ncstatus, 'dart_to_model', 'nf90_inquire for neutrals files') ! Get full spatial field for one variable at a time @@ -678,14 +679,15 @@ subroutine get_aether_block_dimensions(files, nblocks, nhalos, nxs, nys, nzs) integer, intent(out) :: nxs(nblocks), nys(nblocks), nzs integer :: iblock, b_nzs(nblocks), ncstatus, dimid, length +integer :: temp_nDimensions, temp_unlimitedDimID, temp_formatNum character(len=NF90_MAX_NAME) :: name ! Look at each block do iblock = 1, nblocks ! Get info about the block file - ncstatus = nf90_inquire(files(iblock)%ncid, files(iblock)%nDimensions, & + ncstatus = nf90_inquire(files(iblock)%ncid, temp_nDimensions, & files(iblock)%nVariables, files(iblock)%nAttributes, & - files(iblock)%unlimitedDimId, files(iblock)%formatNum) + temp_unlimitedDimId, temp_formatNum) call nc_check(ncstatus, 'get_aether_block_dimensions', 'nf90_inquire') ! Verify that a single time level exists From 3894555167d89430a2001a5eba3f13878610d104 Mon Sep 17 00:00:00 2001 From: Jeff Anderson Date: Mon, 10 Nov 2025 14:19:05 -0700 Subject: [PATCH 13/24] Removing publics that are not used remotely. --- models/utilities/quad_utils_mod.f90 | 6 +----- 1 file changed, 1 insertion(+), 5 deletions(-) diff --git a/models/utilities/quad_utils_mod.f90 b/models/utilities/quad_utils_mod.f90 index d7173aeb33..6b06384bc2 100644 --- a/models/utilities/quad_utils_mod.f90 +++ b/models/utilities/quad_utils_mod.f90 @@ -77,11 +77,7 @@ module quad_utils_mod QUAD_LOCATED_LAT_EDGES, & QUAD_LOCATED_CELL_CORNERS, & get_quad_grid_size, & - get_quad_global, & - print_quad_handle, & ! debug - in_quad, & - quad_bilinear_interp, & - line_intercept + get_quad_global ! version controlled file description for error handling, do not edit From ec86b80f1fb01423921bf696e58818ffda22ac53 Mon Sep 17 00:00:00 2001 From: Jeff Anderson Date: Mon, 10 Nov 2025 14:22:21 -0700 Subject: [PATCH 14/24] Removing legacy regional namelist entries for obs_diag. --- models/aether_cube_sphere/work/input.nml | 4 ---- 1 file changed, 4 deletions(-) diff --git a/models/aether_cube_sphere/work/input.nml b/models/aether_cube_sphere/work/input.nml index c423e872f7..4a14342d0d 100644 --- a/models/aether_cube_sphere/work/input.nml +++ b/models/aether_cube_sphere/work/input.nml @@ -185,11 +185,7 @@ bin_width_seconds = -1, init_skip_days = 0, init_skip_seconds = 0, - Nregions = 3, trusted_obs = 'null', - lonlim1 = 0.00, 0.00, 0.50 - lonlim2 = 1.01, 0.50, 1.01 - reg_names = 'whole', 'yin', 'yang' create_rank_histogram = .true., outliers_in_histogram = .true., use_zero_error_obs = .false., From 7feff8ee896f6ed87ad92d7d031b09783a85adde Mon Sep 17 00:00:00 2001 From: Jeff Anderson Date: Mon, 10 Nov 2025 15:08:29 -0700 Subject: [PATCH 15/24] Removed redundant code for slant TEC. It now explicitly calls the original vtec subroutine. --- .../obs_def_upper_atm_mod.f90 | 64 ++----------------- 1 file changed, 4 insertions(+), 60 deletions(-) diff --git a/observations/forward_operators/obs_def_upper_atm_mod.f90 b/observations/forward_operators/obs_def_upper_atm_mod.f90 index 502ebc6f9c..979ae332b5 100644 --- a/observations/forward_operators/obs_def_upper_atm_mod.f90 +++ b/observations/forward_operators/obs_def_upper_atm_mod.f90 @@ -267,6 +267,8 @@ end subroutine get_expected_upper_atm_density !----------------------------------------------------------------------------- ! THIS SUBROUTINE NEEDS ADDITIONAL INPUT FROM AETHER SCIENTISTS +! This routine is legacy and it is unclear that the method for getting the total +! electon content by summing the ions concentrations is scientifically correct. subroutine get_expected_gnd_gps_vtec(state_handle, ens_size, location, obs_val, istatus) @@ -404,66 +406,8 @@ subroutine get_expected_slant_gps_vtec(state_handle, ens_size, location, igrkey, sat_pos = sat_position(1:3, igrkey) ground_pos = ground_position(1:3, igrkey) -nAlts = 0 -LEVELS: do iAlt=1, size(ALT,2)+1 - ! loop over levels. if we get to one more than the allocated array size, - ! this model must have more levels than we expected. increase array sizes, - ! recompile, and try again. - - if (iAlt > size(ALT,2)) then - write(string1,'(''more than '',i4,'' levels in the model.'')') MAXLEVELS - string2='increase MAXLEVELS in obs_def_upper_atm_mod.f90, rerun preprocess and recompile.' - call error_handler(E_ERR, 'get_expected_slant_gps_vtec', string1, & - source, revision, revdate, text2=string2) - endif - - ! At each altitude interpolate the 2D IDensityS_ie to the lon-lat where data - ! point is located. After this loop we will have a column centered at the data - ! point's lon-lat and at all model altitudes. - probe = set_location(loc_vals(1), loc_vals(2), real(iAlt, r8), VERTISLEVEL) !probe is where we have data - - call interpolate(state_handle, ens_size, probe, QTY_DENSITY_ION_E, IDensityS_ie(:, iAlt), this_istatus) - call track_status(ens_size, this_istatus, obs_val, istatus, return_now) - if (any(istatus /= 0)) exit LEVELS - - call interpolate(state_handle, ens_size, probe, QTY_GEOMETRIC_HEIGHT, ALT(:, iAlt), this_istatus) - - call track_status(ens_size, this_istatus, obs_val, istatus, return_now) - - if (any(istatus /= 0)) exit LEVELS - - nAlts = nAlts+1 -enddo LEVELS - -! failed first time through loop - no values to return. -if (nAlts == 0) then - obs_val(:) = MISSING_R8 - return -endif - -istatus(:) = 0 - -do i=1,ens_size - if (any(IDensityS_ie(i,1:nAlts) == MISSING_R8) .or. any(ALT(i,1:nAlts) == MISSING_R8)) then - ! mark the ensemble member as having failed - istatus(i) = 1 - end if -end do - -! Set all ensemble members tec to zero for summation -tec=0.0_r8 - -do iAlt = 1, nAlts-1 !approximate the integral over the altitude as a sum of trapezoids - !area of a trapezoid: A = (h2-h1) * (f2+f1)/2 - where (istatus == 0) & - tec = tec + ( ALT(:, iAlt+1)-ALT(:, iAlt) ) * ( IDensityS_ie(:, iAlt+1)+IDensityS_ie(:, iAlt) ) /2.0_r8 -enddo - -where (istatus == 0) - obs_val = tec * 10.0**(-16) !units of TEC are "10^16" #electron/m^2 instead of just "1" #electron/m^2 -elsewhere - obs_val = MISSING_R8 -end where +! Until slant gps operator is written, just default to regular vtec +call get_expected_gnd_gps_vtec(state_handle, ens_size, location, obs_val, istatus) end subroutine get_expected_slant_gps_vtec From 185378ba0f79be659f0a3cf50592c9ba1d6908e1 Mon Sep 17 00:00:00 2001 From: Jeff Anderson Date: Mon, 10 Nov 2025 15:10:10 -0700 Subject: [PATCH 16/24] Added slant TEC to table. --- .../modules/observations/default_quantities_mod.f90 | 1 + 1 file changed, 1 insertion(+) diff --git a/assimilation_code/modules/observations/default_quantities_mod.f90 b/assimilation_code/modules/observations/default_quantities_mod.f90 index ebc2d068e9..931e298a99 100644 --- a/assimilation_code/modules/observations/default_quantities_mod.f90 +++ b/assimilation_code/modules/observations/default_quantities_mod.f90 @@ -131,6 +131,7 @@ ! QTY_GEOMETRIC_HEIGHT ! QTY_GEOPOTENTIAL_HEIGHT ! QTY_GND_GPS_VTEC +! QTY_SLANT_GPS_VTEC ! QTY_GPSRO ! QTY_GRAUPEL_MIXING_RATIO ! QTY_GRAUPEL_NUMBER_CONCENTR From 7e0e6cfe5a0d3202f7e6c69b910924e78ed7c509 Mon Sep 17 00:00:00 2001 From: Jeff Anderson Date: Mon, 10 Nov 2025 15:10:53 -0700 Subject: [PATCH 17/24] Added additional clarity about what the Aether folks need to do to make F10.7 DA work. --- models/aether_cube_sphere/readme.rst | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/models/aether_cube_sphere/readme.rst b/models/aether_cube_sphere/readme.rst index f8ba52d983..d40127e94c 100644 --- a/models/aether_cube_sphere/readme.rst +++ b/models/aether_cube_sphere/readme.rst @@ -155,7 +155,10 @@ DART understands. **F10.7:** Aether restart netcdf files do not currently include parameter values like F10.7. For now, -the ``aether_to_dart`` and ``dart_to_aether`` programs do not do not do input/output with Aether, +the ``aether_to_dart`` and ``dart_to_aether`` programs do not do not do input/output with Aether. +Default (meaningless) F10.7 values are generated by transform_state_mod.f90. Once Aether +modelers decide where the F10.7 value will come from, code will need to be added to read +the F10.7 value in ``model_to_dart`` and write it in ``dart_to_model``, but obvious hooks are available in ``transform_state_mod.f90``. This module implements the basics of two ways to do F10.7 estimation. The first is to have a single scalar value of F10.7 in the DART state. Subroutine ``get_state_meta_data`` provides some initial suggestions for From cf9e7b0b1ba7fb8cadd7aab79c8f3169123316e2 Mon Sep 17 00:00:00 2001 From: Jeff Anderson Date: Mon, 10 Nov 2025 15:13:36 -0700 Subject: [PATCH 18/24] Removed use statement for netcdf library. --- models/aether_cube_sphere/model_mod.f90 | 8 ++------ 1 file changed, 2 insertions(+), 6 deletions(-) diff --git a/models/aether_cube_sphere/model_mod.f90 b/models/aether_cube_sphere/model_mod.f90 index 6e9ae949cb..a58c34fdf3 100644 --- a/models/aether_cube_sphere/model_mod.f90 +++ b/models/aether_cube_sphere/model_mod.f90 @@ -5,8 +5,6 @@ module model_mod -use netcdf - use types_mod, only : r8, i8, MISSING_R8, vtablenamelength, DEG2RAD, RAD2DEG, & vtablenamelength @@ -439,12 +437,10 @@ end subroutine nc_write_model_atts subroutine read_template_file() -integer :: dimid, varid, number_of_columns, ncid, ncstatus -character(len=256) :: name, file_path +integer :: number_of_columns, ncid ! Gets altitudes and number of points per face row from an Aether template file -file_path = trim(template_file) -ncid = nc_open_file_readonly(file_path) +ncid = nc_open_file_readonly(trim(template_file)) ! Get the number of vertical levels ncenter_altitudes = nc_get_dimension_size(ncid, 'z') From 1e5aa6c2b18c01d4bbfd2828d5e3be15c48812ab Mon Sep 17 00:00:00 2001 From: Jeff Anderson Date: Mon, 10 Nov 2025 15:14:40 -0700 Subject: [PATCH 19/24] Removed old demo file that was used for Michigan tutorial. --- .../work/demo_documentation.txt | 69 ------------------- 1 file changed, 69 deletions(-) delete mode 100644 models/aether_cube_sphere/work/demo_documentation.txt diff --git a/models/aether_cube_sphere/work/demo_documentation.txt b/models/aether_cube_sphere/work/demo_documentation.txt deleted file mode 100644 index cbea9f9171..0000000000 --- a/models/aether_cube_sphere/work/demo_documentation.txt +++ /dev/null @@ -1,69 +0,0 @@ -This file provides step-by-step instructions for testing the Aether/DART -system with a variety of test restart files available from the University of -Michigan. - -Check out aether_michigan branch of dart - git clone https://github.com/NCAR/DART.git - git checkout aether_michigan - -Set an appropriate build template - In build_templates/ directory, copy appropriate template (mkmf.template.gfortran) - to mkfm.template - -Build the DART software: - Go to directory models/aether_cube_sphere/work - quickbuild.sh nompi - -Get the sample aether restart gz files - mkdir B24_AETHER_INPUT_FILES - mkdir B24_AETHER_OUTPUT_FILES - mkdir B6_AETHER_INPUT_FILES - mkdir B6_AETHER_OUTPUT_FILES - - Put the gz files from Aaron in the appropriate input files directory - -Make an increments directory under the model directory - mkdir increments - - - - -End to end procedure to make aether cube sphere demo work - -1. Remove all netcdf files from the work directory -2. Remove all netcdf files from the increments directory -3. Remove all netcdf files from the aether output directory -4. Remove the aether input directory at the level below the gz file -5. Untar the gz file, use the finder -6. Perturb_aether_ensemble.m from the model directory to generate perturbations -7. Run aether_to_dart 1, ens_size to transform to filter_input files in work directory -8. If looking at filter posteriors, copy each filter_input nc file to a filter_output - cp filter_input_0001.nc filter_output_0001.nc, for all ensemble members -9. Run filter in work directory -10. Copy all files from the aether input directory to the aether output directory -11. Run dart_to_aether 1, ens_size in work directory -12. Matlab get_aether_incs in model directory -13. Run plot_aether_lat_lon programs to verify increments in model directory - -Changing resolution for tests: -1. Remove all nc files from the work directory -2. Delete the aether input directory and then recreate by unpacking gz -3. In perturb_aether_ensemble.m: - a. Change the input file directory - b. Change nblocks -4. Run perturb_aether_ensemble -5. Copy all the files from the aether input directory to the aether output directory -6. In input.nml, change the input directory for aether files in aether_to_dart_nml and dart_to_aether_nml. Also change the np and nblocks in transform_state_nml -7. Run aether_to_dart 1, ens_size -8. Cp filter_input files to filter_output files if you want to do diagnostics in dart state space -8a. Run perfect_model_obs -9. Run filter -10. Run dart_to_aether 1, ens_size -11. In get_aether_incs.m - a. Change nblocks - b. Change the directory for the input and output files -12. Run get_aether_incs -13. In plot_aether_lat_lon.m: - a. Change nblocks - b. Change the directory for input grid files - From 54afcec3b30e867dbcb4c13d5737ef87d56e3a1a Mon Sep 17 00:00:00 2001 From: Jeff Anderson Date: Mon, 10 Nov 2025 15:15:12 -0700 Subject: [PATCH 20/24] Made default namelist consistent that size of test ensemble is 10. --- models/aether_cube_sphere/work/input.nml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/models/aether_cube_sphere/work/input.nml b/models/aether_cube_sphere/work/input.nml index 4a14342d0d..6734d799c5 100644 --- a/models/aether_cube_sphere/work/input.nml +++ b/models/aether_cube_sphere/work/input.nml @@ -46,7 +46,7 @@ output_state_file_list = 'filter_output_files.txt' output_interval = 1, output_members = .true. - num_output_state_members = 20, + num_output_state_members = 10, output_mean = .true. output_sd = .true. write_all_stages_at_end = .false. @@ -63,7 +63,7 @@ obs_sequence_in_name = "obs_seq.out", obs_sequence_out_name = "obs_seq.final", - num_output_obs_members = 20, + num_output_obs_members = 10, init_time_days = 0, init_time_seconds = 0, first_obs_days = -1, From 86114f52722b7a3d9e570fb067212c76fc7e709c Mon Sep 17 00:00:00 2001 From: Helen Kershaw <20047007+hkershaw-brown@users.noreply.github.com> Date: Tue, 11 Nov 2025 13:43:14 -0500 Subject: [PATCH 21/24] chore: gitignore test_aether_grid --- .gitignore | 1 + 1 file changed, 1 insertion(+) diff --git a/.gitignore b/.gitignore index 8440b04fba..90fffd8038 100644 --- a/.gitignore +++ b/.gitignore @@ -94,6 +94,7 @@ streamflow_obs_diag cam_dart_obs_preprocessor aether_to_dart dart_to_aether +test_aether_grid # Observation converter exectutables convert_aviso From 95cd3ae387f6f48ab9c9ae4847ed962b0d7f6107 Mon Sep 17 00:00:00 2001 From: Helen Kershaw <20047007+hkershaw-brown@users.noreply.github.com> Date: Tue, 11 Nov 2025 13:45:46 -0500 Subject: [PATCH 22/24] chore: remove unused routines from model_mod use statements --- models/aether_cube_sphere/model_mod.f90 | 11 +++++------ 1 file changed, 5 insertions(+), 6 deletions(-) diff --git a/models/aether_cube_sphere/model_mod.f90 b/models/aether_cube_sphere/model_mod.f90 index a58c34fdf3..9aeaacfefa 100644 --- a/models/aether_cube_sphere/model_mod.f90 +++ b/models/aether_cube_sphere/model_mod.f90 @@ -17,12 +17,12 @@ module model_mod get_location, VERTISHEIGHT, VERTISUNDEF, & VERTISLEVEL -use utilities_mod, only : register_module, error_handler, E_ERR, E_MSG, & +use utilities_mod, only : error_handler, E_MSG, & nmlfileunit, do_nml_file, do_nml_term, & - find_namelist_in_file, check_namelist_read, to_upper, & + find_namelist_in_file, check_namelist_read, & find_enclosing_indices -use obs_kind_mod, only : get_index_for_quantity, QTY_GEOMETRIC_HEIGHT +use obs_kind_mod, only : QTY_GEOMETRIC_HEIGHT use netcdf_utilities_mod, only : nc_add_global_attribute, nc_synchronize_file, & nc_add_global_creation_time, nc_begin_define_mode, & @@ -37,9 +37,8 @@ module model_mod use ensemble_manager_mod, only : ensemble_type -use cube_sphere_grid_tools_mod, only : is_point_in_triangle, is_point_in_quad, grid_to_lat_lon, & - lat_lon_to_xyz, col_index_to_lat_lon, lat_lon_to_grid, & - get_bounding_box, lat_lon_to_col_index, get_grid_delta +use cube_sphere_grid_tools_mod, only : col_index_to_lat_lon, & + get_bounding_box, get_grid_delta ! These routines are passed through from default_model_mod. use default_model_mod, only : pert_model_copies, read_model_time, write_model_time, & From 194fca2d13f396666e153c8150c448c9d9ed43eb Mon Sep 17 00:00:00 2001 From: Helen Kershaw <20047007+hkershaw-brown@users.noreply.github.com> Date: Tue, 11 Nov 2025 13:48:03 -0500 Subject: [PATCH 23/24] fix: tasks other than task 0 may have f10.7 so use ALL_MSG for error_handler --- models/aether_cube_sphere/model_mod.f90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/models/aether_cube_sphere/model_mod.f90 b/models/aether_cube_sphere/model_mod.f90 index 9aeaacfefa..daf8d8696e 100644 --- a/models/aether_cube_sphere/model_mod.f90 +++ b/models/aether_cube_sphere/model_mod.f90 @@ -17,7 +17,7 @@ module model_mod get_location, VERTISHEIGHT, VERTISUNDEF, & VERTISLEVEL -use utilities_mod, only : error_handler, E_MSG, & +use utilities_mod, only : error_handler, E_MSG, E_ALLMSG, & nmlfileunit, do_nml_file, do_nml_term, & find_namelist_in_file, check_namelist_read, & find_enclosing_indices @@ -331,7 +331,7 @@ subroutine get_state_meta_data(index_in, location, qty) longitude = 360.0_r8 * real(seconds,r8) / 86400.0_r8 - 180.0_r8 if (longitude < 0.0_r8) longitude = longitude + 30.0_r8 write(string1,*)'Longitude assigned for F10.7 state variable is', longitude - call error_handler(E_MSG, 'get_state_meta_data', string1, source) + call error_handler(E_ALLMSG, 'get_state_meta_data', string1, source) location = set_location(longitude, 0.0_r8, 400000.0_r8, VERTISUNDEF) return end if From 1f4774ec74e2f8547070fc4ab71fc7974ddd637b Mon Sep 17 00:00:00 2001 From: Helen Kershaw <20047007+hkershaw-brown@users.noreply.github.com> Date: Tue, 11 Nov 2025 14:07:07 -0500 Subject: [PATCH 24/24] bump version and changelog for release --- CHANGELOG.rst | 5 +++++ conf.py | 2 +- 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/CHANGELOG.rst b/CHANGELOG.rst index 2e7a494d42..be326ae49a 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. +**November 11 2025 :: Aether Cube Sphere. Tag v11.18.0** + +- Aether cube sphere interface added to DART. +- SLANT_GPS_VTEC QTY and obs_def + **November 3 2025 :: DART tutorial. Tag 11.17.0** - DART tutorial updated to QCEFF v11 diff --git a/conf.py b/conf.py index 695f560904..9d89dd35ad 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 = '11.17.0' +release = '11.18.0' root_doc = 'index' # -- General configuration ---------------------------------------------------