From 1792110f51a5d276d31fd46b8089a5ad17253242 Mon Sep 17 00:00:00 2001 From: Matt Dawson Date: Wed, 20 Mar 2024 13:33:37 -0700 Subject: [PATCH] prepare version 0.8.0 (#57) * add TS1 and TSMLT configuration to examples * add new data sets for WACCM * fix memory leak in tests * add updated CFC cross section datasets * run example test in sub folders * copy data into example test folders * reorganize temperature based cross section * draft taylor series temperature parameterization * add taylor series param test * adjust grid merging logic * finish BRONO2 config and tests * fix MPI code * draft burkholder parameterization and tests * add range override to quantum yields * finish HO2NO2 config and tests * update TSMLT config example * fix example configurations * fix ch4 example config * add ch3cl data set and configuration * add SO2 data set * Updates and tests for O2 photolysis (#38) * stub test of LUT LA-SRB calcs * update lasrb test conditions * add od and xs calcs to LUT LA-SRB test * fix memory issues in tests * finish LA-SRB LUT comparison test * Add H2SO4 and NO datasets, configurations, and algorithms for WACCM (#41) * draft h2so4 quantum yield and test * add h2so4 qy test * add data and config for H2SO4 and NO * Add N2O5 algorithms and data sets for WACCM/TSMLT (#43) * fix bad jo2 config in ts1 example * add N2O5 algorithms and datasets for WACCM * fix pack/unpack for temperature based cross section * add acetone calcs for WACCM (#45) * add acetone calcs for WACCM * fix uninitialized variable and air density in tests * add branch options to acetone quantum yields * Add YAML option for configuration files (#48) * add YAML config option * add yaml to json run comparison tests * update to new musica-core release * Add ability to calculate heating rates for photolysis reactions (#50) * draft heating rates class and tests * finish heating rate tests * add heating rate output to driver, and include in TS example * Remove musica-core dependency (#51) * merge in musica-core dependencies * don't run tests in parallel * remove unneeded utility modules * remove io functions from string_t * remove debug output from tests to reduce log file size * update valgrind suppressions for MPI * update valgrind suppressions * fix valgrind suppression format error * remove wildcards from valgrind supresssion error types * add valgrind suppression * compile for gcc-13 (#53) * compile for gcc-13 * excluding oldtuv when using gcc 13.2 * removing cmake debug message * trying to add a gcc action * syntax error * isntalling netcdff * trying to test multiple gcc versions * installing numpy * scipy * using better thing * separating build into docker and gcc (#54) * separating build into docker and gcc * fixing pages build * run tests in serial * not running tests in parallel for focker * making sure memcheck happens * adding ctiation file (#55) * adding ctiation file * only adding software citation * syntax * more syntax * maybe now? * correcting authors * ... * or now * duplicate key * *marge noise* * trying to update url * Fix bug in map test with OpenMP (#56) * fix openmp bug in map test * fix map test for non-openmp builds * prepare for 0.8.0 release --------- Co-authored-by: Kyle Shores --- .dockerignore | 1 + .github/workflows/docker.yml | 50 + .github/workflows/gh-pages.yml | 6 +- .github/workflows/test.yml | 59 - .github/workflows/ubuntu.yml | 35 + CITATION.cff | 15 + CMakeLists.txt | 13 +- Dockerfile | 51 - README.md | 19 +- cmake/dependencies.cmake | 47 +- cmake/test_util.cmake | 15 +- data/cross_sections/ACETONE_JPL06.nc | Bin 0 -> 7424 bytes data/cross_sections/BRONO2_JPL06.nc | Bin 0 -> 6156 bytes data/cross_sections/BRO_JPL06.nc | Bin 0 -> 11768 bytes data/cross_sections/CF2CL2_JPL06.nc | Bin 0 -> 11013 bytes data/cross_sections/CFC113_JPL06.nc | Bin 0 -> 10364 bytes data/cross_sections/CFC114_JPL10.nc | Bin 0 -> 9687 bytes data/cross_sections/CFC115_JPL10.nc | Bin 0 -> 10302 bytes data/cross_sections/CFCL3_JPL06.nc | Bin 0 -> 9457 bytes data/cross_sections/CH3BR_JPL06.nc | Bin 0 -> 14428 bytes data/cross_sections/CH3CL_JPL06.nc | Bin 0 -> 11488 bytes data/cross_sections/CHBR3_JPL10.nc | Bin 0 -> 11474 bytes data/cross_sections/CL2O2_JPL10.nc | Bin 0 -> 17686 bytes data/cross_sections/CLO_JPL06.nc | Bin 0 -> 9189 bytes data/cross_sections/H1301_JPL06.nc | Bin 0 -> 11503 bytes data/cross_sections/H2402_JPL06.nc | Bin 0 -> 11754 bytes data/cross_sections/HCFC141b_JPL10.nc | Bin 0 -> 10754 bytes data/cross_sections/HCFC142b_JPL10.nc | Bin 0 -> 11580 bytes data/cross_sections/HCFC22_JPL06.nc | Bin 0 -> 9598 bytes data/cross_sections/HNO3_JPL06.nc | Bin 0 -> 3436 bytes data/cross_sections/HO2NO2_JPL06.nc | Bin 0 -> 2704 bytes data/cross_sections/HO2NO2_temp_JPL06.nc | Bin 0 -> 2992 bytes data/cross_sections/N2O5_JPL06.nc | Bin 11606 -> 11606 bytes data/cross_sections/SO2_Mills.nc | Bin 0 -> 9680 bytes data/dose_rates.json | 5 +- data/photolysis_rate_constants.json | 5 +- data/quantum_yields/H2SO4_mills.nc | Bin 0 -> 1856 bytes data/quantum_yields/N2O5_NO3_NO2.nc | Bin 712 -> 0 bytes data/quantum_yields/N2O5_NO3_NO_O.nc | Bin 720 -> 0 bytes docker/Dockerfile | 33 + .../Dockerfile.coverage | 14 +- Dockerfile.docs => docker/Dockerfile.docs | 14 +- docker/Dockerfile.memcheck | 32 + Dockerfile.mpi => docker/Dockerfile.mpi | 18 +- .../Dockerfile.mpi.memcheck | 16 +- docs/source/conf.py | 2 +- docs/switcher.json | 9 +- examples/ts1_tsmlt.json | 2095 +++++++++++++++++ examples/ts1_tsmlt.yml | 1742 ++++++++++++++ examples/{full_config.json => tuv_5_4.json} | 5 +- examples/tuv_5_4.yml | 1218 ++++++++++ include/util/config_yaml.h | 285 +++ packaging/CMakeLists.txt | 8 + src/CMakeLists.txt | 25 +- src/constants.F90 | 4 +- src/core.F90 | 70 +- src/cross_section.F90 | 84 +- src/cross_sections/CMakeLists.txt | 2 + src/cross_sections/o3_tint.F90 | 2 +- src/cross_sections/temperature_based.F90 | 693 ++---- src/cross_sections/util/CMakeLists.txt | 13 + .../util/temperature_parameterization.F90 | 436 ++++ ...emperature_parameterization_burkholder.F90 | 257 ++ .../temperature_parameterization_harwood.F90 | 195 ++ ...erature_parameterization_taylor_series.F90 | 273 +++ src/cross_sections/util/temperature_range.F90 | 158 ++ src/grid_warehouse.F90 | 14 +- src/heating_rates.F90 | 584 +++++ src/output.F90 | 25 +- src/photolysis_rates.F90 | 24 +- src/quantum_yield.F90 | 43 +- src/quantum_yield_factory.F90 | 17 + src/quantum_yields/CMakeLists.txt | 2 + src/quantum_yields/acetone-ch3co_ch3.F90 | 172 +- src/quantum_yields/h2so4_mills.F90 | 262 +++ src/quantum_yields/taylor_series.F90 | 99 + src/radiative_transfer/radiative_transfer.F90 | 62 +- src/radiative_transfer/radiator.F90 | 57 +- src/tuvx.F90 | 41 +- src/util/CMakeLists.txt | 21 + src/util/array.F90 | 368 +++ src/util/assert.F90 | 478 ++++ src/util/config.F90 | 1569 ++++++++++++ src/util/config.cpp | 349 +++ src/util/constants.F90 | 35 + src/util/io.F90 | 479 ++++ src/util/io/CMakeLists.txt | 9 + src/util/io/netcdf.F90 | 1299 ++++++++++ src/util/iterator.F90 | 81 + src/util/map.F90 | 637 +++++ src/util/mpi.F90 | 1165 +++++++++ src/util/string.F90 | 1528 ++++++++++++ src/util/yaml_util.F90 | 452 ++++ test/CMakeLists.txt | 36 +- test/data/config_example.json | 12 + test/data/config_example.yml | 8 + .../cross_section.base.config.json | 12 + .../util/burkholder.config.json | 22 + test/data/cross_sections/util/burkholder.nc | Bin 0 -> 436 bytes .../cross_sections/util/taylor.config.json | 23 + test/data/cross_sections/util/taylor.nc | Bin 0 -> 436 bytes test/data/heating_rates.json | 100 + test/data/io_netcdf_test_data.nc | Bin 0 -> 888 bytes test/data/la_srb_bands.config.json | 49 +- test/data/quantum_yields/base.config.json | 6 + .../quantum_yields/h2so4_mills.config.json | 143 ++ test/data/quantum_yields/jh2so4.nc | Bin 0 -> 863648 bytes test/data/test_config.json | 20 + test/data/waccm2_ref_101.grid | 104 + test/data/waccm2_ref_101_mod.grid | 104 + test/data/xsqy.doug.config.json | 1225 ++++++++++ test/json_yaml_compare.py | 26 + test/oldtuv/CMakeLists.txt | 2 +- test/oldtuv/Profile/Profile_factory.F90 | 4 - test/oldtuv/Profile/Profile_warehouse.F90 | 18 - .../oldtuv/Profile/air.from_csv_file.type.F90 | 14 - test/oldtuv/Profile/from_csv_file.type.F90 | 14 - .../holdingtank/from_csv_file.type.F90 | 14 - test/oldtuv/Profile/o2.from_csv_file.type.F90 | 14 - test/oldtuv/Profile/o3.from_csv_file.type.F90 | 15 - test/oldtuv/Profile/sza_from_time.type.F90 | 7 - .../abstract.cross_section.type.F90 | 4 - .../acetone-ch3co_ch3.cross_section.type.F90 | 2 - .../cross_section/base.cross_section.type.F90 | 9 - .../bro-br_o.cross_section.type.F90 | 3 - .../cross_section/ccl4.cross_section.type.F90 | 4 - .../cfc-11.cross_section.type.F90 | 4 - .../cross_section/ch2o.cross_section.type.F90 | 2 - .../ch3ono2-ch3o_no2.cross_section.type.F90 | 4 - .../chbr3.cross_section.type.F90 | 4 - .../chcl3.cross_section.type.F90 | 4 - .../cl2-cl_cl.cross_section.type.F90 | 4 - .../clono2.cross_section.type.F90 | 4 - .../cross_section/cross_section_factory.F90 | 2 - .../h2o2-oh_oh.cross_section.type.F90 | 4 - .../cross_section/hcfc.cross_section.type.F90 | 2 - .../hno3-oh_no2.cross_section.type.F90 | 7 - .../hobr-oh_br.cross_section.type.F90 | 4 - .../n2o-n2_o1d.cross_section.type.F90 | 2 - .../n2o5-no2_no3.cross_section.type.F90 | 4 - .../nitroxy_acetone.cross_section.type.F90 | 4 - .../nitroxy_ethanol.cross_section.type.F90 | 4 - .../no2.tint.cross_section.type.F90 | 13 +- .../o3.tint.cross_section.type.F90 | 7 - .../cross_section/oclo.cross_section.type.F90 | 4 - .../rono2.cross_section.type.F90 | 7 - .../t_butyl_nitrate.cross_section.type.F90 | 4 - .../cross_section/tint.cross_section.type.F90 | 11 - test/oldtuv/delta_eddington.f90 | 13 - test/oldtuv/diagout.f90 | 8 - test/oldtuv/disord_subs.f | 186 -- test/oldtuv/grid/grid_factory.F90 | 2 - test/oldtuv/grid/grid_warehouse.F90 | 18 - test/oldtuv/grids.f | 8 - test/oldtuv/photo_kinetics.F90 | 21 - .../abstract.quantum_yield.type.F90 | 4 - .../acetone-ch3co_ch3.quantum_yield.type.F90 | 4 - .../quantum_yield/base.quantum_yield.type.F90 | 12 - .../c2h5cho.quantum_yield.type.F90 | 4 - .../ch2chcho.quantum_yield.type.F90 | 4 - .../quantum_yield/ch2o.quantum_yield.type.F90 | 4 - .../ch3cho-ch3_hco.quantum_yield.type.F90 | 4 - ...ch2ch3-ch3co_ch2ch3.quantum_yield.type.F90 | 4 - .../ch3cocho.quantum_yield.type.F90 | 2 - .../clo-cl_o1d.quantum_yield.type.F90 | 4 - .../clo-cl_o3p.quantum_yield.type.F90 | 4 - .../clono2-cl_no3.quantum_yield.type.F90 | 4 - .../clono2-clo_no2.quantum_yield.type.F90 | 4 - .../quantum_yield/ho2.quantum_yield.type.F90 | 4 - .../quantum_yield/mvk.quantum_yield.type.F90 | 4 - .../no2.tint.quantum_yield.type.F90 | 11 - .../no3-_aq.quantum_yield.type.F90 | 4 - .../o3-o2_o1d.quantum_yield.type.F90 | 4 - .../o3-o2_o3p.quantum_yield.type.F90 | 4 - .../quantum_yield/tint.quantum_yield.type.F90 | 11 - test/oldtuv/quantum_yield_factory.F90 | 2 - .../abstract.radXfer.cross_section.type.F90 | 4 - .../base.cross_section.type.F90 | 11 - .../o2.cross_section.type.F90 | 11 - .../o3.tint.cross_section.type.F90 | 8 - .../radXfer_xsect_factory.F90 | 2 - .../radXfer_xsect_warehouse.F90 | 19 - .../rayliegh.cross_section.type.F90 | 8 - .../tint.cross_section.type.F90 | 11 - .../oldtuv/radiator/aerosol.radiator.type.F90 | 51 - test/oldtuv/radiator/base.radiator.type.F90 | 23 - test/oldtuv/radiator/radiator_factory.F90 | 2 - test/oldtuv/radiator/radiator_warehouse.F90 | 47 - .../oldtuv/radiator/radiator_warehouse.v0.F90 | 16 - test/oldtuv/rdetfl.f | 55 - test/oldtuv/rdxs.f | 2 - test/oldtuv/rtrans.f | 184 -- test/oldtuv/setaer.f | 5 - test/oldtuv/seth2o.f | 2 - test/oldtuv/setno2.f | 1 - test/oldtuv/setsnw.f | 12 - test/oldtuv/setso2.f | 1 - test/oldtuv/solvec.f | 43 - .../UV_Index.spectral_wght.type.F90 | 4 - .../abstract.spectral_wght.type.F90 | 4 - .../spectral_wght/base.spectral_wght.type.F90 | 9 - ...ppley_uv_photometer.spectral_wght.type.F90 | 4 - .../exponential_decay.spectral_wght.type.F90 | 4 - ...n_305_nm_10_nm_FWHM.spectral_wght.type.F90 | 4 - ...n_320_nm_10_nm_FWHM.spectral_wght.type.F90 | 4 - ...n_340_nm_10_nm_FWHM.spectral_wght.type.F90 | 4 - ...n_380_nm_10_nm_FWHM.spectral_wght.type.F90 | 4 - .../par_400-700nm.spectral_wght.type.F90 | 4 - ...ytoplankton_boucher.spectral_wght.type.F90 | 4 - .../plant_damage.spectral_wght.type.F90 | 4 - ...mage_flint_caldwell.spectral_wght.type.F90 | 4 - ..._flint_caldwell_ext.spectral_wght.type.F90 | 4 - .../scup_mice.spectral_wght.type.F90 | 4 - .../spectral_wght/spectral_wght_factory.F90 | 2 - .../spectral_wght/spectral_wght_warehouse.F90 | 16 - ...dard_human_erythema.spectral_wght.type.F90 | 4 - .../uv-a_315_400_nm.spectral_wght.type.F90 | 4 - .../uv-b_280_315_nm.spectral_wght.type.F90 | 4 - .../uv-b_280_320_nm.spectral_wght.type.F90 | 4 - .../visplus.spectral_wght.type.F90 | 4 - test/oldtuv/swchem.f | 1 - test/oldtuv/tuv.f | 39 - test/oldtuv/util/la_srb.type.F90 | 12 - .../vert_Profile/air.from_csv_file.type.F90 | 14 - .../vert_Profile/from_csv_file.type.F90 | 14 - .../holdingtank/from_csv_file.type.F90 | 14 - .../vert_Profile/o2.from_csv_file.type.F90 | 14 - .../vert_Profile/o3.from_csv_file.type.F90 | 14 - .../vert_Profile/vert_Profile_factory.F90 | 4 - .../vert_Profile/vert_Profile_warehouse.F90 | 18 - .../air.from_csv_file.type.F90 | 14 - .../vert_Profile_v0/from_csv_file.type.F90 | 14 - .../holdingtank/from_csv_file.type.F90 | 14 - .../vert_Profile_v0/o2.from_csv_file.type.F90 | 14 - .../vert_Profile_v0/o3.from_csv_file.type.F90 | 14 - .../vert_Profile_v0/vert_Profile_factory.F90 | 4 - .../vert_Profile_warehouse.F90 | 18 - test/oldtuv/vpo3.f | 12 - test/oldtuv/vptmp.f | 10 - test/regression/dose_rates/sw.compare.py | 44 - .../photolysis_rates/xsqy.compare.py | 43 - test/unit/CMakeLists.txt | 2 + test/unit/cross_section/CMakeLists.txt | 2 + .../cross_section/acetone-ch3co_ch3_test.F90 | 23 +- test/unit/cross_section/base.F90 | 43 + .../cross_section/cross_section_warehouse.F90 | 21 +- test/unit/cross_section/hno3-oh_no2_test.F90 | 187 +- test/unit/cross_section/rono2_test.F90 | 45 +- test/unit/cross_section/util/CMakeLists.txt | 14 + ...emperature_parameterization_burkholder.F90 | 102 + ...erature_parameterization_taylor_series.F90 | 103 + test/unit/heating_rates.F90 | 138 ++ test/unit/la_sr_bands.F90 | 30 +- test/unit/profile/from_host.F90 | 4 - test/unit/quantum_yield/CMakeLists.txt | 1 + test/unit/quantum_yield/base.F90 | 2 +- test/unit/quantum_yield/h2so4_mills.F90 | 210 ++ .../radiative_transfer_core.F90 | 16 - test/unit/radiator/from_host.F90 | 44 +- test/unit/radiator/radiator_core.F90 | 30 - test/unit/test_utils.F90 | 26 +- test/unit/tuv_doug/CMakeLists.txt | 20 +- test/unit/tuv_doug/JCALC/CMakeLists.txt | 21 + test/unit/tuv_doug/JCALC/XSQY_ACETONE.f | 274 +++ test/unit/tuv_doug/JCALC/XSQY_BRO.f | 116 + test/unit/tuv_doug/JCALC/XSQY_BRONO2.f | 176 ++ test/unit/tuv_doug/JCALC/XSQY_CF2CL2.f | 234 ++ test/unit/tuv_doug/JCALC/XSQY_CFC113.f | 233 ++ test/unit/tuv_doug/JCALC/XSQY_CFC114.f | 224 ++ test/unit/tuv_doug/JCALC/XSQY_CFC115.f | 227 ++ test/unit/tuv_doug/JCALC/XSQY_CFCL3.f | 231 ++ test/unit/tuv_doug/JCALC/XSQY_CH3BR.f | 235 ++ test/unit/tuv_doug/JCALC/XSQY_CH3CL.f | 236 ++ test/unit/tuv_doug/JCALC/XSQY_CHBR3.f | 241 ++ test/unit/tuv_doug/JCALC/XSQY_CL2O2.f | 117 + test/unit/tuv_doug/JCALC/XSQY_CLO.f | 115 + test/unit/tuv_doug/JCALC/XSQY_H1301.f | 230 ++ test/unit/tuv_doug/JCALC/XSQY_H2402.f | 235 ++ test/unit/tuv_doug/JCALC/XSQY_HCFC141b.f | 231 ++ test/unit/tuv_doug/JCALC/XSQY_HCFC142b.f | 231 ++ test/unit/tuv_doug/JCALC/XSQY_HCFC22.f | 238 ++ test/unit/tuv_doug/JCALC/XSQY_HNO3.f | 140 ++ test/unit/tuv_doug/JCALC/XSQY_HO2NO2.f | 210 ++ test/unit/tuv_doug/JCALC/XSQY_SO2.f | 108 + test/unit/tuv_doug/data_sets.F90 | 47 +- test/unit/tuv_doug/driver.F90 | 69 + test/unit/tuv_doug/la_srb.f | 196 ++ test/unit/tuv_doug/lymana.f | 120 + test/unit/tuv_doug/rdo2xs.f | 117 + test/unit/tuv_doug/schum.f | 320 +++ test/unit/tuv_doug/test_la_srb.F90 | 182 ++ test/unit/util/CMakeLists.txt | 29 + test/unit/util/array.F90 | 152 ++ test/unit/util/assert.F90 | 255 ++ test/unit/util/assert.sh | 34 + test/unit/util/config.F90 | 629 +++++ test/unit/util/io/CMakeLists.txt | 17 + test/unit/util/io/netcdf.F90 | 623 +++++ test/unit/util/map.F90 | 505 ++++ test/unit/util/map.sh | 32 + test/unit/util/mpi.F90 | 364 +++ test/unit/util/string.F90 | 567 +++++ test/unit/util/string.sh | 23 + test/valgrind.supp | 173 +- tool/data_conversion/json_to_yaml.py | 19 + tool/data_conversion/photo.config.json | 124 + tool/data_conversion/text_to_netcdf.py | 61 + tool/data_conversion/xsqy_subs.py | 218 ++ 308 files changed, 28890 insertions(+), 2691 deletions(-) create mode 100644 .github/workflows/docker.yml delete mode 100644 .github/workflows/test.yml create mode 100644 .github/workflows/ubuntu.yml create mode 100644 CITATION.cff delete mode 100644 Dockerfile create mode 100644 data/cross_sections/ACETONE_JPL06.nc create mode 100644 data/cross_sections/BRONO2_JPL06.nc create mode 100644 data/cross_sections/BRO_JPL06.nc create mode 100644 data/cross_sections/CF2CL2_JPL06.nc create mode 100644 data/cross_sections/CFC113_JPL06.nc create mode 100644 data/cross_sections/CFC114_JPL10.nc create mode 100644 data/cross_sections/CFC115_JPL10.nc create mode 100644 data/cross_sections/CFCL3_JPL06.nc create mode 100644 data/cross_sections/CH3BR_JPL06.nc create mode 100644 data/cross_sections/CH3CL_JPL06.nc create mode 100644 data/cross_sections/CHBR3_JPL10.nc create mode 100644 data/cross_sections/CL2O2_JPL10.nc create mode 100644 data/cross_sections/CLO_JPL06.nc create mode 100644 data/cross_sections/H1301_JPL06.nc create mode 100644 data/cross_sections/H2402_JPL06.nc create mode 100644 data/cross_sections/HCFC141b_JPL10.nc create mode 100644 data/cross_sections/HCFC142b_JPL10.nc create mode 100644 data/cross_sections/HCFC22_JPL06.nc create mode 100644 data/cross_sections/HNO3_JPL06.nc create mode 100644 data/cross_sections/HO2NO2_JPL06.nc create mode 100644 data/cross_sections/HO2NO2_temp_JPL06.nc create mode 100644 data/cross_sections/SO2_Mills.nc create mode 100644 data/quantum_yields/H2SO4_mills.nc delete mode 100644 data/quantum_yields/N2O5_NO3_NO2.nc delete mode 100644 data/quantum_yields/N2O5_NO3_NO_O.nc create mode 100644 docker/Dockerfile rename Dockerfile.memcheck => docker/Dockerfile.coverage (59%) rename Dockerfile.docs => docker/Dockerfile.docs (63%) create mode 100644 docker/Dockerfile.memcheck rename Dockerfile.mpi => docker/Dockerfile.mpi (69%) rename Dockerfile.mpi.memcheck => docker/Dockerfile.mpi.memcheck (73%) create mode 100644 examples/ts1_tsmlt.json create mode 100644 examples/ts1_tsmlt.yml rename examples/{full_config.json => tuv_5_4.json} (99%) create mode 100644 examples/tuv_5_4.yml create mode 100644 include/util/config_yaml.h create mode 100644 src/cross_sections/util/CMakeLists.txt create mode 100644 src/cross_sections/util/temperature_parameterization.F90 create mode 100644 src/cross_sections/util/temperature_parameterization_burkholder.F90 create mode 100644 src/cross_sections/util/temperature_parameterization_harwood.F90 create mode 100644 src/cross_sections/util/temperature_parameterization_taylor_series.F90 create mode 100644 src/cross_sections/util/temperature_range.F90 create mode 100644 src/heating_rates.F90 create mode 100644 src/quantum_yields/h2so4_mills.F90 create mode 100644 src/quantum_yields/taylor_series.F90 create mode 100644 src/util/CMakeLists.txt create mode 100644 src/util/array.F90 create mode 100644 src/util/assert.F90 create mode 100644 src/util/config.F90 create mode 100644 src/util/config.cpp create mode 100644 src/util/constants.F90 create mode 100644 src/util/io.F90 create mode 100644 src/util/io/CMakeLists.txt create mode 100644 src/util/io/netcdf.F90 create mode 100644 src/util/iterator.F90 create mode 100644 src/util/map.F90 create mode 100644 src/util/mpi.F90 create mode 100644 src/util/string.F90 create mode 100644 src/util/yaml_util.F90 create mode 100644 test/data/config_example.json create mode 100644 test/data/config_example.yml create mode 100644 test/data/cross_sections/util/burkholder.config.json create mode 100644 test/data/cross_sections/util/burkholder.nc create mode 100644 test/data/cross_sections/util/taylor.config.json create mode 100644 test/data/cross_sections/util/taylor.nc create mode 100644 test/data/heating_rates.json create mode 100644 test/data/io_netcdf_test_data.nc create mode 100644 test/data/quantum_yields/h2so4_mills.config.json create mode 100644 test/data/quantum_yields/jh2so4.nc create mode 100644 test/data/test_config.json create mode 100644 test/data/waccm2_ref_101.grid create mode 100644 test/data/waccm2_ref_101_mod.grid create mode 100644 test/json_yaml_compare.py create mode 100644 test/unit/cross_section/util/CMakeLists.txt create mode 100644 test/unit/cross_section/util/temperature_parameterization_burkholder.F90 create mode 100644 test/unit/cross_section/util/temperature_parameterization_taylor_series.F90 create mode 100644 test/unit/heating_rates.F90 create mode 100644 test/unit/quantum_yield/h2so4_mills.F90 create mode 100644 test/unit/tuv_doug/JCALC/XSQY_ACETONE.f create mode 100644 test/unit/tuv_doug/JCALC/XSQY_BRO.f create mode 100644 test/unit/tuv_doug/JCALC/XSQY_BRONO2.f create mode 100644 test/unit/tuv_doug/JCALC/XSQY_CF2CL2.f create mode 100644 test/unit/tuv_doug/JCALC/XSQY_CFC113.f create mode 100644 test/unit/tuv_doug/JCALC/XSQY_CFC114.f create mode 100644 test/unit/tuv_doug/JCALC/XSQY_CFC115.f create mode 100644 test/unit/tuv_doug/JCALC/XSQY_CFCL3.f create mode 100644 test/unit/tuv_doug/JCALC/XSQY_CH3BR.f create mode 100644 test/unit/tuv_doug/JCALC/XSQY_CH3CL.f create mode 100644 test/unit/tuv_doug/JCALC/XSQY_CHBR3.f create mode 100644 test/unit/tuv_doug/JCALC/XSQY_CL2O2.f create mode 100644 test/unit/tuv_doug/JCALC/XSQY_CLO.f create mode 100644 test/unit/tuv_doug/JCALC/XSQY_H1301.f create mode 100644 test/unit/tuv_doug/JCALC/XSQY_H2402.f create mode 100644 test/unit/tuv_doug/JCALC/XSQY_HCFC141b.f create mode 100644 test/unit/tuv_doug/JCALC/XSQY_HCFC142b.f create mode 100644 test/unit/tuv_doug/JCALC/XSQY_HCFC22.f create mode 100644 test/unit/tuv_doug/JCALC/XSQY_HNO3.f create mode 100644 test/unit/tuv_doug/JCALC/XSQY_HO2NO2.f create mode 100644 test/unit/tuv_doug/JCALC/XSQY_SO2.f create mode 100644 test/unit/tuv_doug/la_srb.f create mode 100644 test/unit/tuv_doug/lymana.f create mode 100644 test/unit/tuv_doug/rdo2xs.f create mode 100644 test/unit/tuv_doug/schum.f create mode 100644 test/unit/tuv_doug/test_la_srb.F90 create mode 100644 test/unit/util/CMakeLists.txt create mode 100644 test/unit/util/array.F90 create mode 100644 test/unit/util/assert.F90 create mode 100755 test/unit/util/assert.sh create mode 100644 test/unit/util/config.F90 create mode 100644 test/unit/util/io/CMakeLists.txt create mode 100644 test/unit/util/io/netcdf.F90 create mode 100644 test/unit/util/map.F90 create mode 100755 test/unit/util/map.sh create mode 100644 test/unit/util/mpi.F90 create mode 100644 test/unit/util/string.F90 create mode 100755 test/unit/util/string.sh create mode 100644 tool/data_conversion/json_to_yaml.py create mode 100644 tool/data_conversion/photo.config.json create mode 100644 tool/data_conversion/text_to_netcdf.py create mode 100644 tool/data_conversion/xsqy_subs.py diff --git a/.dockerignore b/.dockerignore index e3158026..69a3598b 100644 --- a/.dockerignore +++ b/.dockerignore @@ -3,6 +3,7 @@ # include things to copy !src/ +!include/ !etc/ !data/ !cmake/ diff --git a/.github/workflows/docker.yml b/.github/workflows/docker.yml new file mode 100644 index 00000000..be54d833 --- /dev/null +++ b/.github/workflows/docker.yml @@ -0,0 +1,50 @@ +name: Docker + +on: [push, pull_request] + +concurrency: + group: ${{ github.workflow }}-${{ github.ref || github.run_id }} + cancel-in-progress: true + +jobs: + docker-build-and-test: + if: github.event_name != 'pull_request' || github.event.pull_request.head.repo.full_name != github.event.pull_request.base.repo.full_name + name: Build and Test - ${{ matrix.dockerfile }} + runs-on: ubuntu-latest + strategy: + fail-fast: false + matrix: + os: [ubuntu-latest] + dockerfile: + - Dockerfile + - Dockerfile.coverage + - Dockerfile.memcheck + - Dockerfile.mpi + - Dockerfile.mpi.memcheck + steps: + - name: Checkout code + uses: actions/checkout@v3 + with: + submodules: recursive + + - name: Build Docker image + run: docker build -t tuvx -f docker/${{ matrix.dockerfile }} . + + - name: Run tests in container + if: matrix.dockerfile != 'Dockerfile.coverage' + run: docker run --name test-container -t tuvx bash -c 'make test ARGS="--rerun-failed --output-on-failure"' + + - name: Run coverage tests in container + if: matrix.dockerfile == 'Dockerfile.coverage' + run: docker run --name test-container -t tuvx bash -c 'make coverage ARGS="--rerun-failed --output-on-failure"' + + - name: Copy coverage from container + if: matrix.dockerfile == 'Dockerfile.coverage' + run: docker cp test-container:build/coverage.info . + + - name: Upload coverage report + if: matrix.dockerfile == 'Dockerfile.coverage' + uses: codecov/codecov-action@v3 + with: + token: ${{ secrets.CODECOV_TOKEN }} + files: coverage.info \ No newline at end of file diff --git a/.github/workflows/gh-pages.yml b/.github/workflows/gh-pages.yml index ed377e74..9ef87037 100644 --- a/.github/workflows/gh-pages.yml +++ b/.github/workflows/gh-pages.yml @@ -54,7 +54,7 @@ jobs: # create two copies of the documentaiton # 1. the frozen version, represented as vX.X in the version switcher - docker build -t tuvx -f Dockerfile.docs . + docker build -t tuvx -f docker/Dockerfile.docs . id=$(docker create tuvx) docker cp $id:/build/docs/sphinx tmpdocs docker rm -v $id @@ -63,7 +63,7 @@ jobs: # 2. stable, represented as vX.X (stable) in the version switcher # edit conf.py to produce a version string that looks like vX.X (stable) - docker build -t tuvx -f Dockerfile.docs --build-arg SUFFIX=" (stable)" . + docker build -t tuvx -f docker/Dockerfile.docs --build-arg SUFFIX=" (stable)" . id=$(docker create tuvx) docker cp $id:/build/docs/sphinx tmpdocs docker rm -v $id @@ -84,7 +84,7 @@ jobs: !contains(github.ref, env.DEFAULT_BRANCH) run: | set -x - docker build -t tuvx -f Dockerfile.docs . + docker build -t tuvx -f docker/Dockerfile.docs . id=$(docker create tuvx) docker cp $id:/build/docs/sphinx tmpdocs docker rm -v $id diff --git a/.github/workflows/test.yml b/.github/workflows/test.yml deleted file mode 100644 index 37e0cb90..00000000 --- a/.github/workflows/test.yml +++ /dev/null @@ -1,59 +0,0 @@ -name: build - -on: [ push, pull_request ] - -concurrency: - group: ${{ github.workflow }}-${{ github.event.pull_request.number || github.ref }} - cancel-in-progress: true - -jobs: - build_test_no_mpi_no_memcheck: - runs-on: ubuntu-latest - if: github.event_name != 'pull_request' || github.event.pull_request.head.repo.full_name != github.event.pull_request.base.repo.full_name - steps: - - uses: actions/checkout@v3 - with: - submodules: recursive - - name: build Docker image - run: docker build -t tuv-x-test . - - name: run tests in container - run: docker run --name test-container -t tuv-x-test bash -c 'make test ARGS="--rerun-failed --output-on-failure -j8"' - build_test_with_mpi_no_memcheck: - runs-on: ubuntu-latest - if: github.event_name != 'pull_request' || github.event.pull_request.head.repo.full_name != github.event.pull_request.base.repo.full_name - steps: - - uses: actions/checkout@v3 - with: - submodules: recursive - - name: build Docker image for MPI tests - run: docker build -t tuv-x-mpi-test . -f Dockerfile.mpi - - name: run MPI tests in container - run: docker run -t tuv-x-mpi-test bash -c 'make test ARGS="--rerun-failed --output-on-failure -j8"' - build_test_no_mpi_with_memcheck: - runs-on: ubuntu-latest - if: github.event_name != 'pull_request' || github.event.pull_request.head.repo.full_name != github.event.pull_request.base.repo.full_name - steps: - - uses: actions/checkout@v3 - with: - submodules: recursive - - name: build Docker image - run: docker build -t tuv-x-test . -f Dockerfile.memcheck - - name: run tests in container - run: docker run --name test-container -t tuv-x-test bash -c 'make coverage ARGS="--rerun-failed --output-on-failure -j8"' - - name: copy coverage from container - run: docker cp test-container:build/coverage.info . - - uses: codecov/codecov-action@v2 - with: - token: ${{ secrets.CODECOV_TOKEN }} - files: coverage.info - build_test_with_mpi_with_memcheck: - runs-on: ubuntu-latest - if: github.event_name != 'pull_request' || github.event.pull_request.head.repo.full_name != github.event.pull_request.base.repo.full_name - steps: - - uses: actions/checkout@v3 - with: - submodules: recursive - - name: build Docker image for MPI tests - run: docker build -t tuv-x-mpi-test . -f Dockerfile.mpi.memcheck - - name: run MPI tests in container - run: docker run -t tuv-x-mpi-test bash -c 'make test ARGS="--rerun-failed --output-on-failure -j8"' diff --git a/.github/workflows/ubuntu.yml b/.github/workflows/ubuntu.yml new file mode 100644 index 00000000..8610eb18 --- /dev/null +++ b/.github/workflows/ubuntu.yml @@ -0,0 +1,35 @@ +name: Ubuntu + +on: [ push, pull_request ] + +concurrency: + group: ${{ github.workflow }}-${{ github.event.pull_request.number || github.ref }} + cancel-in-progress: true + +jobs: + gcc: + runs-on: ubuntu-latest + if: github.event_name != 'pull_request' || github.event.pull_request.head.repo.full_name != github.event.pull_request.base.repo.full_name + strategy: + matrix: + gcc_version: [11, 12, 13] + env: + FC: gfortran-${{ matrix.gcc_version }} + steps: + - uses: actions/checkout@v3 + with: + submodules: recursive + - name: Install dependencies + run: | + sudo apt-get update + sudo apt-get install -y libnetcdf-dev netcdf-bin libnetcdff-dev + - name: Install python dependencies + run: pip install numpy scipy + - name: Run Cmake + run: cmake -S . -B build + - name: Build + run: cmake --build build --parallel + - name: Run tests + run: | + cd build + ctest --rerun-failed --output-on-failure . --verbose \ No newline at end of file diff --git a/CITATION.cff b/CITATION.cff new file mode 100644 index 00000000..38686111 --- /dev/null +++ b/CITATION.cff @@ -0,0 +1,15 @@ +cff-version: 1.2.0 +message: "If you use this software, please cite it as below." +authors: + - family-names: Dawson + given-names: Matt + - family-names: Shores + given-names: Kyle + - family-names: Walters + given-names: Stacy +title: "NCAR/tuv-x: Version 0.8.0" +version: 0.8.0 +doi: 10.5281/zenodo.7126039 +url: "https://github.com/NCAR/tuv-x" +year: 2024 +publisher: Zenodo \ No newline at end of file diff --git a/CMakeLists.txt b/CMakeLists.txt index 5715ce5a..ee0159b0 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -6,8 +6,8 @@ set(CMAKE_USER_MAKE_RULES_OVERRIDE "cmake/set_defaults.cmake") project( tuv-x - VERSION 0.7.0 - LANGUAGES Fortran + VERSION 0.8.0 + LANGUAGES Fortran CXX C ) set(CMAKE_RUNTIME_OUTPUT_DIRECTORY ${CMAKE_BINARY_DIR}) @@ -31,7 +31,7 @@ option(ENABLE_MPI "Enable MPI parallel support" OFF) cmake_dependent_option(ENABLE_OPENMP "Enable OpenMP support" OFF "ENABLE_MPI" OFF) option(ENABLE_TESTS "Build tests" ON) option(ENABLE_COVERAGE "Enable code coverage output" OFF) -option(ENABLE_MEMCHECK "Enable memory checking in tests" ON) +option(ENABLE_MEMCHECK "Enable memory checking in tests" OFF) option(ENABLE_NC_CONFIG "Use nc-config to determine NetCDF libraries" OFF) option(BUILD_DOCS "Build the documentation" OFF) @@ -78,11 +78,16 @@ add_executable(tuv-x src/tuvx.F90 version.F90) target_link_libraries(tuv-x PUBLIC musica::tuvx - musica::musicacore + yaml-cpp::yaml-cpp ${BLAS_LIBRARIES} ${LAPACK_LIBRARIES} ) +target_include_directories(tuv-x + PUBLIC + $ + $) + if(ENABLE_OPENMP) target_link_libraries(tuv-x PUBLIC OpenMP::OpenMP_Fortran) endif() diff --git a/Dockerfile b/Dockerfile deleted file mode 100644 index 8f225029..00000000 --- a/Dockerfile +++ /dev/null @@ -1,51 +0,0 @@ -FROM fedora:35 - -RUN dnf -y update \ - && dnf -y install \ - gcc-fortran \ - gcc-c++ \ - gcc \ - gdb \ - git \ - netcdf-fortran-devel \ - cmake \ - make \ - lcov \ - valgrind \ - python3 \ - python3-pip \ - lapack-devel \ - && dnf clean all - -RUN pip3 install numpy scipy - -# install json-fortran -RUN curl -LO https://github.com/jacobwilliams/json-fortran/archive/8.2.0.tar.gz \ - && tar -zxvf 8.2.0.tar.gz \ - && cd json-fortran-8.2.0 \ - && export FC=gfortran \ - && mkdir build \ - && cd build \ - && cmake -D SKIP_DOC_GEN:BOOL=TRUE .. \ - && sudo make install - -# add a symlink -# Create symlinks in the Docker container -RUN ln -s /usr/local/jsonfortran-gnu-8.2.0/lib/libjsonfortran.a /usr/local/lib64/libjsonfortran.a && \ - ln -s /usr/local/jsonfortran-gnu-8.2.0/lib/libjsonfortran.so.8.2 /usr/local/lib64/libjsonfortran.so.8.2 && \ - ln -s /usr/local/jsonfortran-gnu-8.2.0/lib/libjsonfortran.so /usr/local/lib64/libjsonfortran.so && \ - ln -s /usr/local/jsonfortran-gnu-8.2.0/lib/libjsonfortran.so.8.2.0 /usr/local/lib64/libjsonfortran.so.8.2.0 - -ENV LD_LIBRARY_PATH=/usr/local/lib64 - -# build the tuv-x tool -COPY . /tuv-x/ -RUN mkdir /build \ - && cd /build \ - && export JSON_FORTRAN_HOME="/usr/local/jsonfortran-gnu-8.2.0" \ - && cmake -D CMAKE_BUILD_TYPE=release \ - -D ENABLE_MEMCHECK=OFF \ - /tuv-x \ - && make install -j 8 - -WORKDIR /build diff --git a/README.md b/README.md index 28eb9c4a..d2852982 100644 --- a/README.md +++ b/README.md @@ -5,12 +5,13 @@ Tropospheric ultraviolet-extended (TUV-x): A photolysis rate calculator [![License](https://img.shields.io/github/license/NCAR/tuv-x.svg)](https://github.com/NCAR/tuv-x/blob/main/LICENSE) -[![CI Status](https://github.com/NCAR/tuv-x/actions/workflows/test.yml/badge.svg)](https://github.com/NCAR/tuv-x/actions/workflows/test.yml) +[![Ubuntu](https://github.com/NCAR/tuv-x/actions/workflows/ubuntu.yml/badge.svg)](https://github.com/NCAR/tuv-x/actions/workflows/ubuntu.yml) +[![Docker](https://github.com/NCAR/tuv-x/actions/workflows/docker.yml/badge.svg)](https://github.com/NCAR/tuv-x/actions/workflows/docker.yml) [![codecov](https://codecov.io/gh/NCAR/tuv-x/branch/main/graph/badge.svg?token=H46AAEAQF9)](https://codecov.io/gh/NCAR/tuv-x) [![DOI](https://zenodo.org/badge/396946468.svg)](https://zenodo.org/badge/latestdoi/396946468) [![](https://img.shields.io/badge/Contribute%20with-Gitpod-908a85?logo=gitpod)](https://gitpod.io/#https://github.com/NCAR/tuv-x) -Copyright (C) 2020 National Center for Atmospheric Research +Copyright (C) 2020-4 National Center for Atmospheric Research # Try it out! @@ -22,7 +23,7 @@ a tutorial on how to use TUV-x. # Building and installing To build and install TUV-x locally, you must have the following libraries installed: -- [json-fortran](https://github.com/jacobwilliams/json-fortran) +- [yaml-cpp](https://github.com/jbeder/yaml-cpp/) - [NetCDF](https://www.unidata.ucar.edu/software/netcdf/) (both C and Fortran libraries) You must also have CMake installed on your machine. @@ -143,13 +144,13 @@ The TUV-x software can be cited with author = {Matt Dawson and Kyle Shores and Stacy Walters}, - title = {NCAR/tuv-x: Version 0.2.0}, - month = sep, - year = 2022, + title = {NCAR/tuv-x: Version 0.5.0}, + month = dec, + year = 2023, publisher = {Zenodo}, version = {v0.2.0}, - doi = {10.5281/zenodo.7126040}, - url = {https://doi.org/10.5281/zenodo.7126040} + doi = {10.5281/zenodo.8110063}, + url = {https://doi.org/10.5281/zenodo.8110063} } ``` @@ -185,4 +186,4 @@ installation and usage instructions. # License - [Apache 2.0](/LICENSE) -- Copyright (C) 2022 National Center for Atmospheric Research +- Copyright (C) 2020-4 National Center for Atmospheric Research diff --git a/cmake/dependencies.cmake b/cmake/dependencies.cmake index 931b5223..23e8a8cd 100644 --- a/cmake/dependencies.cmake +++ b/cmake/dependencies.cmake @@ -1,3 +1,6 @@ +find_package(PkgConfig REQUIRED) +include(FetchContent) + ################################################################################ # LAPACK @@ -36,25 +39,6 @@ if(ENABLE_OPENMP) endif() endif() -################################################################################ -# json-fortran library - -find_path(JSON_INCLUDE_DIR json_module.mod - DOC "json-fortran include directory (must include json_*.mod files)" - PATHS - $ENV{JSON_FORTRAN_HOME}/lib - /opt/local/lib - /usr/local/lib - /usr/local/lib64) -find_library(JSON_LIB jsonfortran - DOC "json-fortran library" - PATHS - $ENV{JSON_FORTRAN_HOME}/lib - /opt/local/lib - /usr/local/lib - /usr/local/lib64) -include_directories(${JSON_INCLUDE_DIR}) - ################################################################################ # NetCDF library @@ -62,23 +46,14 @@ find_package(PkgConfig REQUIRED) pkg_check_modules(netcdff IMPORTED_TARGET REQUIRED netcdf-fortran) ################################################################################ -# musica-core library - -if(${CMAKE_VERSION} VERSION_LESS "3.24") - find_package(musicacore REQUIRED) -else() - include(FetchContent) - - set(ENABLE_UTIL_ONLY ON) - - FetchContent_Declare(musicacore - GIT_REPOSITORY https://github.com/NCAR/musica-core.git - GIT_TAG v0.4.1 - FIND_PACKAGE_ARGS NAMES musicacore - ) - - FetchContent_MakeAvailable(musicacore) -endif() +# yaml-cpp + +FetchContent_Declare( + yaml-cpp + GIT_REPOSITORY https://github.com/jbeder/yaml-cpp/ + GIT_TAG 0.8.0 +) +FetchContent_MakeAvailable(yaml-cpp) ################################################################################ # Docs diff --git a/cmake/test_util.cmake b/cmake/test_util.cmake index e1bffb9b..e3a5b728 100644 --- a/cmake/test_util.cmake +++ b/cmake/test_util.cmake @@ -25,7 +25,7 @@ function(create_standard_test) include(CMakeParseArguments) cmake_parse_arguments(${prefix} " " "${singleValues}" "${multiValues}" ${ARGN}) add_executable(test_${TEST_NAME} ${TEST_SOURCES}) - target_link_libraries(test_${TEST_NAME} PUBLIC musica::tuvx tuvx_test_utils musica::musicacore ${BLAS_LIBRARIES} ${LAPACK_LIBRARIES}) + target_link_libraries(test_${TEST_NAME} PUBLIC musica::tuvx tuvx_test_utils ${BLAS_LIBRARIES} ${LAPACK_LIBRARIES}) if(ENABLE_OPENMP) target_link_libraries(test_${TEST_NAME} PUBLIC OpenMP::OpenMP_Fortran) endif() @@ -48,7 +48,7 @@ function(add_tuvx_test test_name test_binary test_args working_dir) COMMAND ${test_binary} ${test_args} WORKING_DIRECTORY ${working_dir}) endif() - set(MEMORYCHECK_COMMAND_OPTIONS "--error-exitcode=1 --trace-children=yes --leak-check=full --gen-suppressions=all ${MEMCHECK_SUPPRESS}") + set(MEMORYCHECK_COMMAND_OPTIONS "--error-exitcode=1 --trace-children=yes --leak-check=full -s --gen-suppressions=all ${MEMCHECK_SUPPRESS}") set(memcheck "${MEMORYCHECK_COMMAND} ${MEMORYCHECK_COMMAND_OPTIONS}") separate_arguments(memcheck) if(ENABLE_MPI AND MEMORYCHECK_COMMAND AND ENABLE_MEMCHECK) @@ -77,5 +77,16 @@ function(add_regression_test test_name command memcheck_command) endfunction(add_regression_test) +################################################################################ +# Link tuv-x to a test and add it to the suite as a bash script + +macro(add_std_test_script test_name script_path) + target_include_directories(${test_name} PUBLIC ${CMAKE_BINARY_DIR}/src) + target_link_libraries(${test_name} PUBLIC musica::tuvx) + if(ENABLE_OPENMP) + target_link_libraries(${test_name} PUBLIC OpenMP::OpenMP_Fortran) + endif() + add_test(NAME ${test_name} COMMAND ${script_path}) +endmacro(add_std_test_script) ################################################################################ diff --git a/data/cross_sections/ACETONE_JPL06.nc b/data/cross_sections/ACETONE_JPL06.nc new file mode 100644 index 0000000000000000000000000000000000000000..ee1e2d29c7676f1dfcad004d5c5b49d5a195a370 GIT binary patch literal 7424 zcmd6pdpuOz|Nn<5CL+=Ovb!FNIj$uudkxaXEk)9mF$Tk!8FRsuG%o3;5M5MCq&SsR zNlwvTN;(uJMY=1LP|@W$s#Cu`tj;-~-{gF*uP#i7fCovm!>wb~Frj;TZtUm}$efhxHqJg!I* zXi5m>;Q_R2qM&~_OPO9WiJYr4z)ss~k(HD25)&Fs585g_?LaLB-SamUBdjI3Eowns%TUX|azm*~+9APj$ zh^2*%nU(ciVYo3pQxm2mKS0121xq;M5QQC+Nie-wo-D$PBMjt8Oo?TzWh`QWgwG2U zm=g0@?kr-VND#;qniB3T7Z%|vmnZ}xQ(_^@l|{IVL=ssrM`lVaqI-A(0Z(GKOdiM! zGbKD(bkhpHYDo^Nh|4&Ud}#hCay>r z$X88CYC45bY0jcGR?xCpT3OHwwVZ2aX>CmyTg;tnYhub|sz&_Rt444|yr3XHm#@-+ zP&pwB;SoY!6v34T&?W@&WlSbC_BJJ;31Lq_J;qn4`{j>Xfci^udFg}zRr?!laev;)M6}^H1pVF<&e1Y@`w$5R#1YA5QhvX3 z^jQBLH=Nd7!RHAA>C}?&1bj|_fJgjCa$^(d6`1`m52k<<9uUZ(w`VCoI9$d4!{J9k zMaO?v=u9G*gt0K(MAd4{4PR&3Um}cM%`65=s&-d1+}wYctCWlQ>-zp8& z;B-6vtmU!}>v!=r6Ft*qHv9O3ZA`a?Iud3i`od3kY0iWBOw%F|#qt zF`EZC@C{|K!wFnxWBOw%F|#qtF`EY{><5D_BygRL>5r+z%*HIoY#yMf9}KpLz;!mJ zKc*5h8?zjOG{_PlSi9W6qnC6&lOixUI zOfjYsGZix%^9*J=W*ufTX7>Q`4;fpkkLv`cIVKy^6Vo44jH$#-#mvS$gISJQhuMtT zJ;457NZMzaKCTm(=9p|uPfUMIF{TnT6*C+23}!iI9cD9T_W|FR$EnFNk$Hbv-dI0^E$ z7Uk(5uLCDQ2Tbc-1qzf_y6L|efRooYJlYdo4GOic73`ZE2hRAsnBtZb2hR3%YVU0J z1x3|C=I`9zf@1u934Z>fQ+cg)n>Q%UAmm0~JU|&fN|@vL5R|WZlQRB<8Msm$T^)Y* zAgCbyLdoX>aIJ0AEW$VoT;KhR?;Y8CP_?wT=KZa;;D*h%+K=;HLCtQ)lG&q*!L4%| zsVmAjpl*x()|%g6f;%`)eam^~u!Bp$JrB^9@)B{1Z`Eb4(`9-3SMrEU)>it5xjEvbc*wJ z2xuQ1^7Te~H)y}{*xhPY6L^hv?a;EG@OZL4=!hGAczo<{prfOCmv>zv=;T%o+rwgj z&c_A28g|5ht_2aBbe}8&U1<4t54#G`^`#05`ElS4p7(!oteRh}vKhQ#w%(4ETl{k$ zuK#$x>&#ryf}ailj^A0E{H=CV4d`^<@pkjbqoAYagmC`F8K48}|GF&Cz362fc#VB+ z-{iiL*%Jm{^|}eJZe@d4OAY3Q4!HncCLiun6V-yYmw~1E@0`F7eOk?pL(w5FXu*EJ zSbeVVy5%(Rd><@Wdte@D&Wp@{{A@mWwmCyw<<|$E%6EIt*_jI-cb)t-Xl*@s^wY9i zvhR-I0iH*b6?N*xg>RtI)AZzX2R(4FK&Rt--!pJm?aj=I=L*3c9Jg-RO0DG3P*A&Y zh2GxWx8MfWxq67lPOnva!F89(aQHkfsHj+VZPFqKa0Tae`HZB}nvLT@nZ5t&hDK-b z+quHb4`XJ4;+R7>#aU6HDCAe}JN0Scj7YB`x!CIO_vD1Y`MAM&1accTGE;mOf^6J> zAZLXvW4{pW@%1HB;{+g${O+LKW&w75yzgjqm<5uiMqGT-xd6o3nRq^&qzht}@6t1B z?*&ntvO-Q)x&z5&jl@STmOyAA-rlNP1wu9$xG21nL10h{sdrrtI3pA{kJomC)v1nS z|JZK?e6-d&4XzmlmL8^}`linS?vEE{+1wU@1^Q!p=R1}FM+?-n_5D{cFQo0xuW3oZ zYRu!_vInQY%*HeuE5#IG^7QlR#5^msS)eQOc0GsU?>ekDoKlMvTdrHiHo2qF$sIQ7 ze%Fv^=vj}e8Xurt+qw**E8QMe>JG@!I9=y}qkZAB)a?pLb2!iu*UW?Q0!3SHFL2Nio-5b^YoWNaZFNU=u6XdM zKr07^oigjbH^Kn&M{pjecbLIoj`JRyq?<74k#5t^_t(MT;TbWXXXL=(F};7@h|7dQ zx?5w>lyb=3J^EmiEr9-p#hJhOr$OI`SA822XTfFJT{25G4e0t|!%jGQK6GAv_I@m* z1hNfX=05v$7+Sx2o90+F2u?8Yi#2R&K*S`AkHY!|$adcBS06IVk@N6pU%eF#XvubM z^{0$_v^?d!{kB^!XtmY>b@}uK$Zz%x(@Rno;uu7J(I)IrfV=kLVN!p@-RrWloOc27 z<{T-A9We_9KesGi*Ygbt2CwGcZGDHt19^!g{f}89Y1@~GFO|=b?9bw@Eg?N9lKr}2 z+>&+_oz*jn)m?~UvQ~{=@3I&v3yf3|QM~Ow!g0?D6u-c>T5b}J;&|?yb2*!k^1=Nm zmrJ%N&h^lR#2uX|e$BNRHWS{V1n0pA+&?N&LiY9ZiTA@$LU&Y6`J8lw^A~NMnQ2bx zzCk+<2K8C3osM=sUvvD%ph~psbVF+SX$_Q;c%xy%@4YDX85;q|%X_nxo1)R6X)ZeUdEd~`@@XG_S!08SJ5R2faibC$ zJZsFTISJ7SFwR=HFCC3YDQL{!Uy2NUm*!m>wh|d>O?$QHO9L|etULM6jy_~)ZJ2my zO*k51D^Ry6ibDn=0io&}tRF?q%aMNB%e>N;H<7;Y zy!*Ymc1Z8=$@*EVqtP%waO`@u7t*zH9y~wzBGPeO-qx101r3#b*|htd3t|=(D-Qp) z1~JvFG+$QVLfZY?4HIeodBZ2~o<7pr#=RnrwnbVxX_jv&Z8T)F+T*^?3^YW&u7k>R zM1#{qmv37fiUwOx?A)046=~kP8yE3#7t&no=X2szJkq$fcHSX_gGgigSL%LO8X9zV zPGyJ2UNk82jouuk91YsF%>I)692%7T`B=@e0yN0UxH{+N??^rW_Q--^O-QZ1xga;@ zJyKg(_j!>1eZ=^f+3k~2f*7BAw#_doM{36J=Vf*3A~mctwC9d>F`$SOW8!@XCKB=pWW6dzDX}qeLbTdUY^dQKF{}Pn!xRdab^*w{ZKsnXGY3%Tq!WUl1m zbH=p^WOa6`de^%ZWTPme>!9rz@`)$s?667=vbiYtuIH7<Tp{cei{}4bu8^Jm42H5 znYMO`%pe=6)m8k*g8f&Z_P&|-_@BqZp$c`Ewc`Sz&X-+2^Eb1huG>hKVW|hy^{M}~ z`ECZ(n|F4$)7n00pjJHlfuAyW7KRo@{&(}f&(9p?DYC0ifs%> z8@Xik9lZ+2OyNC>F_;8L-+j&>u73oM`b|C6YvOY_vb4}4A}|6Pc4Spd>@$S=hl|eF z)+a%Y+ha9!XFexCtYehfZ;c`!`d1iFncPI4oi2M}Sz$so?rv_Isbx+5dG^F<-*kxd zS7wOYt~()Oc;%PL(znRO!X&&TU5U({t2ky3@yH_8bsi}@gMN;WS&*}#98IqoJBjy4 z0~$V{7xl5Bj#2bb7mew>7^RWvh%CgRH8ajI5F({k6_#Ydfhd zuFj~vUP3B^uBL(Ya#A^HLR)1GkBt4WT334(hul~~enX$vkTEIc`&Z4HMs7F)dh&;c zkn8W>HMknGnOr~8IJf$2JgEpi6jS=wM>4wU)aCe)mt=JC;+#phddaA-l~mC$f09v~ zTbz8)ogt$%In6_j+{nls=zP(eCNgr`$#5r)JEXiuGmaV|CFK#{DZt!B%GKO<-H%yA z%4CA{gUnw^Y3ul}+;u}qX>3Sxck%&Jx^Dd32>~9YRCr+J;Ek(Dsgz&y{dPMk#kxpN z5s`+{DpH~$P5NuL2^q1WXhi8yHW>kK_>QQz4WO#tqud|*0AO+LAvfmhVlVM#}7WUSQNP*YF z=)wt0NWpdoTTabQGOQ}fL3mq(0~vkifx92cNn@PIihe-) zW#&(tvNV)jJMHI^*W3wVX(O6E@!>@R7NK9LgQjuMhyg$ahIug@So8;#nt zd(=tSnS48!+3}>~_cJMWy3M4OjmGG0M~9INeru)w$Xsg5kqw*Bfhx)@^7x7|dDke5 z@hSixkZV3CnRL=@u8$u+2gk*c~FtY zH$K_Brc?5=Iqvr~tSIThPv*aGxkyRO3L7i>u2YgibGzaDW>PW^tD?9(ijtqM>S@>6 zM#+o*w0{^ zuemnwIHip0&YF7Ejf$Ik+0bTsAr*J2vxU3Jfr`_p+wX7iC$-6_WZDCT9u*U>ZX6Ds zsc1p9`e-vxO60m!Cq@4wc?sh05*TrsKe$rN6;4L?<^Sb<_%AXw()RX@L3L!V?%Lp;(P?CUox{0Zqr?9n Dfr|zZ literal 0 HcmV?d00001 diff --git a/data/cross_sections/BRONO2_JPL06.nc b/data/cross_sections/BRONO2_JPL06.nc new file mode 100644 index 0000000000000000000000000000000000000000..2da2063bb2ce0890587915114a1f621c53a84888 GIT binary patch literal 6156 zcmZvd30#cZ|HsG9L<)87J+c)wErdFcbDm23Vzi;qOw-g%%~CVdW*uA?*|OYAw#Jrn zi4a{s#@O9ZDU?f0#En9TWXbQDc~0?r{r~fNJ@bCP=bZVT@Avclo->})ygRX&51U38 z`so@YmMLj&r5|<@U%{6ORYHYfgqiQH5=xVV3ce~uA!J5btlsooSNiGho}v=T6^5m( z&h#@NEIfjk##ix)S#ffORHz`FIF9sq4}n6+R|#X=*Y$UHbe?GM=w$CSg>aha<~+%5 zqLX2+n@X&b2n}zHzk!|#xl&0eg#wjWE+hUYx~_3z<5I)E{bz+ndxT66p6(p&&kb~( z#8IWI3_eV-A9fl)RVWe4;#DHUFsoeyLmr0rZYeUc3MXgq*I6c|zv=wwG>hqJJNn)7 zCmo{yClV&spM4s9bP>fGg`wZOY;blaoLroUj*mnv6B6<`B2KJOs)$&FVo7qbOl3!? z%H!donp@H3QhnLSsmQYj4~(W`w^#I&ynP9TSvu1FNq@jOxQ z^b`rDVgapc0KJn+EKm}376ex$SIGtKQ^uyHdzJ`S3JI}{a92s?$|R9cAr=s!s+3r< zP{|>@Qu&e;zOfa9Q=~D5_I9ED+Yz+b1UH42OTf%JPO^8VM};batB@z9NR)=|4dlnj z=|agB8Fb=&C7+gyPR39k4%<^Ml?r7lC9QLN;Rw12#!ad`-t)Q;&7c^ti( zFlftT6G_xobCo%iV%YyPL7Utgwv$St`qE?CQWg4By5~qU0rPL3~t%%pUw** zkPGAD!~(G)N5UYpN+kSooW=7Q+33v-<3Il}R+uEDTTUhr63)(!_Rg-8hyXU5NLSi~ z*%DI?q=#&YC?{e(;qFA(gc+9D8Vu)lW1jO|T2{jiU^spPslBt|>ia)uzNlvI))M>Sd@gqwi;8% zkhz0cl$64@8dJwmW(13pQP@^v>KMw6U{P`k+iFZ5!z3eER1$%03X_Ma#?)ZyF!c&RGi3fZSd@amHigN&R zGc^81(DhXj*rqUfm}*Q7rVdljFvSQKl|o>f!sKD9F*TSvOg+O?BUn@_fo%$thpEQY zVCpdS4AYEYQE3FWDNG)w8dHO*!_+fOH-bf_6WFFOd6;TU4W=rW#X&sl(JWTw(-^ zT0&r(GLnp*)2;3}sv_rzk}p}cY$j)`YWA!<8caqk^;_~Ko=t{kFE4l#|D5C=c(ZP< z)m}2VG;(-cg+Cd{y=&cH$R+)GUm8t>b)=tV;;^VVZ_?++Kf!;-<&oaktpp>6m6KkV zW7Gb)(@IXO_O>51TtIr>S>wL`?po5LUeaPd{3Gdp%OYXEXAMbhA3@%`x0Hm~Kj}JU zY4=J~(sjS()7;7max&zsif$c3PQ-qk_iXLoAaW!f@$c-zvij^Qup!4OA8RaBOUSW1 z_w?T6F_IiTskks8UP6ux*e3F7$R$Vc(yb`Do+NB;bltwVh8*?;RK6HeL=I^glKC{} z4LLYLdeuzoL=J4)SLEZ@m;B{R|E$Yv?8slbEtk08@*^#+?|u1ucqh^#)D%T73MU8r zVLRzV!!)vgc7X(rioNzfwp+eEU* zjDBQ7k5goKynol`9sjYJ7)W-(`*wbMl5M(UI@t;D*9q^(0tLnU*QJBDZ<~2bK9+)S z%zogj@|wdKRs{Hx7#fj1p&ERSdAzuH{A|#=@%^oz}fM!i!7l0h=?fGVaRz&)q;Yi`>Xg1hqsfAW4C2=3(fe)+xiF{pfhYFv&q7gWON1XwEp6$xdl zOQ+rew~NyMmKN>+x0(8Y@|9Cp-Msc3l$*}(xi%pIl*LDJi+y*1QXJ1M9oSISDFNIp zRcwgxR)QNit{Y6BfD)J0x0$8eGS5Uj3f-J^A`haOK0& zfMcKEgDZW@MwR=8gUh4LH(G6GgG z8=T*FE2}zf7C86yNLh=c4LBRVzOO}n3pjIT#n?N45};UnMY-8}2{?7B+xZ#Uk3rFp zXKhI#1>nTF=`*K$ZUM(}-pAlcdG8Hn;P7bYyx%Wv2Kl0Hk)a2oL7x2ys^9S$Aoo3g z^zHMW;J|HCTmI-@u>YF3iJ3VBdr!>Tw?3r-{8k7?%-D8}K4q{yWcioyHEY+Ln-pW6q;R4E63<@zE) zr`TUje;JGf;XaX0`?W}b;}hhMa}0Opci1tFiKQzh6n6OIH(d%GoOu=T3-6C#qF;mf zI8R=h_p15pgeW>-_!G~Ft!Uo#)adFXhtXWyhl)8<8pO=}E&- zPkZFQEXGTo@(=RARhx4$ZzT$neBwT~IDoj8rRlrVrXw!7e)M&-11NaFxo=|}8&SYk z7ZBi(kAfeWZ!0M7+tD90u#Q~4^?)&L3N&4};b0!u5^+yC=37kGp!WHYtYVvv z{%()AJ$`OXP{rH)ugLpcVeY+cZOBt|_2jQriO9DP`8~F59SS^KW^*kk4*Aaa_idF~ zBG2ah%sinfa_@Akizp!op<=u7RUfR-)PMy3uKW_@I!>8vRu_gQ;(l^zo@Wwl{t!)d z+b90|{vq<%GSe+1eG~GX%t=W7BN_$Iy#FA-=Uz19LCGH*56(qlW7?84f2%?fbhpt8 zqj20`?Yg&*&;7D_brI3C<2=RrQnkrBYLtM_tE_lN!;0a>Na1FCEhD!GrKGMd8F(%Z zrK63{z28Ql1z0EbgyC+B4sp@4JWus1?oRaU{92!a0SnNo&8o8ri$9~x9Bu0Lldfnz z_LqhA+9cb$Zu(=O{o)xS9J{xh_RG9+GcV37(tgS4>_2x%toGCWhHR?9TlnnFZX&Bt#o+_Uoz(ezPPcR zDC8z}=aJaLJokn+C3&m z%Oh6R!?eh44qI*M`v;AJx11ozXv=}u%(pE3JZ3M{?d-bj?b;N0 z?HsS!1_i;4f(@Y=fn9>rAS1{o(DQH4ouYEvy{R>RA^) z4&L3r^n3HG5Lmsth8vQ189pejU-7KwcUWWIoblCU z$E&wd@Bp(PJUQY+bD!m@+U>ncO#Z2H)n4!^|J=o_N~^_j?(1vevc|FxEIIsr;iq6n zSfNTS;TJE1)%|@Own$xI&5+B7x0d#UdhGwH%h~d9X%f6|bt*sSrYXFV*3sV=wu6noq>``B2 z#@rXkEOVpw{*^AsoT(S;xAe)Sqn7v4fIgLNgHqljOMEX5s(v%5t>7B6a%z@Uc%Aq! DL^IFx literal 0 HcmV?d00001 diff --git a/data/cross_sections/BRO_JPL06.nc b/data/cross_sections/BRO_JPL06.nc new file mode 100644 index 0000000000000000000000000000000000000000..5ad156c8a4f773e3b51b541d4c920e4dace4e252 GIT binary patch literal 11768 zcmeI2d0dp`zQA7?)^Su4Qxun1DMcN|VOSjChYicHFXMoSRxkrIFe9_j%sU8`g=J=n zMwa^$WGYtnp>wWVTA`I-rI(h|#U;ZfB{e1V6vs->^UV8u#bf8*dpw_W?&to&gUpxr zS%2H}d*|cxypWchGEh8H?CIyn2;~-*-Y~vKjtz&lEt;8|maO%Z{DINoNcQ zpwBBr^pj!Ic<@a^V+8F>N*)j9gU5%jb&Eex>ESVyR(g7PcpSo3fuf;w{`w5y2mVf^UaNm&Vbc}yUwqN-3?lhd=+ zIeF>1ImLNN30Z1JGKVT8V!ZhQISJWncYhW3&o`N!EcvHrZALCBIfXTttwx*EY`3u` zE{?U?xxS_36PdZbbs*DaQP`pA)WF)i4N6KPka;eEs78M^Z z3s=Y#(++PH@or)6aEm)?$asPOm|GZT8oFf#8B2@c7O#JuTlmmBj-hAb*SR-iy0sdF zBkw@){QPIAdHE%BaCc=0J$PgIjHb^XUV>@Fm3oKXYUGHe7g3Xwvc!M(Z*DjJ8zYEi z!ydJ5Tq>PEM`;6Bmq$%GyPX%OGjuHtRG25tLK zxzBCo0d(Cv%5U2q()IaH;>$PPm6?3T(rOPc^b;fDj8?L3^qk9KbSCmij`{KF1xNq= z-jg$Rb-sK)A9&}^6B407^d9>V+3K{Yn8*Q4T(1 zOGs#m$Pd0=TsAYur(zmaG~PbU>9-Tb19Y?})tUZ5iV$jdKi^yE@jjNjXJ?o-=p-TV z{)ZO;d6(T|;8CS$5hw`Gi*N*^XD;7~VelCro6kNtuP@XpFpu02I`eb+xMS4Ai}we^ z1eH4MPG_;xSjv&tX>ni5ufUjY%=13vcE%(38hC;d0^I^&;87#q`Ao$*abR1=oq;H1 zVnI}ig%8BRjGTtPR-K~Os&kUm#qQ9LCd<%3Gw8X0IuHe&1(RKjNqzqBNfd-JAbFAo zHrDv1PJ3A}r22oef`@p0wS3@V`y-SH&<3zB=4m~GCh_#~0@`^cC7QkCH1Om>I+ z+Y~XQJJ#}N7O=_0aBN|j-C;F4*l?Mgj-vbCj~`X)Fp^wpa1WzzRVtxEu80hihlhpB z+3=`Xc~oqaQWC+N1otdw<}60{m>?XJMB|Occw_tGO){CL&D&o}%gi{A`joC!m{**r z%`MK*WXYptTs7C*ofSf=`^*1N3#2CHX1Rlu`i~SLV1;+O5Sv1v3-!V`P26Gbw-_BS z)C&=(j+>1^O+}Z-IUb^jo0c0{s@~w?MxI`Yq6Jf&U{5 zbUmhWuhfm~MKTV)-VYgo3_`NVP^28GM5>T!NDZW>US1|eBwC{m78B2~yVqy|}t)FDmCN@O*%7P%N% zk6eRnKsF(pk$aFW$Tnm_T=Udyx!>`Xd97K}Z%Eij*UjNEI>-sX-PZbx0Gk z5?PI`MJ`6xBiA4skWI*D_B!RyO7<;UL@l}{gDC4AS8EUC3@^FOsQ3{gDC4AS8EUC3@^FOr#u z`Xd97K}Z%Eij*UjNEI>-sX-PZbx0Gk5?PI`MJ`6xBiA4skWI*D_B!R zyO7<;UL;eE`Xd9XRrC;pKjnHGk67KOXAHwg93pZ6AR-4X?&~ck1AlZeoBR(k{moAs*(_JZRb6HEsX@!0Yz73Yv^ z4zd0v4!hNCGqP5@&0cLb7{&ZSN$6~&-Z3fGpPW2|Ddh6#Q2H@RoZolA9_z1&QD%x~ z-9EHs9eP_inNgvPmPLg{D5GR@n>CaOHA$RkF0q*H;+YZP`;P0@j4cr`r+6!8IyepLmd_j!vN#+TzO=x8 zb$T4Uu)VD=G$9gp`ObwQGp51W^*&!6zor7+lS7iLmnq?wC8K&DZcxIaYl)I@V**$$ zm8CD<0th;?_RCM-mz*BtVbPC&wbr$AI&NlZsbAiHF2n+)?es zOlaIbYWBh_NighmP{p6)rbBtI*DFs)0@Sr^Y#Y5z1NPp)o;PdL;btAP?`%f`MCU&8 zOY1R!;)I^<2g5TU>)f!W>WVyAbjHh2VCd_YA5{3q`5RPV+x(664>Ap`O22>YsL8XS zYUgVgJc_cR$YaN&(F2pAeb1QxT7F+5e6oZqeqEgo55D(v&zVt=fRC<6eCg?#keRkk z`|)#`aCzawPrYnNhStc>_LR*^g7W8XJyF!Eg-7>#yj>KngKZ~j8a*z|f)xwCUGDQv zF06|STRHG%GJJk?LAdHf0<6B_DvyuX!q%f#mVR4N0@oKzZE=+qfz7XTPvUp^Q1A12 z(?{}5h;6OydG~N46l>+$jfzCb2})|2@Qw}wUXu?jXfuF%=Z%~UQ4tJ0ditooG9MOM zKAL*ztt_ZI)cNAcA~ig|**8$_TtgAVO97YgTfY|1#M1Loz`IXB}A;H$vP zQ#ZHe!nZ}9^EMWz!vtI50g*fv9#>qh|8!U;)Gn#MQ6E1SM)dx$^W8!QpsM@eg57&FA^PHM`?QcW7(8fV@Re6Gz+AOu)qq=hF!@1E$U{wKP^7AD zdupW>vh8UzXJ|@c%!3o+U;4ZN)~mFs=MH7Tg1BRC?`YKUesj&b=^K;bG3D&($}PEY z$)i5fM^OSj!TYq0fmSFOJ>QsbG{Lj;Dw5w!)4`NWjdPE5<-?ZazAf)%WP%!Mrqu6C zgzTHrFZb)G!*jj|H_!Pg6&{%Xhph#@MtJ3ml4q@7Tj9R>&LcCT%iyQ+AGO{ZS_EsG zf4LAjVkTUfw7H=9pN!nmtCXgYc68TGUI5L{F;^n>e}uzpzOOn*xXgeS?qS}`~ob|o(P zy7etJgnTxmBkH>h=s9`eLgCUpSgarYjb^S6HZ(SRp3#(HT$R8N+>5(^y;TU~gMakD z|BGCxKe>9>_kT);#z)^DcKxMzketz#E%k^4&yXuSc3g@FkF!nsajmIvKA~k{tBOU}NV+*$OY&!U?AF`$4L=q_W+Wc-F zQo-2CnODo#O@~X$-{M4m)8YA4-|q7xr-N>p=CXFV3UYIsTSK1Dg7j;Z%RY@Lf&cV< z-_Lfl0RF6~U%sj)9ft1I?po0_9p{(FIRppNrS@e?Dfj?$-rek zv3=bs6~yjJ%;;>3y*+dB%An6z$8RoREpU>p5;c=He?e6V!?oY(=;=x+sd1za3( z@}sFR@jjQIGAyEZ}IM?DIj_E_`xFY$&meaFqio2c-Wx4 z9B-X45}HbS4{v&67~Fc}@EA$bPzZc|XqErfA@K2r!5db8Hw0wP72Mk+0-!l&V7ikG!8lw_f1U-bO-zp*ZpDR3d>*4$Gw^QT*2Cd*W$cuR_%vz4Ez;9arvwO literal 0 HcmV?d00001 diff --git a/data/cross_sections/CF2CL2_JPL06.nc b/data/cross_sections/CF2CL2_JPL06.nc new file mode 100644 index 0000000000000000000000000000000000000000..f84b84a8e346c2990cc4c3392412e38bb2aa97e7 GIT binary patch literal 11013 zcmeHN4UAOP6~4Q(yX-zjpom#oYPp3b?v|P7%$s5VW)^mso#khLVfd5Uu5V}F?mT$& z-tyj?RfyItG};&Y5?A&-u=G&V9Leez>f?;~MEJQh9YX5#=LZDi^St5N|m6*R`8_m$k1d z_y4kdo>%9qkY!A;CeawdzEILkkl${t-Q%f$O;cIfEUYXqD=Yg3Zxzxv z3+MmR*XNEeSzAqN?}T2Jo-IBJm-dmP5*zq9A1^Gd{LdD8aQa9Usm8gJU5Rv>Tnod| z6x6kSd3UNOy}Y-lKb=f;rHFq68ssCDY(P(DF+x5Jjy##bv6UwobFMrsZ zT-NDNG1aCq)%tsqeYQ2M*{-fRo{saNGukww*{D#f5&#`x_SUG}EQbQQ?BK%IupCxo zrSa%be9SFmf?GV+z<41q&n<*Ba<}Y)u~>v#Dz2Ve81+tZ>gCuvR|ckM)igeGf|zs1 z>TL)wTcU?Y*9y^tfl+lmK9^MpXry7)R`Z$*NZ*B!L%FBsrVE~%K2HYGFc~@f#QaNr z$8;d$i2qmLO|8Z-AinZ)kqyu`40+)`-}q#rhmc5OjK|B4Du(TkIJTe3eICkFaoq{! z!v4j#6n*EP!kQ*!rmDGET~@*UMEtInhp-ub=bpTGA)WXFyvYcBPk zNQ6Ri@6p8&>R8%HbSjB{1oW?*hT-Y^CacG`eM_rnqV$!Kuc0J_a+Y3(BNN!)M`l4b zg6!PSvr*Er?5u98E+m$ZZ3K|J`P}140w-YZUCrSK{(FVhwsB28%3!_Nz6d#YV)4PE z_in9W!`3n((vXNe9{NPORUOd`%^Y%bz(23NcJQSmp6|MFkdI7<><-oxQ+wC)^lI{D z=!;pu7XDBt+=wO{<2~~nf!|+$X!naavq1Q7-iBF3*bmh56$7DQ>Ml#g$SUMpCjTA9 z`MX)CI+|NtdVJ3y)u<7pApJy*gpJV6D?i?NddRaC5)$qsJOqm?)=1-izclkKg zJZ6=n&1@bbs5bfe%BaVDOuYyrArHfSC#Pi4n(V5Lv<#DvEg874x*%{k%oPI~kxUik}7gPQw&gr>thxd5SxcN$n zCyWr%Q-Bi>nLhCu)p_Ol{U;|9QDkDFs^4HloK8YW{Z*-s)T&fZGS%-aL-AV`lR)N#q;le4|Ca`Gc4?$6rbZ zbv{n4wLaaS>`;uobseAzuSeoqZ@<@s?2}KZA?CFA=g6N`N zylIN9aB{t1xTqKNuvG}Tf4cZqk|hL62$T>gAy7h~gg^;_5&|UzN(ht?C?QZnpoGBx z1c5fK&0A-b%P}s=AggcVa+J$4F3AvY=W>+GF)m4tw{tnlImRW)^L8#rxg6t?m~D7y$4+&B#;+7ogcbjz5*)7i z;9$|a&dp`nQQchO{KGzyk&W%W$X0120XIn~tYcz1S$Sa*}A z+Vw3pa3B{{LLsFNKkB8`#jB^58l`z*P-$-Jl-7-3X;51=hhVjEV<@OZLuS4X)UKD7 z=mUms4cY2&ZcB?KrR6@Erd2bm*#WvrUM15GTi3EifVRusGF@sJSWJ=uQJdh7GeDC#u+uUI z_=Me-0arr-3d_?axI%|+8tN9uGJ}1(>pB5?cvmu~<@Jne&`uq$p!E#gmqYKqoaI^> z(d3<}!jURn<7iYjX~NB0&TvkHpC8b)Tgbw#woFqas!>q!_?`AJzlEcRcY!t9FsMv> zESUnrw66g8WLUqD5>yrjDB>+kNh=T6^R5G+2~T)Lz*=Ah%nL0DcDPZYW1HG`sh+1xG+TpNy2v}^*i66>T7X5BP!sJ8%){|AT~aU| zxC29o`f^*~6A_nbQ#e4Qk;Y&&s?fS{b7NzD0L_bnc}<>qc}+Ee`u{)Xp+6+4PX-sI z^}Gd)ZifKS4a0KPEdkmi)3qwl6Y$sa!EUW!AKD2KfKCMFuG1Y2lfe);a*g5Iz>(VJD4?C*ay8i*msr?f;2YP(rgU)53_Si43IL1dS+BFe?(9c66OZi6&BY#D50huLxMaRVr3 zYD31H2}3)rRQT(kB_db1bP9pwZ@_57Mt%>;J_80bke_LDprzf86 zJ-WR$-g@`iZjzux)ohNCn-=Uo2} zpI?oKK%?2Fwo z^}g2Mxevrn=Ti&b+jV!W_w`(fs>(4yAIX30y87I%*pvCr9Uw1%{d@FX% z+*5t^Eh}TYYLkZ--P<0E$DYt{%rwVdeEq5BN6Z^z`*$ALb7NsXHs0HH zclVqGK`~GTN(c>+qBNqaT3QuSN?IsYRaK}4O4|rXn~1bcs8m{|iWK^xNc|_2D1C2d z#x@SLF@h>mZ|u8wGxKKVz2E!I+tbW_d0l7MRniivw5p1Ta*>yN>R3yNcT{fu?du!X zbqc4lgpyKt#~Bwc#QHuTz7w*J3DzY#qo@ld#RU1;-8Bb2^RH?yDOrq-r6naLH}hU0 zeT#Aat3SPLYRQ@^Qga_@m3zMUBwX4@j!10alYG4Ju>8Y4{4A>aNCm0Fx#PXu`OLJTWW3+D#x&d2HOI5D7L?Jaam_}9R!0J0Bh0?KL2i*lfm|lrxH>F{ zBXVTbk?;6eSjdd9c&vf(LS9~22wBC$vJb{$5n(C&_`<@dcZyRl$JUt}n4VYj`N$dK zQ}+%&fbg;26zP`5V8kD{gvJ@pDl(Y0Q0@;rGKC&3H z5oG5fo{i#`WoL9#bs@35??C{$o6kL!Bya*2-a!sO@ZT$}wT)ZqQ3l(^Nt8eI09nGCydg_@$s?Z`vLHdCf2_HetE8p7ohY`uAnfFFp19nM4$sSeWWJ7!enc5K@02(UllTB;$!8kNQop3=%D) zx*wT{!e;^5*_O2reUL?axq|;5BsOlwkIN!~m5{TyhOkf&!$M$VP=T!qe}Lrs=eUmEZh4w1u%MC8{D*+b^>s8OV+aUnoYxU$Pc4%-&e6wXWP&gP4({Q9U+|t^x${%Hr@ICA5uAzBjuIFRo$T!OQMyL7a4`SM! z`cj(J`8cuGmef$ZD;^FF@FkG~YdDtq1>|G!}6=e~DA_7GOiU<@DC?Zfqpol;bfg%D$1d0e0 z5hxaY^VMlcrKn)K|qAfJq#P3>BET>uBc3g_*p48UTaH|oZW+6Wer+8L& zX0s!uT)U9QE1}lvcvmEDz=4_(se^Yo!Hd>QNx1E6trl~K1K~g<2shY9Vv zsyPCShgU&YW5~?cfh+Y=hdylR)`+c+<#x785|vVNzf4oAnbGV39gqiP+GXon#t6_( zxlg8REhD3u0oo^b%e1Fp?=&n_OUQIxLDvFwv)n7w4fd!GI&0+~nfAdgkUOHf0osm} z4XER~1AdLd&1ZndabS;S4D$*5ECVi#0u+{~9k@c5ZW`)N$1;Qcy6ZXt`pUj|PRr|Q z)u25(Tukd}xJ3u;{+#7nY0>4Kw8B9v-Q;LgH)*?@x16z@20u!mDYuY;yKb2###N)B z;-NfEvS@}IUfBoUXk%b9OPz10GP()mo;#M9m?Og|86S45 zSqr3dth`2Zs$q?2c)^yTaEpv=VPJ^Qps3F9TsPsSS##V#Ed^+&5R>6(IY3*Y!Ek65 ztqZp_hw1}TxVgcz(i<~o8O(p=yPMM}_z*Pn6amzr?F#ilLSis;o8E73zYL(K^t=Tu z?F3TmhGDtt&Hzoybh8SS0|d2vuum)4FFyvX#)$y3+jK|6Z9nqivGFc@g8cB^LA=;z z4tjI2&wRU2hs>q$dl}W8qUg-4Wfm-tz%oVd%XC$MLa2h_XrmXdW(b#bC3tk%4z+8x zWm>q4X?q%yYCDZa8o;Sw;|!0&%}v2bbk<(E65I@4wx2+m|G&URqL?IE+_W9Q>#6L) zlZUtOD5f++<^=YVp)5(kITp!K^TQd{d!Rb{NM5CNcvoI8(K<6*_`?6KX8Uw+^RO|chGG@a_WB^v8Ko?W{2s2qDb`%LoGYb#<^ zf8BquvZOYad*o)haqkkYw$KGfFJ{bf|XyAC;e&{kvDTolrV1xS&qLV*X z?r%A8=;u|3m0Pb~IIruM-&TmcfBviKC%E3@%EKeqIPbmwkh0^SHQ(Ly?iZE9FBaVT zm8`4mdi?vx{*p74NcUS`DtmEQ={$DgGnq46lqIBQbjL)$^3y$AHZ>eiDEIzr*R{`` njwvf&c>Y(vZjLH3@6(9R-$G%+RknaF(CQbpH+-+{pc3gWM#rFAZ#~)|ov(pq%-Mza#-^P2p z*501;p;j?%1r16f)U=S6Dv+urYRxow_O-X(_2mEK}fget2(NlHL?%E(*|QTNrLo`?A02UJJQMD0k{vGs&Q zmVs$Fnh;8g;S*O}LmpDf21Hx?BCdW5*B?sjSqi@@H8m&P-a(Uk zMl-XzWzu-gp{C{JyCzgySL22zQC@0mi4P1ahWVFr$fKH*NT%xA^^BgJ2Rf_?C9-Mv z>i%$7k1xVZTgpruiG~MkYh1G(UCX*QR)I45G@;pO(AJP2Y=qgj)=7<0(4S7G>bJ_0 z9Fjr}XTRfNVIi}^f-%M-C)n^A;+5RKurTVq#i^I(3oQst*Q=#`H@=Y;P%iF3O8>-C5<@ ziER(&W9M7My5?l2vh~VNd;~SOOh0!i<@yQ<3Ew00R>oEF&&>StUx&8O zP|Y>G7=32*kPTeUtuKsvEXL*T4kP5JJhp;(|KSA?!Q~f3Jah_+kiu|g!Zc^kE~Z2X zuk-4GhqiX+sW!&*$TgwN<|=bJT2#W~LCD&KZDq3~SuNqf>vSZa^2a!**Z*05+6~4R z7fL+ggpjTQoOsCe*>yDM{FxKKnoUHJiG`^?gAuWk1d;lKk&eht^<ta4sAW%S{fItC(0s;jD3J4SsC?HTkpnyODfdT>r z1pX%oOlmFeI#XPd6sxyzImzV|mt>Upb2-W76qh8;`?;Lta*9i$^L{QTxt!vX?Be}g zPI5WLB^l%WTuyR1#U(L#KbMnSPH{;xyr0VlGc9;H$4+lw?o7C14aC_mWW-b$l(>g0PyE*HPId(3AS3gY^ z;f_$)a6hWy_zX_!>T0}ExYcW_ko~ehxTQw5yD1wz4Ks2V?N{Jgpat6M}>4nkFyYrI4G+o-0BP-A_M_r94M4r;6B zDB9By3WRFw%}lke*@+r&n;tiGYt&Z9(|en|-k3BX(U@u`HQP@Ir9p{y*t(W9{Ip%_ zlW3=9BsJ4d`=oA(_T=onhJ|VoiFW05%};koy%O!W$8^x?lzJrE2lqeDsOtD>D^513 zPUu;1cnt15{WOdNdn_Z)C+xEfxGM5fSe~}w3LUy>sC%=P85qzVC+nvdC!Y?;jBh=leRh;D?6Un;QtY5%*iF;np>ig3DwA{ zcpguqEWmOd%n$x(<6tz6S`r1k=|Bz;N-)JBfLHIQ7!1jKYiP}Zr3(r>0#3y!N< z703ngM{)za)GLS>lK>VNEYa3@Ty=m=@CbBjQ|&P%D%9HGH)oHfk)SShu|LmUVC)Qe zp<{-yVfR^Z5GN9>?u5tL{M{i@!EMGk;5-Wyt-4K|^nZwxKtH*`Up0?|axk#vrh$}Y ziKZQAylM01UE>C3H4SJl!Lwun-qNTw0Z0cHSiFXsi6>PzZD#e+j7qEVda}k#tIbSJ zMa9A=gbUK?%8SuchmK!xYMS48X*%^x_dU&TKYlsA=ZEW?J5pb`Yi#wp=D)t*-R2!$ z(Y)>G;r&hbE@>{h`|Lm8s48pTbLjb3UQ|f)_UTsR(b5l;lVj(|=_ju$PhR@=rmi=C zr~LkbHOpw@Z#Q??Bn! z)5>=*f9~LqHlE<)jwu&|mCtW@;fOMEVTE(}r31>*w|vcG-yJ6*OzrAl zw}0PI{&vFI_ktBy-o2oFeK@;QdDZvudEGal{LFmHdUS0>Iby&2r@B*$qP*>CZEOuG fJFb2D*!0!UDCgce-T17zUTOHt(Z#EduT%aF#+-xT literal 0 HcmV?d00001 diff --git a/data/cross_sections/CFC115_JPL10.nc b/data/cross_sections/CFC115_JPL10.nc new file mode 100644 index 0000000000000000000000000000000000000000..4fd20caf5118a1e31d5128ea55b7dea2ef70c91b GIT binary patch literal 10302 zcmeHNYit}>6~60r9DB2M(h};D6mpvs)mvt#JG*|w9;NYm{Yq?aEU%Nc5HPd5WADVX zGuF(k<3LeesDcu;w2In7DdG)jLCqgph{z8D6+)>*Ky81NR6CR?ek`NUeH07yX13jZP z(PwKmv$F6iQ6;-9m5~|}!X_WSnbd*^*O8?yWIh_hc3~2Q4>TQj3aN2F@T@{W)`4o+ zn-EHB;2TF=w+{11!uUE&K#F4U;-jk7H+s(zzV@5EP*) zsB6!T;ofX+$FA&nE|VVWCDBi!L1D6rcgUuPds+J~(SEFC`4s*P>X<>Mr;iq`vg!Di z>(G29ppF|XRLvNkW#nyBr6MI$Bnk@E!1#><@~jyYiW4n8R@o{p10Cjs^lbd!&aTYB zV6>O3*2q;G&t^tEciQv<%k-I!o1rnPANTGS3Tp_Gaft=lwJORCBC zQ$GxIw~$3{VXT4vQeK{02x%8?IRbq#Nw?HqJ-2Y`oe|V4@p)DTCbOzh^jsu1eqrp3 z2rr)^D^}M|*@A;n_fgD;Y9%z0X~Q$hW&lVZM93i>Zn)<>bJMkC5Y@=co6l@n?mMmn znMeG8`fg1L$$(BBpR4yST;sb@l3y)2RZWgefOWf_TEd72OnI$d%5>yAe2&g zk8X#hj;V{ZtRXG$1N~Pu;_?jN&dagxoBj1SpbUq|$50Y-oQunGWEz`>$$E%J5S_fWUIWMgXx}t^g@<0Pfx~0YC7cC0^PkG-Z^*a=CpG()irXKU(nK{s!J{ z4;L~F$(1LTK8fr%W=z|3CW8`0b(a48^vl0yz8k_$VX_vYJ6N+2+J|=J#>hvYEk=FB z7RI99+zF|rEzRw#cax#gdU zTEjPkg{kNF3{sC8aSGClY9wuhW-K+8{&tqx3IPfCk!3UEtoZMgUwrSO9rIMX6?@m9 z&G-OGQf+B|Wz^$7J}!uNTKHN=0sde5=i~g-oD<^-fX6KoKe3Gra__=jo^xjC~cOI zz1h+K<%?+qP_Pue7m1CF@oH%#v66D>(vTWTVjRglpGOVr7}Y}(DpH%b9RKf9%>-XZ ztND+rbR{Uc9{V)~Ffy)>6Su#We{@5>`YNBDpDvF3aUFO}P~= zEtd?J<#HT83n7oJl}}Y!MWBj66@e-ORRpRCR1v5mP(`4MKox;10#yX62>f3Vm@~WB zJST-D6FlD~f4P7uxY-z2i*1^bK^A`}*Gn`3KKxJ>(CA3O=XAHYy;AuI{a(8MiFh1C0PJ_}k>#7vsrXv+VsK6U00J~O&qA%1d z18WH?0|0<&+ol&EtrX2Eg^s9DbQhSmBE&9^)+HQsjX`W>ATC3$EuK{9PBWnRB0$Av zZy^jBc^B?BUGD%GZukap3*3*?Msx)Wb1HxWT~(US=ZyfU1dqU_Zo`{GmO`!@{wm&7 z3E9bbi}ee{1-i~N7b@o2nqkk9fH;t(bU!>UChs1VN@8=m0pYou=;o_LNaX@T0{66b zW%DuuYKeH;Wy7dxDlG-Ubmtv+?3=bRfSJH~6`oZG&{iki88wn|%kWZ2;KSmVu?8mK zQ3s~N#l>^U1Pg!I8is;pgI!oONwiR>tkAM)I2aOxlF7rOI}wQh#sif+EW8pMst=+| zP$@w?*}U5hJO~G_4V*CYzUxi1wFm?FZrP+I!*(Zu4{%ojBeNjMm%4n0hQ^|GZ8`9Q zgXsqd8Zbu21Hch@*O7{AiFVqob!<(<6pE@uA|om&m$S+)1gjokh-KSuU;q`fD&1p1 zybf$UiVFm{*#xsf!)Q$#odUHnDAI1XJhbZz6Zn?ObaNy&IF4= z2CBt3|J*1R##D-gQ)#E!UyC`#2qk>W05)d<$Z6MR++hx;$T3?LNHKOQ6!=Ad_oe33Ct`FPjkl>u ztwW=6notw%t!?!535Y@Q6{d)7l=DS{{e1AP$+AJ4@m4(+q0LS?*3hu>0SVdKUU+Ht zq3<6*roW{}&%C>Lz45w!YwOu{Nv?!^o>8(CtfK%pbTem-X zM1QsB(KBzHJ)~bBO*e0U{eFGp`5Ug=_mx@w^N0TM(-X7Py47{>P+PaHuim@vmG^Gj nt#2SrQ?qkjdg=!cJoD}!V|oyIE^+YA8}%3dvh(m`rI7v~(kfK! literal 0 HcmV?d00001 diff --git a/data/cross_sections/CFCL3_JPL06.nc b/data/cross_sections/CFCL3_JPL06.nc new file mode 100644 index 0000000000000000000000000000000000000000..9f3dd180fd05c061f1e192442e00432905417aed GIT binary patch literal 9457 zcmeHNeQXrR6(8UEb2$u2XrU0wV4`BTciX$Ojj`_tcbvb#=fm+Cl9V)NeYf^4-rIF| z_soZ=a7bH1Nmz^rUX?b6;WG}w51J%HlqC_h`zTo zW4k78Ax*0Mabx@5?aZ5*_kQm;Z&owj+u7PaTUsc2Dl3U7*Lb;n2dfG4hEJbAes+Cl zYp=)mLr;xc=Plz+qRUJvc}NMWeB^dg3c_1XW@?CMUmfasi4T52wcp6p_uG!8WgIdW zOvB!UP~w449C7Ykd>;4WCn23ouqM%1kGfFOOpv2H=6}mIfA-3fl6hF^DJdyg##@E- z&cpFtnnRvaolJJHp;gOk+3P@uIic7~FKk_( z=fG1IDC$>|o=nkQ@rj z;ii+{^|G*#X<>0$1O0`(v9J)*#KSTUeX)qJl)isqVbpuo%O=P%adTk0URCp+)5N0B z_w7b_*%T?hy4DE|21fZ}d@d;!&`2YSrQ}rykp2=v4&~vhd#}1-`XCuZLuB;A6U(lT z9kYQ(nt0r7e~A{(G@xa39nypw|o4Iz=lH?^u5wg))2?v-3#*NBOI^xfz1Y48`Ny4qJ2Dl$ ztyQesMkYiW5-X1{eIjjDMpa!khMXK^b+?>9a^?j$c1i5yC37IVgEv#DJ-IgBM?MC+ znDytwAKHW)(M)IDXPzVQ`yamX&6jaxf$&)#Ac3$CsO5zpzP%I-&0(n+S%rMdNJzMkTsJe$ihoA_^gCZ!J4v-W zu(t<&#xGC=)n-259Q9a?7q}~okYju?3F7^S4FLACnuhIt-&M<}zg%3Y3@lyWb~f{bO_cE7D=9N13#r&9hf=k%RBZaL}(aT!lkZ4)O zdCx=?J`2b$Ga62HZI2Z%OZi5kTaKtuuu>q_PR2T7MA0Rhx{)rFCEYf z`;ss-$ktH>d#Q>SoSbR7Z&LuH%eB4@8)+*5NADRlt-NZ{kR0?uFI@MPtXIZTAy;PI zZn&$Wh2dbhArK4&LLnLow}hHo8k&6d3=+O(9nH~Ix6cCJCxLvUoNsiBZ$3Y!&B>S2 zL5=srypMC;lkQKnCzAF3>w1#G6|%FEi{-;F4&(oy##UC%7bAcsrM4 zTuyLFhIu=eV_Z&fNp#-M)2`Tll&^7jj-Z7 zSPBPSUN}&6uW@r(c0{+kl%KUV()vbz$4cokI;dH;L-DkeT51OFGW^si02UfpGK6F6r*c>kDcr#t=*rYHA3CR|JiGEf`xT zt2?;iuj5I+=DA ztnIpqYHc#@ENH5qZj_TUU2hF*pwl6D$+R18cbp-`@zXdC)~k$aHn=qmH=2H$z>Zy} zKEMa;Hg&iN@>7_euE81FHA7dn+olod(HzJ2(-Y%~oSN4%icY&UxNz1oa61m#Jvq}c zGor~oL4^ZUy1`bdX3)5kH|>#}3eeKDQ^>*{woKbb6}_O~VLMH+c!e5HjDt7o2$)P$ zrc422+EW08GE6TR4ul*16cLxDgqerSc*h3VL@ZnaU@fo##)Xzp6Lbj%sgd_HE|`Oo z)FUSVV=Zq2NUeaWrt7AoZ1>ZYOgAdvF+^U?2fEdQb^NOUDmn;Y+^yLv@@mLWYc}YP z1yGv03jYEyV4K#6>xg@Y5a4IJHWH9=Dd3L5zB8HyIK2Qqhr+*MD9$88({C*OH8``2 zpG*;YnKt=pDA*JT!6K*)HLqM*=l^hcbi)qCRm(I?BoU2gVAaNHeYgRf3N#9jBnb}G z1K}`>o4O6)88LOn0l*ZZ!@@@qeO=}_xB-@75$Q^PAgj469Hzv_-IQHS>~zLJb?zkTnDh234z z_Q6eyhd;VD`qMKPU;Ccc9<6w)aP6+g6VcVJKRft^-LdHYzb`rQxm+|_5ovtsjW<_B zPaS%0=edq>^kA&F$!Q+ zJslNqy|J)5x-xPu^Jr&z^vLkb%xns=g_&x@gMx+VI_4Y^89^IryN8lpTOx~JDLgs$*L0-wSZvcnd*YFwlvR(k*MuYg E1p4+(HUIzs literal 0 HcmV?d00001 diff --git a/data/cross_sections/CH3BR_JPL06.nc b/data/cross_sections/CH3BR_JPL06.nc new file mode 100644 index 0000000000000000000000000000000000000000..0d6beec24512a9e4dc30270dc3fb19f9408df232 GIT binary patch literal 14428 zcmeHOdvH|M89&JqOfJhqc?4hO7+OnU_s;Gn*=({aX4yP|JV=v(P{nYwdw2JeyZ6R> z?*@Wc;-fmYU{w@xRD86R`Y38!8U07oDo&ZU4&z`;L1!#Q9ktf#w4D(_`hEADyBmWq z9PA*o2a+#)&bjA&kKgxw_kQQ@jSCx_Ckp2X#igahX~%fGEW~>J6%}zAi9=n} zaQ!ncn3dbIyp)u0fY~LsEG_}Jc9GozTlN7)auSw&wuJL=s*8*#rMPyiE!y2pra~8r zg1j~^YH#Z3UbLj6w>uVXYa;INqd+cF!Y=5Dwl~@H8~FU5v|>{DFHudlVvWr-p=4yu zRCJB@Wi6`dR(@zuG8Cy#l|{;1O^~>Op<-Bn5?6VLY{e7F>P97_B#u)$>o8Kj>m+A*0Mb=$A7KA+_8rx5Bm99N>*Rd1hhI+s~nwX8W9&GHt0Q@heA> zbFb>T2Gz^9=-}S9*qOnUG5&n~Tr|#6jW8e?Qbx8w)7PWQq5Y_A#ZlW#Unhd7pA5eJ z%h|`awLZ#^H`xbcjo z$6L<{gbwA_qZfm#V{0JQ6G-(jfPcv(bWhh@){kS`T1wAC>MA1NLQ2R8N9mU^WEAJS z$TWyX5S@E@G>YlEkx(?rg23{LL;$gyubm4LxBxS64_80n-)^k8fpcm@2K$}#Macfz z?!9^Ittn%dEn~z9LyqTh*C)anX;4;WEoG%4s@v_*Lwk4Gwrj(STx2ptcaSC@+S?X& z_mHz;E=K)w_(7g95sekb{>)GNw2!smK6dL=8@xe#$EA8%e-`C z)1n;IzKvHGqs;gRGzV&9Kc5)%n2kql4;AKPTO0uB@eZJ9!HKili6D1ZHyL;;~{~}j2pUX_L_3sf^^!O5BdEZ)AQGz z`K)b>%T5${jt~yD8Q{P}q>uiL>>T**_I;y)=tN?NRkzB3IGOkm`dv-UOxO+d1!}ah*0XdOZ3M;9w@c;0siHeSWXsPyK;cxq6S)GOWJIZ zqEA9|0PEy*2b&Jioqp#|(@BM6`yGTk{mwdU7ea2H?EF=r1q~E5P|!d@0|gBfG*Hk$ zK?4O16f{uKKtTfq4HPu+f6>5*+`#rpGTOlDFsCD&k`y23bePi-PDz@Nb2`lF2&Y8h zISg&Br+%=5&Np($B{^9p-d|Q=;;5PKP-i;gn?fIH$v$j&MpeKF;Ydrz4ya zosV-m%;^ZHWPpuRP8&E~#py7o_i;MH>1&*lEBN)CHgLL%(_v2ca7v8^EGn|9^A3LG z(L`8t@0&yBKJ)^@hWLnZ>55+%*REnKSLKavpbIuA` zGAirKpfu(=u~_!%AU+ z(x)nV%8&-qL-m3{1)*E)6lu4lC1k@xyTmS$HXDkZP(8F!Y!_*Zt|ny7L)*p0B5lnY zL#mF`nnb!Vs{qf-#5R#GG5Qsl(;~Ktv>nc#tdwMVXcQOgk_HtM#OsIiRu7Hgg{`{U z#}{nZRXC>dP}rU>z#Wkr-HV~Iv5kg z>p~gZWXlq16>#jY@&^1t53Q}KrE{7LJTJ{u(mDRR+F+#!Y=(SZKL8rp%*c|4kj1ra zG&7cIi=wK!B@KCKrx*j2C>b5hjM@jIH!7&z{^C@|85JOIj&wYZEcW>w1o1n8;^ z?^X1fx-np@-#(b}@g(RR!kt zgOO1+p-`mA3Sh}|e>R2idxj|h$vRaMi%AkmIabBSW56$!l2&K~XYm@3=xlf{r0F)Gp? zsb7lcLgJ_pfj$Gif2|T zVJQ11`w86Kg|NP3Bk~)4X8>gfp-WD}BQKN(>W{0n)Iq5#DCFvElzx@U4^-On57?s@ zYu6Jp+)kxN_kBu5$Ul0#QI5-YJQ8v zpx9>$LIphD!1qUJO@OM3X_DC$1nNSq@c1J2%Nk8WO;B*k zF$if^jG>p-1Z!8q_fw#10EI8fe)|z0lq3^sjR|`{yVjClIH9kBB9bly{65+mrWA{2 z5vUd+y6pL*-ma%|G6_#%_Oc>Mt^;TJdM7Y#7r|17Y(Gv?3CdC_ z#(Nt2pvGbs{E%(9-5nBAx}Fd#1i>)|ND$2{p1ri$&0Z3=?~-kEih}p#G(nXzeF=%q z(K3}~W&WmskD5v<10DEsdF4slhLB&~oAvIGZrQ%+w&jt?f;aXZS(J)A`qIuNyRXee z7C-&Fy(=slxp?bM8|p(7BQO4U!>Y|kCq;ho$~)IIT{|tZY5Lwx(oBig~o?>M}(GP3W<4`yC5)f4&Ijo1BQ*>}8rJ#XZ$hOU-F zFL)y7Tf4M@XXf$sDkG0S_UcP*bLT{UJ>&TcKSQRLr4yLW!P>!a|Yzihp0-tYet-aoa-zviufh0l6w^Tev*x5DSW z+kE)S_P>V@Jn;ICgNF}ld0-aV>>C(hd6Sy?ZI+fyI^ZEOGX o@ZkJi%kSUW8GhZRy;)h_629>Hmd%fBog4n><@Im;)HN~uKMM_-_W%F@ literal 0 HcmV?d00001 diff --git a/data/cross_sections/CH3CL_JPL06.nc b/data/cross_sections/CH3CL_JPL06.nc new file mode 100644 index 0000000000000000000000000000000000000000..823cff31755dbee9220c9dc205a65fbb2f26a825 GIT binary patch literal 11488 zcmeHNeQX@X6(9Rz$KD+IAgKavN(PfQcDY;K-km?sNo=3bPGbA)`tpgQn!UR@-^P2p z?(Uu;=|@aefv8eIma0He8zTcGYj59m%4e18x;i4ud!n2V@tTNexG?ssJBPRS zj#dXxRyX){ff~^yyDX+kHK{_D&#WU$fCOsEVh;HnY(l;O3BnJsj#;_bnCm%4&Lb;9 zH0(_XCDm}n5m&Cn=a~Rr3E9dCZ<38M)NWS)?j6IRaF(m8z|Jj zf&^=D{8cxvpPO=R9a(z_T5Eh=0t!wYAg2}H;h5+rHLUq?4R1x(0I4N)ICgTdJCh-+ zp$b(&S$nq)rP7&g!|Ab1vU@N^g14bU0aC*|q`QYwK7W_s-%&JN3cotFn3wGBqj{sm zEZ49tnk{?Ovc37HDcv#jtjSa=N-Ro(AW$`ozg(C+&AeQ`5brfgM*b3`!<joQpP=PL4SCBy&82xxS1Iz>GRgF$V?O6b*rlF#4vr+O9@I#eAW8lcs7> zHQIXmCjssjvcN6qV=R(ho?8fM6>gc~-RFR}R7r+d>M(q2k@_1j^P>j60gU$ANJQ>k2Fw4ZbAx0p!6~v*^TT0vIepd zWalxFjgq$QbV-wk4?09gUq9kiKG?StDgJIIZ| zi&=jy{Gm*^5G_{5e-=3c?_dAkk>BIU(!%GZ7NTPipcQ~0vAmQm!{ezKQH6NRmA(=^ z_2j*l?lNzF>bW(8)S*Nig7gC=k~#vLUk-m&}Z_;-6LeuUYYuOb750%0qsZ@lEa8{saKW8FD zJd4LCrhn(mLv2Fjk#{9CAFI~)Zq*Wz637iX$9CN@m*qTIPRHg`{)E8v=7XzF`OesP zrNEO)Na_n9fQLw5_>AKG<*7$sUI;{)iKVDPlLK)Di6HbxQ+=t?R63a&^P%4Y(;(3D zy7!TRD0P-5d!xPoo)3~}S}+8^j=;uXyjl`TTS>Y&G^B(Q7~YndpP_`c81az*gpF#3e4zZZO6`Cv=M1YT1Tus7~>`pG3yzg$^1Syh(1Zg8x?q?^LPuwKLs@~ zop>oN7@{BMeVl7gW-PfimK+@0J~9|-QN268$7&wi4GooYEn1*IIXvit6k`&K1gu=s zB{n6{WxagUluO~_dWmpZFUR4t5c0qZc~_wo3sfvnu|UNF6$?}>P_aP80u>8XEKspP z#R3%zR4nj`SYVcQ@p%fIb_qHy=&Yb*T(k>1E$FPEq$t`2ofdRfP-2L7L8k?s6_o53 z?Sf7VIx8rd5bc6a3py((F-5ze(}K|)ZsifibuA@FzG;PO*bG)K%u@J?Z119xrjXYEMZeZhHraMg?^{}}Xjz%KU zM!YmBJLXT3I_jhC&EaT!+kmor?sS4Wx-|}SXsz*ZG}dC38bQV;rN_vchCS}+lf?ra zib9o)I-=5yZsnO1qND1lO8Xpx<;@W7RfkmCZ<~2$h3JsFU8MtM=YVM=TS}!{%Ld52 zOC40{urpx*Pro{#(jhp!@y2y8M7wdYQGLpALA?n$unf^8b{w$HtQc^}HsPEnL}7Z` zgERCQmZ=|bZ7V!tc%B=g&&(u?tYqYLlMWbgo^0gc@Ef>CineFxWRt%^3j3pUr^~2e z(QdC~yOTu*-xAP_SI)x`wMtV{x>?q7FP)~jo3!{dGoTHd1d(alRw>w+j+DVdInEb} zhNI0PiWXOuq+NoucFzT~NniMW$65dZj0-JjZmlg&trGfEw-5?mk#RWK1x4va6O7tf z+yxHN249c7;ktIt;B!KUML_Ts7Ij&`3t$74#9?)*C<`^verAJLLDNxGcaV9WN@F0s z77ItUmJn@iZl#SW2ag_0O|(&KZ*6G`DM}K3nFUi7(LwY!<{fnL9?jeb*zn3lKtn@! z*0r5URMT}Q*@WjXi%x+pi@Ir#Gs}Q40ib4xgV~}+iS{su!Kgl0w6&RL;ll;3B?7jg zS!U1$2<9UJf@v8hjYit&0O$k#RoYXwTsUq+jYfRs5DzMC(?T>JYYoTaQD2kRCSPDh z8Bsxpj8U=ykiCFk!!&JAKMeMaS~^4f|v8`+`}9hz_H(Afy4R9)&MjbZ-ug3lD!mMVQ&g zs!F+9ts$yKTEkkb8MSI_L;qY08eO(R-ORBqfM`yq-8o2%-HP^O4g5SSxgJZH9sNvq4Vj~_0ky9+9BP+VIJgf$l9P9#hi0(q=u`Q?5+)ku5PZ2YHi_Y z6c@cu$qNBT*8j^(fucmC@Ddl}iw(OI7UN0VoO{#qU!ug@55?skk_m=bYm@)RrYcJK z>J-J)OWC|$U+)^@C7m|nmpM%eZL~^F^;c~U0v|hctp4-kXA9ro9`F3eYi)amMzzkC z;eG#p_FSm*%?;oD@wusuoy&V00%teg+`0RmQ(qYQ(~X^X|DwV9TK($Ip7*@xM>j6( z9DaDYa`JE0o&OBIc6?;*g+zb4sj9a5twdq9b4I=W^~9b#UVh;0k6umuppo8s=qwoW{kIJ4*C&yV&zm3Z}`FQ2M;=7~hjUw1W~zyElGk9REb=HZ!hyDuI|yl{We zKDqgU#OX6VZ{HL8cA~3sO?PV5!Nh~F1Un~=PA1B~U9tK8LOyYQ{if$4Z|_aKlY8Nw z6Gui8OZTmO`Q44F#7*k@m!{Sv5`)2=PafN*C2qaz!cBju{bJ&!$7hbduwh-|KTA>9 AWdHyG literal 0 HcmV?d00001 diff --git a/data/cross_sections/CHBR3_JPL10.nc b/data/cross_sections/CHBR3_JPL10.nc new file mode 100644 index 0000000000000000000000000000000000000000..cf8240a865f1e735b779b2403e723e4b9cc62063 GIT binary patch literal 11474 zcmeHNdvp_38ozByX@~Hz@)q=hh^-{EN%~A@iYe)nK50rRD74dL+6+xHWilzk!jeTr z7c00Z3W|#ED#E(pQDjBeHQ*`-S5y>K@Krq?I3g~-SQmk1@16Okt)RQ&QICJ*mgd*F z&+q$vj~nit-<1`W3}i+#i76?_C}*I&YSC+K(D3A()%KdQqPj%$*2M8zov9x*8AHxS zCJ`mjF2ly4Bm$;nbaoHp*_=W9nUIHHUryQF8y5h-ZI z64I-mri+Q8OPkPcMjv=Tj5jpw_uU#!qFqfW8Kuy<-IawN54w<4QB|m{Mdek+)t>U2 z>L!o7u(BALXHkVrsGmNdy0EHP>+gd8^?oUg$v**yMAcnXf_+j@422~*gj*si4#{e7 zQ>UOvLQ6noF%)MmG82Ik$^3(W@@i4_`dYJ!q@d(Ghjg+gDc5hlY-NqRtioKZi#A9X zt*P2wtH>RqqDo>|lW{!hOm*rM6)I4H!$M>vvlnEsPS$4e`&zRL?5y3vI&ybEXwuDs z`j~~-k}!^CDBzY7mU<0~al>UrOoKm#Bv5 znrigW$w(ecpA(V{YM2f|5rU#hm|jLHCuMo+%+s2geo7C*cGP*~&zGKSJ6#6U!}$NT z-GCGt2FR3{Xk-Jb8x46Qs!TnT89fZ7yq{N8>D;aXZhw&ZG?oX@b^Dal8?J2bwVk=Y z-gH)GO1^|vCnSNLkXaRjBy0pVqKM%sdXht*E&1(BKfU#AsH?00^mDBzfKCR2_3)J> z)M;^{tN|$N3~~Q{gJ^h~uF&gg+dZWzX%tNf=wgZpr9hZ`4?`Bx{w6e(WFwNDn;;vx zWm)k_AweaHfwl@B-Wdrq@mB^_i!gGqKL+VrOO%5qOV8b$ijtUrSM zQkm#RWGL|sgd9QZ4zIrB6*{xQ@C(|8*~_q*xR#0h!1fXeNvfWTsaH{d^9JWQVh5Dh zg|MjhF5RR?t=JRB{Fm*-L$gu!^)d9T}eWs`^Y&f(^ctjDER8Bo6CD#Z2}#g zNOh)vkRs^NlkAP>^K(7j#wp|U$##OR4afT*8vxnM&eQRzQnVOoD58t72fSyl-U%Ui zhR4Ugl*Urp^v>;&M@|`?^|_KYA5BPtlz>Kh6*(Mk3X5KqY^P1VDZd@`oV@UYXEbA6 zeZG!oC}E%`05~4?^uEtjoVRvtc(bn~8kyJ-)f~_raWJw`*RLxsDXuH7b{98kuAf7e zp^oMg)F14KhRz0MN1UZMe49kqfnCgtsAJP${IMi5xH9nU&@dzf0njO??Q$w%GL3kW z{|(8LTBK0;7(AJ6dK~rFzf=`QRKKif-=+wSny=MQZ@@)_INaDOD?w4gcGgBm(YR01 zM|l;IGZ1GW&On@jI0JD8 z;ta$Yh%*ppAkILXfj9#{3j;3ErL7YMi~*unz1{^F1&jfrHfRTo0>%K5AKC$j7hc-GFEwj0bc9HUmZh*8|1?y8)2`;{jcO&45wB^?)(JZa@@< z@qjMCX22-mdcYW9Hy~1BJfI7(888aC9xw*j4TvHz9?%8Y3>XDm4;TaN21K1O9?%8Y z3>XDm-|3=kMtU)?OCblFCUStRUEBM8`jPClDf)S5W)61d!ks#WOL42D zgjGz>x3MC6$?cT|ha$lia#}05_N@*x9#x5W>D6C;DmgP%GMQ>}kDH%r%tqdRXi?;# zOzw95LP)e=?TMcJGWywY`b<$!GV)W&QLEKqvpLe~M+Q^hd#9M6>TqUT9nPEzW=79l z6;^~$8(GJmYqMtNI6}d6B4-9OMQRC1a+@M__!s0e4C7&IS?m!)K2fpYI<}6*C5j~a z0v24vRa2AbH7~5TtjlUsh$W(WIT06Uy-Pu!yA)E>weZxWg}!7fY~5jrhp> z3M?+}6ao=}Uaa71-BR|fXIBwz#10}du9jI$D8{uBLXcPQXLDE`*%nL*XBoE~Brjg5 zVZxeW3eEJimiPggm$Xo}9eG(e6tw7GAh$9Mp%Rx$fq<+E3n(vmsu+?ZorGt?`4kqr z<#`c7A(U0IC4|A9D@aR-x`L)D>m~-0f-+%v{PcjT5Ju&INZ$Hr3Cl`{rjK@QWHpZQ zi39fd5M@L4i@47XwC)&KbD1m~uCR>9wE^OJDp{sO@QT>ul~|maYr%HABbQt!kWT4# zXPz^|!Z5#dO$tRt4$0JEaG{sPW+BeZ$|IUs9gZF)9C>O+* zo}Ys&G7PJKR~Ut9hjZen_gw%ZjPkO{l$klyoyJ>exYZL^sweMB^<*F|gORt~7SI`M z7Rn(lM^TTfl>>r85>OjS9wga`K8alF;g$usjK$SbyQJw>!IGybqPLywE$N;PMIvck zu{MZGKxiZBgCI@5cBeBl!-6|HNa$ueNyc}w43lYh(A@vcY!qkm2QXVbj`z)U z?mC(2;ib+8ZXa;Q!%yp+_QIBF_57lXgD390zMlW6arJK7-g>^@{@CoayQcFEjd!0( z-O<2b_t~8Cjh03pjh!+2)@3t!e#RTq=FXqRKa~8Eir<~ZZyIBNdGCfA(Nm?q@6b_f>Ikbw)Y=M(w9v-B*|LUmrQKci4(z;KR*V+}3aP^bZR8U7O6G>>cFd zxBO>Ol4V2zfApi-%!G@a{7rX;HtfG9o9`O3-Z!B4u^onFwz^5~%(ceS@?@ON_7 z)dT-Cf!|nX`O72u^}!%%SC+Z^O=&mQ&Yqp54PcADzFL8&E!fOWNxZ?&XzcdF$j3 zuB(2*)U;pwxq}Ub$B&n_aJMQ)KhD~675C!yjeG7sSkDbuKC52F3IabO= zmd>qMvtkN&a{r=3e=rqr*XJZ}JXVs;&CYw!ZmzR&tXTIAR;@_ZGEQ9A_`4Z~Wh}X`{1cs=_@5V8 z@n0Dx!i4D~^M`)?wcHVFg4sFVWvQ|IjRPz!n)4?uEi5eTaFtoB=KS-UcI@z>Nf%qj zWeRt71LIh%?D?jxn1lAF$F4T1lxagk`?4vD3|Xc| zq0D5Hvb1cbQv30vY^hoyO-h#uSkvL}>%%y39kS$}?}(5`%e2WUsog^r8H$vD3Od&& zcZ_~~ByeCzM1Kb^HTbSMn!1)49U@jMRWh|!A=4Q9=*C^lk11QG<~!8K*OTib_w+v9 z1-%49PkBnJe;*%#kFUVD=fSmBrfFgRG%d!g;qEv4Z<`i|>4|Asz}?Fq=ESr9&zlxg z>YYdG$xZG2y3`Ei2JzQhG0nMZ#8u}+RHG23Qk|m6lxn%c z@((Wpu6CPOfLZkPDS9j-5a)&v>4qR$kaewf7$;wn{O{JL6Dn8$mGe-Ho z>+-Wgs*!0wHvQq9!PxRWGNmBF?{1&V~-rTg2cZ^{;6fYRsLUQ#)&s` z`h7^X&ivh${FwP~xWk-kfBpIIrJiYyBLt>reuD`ySCIe93xIo<{msPV2gM&|%^f#& z;V80awCN&leCBVAHXAj1$j4M0gF0eqeuhaKV~$!_qa-k{$!euWlcVId z200z~rpI+-;*I#biDw>!Sz`x~czmY+`Dea67j~_y`Ew$gE3vt&4(X;uY{Cfn)Q<`4 z8x|859TJvkO#L2QGkl_@NVWg&L^O}t7*6iX-Cp4{{(+L-VA@%ox3i@1YI9;<@^7?zwf6B2)7SKRF0Z>!_jWm#UyFtz4-#{x-#h(U@y- zgX7syE^ur@s#2XHQ?ot-A%7RY?rlwXC97pztxPfA#=lkh9{LJ>yL$=LMVb_D1j=N3kzT|)WIsKhqcfEnbBw;vQP*`Pz)td1#@8mEQUH* z1@*8N8Xz+U?L!s{p$Lkh1gc;zEP%yO2dkhS)R~N3Kqdq2Llz352#TQus$ecGfW=S;tDqj%LIY$n(LQ9M5Q?A}N}vkn!U9+fb+8KR zVJ$R3Mv3+z3x!Yw#ZUrOFc%iUVyJ^vP!DUN0WvC6`?k;tx=+A{YV1Fab)S z9I9Xr%!PTd02aYwSPFHp5>~+jP!DThEv$nE_yRItV*Jnvx=+A{YV1Fab)S z9I9Xr%!PTd02aYwSPFHp5>~+jP!DThEv$nE_yRI&j2}8dSI9zlD1-q}1S6mrCO`?4 zLlw+{xiAkFz#>=-OQ8-{!YX(G>R}D6g>}#XUqD8K@k1x*3R&n5g)jh$U<4Gy1So-W zsDe2#7v{kNSOkk2KnavX z70iLTFb@{MB3KMdp$=BUDtG|uVGXQ>bcB~T7k zFbC$sJXipWU@y--~p(IHLw=eK?8gNneiAubb_vsh3-%Y1E2_sp#-X6E-Zk> zPzS4^9@atwWG0yU=LA_Ogd!-05~zZ?umBcA9jtd6D)94TS#C2jw=3DM6Pv0~YqTuCHHcNqlDUn4o@{1TMiRHtMVb2N(;C)3R;$iR z=C@7uwhKugI4~sLKAPJE+uJThkt|PFsuh_sZacIxN0B1)WIvqAP-YrW8Fxyn|MUU3 z2h;e0y=l{p`%sxw?a|v#ELBM}r5bLhl0uo~?kg1b^01HlxMQ=o9e1j~{g4m409my( zGmYy6ciOAFFSql>K3I{Iu280_r7HQj-uCvPg8l;bAD-&T#tTAB=eVtS3U0@{GRu<< z6$}xueWh~QI8RoZnZia2f(2}FmU@g_nVur!dhW*U1d=9clxh{fAB@$gxQ$`ztPDO* zTDgqnLSh;t>mHKM?Z)w7lVsYlGFc|ebIx zA6db5C|#PNGB(JaR47wqUQ)GMI*z+Q%k@~PCfr18l<8TSH+Dj*9>+#;H*@>l)7@BA78iewoPSih zlIz-7g;s8ikd)i2o}4aY+WwlpU7`}`gk%?qev7AeFUnMRQvzliOJ2nm%l%knC`M1Etix^W0*bu7o_Q5 z(?@Gu3H@1Rl2*zUixf6#9Q!dQ{F=g2lI3v4f&Y&cT4}ne1{ssw{@B;<)xUVKeb`m&5?>A`=)-Qeye6bO9-d|2*^|Ka)U^&da%xf+m^B4yn(Gd%3Q(ry)tQ6n2Kl_EN!EktZu#{~J1WHV=MEJ^`^Spu$qo&= zu4BY>@y3!6Md&~}txXV_HY1vDYjfu$xfVrlwV9v(gho-9w!IqsP&j}_w7t4K>5u+& zT-%vFT1WM#_c!%XW$uim?aFW3c5NL=3xd849-rTjTAhlXSp6=7{`8{BkezuE)N}Tp zf@ZJ7>DBV-W2~o#)524I`#y6Fr*mgF|NSdnUphVbS|6vFzI4*d@}HJJ38Oy-&pNZe zEQ}gvr#yKq3!~|2{VOVagwflL!)S@FOZBx!p)|RDE3dvap|oSZL;m`zkDAY$ zuQT6oe%{MdOU9<`38NP6557L*)|c9+y`IudG&j7|<<(PAT{A zz4%zfhwpiHK?VoHrfnYsK_gNOg}d#}A@6^UEI2_&kPg&9{!%>tpEN_KH#4=ETx% zY2hu8d=W?Yz5Jnl#p^g~>hECmGoI4mTQzU`4WXIsj{E4G6VSf|S}}`V7*RBo{@!-_ zGOxkI=&4P2zIS#WPH&2$%j&C#)6+9OQygj+6lOiIa|6TSM`OA$W_jhoZerewQ>28JG5Htj13?e;puCnZWk zr_ZTgF~V8$q5r-ooMYaxiL@kT|LmBBqo`~BguQDUjH0t=3g5pPJCa^HF{&>2@(3!H zHFG;H9znm~6x3+=_Tltdz4B>oyWuoEXvL+}X~XE!Sx5HWzdMxPJNc?yJ!mLxdunw= zx3UBpbt>}eRhtC5vfa2tX&FQ4LM=;Cr@K&S;&dwBh@ifDqmO@{bmqtIVWyL z;5UQlk%|^cLZ?A=>X|dN}-6ryTAYIC~(q6%CuTM;U2sDV_f}d*B35xigF?`u732;EN$YNuzs{pJCCI=wntEN-lv{gv9ZtA zaC$B^_V)a)AJ?mS-I&*@d3~AJ;Thf0)Ndn0Y5wWCL9Q^&^k^jM{S3#&(K^Sik>XiufN<>pOzTHr9Cy>UrS-Sd&XCU(S3)HJV$m>3I zVSR_)U&<-9nRV*T-tz?GCR9GFv%tTgH@(pIT-r>_-ZZ*=&Z=>yOR1+~P$$$i~cU_uP|?INxaahG0)xG_cIG=e*Bprz3-E{BL%nuLr&vxi+*L zJ#ljF^_FWq=!PMK6f>+m=vNnBKdeu3r=_VsM4vzW8Ex}2F;DQtXH+z;NuATWu5?Sw zJsoAOx>BuflKb)nC%8%Au;?@X9cdM9=P|r}N4ovV-8FSPSz5lKlFgQ~ zbglH8@2sp?)X5H1`s&@-yy@0pG%C#)VTeco;9 zRM{^-=l{@#t}~2ot!&-~^V*tvbiN$)x>0L7{m3f2l5bnlzNy38jcM76u6FEjvw4Xt zefQ(Fvfun%>9EALTKVrT^v8yysq-Kg>a6p!{`E>rnwjwUuq?ABO>MF>{7I9R^!M#w zHCeu*1^p>gJiD8y1#RilJoZ#|bK1E2YPD3=9PwyQ3nOQYm+Wgs=UEJX{vfRx?YQ5w zYhv4GsO!!&Jm%u`py|%^yvx>Yn|nDUK27QS)yXXuuWm}c#)iGTqiBjaHKh-o-aF`S zI$^y#Azn`O(&TTg54$_jmTO<=18bX5b@Z=AcQTvM>gQ7=3*S1@&sT=H_sMspGr}7h zZnbu#*B>3)Ua-C~4J?{FrFTGM#L?j<(Yla=2__cDnFSVmJpZi5!JY-A9Jhq<{ zHN}?hUs@en-`E!MZAc$S(wgDZv zFMoG#MFXs>2K4Jev{Q2H28g#cRqs68dh$qX#M>J2wxZpf5;q(lZ$-bUbW=~TvqBzP zqK;b9FYGp09P4UHk5^Ci5nZsLDT{_mE9P0y`k_Aa-9jy}?ikwkX05?`BZD|IG+0$2 zzTJYM>&NJsibd~)2ZH7S*h+_4dmATBYAyh7|7!ZMYUF448#@eVPq%R9uBH+2~IZDLxFx5?}k9X*>KyhSAb=h`?0-6H-+3K})} z=_WC)!<%Go1KSB6l{ZMU(*3VO18)%1`nyirKIr>uLezCqJkMr);i+pF?=@n3fAP|W z7S~Ar+`+9n@m=(sK1Ba$;m^`49Im64Uy*NPZi!ExKp%1#$Uj43oOg}+ zx!D;qcDd^CcN0%zeovDtFW=vFSbvHnf46hAyYLhVkDq5h>GVlr%Kww3@gYHESN0@X zkpA#s(7F>OtLtxyB?C^7gxWcF_Z}Z7^xKi^0}GFn$z%E`jt)Ccq+J@@xiQB{=#`75 z*(G}7zO*djaHO7$9-VJH)KO2CMO2E1ryV05?v2%FKddIVM!7h#y{gG*i?j1c)lu^B z`z1|=gdfGcA3;2hkcqQT&s~4%$=hGG!fMN2^5r~c`uNd%iA8kr{PQjLlA8@x zKHk6VA=SsqUDm4ikR2t7p@DP{iBT&HcfH(A{5=DEwp_WJR9(z`8ym2jyjgiUd*_|s z$<4I(BYUj+olNL1&{dB5os71>d~uNb@1()ak=f7dcadck83%K=?IP30Z7hG3zKi6H zJnHsC#4hC7E>iA%bnw&LRpjma{MGx8RgtNy2e@5}uOcZ6E896A*h%(XJ^MWI+HYiP zufp|vY=0wke*6dz?;S+^$F{mP(qEBhzmO9G%t?+8ue|ZJT2zszM zwQ~h2I`2TotkjXLZ_*bp_tlZ7gA%%_HRYsyz00LDOE)1;Hj*wwmjoBzDkBSbFD~`% zQbwZN3?5$C{|EBR^tfFfvo??mmW$5csa;PZG8T#^c34m3cTWtZ*`*{e%~|v2$U0Jb zV^IFDoz{^9()lG5$FC)~FYAA!$4gKLN=W{@V?$ia*N{*Sw?zZUlinMwT!HZTC}b>=v$I~shM`JZYjAD-t0X4sE7>O>@3>i zRfN1PB=gJWtNku4A<499V8_TMsAr4G>K+AOuBu-|vi3FkVqWSZtm}oO)h)-fqeB;x z<$2Zd-yB{*&c_Emdls>PxOCaNP_}PA@@qahxA<0t;ZOncser_cl66_PcOJRZfAVer b+jEgmbBW~jn*s0r=8(W0NrqmD`Q%>!4ooe^ literal 0 HcmV?d00001 diff --git a/data/cross_sections/CLO_JPL06.nc b/data/cross_sections/CLO_JPL06.nc new file mode 100644 index 0000000000000000000000000000000000000000..9b0c4281a9b264c284a894433907027ef90a39e9 GIT binary patch literal 9189 zcmeHNZE#dq89uw4gk)Jh6xx7PIf6w(cW-w$A0(NJY}jl*$S2u+Q9CX-yEoa}+`Tuw z_iku9Fa+yZaL{3x($YU2#A2sb+8C3Fr)2{R>4+$-+RtU zLa16gt>ce9$?miFe7@&-pYxubb9Qe_W77ivXZ+sMQX1t{0 z@dkeAUFGKaig}S}G8g?`;=wAn+(wE3d?jRV4e=bPzpjNRv7oQ)8_K{P5*6;{#FJ@T$?`L=iR`rn*Qi^@Y+Z&QevIMel zDrjqCYe%9p+1k~aO2!-76C`jKPRK`!S%c1oj)Yr3#_RWHHJie}LJif4H#X6XmQxK| zGYvYFcc@`HGezTyr71(YDp8&)Ye)bL@52w^Vx*&KT0$yLP|w$$KwM_U)V3ccb@2 zAQZ^GM>oP!#}p$~^GVe;kbm()T%NvlEFa4rYcBmXqR&GQlV@LYeb7dB0+-&dku$dj=^*iP9P8OeZopJZg z3QtTzplbjZ9+Eiw8O=HW!V|xpEkqHCg{c9Z32_k#qx5?cO^KdFXFQQ|rC$TXpwKdk z^O1!p<}4_?RM-6A2U)bAR|xDtVdG-_xGWM}37oq$goQ#Fm$n?aj24#Qiih|wEH4_; z4EwLb%rIL=^VpZFhP;zCE%)0L(CBKdx38Zz0&#S3*tBx0MI%x;0IhJ{m$FuAONCgO zahu_;iWWx0(W+255{iUrq`E#_U0+=rsAQDzHS1`OuDWfO@iuYP8|8YVGkOcG!>~F1 zrF2;1?a-$<)?hLfZ|_QN?rsm)NX~uEFE)4F3E748|H(jeysO<6Df$nR5UkkKg*JuI zMZWl^DYnA7`9k3$U-ZL9A!Pp|@u`3X1_}%m7$`7MV4%Q2fq?=81qKQX6c{KlP+*|I z!2g7SDI>$NXA$>pB)gc-Kr{9MSU5ZxP_wOaLrnL ztMK>ETrAa>MeAzY`~%aM71UCU5$HNvRTHX=)EK$7U|EHKlQyJl=7^2 zG1H>RJw=5>RN7~&R5NIUlQZqHtO`Fkph+j6fqQI;CdL&#ui$|@?PM;CRKIv2NP%kF zod>egtT0>?ibAgHP`m}t>+ThNyE0_L#hz(Rz_b-x0kU8!=p4x(H*;`P@7TbyaGNU* z%mt;ufKbA{LycU}?+4#m%7|)H6F$&r$jE`!aODdYLf$ZSvMNoRhNBsIGtVYGgs#g_ zdkpRjtbC5`KO-WbF5W9Zs#|6 z$~xquZL2r+)OE|Tl?(2kd~1uW9~o^k4kYDg79Ib7$+A9q@JeLfLuSA1y)ysAnf(Lu zq59)LIHe5Af4Mf5`OO=H@|8CqeCxHh2jzF7`@i+@#8&xKeY$=3i2?bQ9s9m~aQT3I zBK7XkbKCpn=dSFo_1)elA2Ze*-J$i#zux&z`FGDIWAcU4yIxJ*8h8DQ(1rWar^Z@+#T>t<8 literal 0 HcmV?d00001 diff --git a/data/cross_sections/H1301_JPL06.nc b/data/cross_sections/H1301_JPL06.nc new file mode 100644 index 0000000000000000000000000000000000000000..e9fc0ec1d89cf3f25c5e3a60657960ed44e8af2e GIT binary patch literal 11503 zcmeHN4RBP|6~4(PAz9Z1Efy^lu2^iMyU*QCvLtx{v%C3&gd}DILaPlgyD!<7ynQde z_cjRDy4otOrP9G45FMvFPQ^hTTYpBKs!JWJPAwwUiNcJ9D&tQ(BK2p=3~0~&OF}?v z9CfPQ8?s;CJ?Gwg?m6E*ce(fdqP4O4WcPR6`NhRZl#h8i=w&s2E;#yha(icMV|Tvi z!Tfo&&Q-`oqRC`*=c7ELa@uTE0N^S@lQqP%r-JCYkOzK1wbzJO_S%l6#T_&qOe3uk z!YCg;NsrT~ljn^t@`+F@111u}N}>xT#sEFJcIM60{F7_)@@A0A{Jgxpg)`1HyPT6o^`W^ckuRNhJ~Lz!*hwM3l*Va(s#5y9E+iEK^2(_ zv9)pW(x#5s;?9oVSTx+;ggieW6LO(K)}SN2w2A6BaQ&X7W@GrLU_*7Hjm>5DuV`x9>gc z_}DQU(3r>nYwS)cCd&Z1^7BPDAaf&2UWCsz)|t={NJu=TRmFU}nfvy0g^zmqBr@)V za`dkASB=NcGmVKRWu~IJq&lyF#|e2HH3iE?anhD*M_7_WhpxDC=a(NnKU%+j+Op%L zClaAR9zA?MEOk;EP}NDO>SLgPVJTUju5(yDk=@o(d@4a#9-2cCp*J~8KSLnHMBjyG zKsJKx+{?33)HJPxW+)CMmSZ*o$lbi}u_Qq{VBziI?g#$U!fG41rIa$HUTj|o{Ub7K z`grtKm#}8b8Hh9_Rvusa$h}$_QFYZAaFUSKX?gwb7kALuwUb6JR0i1{W;34J+ZV@r z&>5ghvi?l?B{q?bX!2y}GtUv^?>BDTw2SmCJUorhLU`B%)N;WO-(J#&=CD*uSVj02 zPyHxZvHQ>~imf{1LyzqlsF+y9D2PvJk(eW>(Gq#EEl%eO35o0@$Bj%zCBH^$_mN*M z9;4d#Nb7tuXYvOWLAA-xQ==Y>@tbsoAvBk-PeHs-*#KZKndfYN?yVq9Z4s55r<0*fLb9&L*Q=X*3 zxM-@x6O#}~4dBEhOrQ8n%-OsBu9qhgQDkCasz+x;EJJ=m{qCmbrtYSWXj3nxeh7vk zL`x{n=O&_Ncq*Ao_?mSzM^|Z^(|MaH;Tz_B!{dDO zz<&w~VL1M!v|r=xNZu!7t%&uu1}go5-X&e_{*dHc>Xbb^^8pa#%KxGVTB4opl%!-$ zLJ@=&d%EDJAiAg*-!#QmIJsUhT-1wx*eD47x=j3)!<+|l9>{qh=YgCDavsQeAm@Rc z2XY?Bc_8P3oCk6q_-Z_$HqdbzIA%CzIih|p=a}J`<%kBjoMVP#mLp1XImZmgEJvhq zImZmgEJrlRrwB z?>AEAV0VQ(qV?&TIbbQn$u)IucTDP%a7-~0s^!JqQn!SgElo}6Ufd`xm2iuxCsf0W zmr6?{+?KZ1=q6EXl5lHUQ@wb()GpypYe)l~7O73bOX1?m8BiQA4wKHhl@ZN`Ne#he ztrtg0!!}dz;~g$Fb-3g5Vi+Dr$Oz4vp(|@_@K%@RIJOr*wK1AhQ(9cnahnEr=~^5v z{z1DdX*ybONsDCEPTk=xK%ABj64exIooY z8(}u;Fqn)xObLT`aaS7r6K8t*~CXia71@sFN;_N_8 z4K`9T-e3T|W&J!4cv&Wavj*-w&#)M21PwK!k(Uy40Nve26fyv|HBwR{(=V6Edb)AHX z*Ckxz#Z>`cD2U4gwKcUB-mlSA!m4E&CSeW^$6?Keab;Dd7YBS*{_)uaYW=?80zZvb zN>vQ%Z14(Q@-5!TNvW-4ZDx z;YivVN|N*{67PkY4w=u3fpRUHYQ@(oLnPPY9>`lm2?f+*QW)qMZ&OK1UP2OPr$xvI zIk|--;^oRfa!^wYjiuBRWZ-!dQ)53|nGrtHT?(>ub1-5BDMs}O3`aOlE9nQLU5jeM z#sSRhCONehh*#|oR{N^`Rh5KzwSfxSjw~IvFVJ3^XyR9F$ay37kg^7H{--BCg{~9W z5pl%w#ZALeG($56a1ypsMIVA)(mp}H3I@muhxNP>+wy?wy!%Z zmxcFl^LBkGKmJl^PvpG!X_sdASv2;g# zul%Ud^~-Y_UXs_{|A%COwo9IM^wg6FuX{#L97)}D-naiK&)D$(mWG=ill^m^fA_uh z56IGOr$t8J-zIOntn8AP3-6S#f9l4q!TGn!({JA}S{b@QE|_)Xz@Agq%RBzIcaHUw zpUMYITUYfRUMmNe?EP86Ac6!L{(_=bP)QTC<#+vhs~O z`!LpI4LKPdS;U52&OV=H1K4xO$vv!VrwjYpi4%UHYljjJbR=|54(ntzn1-VXp(G1F zamLZ3@p_FNKMAQb!ECY`1K1Zzn+asgvhjBq=ATt!vyH{dESt^N$XYG5kHz`NOrCUn z$?>^l{0itb%<#qTz@_bEo5LJ<4;ycJIP8l(oPk~KB!}eU+@Z#bwl?x(s6toJ)~fp1 z)lF^n%}pI`p^C<8;#`Oh*~u_-KvTu+YNLNS>)#%g6BK?$sz`dMs)k17xTGXxRiRx; zohqt6*wim-ve*@qILbE`^-YFl=Hfyk?x|IKF;Uo{Kebu zvzuWdL&9RH2F6?X^}<3(F$>EY7>mUUOZK-H7E^kAne?LOI%h_v;nhesatNHay!{%a z*Ic5B?XFo?50i|X3-H>OZBgUs6E!g|>A>`LNI8^Md6ynB!t`A#i26wXfd{9Y8avYl za-8w6jNOP_+y=y+m1SiE^bNPX6+Zj%$*dk0qKMCESDD=2&ba+X;WJnsf$I(_NAAC* zb1-(!;bzlGnJH%yR@<^!oQPAG;;?N*J*i2FN;Aok4_92h{kxBzm#khreD0~yvl5|& zEPC`3*y>oyN#O`mcnst}Y$R?^`*gD&+wQ8({Sl(wMkXQ>(#bsi8iB09{&q4JvJqtG z4wj8Vs;Wg~Mbsg&oNyz6+->au3vmK7yzPvB(7#d4+Hz*8AsMWp3HKKp*DrQIOrio59rHSl`x8&Vjy| z^~b{>+JrYE%ZU?^;GqtC$xS!%mQv9e&vDC8@}|nTk{Ba{rTK z556fTBzsD7{OR{ zroua|Gfa4>bi+Azjpn@i^!}|9#2X{Q=f6Mah zE?G&u&#s(aa~};izf@Hu^{A>D-==^@Lu>7G=g}%4jxOj{wYa2FALqqUxbJh#QDIGj zTp2Nj;awFi^?Ut=9S^kkgmyTOAu)p&?WL7a6DxH8&a}#XSkd60CJk zx3p;q-m160X5TG|KufgBb=g3}hI{Fpyy&!$5|C3^4(+r8i+8L%8rWq2IwKGgHOfw{X zW;h4k}KGFhUE-98KxMnWte8Tk0H_6c!uQ+I~k@Ju4R~JxQ`)8 zu<;Db8Fn&EFqL<@CPxGnxL+nVVnwZ6zJpvvW+Tp>haU33vn2$RDR2thEpLoRg&>8cnYd^53No(+H@@$#v`?|yikq5QZqgZ z>cp6;c<|Yz%h3b}re%57^gg%G?RWb(U3rE{TB_e5V+RC+Zv__MqNX$*ExY-=7RbvrJansq{ERHrL zwSkz5-KsfSmy{(poyRqDv{~zwp-(N>z|q-ojHdU9x|>$uWUXSqoB*$S;po^+LpZQO zjdigJXR9$dadT5xo>t-tHL?;D2NFPEi>&JjH+^p@QdYgQNxePAt!1?GhoWZPE~q)Oav zN=5B7ja5I>Dl( z)-T}%r9qFs#A`4SmqZ0^!>(*HzSA z1SBMQ7XF{zJ{B=C=Jo>xpwXJZD%OF)`j15smMT3AraO(gJ+5#^s;|O5Bx~cjglk z^0U?Fb@yC*?8?ix<_qJ-k8Rtv{X*f;bHbW2ho=cItkOH~t#%1JV(D9tZki$F&l_{^ z3m#4o*F92`y}&Dsn6Rj6@vT0=9Pbxqg|1oq-cteLwa<zMxQ_+m%x) z775yx-RE9)S)t(g2ft}kNkDkwjhnXI_8*^6u<#Yv-n+cQ$5&sJPIhy`Tk{^y*>L*| zVde#{J3f7^KzNaCzGc*rsltu6xd-3vnIZ@iviDDZp9*{LyFDRD@-5VvGL_)c0us1_vY6h<44uk zZeI7nr~KO&uQ(8T?BD$MgDX03Ir1Lwmo`3iaNB-<*UarJcPxILfAyX>AA0@sSNX%2 zcpDzK|BYX;WY0}6t=qwW@a)}dVxRq)&pkhW(TI=J{LDFzJW_n>T?mB+eRpT}s8uuH1_@dE!4*%pf{@Q6rQ+pr1f&b`@jkbZyuH(!1YY!}% zk>cIgk8$qV*w0^9a-YxH+Q;{}mX0g_w41+j%rIBuXr9RKl=HeExt;A{X27>d3>OZpDN$AcyoV%Kd@njQg+D0_v)+lIZsUExBEKY z{@wJ+{6!1xIG=6sGd}Z*(l~o}Yv1C%U1xXC z)U-6$v}&GhQfMBn2yLMXq7hY9B~qm##Z(O;YKTabK4?=ZA$>s`wTLPbRa5%^J2O6G zNDCDDkZ#Vt|7PZ&nSZ|jn}1d_`%p(~+Z^vr-qP}NBGP%DN>{RyAg_4jo7U z^*vu&>6UqB@G8+{y7ZQk5>#2djFf@!%p}t_MBZ18dLH6~52y|rshUCCv9y#!=7VY2 znh;7#;TwCLKOgfuJ@`#X2NSGHRMwy_qy!V>#qCSJ>Y6{Nv7}@X7M7Njl&s*jLV6Zq z|2HhZd2+}lPfkRNP>-dER3O;XUGNe|VnmL)kP zg&JOY*2COFrntpr4YU{X^4vm519!_#Xp2d>rR>_dg;DPpoO&5H&Xs}b&T1}iIYoSA z$H4svFB_tVudek%gMl&gqnIx#6VP}^6-&vg4j}yngdEbt6-vArtyxhT)Zai^pY z_OH38;5*+eRy8d$&Ab_lOUk&Ph|f{8uxu13XQ}pDoH3*`_kH%Y>+iiFdGyg)8!q;q z2!uj%@6k1|)G@V?+S#P`JkWo}TwI=>m8=}=_OzETKt+Zw+4g{79HUfyl)fjd%5Y^rE>jQ7TkuKC!RWvJqv_SRzV>ofv^v#<$(|1UUG)!uuzPwLcXQ4 zcZas@{>rP0tvZFFC-)3ejutTr(o0$-<_KzT+PC$sVRx<&kZ>QlXk;7}|BdV$fBWLP zNvgTbD#baoeu$vj^!$}kkNKFoD~ymIau*8X{gVv<_OdG^9!?6Akiu|g!ZAMdR;EM< z&-3iA&~r+GY9l<3oEOThubD1KOUjr(2w9r4Oxqr`)szF<>0lw`k8n=^{`_m2>x{du zlz3tiLb?WU;vv(g=FyyA9^U`+sYDc!SeWY584>4^AX2|S-WKnV_r&6ZF7@kS7$jO+ zaju$(V$K4x(@pIUT*{)yxq|Q0NNik;*UBP+m5|eyhOkf&hOv`mU3J?mY>4oxk# zy$Q$4rSM9qxgyq41E*Ce@n)|#A@xZ#p%`h^^3#5)U!rZ6rlxg2ZI!wu z+HUG;)$r49X}v@{bJnM0>3f4RqS2PKkEIWsozhIDQ(%&ia)x z&4w9|zy+wE#;{?hsV8}d-KGxrMt%yz)3rE4n`Y?BxNRDNKFx7#KRub>9m}X$Ev4wR zQ-cd?Ed{sfpx&1;9Wy1W+!I$gaHSh;m1+i!I$6^m&8YBl0!=u%G~9VhG(M*2IRy{r zX%F+NTnqifeAH1en)a9y1-NNn4iHK)#b789s`FFyg>-dbO+%#v08n*ZwF3RQv^wIa zeG(LHf~j2*VwXniLmYFRL9BB@ya>7aK*&$ms}9BY4syEt(nFV$G~p`Mw8mlLimd>* z!2L*VM3=KLApt1RRHD&jQgMJv@DsSSRrO;gY0y9i}eNK0$nGW3l)=W zjk&)C0kI=N>2~-zmAo4zDu~VK283sBqLtT(kp2q@3EYz#{FN6GP!0y_FB?W#mT1Ot zMw?fy+B&LZ98-bw68x47KwBC%$0Tpe%)&b;jtz@n#2OfYMI9Il7Z=OPK{pDbHgpBc z2Ag0sksBMSk@d5PXbyS35G!cArt7AojB~gE>V%dxAuLo*2~vTyItsn1MoPtyn$sN% z0)(jpOO&K-TBGjjbT85Z{9?mKMMZ~qC*X!z8&fHZqb#bjXlf&Fz!qHe5=Hj_m_WWz zeN!ORSVybmrY5->7%8W%pgfV&jDXTw8+yWUV^o2raVVY=N++ZDE->Ds+HElo!=aOFzj4srT& z5choUauAOkjQ8!T341v(zaMwGCZJO&SX0Md7yfb8zN2d<%Y7&B8G5879J$rleAp9gh%A5Ef9v3~n#hrZ z-EYyaOOf|heCAsx#%_xQw#Cn#(w0Zwan#p)s&9FwKRo;N5wmpfd*PMy2fzLL_IJYzzQ1cuP5wmqw=ci?;OYmChkyL^ zH}3xO*h}Hc`|DoVdHe_A*=LU(TI&5?_{C)lo{j7K!|Ol))YzxAJ>m9^k9l|eWLJ3X zR|}mlefOd83%9o%zUfFl{IxUlt*xhW;e97hZhYb~J-qnb{__J*Cc|f{`u<|pZ4UR( TIg~lj+Z$f`pwc%KYz_YdWAx<} literal 0 HcmV?d00001 diff --git a/data/cross_sections/HCFC142b_JPL10.nc b/data/cross_sections/HCFC142b_JPL10.nc new file mode 100644 index 0000000000000000000000000000000000000000..6ac72f1ebc48337b1f92bc0bfb70857633ce2c84 GIT binary patch literal 11580 zcmeHNeQX@X6(9R-$G%)XS`sDD0)wHIP470lYoC+zCB>KXSNs*%=OoZpID2Z4YsC=Z*h9X)(Q2Iwv{-IJ#t5o5S(iWk9P*tE(i8d8f@K-4y_r0AN z`)mhDLQ+-gjbp!??>E2qdv7K)_s!nU?ls}d!qxTlM5cL>w#RshDk^GDT=(wo-p-Ng z$TQWAL0PC)RLL&OWw@GDVUvxYCN&^Jb!2%9nU6GMyAX-M4>TRKb1h?@@0vNEtOwPw zHzAZ%!(SY6{d&yb6T-iQ^m4(gWMvDsg_PlfoVaDv(Lnt*+p4NIU}1GtRn?`UR?5%@ z9RCwnUAZvjrh2mJAhfCt))ETi)FJYGn0I_c^p`8F{ooaT4x5HZ9jV8$(*vnYhFk(g zxD?d2bJt+kP-fTep|MOlHPA&OU&IB4NG`+INWdqXpBW@Xw$&^V6N(G;bD} z?U{~Evn8L}j=xwnZMde9wU|Oh(&Hoo3RT1SYX#&(%+KY=TRY97nO^}q%n9kC&wuvK z-Ra)`NEcUaEmv)9C_U^tQ_S^E<^?)7LStOhG;>j*9eNaWgwc1jDhWl67V_iq9h#!) zioW&vABDJCNSRpz)n%hEFk`owp(3~Za_lS)iN63+R){t`9ceW$re%~iO)m zW7q9pv|VHsuUZzF>aN7%sv2P@67g9P+{W-rF7tNsAV=Oh__Y@R_!9kZ>PaF*DAJzjpD(_wL%YK(%YI zcQvjVKR}XHTb@5R>Tw&N62yCI4If)ZkPq1aU@tpI;^Cq&NhuZQD*Q^Y=Kya+h{%iV zZ*THeEmCb##F2T~n2%K#aI~sMgaooV=Q^G@=CPa)+v(V1$e$FP{@eTuW?+mjpDXd? zBBTry5X3{Km*-KPKRx%@AIga+Be7I9VsRp_BPvpVq^rAYq-!YMH5O364W>b&MuIdmqC@}fcHRwOn$?ztp@YYuesF zrJ5@DqgDJ+l`8oK#|=(X0As+l(LH-!2KtNLTNl22gBB~I{O-XcF zE>D_rD_mYK87|A^ID8gDj;xcPDzbt=1%V0z6$B~>R1l~jP(h%AKm~yc0u=-*2viXG zuOQIDI)Zs#6>@f*=jjBOb3&2=&vytpE99Jz#1!>H&I&mvBsn1Jg`5>~PDnB->V=#Y za!yEMiFzStg`BfG@N$jczCJCk{)1axLP+F}HE;1lNnMtM*M}&zOT{eQwmIYF#a=k$yQLgH-LyBPdt1`odfIBj%dZ&T zel>@O;8m`@L5spqEN_lmCC7Dg1q=Q%zhKymmN(|NeN8to!)lP0w3QTi1+2#+@YgyBbN3I`i8rcDo4JP8k#QJTh%{f?Ct0}eVCyzfLQ zOiy>>4Be(}88e<^$A(Sc_oDPKvk#>UtZ3#8i}suFkZk7Q)f<`*7aSiT6;;8_C|r!v zJszW`O;di+@umt4zC=JXekl)c(+cgHHms6?m*{keTUBd?@nJn|3Y4ZpjzR%$I$Q#T za=f9c$MkrVqAis0`JuH8mR>-BSr&6+Bc(i>jM8BRiuS?U&Iz(J!}S4{xyUHS0~A+4 z*A~;Gw2%1|zaUVuf^R1b7+DA2JRNri7H)V3kPGaO+y;1QSQ0U#04&g1p{Z=v@PSS6 z5$Lqja3_(dklP9WO73I<2^vrr>le8Tj9nlvR4foS9ekD?#DOHMd*EX^fA=a>a+@;_ zIL{458!r$iqf0mm^wYLR8&_~pQ)6vs4Wy#^C4|7!Q!n zcsSe%(3_U!_{NMt4p7gSMF)aJV_C?G<=GSr%zAZ|%n7(yUO~9_Vl!ZuE2*B(HDE(3a0(9e^GXn+)c}|hh zf?+um;9u}21a=Dc9UeR7XN0mWP?|Qt$~>Rrw-8`CdWn{prUqJVQ=0>dgu^Ke_(R5w z0a0ue!}rcoZqj1l+Do8qD=GJeY8DtvG2kmY)E|!38jG zcnrRi1_z14Ox|^tgp6RApt$^$28_@Z3Jpd0zdF<$rcHLSxuM}>j7&(~3qMF+#Hy8PATv12dZ`Sp#bl5f5C)W+MNoJ+oP^b03ye{nqdlP5O)`FBU3PX6&9cRzai zzDJWpxp(c!+=I#Z^y`~9zVYqk;K?To-#d6Hx$pRGgQq_8)#PK}di?0m_jySt)O|8L zT1c)wyt(t;XUCFPU2!<_;4_)zkz;o~9^KKKEU_DJxOM-IWbbnwU;4%&ExBRG;M@K7 qHOY69ZzO&&u_^iQ`uLGY;^E}4FFWwscOQPQ{bhI6@BO|v+y4WjQu5*e literal 0 HcmV?d00001 diff --git a/data/cross_sections/HCFC22_JPL06.nc b/data/cross_sections/HCFC22_JPL06.nc new file mode 100644 index 0000000000000000000000000000000000000000..22a9c384b01a4e5acdf5b04777620512248df558 GIT binary patch literal 9598 zcmeHNVQd^n6&~N&j=i}!p-pf}DH)s~+2wAzTc3TlH&J~)pX0>##q~K!(^ft9?$*Ao z_jaw_Jtt`iHT}`5kftS3MIuCtkRU;VBGN`G0)!y~5!#ffs(=K92uexSBA`fsgqoK3 zc4lnHDUgH~^~X)(d)}EhGw*%xdv8xOeq^wJV1=|+3N$nj(cb3m(;s6!Q9f|uTPH4U z8|)togq{tw_g4N zC2{I&K^7LWC@el}V7`!77ZySiJS+!cE;bRC+IKH3jC$ud^-64?YXj5ws)^5BByQd} z{vg83w#e}8+A1^{81=W{b4{&)Mw-?ft*m>1^g{?aw9hu~y5xuHy<`xLk(t-Nx&F%7 zF&oG{;{P>v%NsBaNH7o()c}3Nlo#O(&Mzi3ghUcwQ&ur-4|8maD?b6ZP zKDiLP&@wi(q%zg7!|s||9w!p=^fIK4=2aZs?PEobyz#(iUVQJP7bW}mFWY`)^h6;P zl1Go;2C0s%m&BKo_}f7Lx+YA|;H|75$DZ8Wa0AL<4fzO4Le4O8HGxc`YLKjkY6R6e z$E#7wwwdIfqfUB_`(@nSs?uM2Izz)5Do#gg7A;OUMiO1u~LkzLcSHs_b4x) zeLbwXy0@_P{5yj*phb*=^c^h{K7yLxMqcRos_!clBz%utu`}+9KUVprHy_gpZcA!4HB)WdDl%u z;j@73weHOizmr8Jt`PbZ5*w58-LgnvCFIi75EcqzoPT5V8MLq-Gal-{u)H>JSni*N znNgNU%h;EyWW_7lj{j{6VDz~*zI_Mn2jJ)(6Sh;<9U7CPA((}E-@s-S935(9(VvEI zRkTovD)C4(7Kz1ZOzDYr_rw#Sb_NO0SIyxNfl)XLPBX|8{J*--7??VJOr?w6IB*mPBCJ4)`3K85CL>K+y zo2GabF6|c#7yV)#whJMTuN1#kWfg%c0#yX62viZMB2Y!3ia-^CDgspmst8mOs3P!x zL7-Rf_4k?Oa*j(f!TNi-oaJ(kOESsFxt!&4j!RPF<6O>iImab2_&ArdT+VSx?&afL z&T=`&C7I&mT+UAQ;vpM5g?*Y|0i+3Qq37!0Ff0fMf&TStsmPAjo~mPKWbIL^bn?4V z6zl1P;kX{fb4u#y1-OL>Q>#+W!>OA+vAElnvYt~Z;1y0!V`^|fNtvy91Qt=0HYo!) zb3Kh>-J&sJR&2*EluY=9JG+u*>2yJx9r?BH(lw{8rx6a&B1$x>wBkpbG`?_E)YGVR zcSMx#t|4jX{1pUsG;0zzizTA4b<`@ig4u0SpOH5Wd(zRSOM81HNy^HjGR4>~lrb88HuW6%NTBd^)Ll4s(@~}*|Ia3DcY?g;) zIsz9o-lXP*X%ZJ3(`F18+?s+*$uLdf#39?v^94t26Yg@t6t<^*xWj;9nc800wj!g3 z=ec2e@?ff@myLpE(jf!xjEw?ZaD(<}$@Ty@KI9*Q!Wk&t?&{RAXwoa&?sQ3qzZalc zuTq3-Xql#GG_#`Nc{$Cnz{TPx4}v%PG?+{?woCzHI$8mM3QRAmM3jy&MZje#WtZVT z-E#po5elCP*bB6Pbzub2jwKXomBWk__Jky*5Uo5IQ$h&now|3Qi@&2I1Ax9)DFNOs z$-HYj)3}i9PU};iqg!+atSxD#J*is;+^0j&2&0KbjWX@i9UWHnwUk5$&BOJ7tTPI` z)4XobMHFEx0Yzv9HdUfsbST_{^JUssv0S*cLWo97d*KrimuXilOyli|NIb64)>wBU z(G~{p;y}Up<=&0T;8WHp+dzSSV2oj!wx{h4(~L}aXb?{@ST9FL^osMN13(${8bZC( zaCJMic^xdD{*it(y_=R zCEAHazz>|h2k@D;O-6A56~e>fM-hHg=0N!Tl_e>1y-hN;a=xhf)y_30%NlLPOUE{e zwp!)3#>W3)WkT-WecF5IxfbXC#^A<(?#xf#^2(cPpy|@9ub%&ldVc!&@Qr6Ls;x)9 zG5Gw}->IkVnm<0d{}<{X?rB~{yI)klocqLuL+4MbUu;-&%xM3v`q&eXZj68a+v>3k zx9|Vn`lD+0)CXsd@BWgyZ~0@Je&QYCdY@CjU)MA}(DI;q`|%rkpNZ^I51$KdoO)_n z?R#tH_jgrv_5Rk@myS8R)LWlD{?ng#Wz`cuJMf!jb6eCE>&}g~^(56-g4V^h=7f57 d-?_h?`KzoRctO@TJikF*bNKIT`yRhp{TFx4bH@Mx literal 0 HcmV?d00001 diff --git a/data/cross_sections/HNO3_JPL06.nc b/data/cross_sections/HNO3_JPL06.nc new file mode 100644 index 0000000000000000000000000000000000000000..f56b8dd432d353fcbcb9d2219326f93da1c8f796 GIT binary patch literal 3436 zcmb7_dsGuw9>=5NgD6@RySUZ$;;TWEGzmo>H};O8f*`N(7J&@OKt_^Gm`o6~)+iRO zcD1W})LI|7QdhT%XnpPx4TpoaKCnIjAJs*xwN~qPeNkQ1y)(J7cy{-X=A6lAe!qL? zcYpW$`^}x0$y2+@ygxZc4}AF*vUVqC3clnHnx}1y!0@6+ChLx`egb22Fgz`|c*g6+ zKJ53ySFcGf!NT$Q&O0|SJtGrLrUe>g7je9e;el4I!DGEmJVOhN**9;nPNREQrO~Ri z8lVk}(u75YMTlcP1y-;!;+;2MPz=vGoxsVM1eUXd*Rt~~Vx_5KjsvsP3gVKILkr?l zrfVjsg>pd(A?r)x$Y;}KjFqt$3l?d>r-8T+@xG_a&I)96V!ZBln>4Q%zIEf_d)Nvx ziMbSzTnb*xMSP}fOwsOPF-yYWd%q-IIEc^y-)|HsVtJmnl(aZZPY5yedtTxOPWs=<^p+UlaER!s6%OB>d>QVFos zAjO5nGI<9z6I43vWdxAIa}Jl)DK_tPx{$+f5yw~HZPQK~i-or$7Dp|Q;cPa>E;zBu zzOqSuA$oC>;K%U@sSdE)lz=XDa=b&zL~2XlE8+x5+FX}+7MM7usE9SO;sPKVHyB<- z9jyk@F22Mf7ELNANXL6CG1J)iAC(XVOT*RYtelO*qK@p+PQc7KaGH$W#E9K1SQsF_ zivS-5|2IwLNPtTi%W$~0u&@SE-N*)^{TcMej-dHDFY@>m~WXsou$blHw-~YD<#HY)DpILrlQ0&KN zR!@vRR?2(U$tVkjZ5gJU(Bma5K}N9@vE76oFK0=RQL`vwy9qsBmPn9MB^0sUgdQ)g z5@eK>BDR~*R7nOC`vtQb25q&`9VetS0mjwtMOQF3Kn#5St=261oYi2|a}EUXl+I)BS;B=*c73W&`nrP=pk(P(j`Ggxd5>#LL;G@u$s_A*e+3TMI*LP z>)51cQGK|!C{oYtINrK6dcU4-h#mUy*e?B)Mxt8ccL#(XsOpLZfmbZPioKuo&MUUs`2_E%MRt1Z+}}KQ2BN8 z{&PF@J)aL)wNG|Z-;KTVbjoZM?93aMHT3=&*zraE`gMut;iKTbmk)fh7ykUqss{fN zAHjP^GhQY|HNqbpnxDGgIt;&SnI~V784Ir`)LjZIXolBZD^tS%xCLIR4o})Q^9a1; z4h>j!a1gwh+HvYZa~^D4zq#Ma=uxn3(&HU;XK&ax>hQ;@H@CsIo|V=~r>DJQ>(>L7 z!5f#s){i&d>&Bgit%Ltw(lE#XTh_JQb?L zb8n0e+0bzSo|TRC4;VwkGsU?n2jf12r{y=#l)1Fq+s^fXwx)sZc_qtX@s!oz+R4q(Xy~Wi8j%OHzbZ}t$CKmG zP<3UEs&6Zd4=DQnvGr#d6E{t(+H8Rnjqm5=GcFju`*tUcn*p`scKuMGZH9{5<}od2 zC&SSvM>FbE%OR+}S+n?f8w^r?Ne$YQ3ImgKg0l)&`zSSGmp_zyIdy1r?*f$DXI*#K zn5igNx6D>`F9_w<71SQ4mZO;q-#j*C#?p zTIMNTTIW?MrBas`e1RCA<1axLgJ`szDxq1g-1FDiSm70oG0 zse3T@OEkCCwLExr8k(1O`l{W}gFd)-ba!qRLT-|0Wk>U+Hy4jbi?FIMswz?C_HmjF u9gRLD@v2CkOT=XYenLK0_HDm*Zb>s*a{R_Z>VO+9Dd_d&&r=0N{Qm)L&@qqz literal 0 HcmV?d00001 diff --git a/data/cross_sections/HO2NO2_JPL06.nc b/data/cross_sections/HO2NO2_JPL06.nc new file mode 100644 index 0000000000000000000000000000000000000000..e1a767e984435ef87a696f963435657df47720fc GIT binary patch literal 2704 zcmc&#Yitx%6keefJ4oc=GbD0TC3bap+?{RdcJD}+wiIk>Sz2hpAGWi*w>y{4W0|?r zQlqgL<0A?PHTa0p8cmEbB=toM5?mq=V8R+lo7K?9F2Jn39MiP zdllRlFY}mgJMb0?&4Byzwd?v&o5nP>e#mxA;-I)31N*F;Lo`P6m30f0m{K2&#iQ{g ziZ`TU$y9o4n5n>Rlz;tf*^Wwo;;5k>{drx7hN$B*l;>PIBxgJM2(mmg3zXSIe>J;O zFLS&cXFpXFYfoG%p2JsoOv_C!DGQMxshAwxo_f!qVD5 z%bBWCnwCVBrevqo{|7sfA_@Y8M=>sE?&2saMX(s8_S{ z#EGCDxkpCr4kdXbg4*OR8LhC5Jh39EOYV?Sr{|0rb_A`EJ7v^m+YT#eEP__T3^5Gi zM0>nE8IGWg45of+kqBDGJ@#lL)YUa>7(^LCt@3i%U>jNCwaYfB1@;#HiFRrk+L&uw z(F|qG#{p2T)g4!oe>0dql^b+<$}o=Fbr10P{y%~ zp5byOuhOzMw3O|PLE4(D0a=g=FOV#?+NMb?<^s!=()kkMR?rJ)(X=f%&;XTQQzEwrYVb#15U$Ly=Q(pfGST_7%BL1;uP+D@bv0kwZnBSWi3 zP*Y&GKun@p+!NEu{}~j|U6OjZE_x|w85G(fcgqM4lTm{J z;~iYQEuI5okV-!+%jp)OzLvQf{wCDgE~2^6f4nM{^#0Cdv~os4`WG}L$`Uq8h=qVG zzc7hJ3@XQ^#i{Ze4k--@#Cs8SUckFwf-JQS8Pz8vDBc)ND1HT+{0b!fMm=8&E1*{_ zTF{}-{-Kw6k{xo3Pr|UydlfkPw*sjolc-Pl$taBpKjw@+25rIntMUvi^$>A=LW#no z5%EJv3CmLSKVFidnc2MNpLs4Vm>R0fnYSxp3DsF9fs+DD0?Pr4pJ3WWVw@H@C~#chq`;EE za)ADC7x-dGjMD-K1&#}x6j%~i4$$)0jPyw&)i8<(m2G##wvt=U+VW(ONVqhyHfwy) zjQ3W{1$OO8{Q3`DI;VdA4!E?Y(Umetu~C(#sBe_}Re|$LADp z#82&Mo4zt}06!jmH9h~8HTcmZ?X&03TZ(twH9hv-S0TLh(7f@xhPUAdwr!j<|JQ~1 zUa@~mDxCRb(Hwl|!uyV_{JIlw7W-NAXKze<{dkj@H%}d?p4#^krn#HxZmj+e8ocyn literal 0 HcmV?d00001 diff --git a/data/cross_sections/HO2NO2_temp_JPL06.nc b/data/cross_sections/HO2NO2_temp_JPL06.nc new file mode 100644 index 0000000000000000000000000000000000000000..6ae279c37f85b045d15804d130b9929488831c9f GIT binary patch literal 2992 zcmc&#eRLGn6<`XEr zAyMp!fl`DO9 zD}C#$LN%TOUhmSGk4)PSw^8V%5|vx^I5Rtv9I!mtbDANGx}6;Jmm(+N4*9_}g78^z zv#;Y}{SA>=v0m?!`IsD!nZ&?z+7JC+lpjE!joVR+sA@WjF|Je^Rn(XZ$wndqlqoIO zn>8-1t45TuUz}m($kjoOiZhblpg2lbHzc5nQ6xmg7-v-_?@lVH&f*MU#O?EV3i8;^ z$u)dd&f*MTQGwf66s+dfd`b{f1-TX6dy717f4)afA+qirq};=!~=l&K3XXCCW?PEm^savO-!g-ZDqutAX`w%1xk5@oQLuuqhW zvLtkCitG-Fx~{R1V0EP-g0DuthDR&aHWA_(+Flx`2{9^2s2V<`i%|_h5-1c`bS0Xc zG8GI0MyoZ7L>VpD6N=Uzr;OmRZp1{Y@n}V-AQ^(G%Q~xY-u$8ME(CO=kO5>xtw|3s z3|6Y6kgBvBlE#!=BSaKvDMjsuv;|E7vLF>!Af78#5(z5n8nB!!ohcD!1--y_m|@lN zdGe8*a9L_mS~#wTZ(sy7Ud*ga_LDs2Kx+ySO;Ov;n4{Nsmc~S9iOWJ-`))s=&Q z+E1zBp;cX|sL<{81W}&1DCl*%IL_yVKnkru5>$|xCp}L8pFy$QIj)}RA}oTIL7`QA z9gpBJ*(gz9yo!mp#8BZKq_PH3yC_ck+ya^lxfN z6ruV?N@WCOnT7HDJy1C&Ek>2uaLAYMN30i7^-a8+C5VWM#G^pag}jAszt5~dky(MD z*{C;4p#pkE7F*-cXaA*_SdvwIiAh3Rob@Vj^uG!unT$W+H@}h}#J|~CrPXLouHzxMj<2bQEv!>8XkG;!y%r|^mX!^dV0JMl5?wyUAaIe2hv>q8yq zH{c`BO!eko?8g0@4+ly|+Hl|9QepGaZ{mZ-<&PJ9!sC5E|83@sMbF_~!lrp|tojn( zv2bVEM`_vkM_bD3aq9%$HmSd5toRprOWyD+3#%gdo}azY2_fQ6f8~;QkIcaxFTHYM z>d-iDV_Dx(jw5Hy0PyOX$JeJ{ev~w1vvlf6c zRj{aB`!)%+n1j^4+<4}X`%jXZ;nDM_zk8BY9f$C{&XCF%D-LAebAgl}UYCzI{hgHk zVE0*WSqCX;x!5)G@i-xOFPn0_dL3DM&cY(IJPuOe*nErp*u%s>DShFaUzyVb;iumYe|YkBeC*+sZ+$&>7ar1&Z1~o{&*6bc z?dgB)yNZvnuda3C-}mkEKRNvbuDVc3vK}uT>~Rs12Y8!3oBDoD-)B+Ke)4442?vOZEob7#kh$tOdbFbuDVc3vK};T|*!;RWLNMGBvj{GMfB@JBwwSMdzN)jeN5hH}QqZ0{}g`4qE^K diff --git a/data/cross_sections/SO2_Mills.nc b/data/cross_sections/SO2_Mills.nc new file mode 100644 index 0000000000000000000000000000000000000000..455770ec28c0474be9a0756eff387ae934bda31c GIT binary patch literal 9680 zcmeHKeQ;FO6~DWi&t(abuTTqkgR~V$!tRm)!NuILSwbM$gd`whVcBHgW*^zFynRUk z`IN7s!HHM|oe=`&-dMIno%~rzx95rIU|Eex{lQSJ;AZ#!l2K}cU8|Qt2NsWn@1TuODZl& zm7CFOCMFOWGMuDvu%wZjCFHwp49HoCjsI{_U$k+8FQIE{qfWB9X`oFAC1(DF9ka9H zeTxO2gv<~imgM3DkmXb-fV{md=LN(3{*z6n!N4?|Or{mMD$z0+_P;Opfu19CGDyxU zE|qHdVzI)}7IMNW6nCS(^f2|mdpHh6EhLR(z~1i4(z-e_h_k>Iu(hnB%Hyr8sP_8m z+@+NsVw(>RSxBl-@RnA240(p~^&vGu`LCZw72RDnod(p15>2SFC~aufX*8zyF17hJ z)!z_S3aB85vxwNZL1w;x7KYrb=#7D3VVN3H1Gfa7pULT@b5mWld&VrAN0^o+O!Il& zHCimLXu7H-3>!yrVeqL<(ZHao&OB}--+gLfL2-dSFBAwCO?4DFoCVHFCtkLQw2(e& zF{*~^OT4|b5HbnVvW4pc$+V>0y|jqZ`y-ZKNSt$L!8E+eLd`z#-4*puLU_dyUhJ-! zQbGhHZ3MiVQe#drSm?nlCxx8x4d-pzjcGA(2KIhi#$w4R)vqwvKs{=7o z*pC!m=jET81?_1WEBLUsqda3Epv6Q+0upio+vGM9SqkzNGMG;zKAn9yjoh)A7Eq&p zoe!29E&@KgWd}%v4MckDG5oy#4H8_2mKr4ke0hBla$>=yk-gb#&lGBN1;{ZZI}d## z)^>lJ5>}#3dWcVTgZ{ktgWnjrs{|zr8NjDI_ojEWS60;3lkad@nEE;V4{U;qNIG!? z;*0>^`K{Z!do6VL=PXXo2#^-q>|&&+i@99ds)u5lF_7WHgQ}~aGnbb6bw8aKjA;=? zqmBYQXj%AAhR|x%6dvw?p$3f!YEHYeFyHRTcN9~{gelIVDUONRFYh@1uHh>mNN|tf z#nu{Cb#V!RBK$=or>||U=qa_)oJGvwGkoAAOYP?OJ1aer<7Vv3Gq{;7y#H|l@Vo2| z3lE$Ek|+%qCY-|RSuBJI!FPNevi89B-b5b2N_|!ei@nl}8a1WhNFc)+wOAtIODK&x zzfOIS*{I2vlB`HxWkH80TG zs3)veZ*{$A3UxzSQY=gUp*0>4t4aWltWuj5{s@N?dDJ~;JpZ~|W3}dgd$NZ8k%oYu zJ`|0Np%FDoBmO0sG@&*{IIl6X&^hL=oMPiwH4MdDrW#ZxBn6II*)?S{HMiUpsXJVTm$`5zaRXwa2!*v)JfSqm#BJJ&M+gP}wdj0_js;CG30ebW5d^|V4 z2*kKRU!q?*`5InBeDU_E++AI16e;Ybw0?7y@Ban>1y^g?}`g6ll!a=ri=!frp zxiiS#+Ij!@k3I;pvsYFwe$(2-=4Ry|da1ODeKGsU$n{H`*x&=@pDa7n#M0JmbwB+@ z6I)SIwD9N;LX1BvY=IDae-zi;9b%zp|F*p3lMv%tf1OQLHgN5+-|q6O48$vbsKYB*qvE1 z)-u)lho5LMHUa2E#N0S*hd?|UXD`0M>6y6j>)p86&(y-eUGpO?!u}^(*#6<%pf_3= zx2k&cwHC%tKYYAIV@CegYi!5GJ@3pqsj)*Z@ee~1?3H(BP1@v7i1mYrL>KQhh+T-6 z5Lv5O??gO@Xm1nz)rj4Qv|aGyh{q7Kmk9nM#Dj=rso>Wjb|GFuWXr^QC*nCo`xAn{ z8nGLZE*Jbb;xWYR6@tGA@gO2uDfl&rU5J+u*($N#iFgii*lNLNh#|yI#3P935Hr>Y zc{}1f#MOweAa*1E3z0r4^kyK&5w{~AL%e{Py_ON6$%u;(e}s4t@eCqaC*&Vm$9Ol^ z{b~L>_A}ll4ZGK|7&Oq|*BN#Fi_-NB%Kvwr>lu{czK_>4DDR~O8(0@_-_a{K82xqX z)CQxDUmLNJg_~ym{K!O)EAQ!FcMiH*?#dZnoVssYrEA)z!WYlSye@y}x&7X2vt2_s z*KaJ@Fx!>eVe8m?tlniCv4)f`c+9m%dE;ouzQ@+s^aRvfH0wJmn3>kr; zq8md8OO-lzWT29V4jnpl?9jneMYrDhc^Ht8`VZu!%g^t}eZ=yMm#-dp7!AuqJEzy8 zWYenbY@|}lSQ({V#`9e7yiswgv^2R^$kwI$XU_gk+1c2ZTWYA1z6tC6?HThna?dk) z5*aRb{ZmO?_dT*#ShP=-ovkdFiOJ*6C{n{-=gv*sn*Z%N8)&(1qK(A%a^LBeShbNI zVzo;P`uEI^bJ1C%Bl_{$j<2G-@Wc(#U8WyUmp<0Z60W6iy-5q$Yts@cpB~W9fg3{o zfx!~?4~95DxIka<4RL=C_vk-IUw=eDG5;HVp?jV7|Asxrym$B$`RFl~SRcK|`Oy#b z4|vbP7=42ZzG>3}4x2QkC5(MKrWH)uw168;n$i-cE!w7I%6isBoUxvEabskF04^ZK48$x+nR&%PS{jJC3KEMFb5l!Fi$Ed_3?Q{UC8@ausYQt;rA4U_ zQLq%4;0BURK+IL1SeBZTnwMUZ0TzeZ!2{%h*sP^_nI%xoAoWanxnOl{K=KAqi3E_A zC@f9PD=E#5ugpx%Nr^{s2}lpJnIJxMMoJNo0^2X{XXJ0HpskQmrl4!5;OB1)Wc&FW zfxL)eH%D4gVsc4lejZQ`X8#9=I0cYe28ZkbD7^tf=LkUQ0w{d}LgyMl=?PH!1BA{C zfYKWvbiM$TE`ZV(Aanu9%Ru`I0-*E+C=Hb_6oBvxq4I@L`9i3C5mdeiDqqwCQD1Zb zLiam>Y5NagiUCf)zy4A|WNxATySbA0ADW-Hf1BjBz}%_F{*8Kd0`r~M_OIToVNjkJ zYX5TMo&6uQH`~7`=dIs!Owj(hjh%zgg>&}L81w$$&(^Vja%}$m|MJuAA9r7fKfUv- z{i8re1;rzq>>r95-hUS_V1M8DYC^ttyZs%u@C3&_2kmd{yJ>&-`%3$(<EabskF04^ZK48$x+nR&%PS{jJC3KEMFb5l!Fi$Ed_3?Q{UC8@ausYQt;rA4U_ zQLq%4;0BURK+IL1SeBZTnwMUZ0TzeZ!2{%h*sP^_nI%xoAoWanxnOl{K=KAqi2{(8 zC@f9PD=E#5ugpx%Nr^{s2}lpJnIJxMMoJNo0^2X=XXJ0HpskQmrl4!5;OB1)Wc&F8 z34aaa08NljG2OtCR+N}rl9`_el!LkBheMnKNG*dyb^w�HJdPpmYJ0z5tu$U`;Msme<-oW{)n&t|H55s z?N3_tGS~;2+MiQC#mMt~kNw5==K5Q4$@Z83Dls@}F1No{bl?Evfy?$cUc@_O^oZNv zj{UoTPuU#%yO-xUC_6r|e-J6^V79)<{^6f1_J_Zf**{(|IYE#`$Ns5HP=fmIKKo}c z1nXZ%Jhgw(eW8I#z{CEPet(0+@zwUPFZ(s<*Yn!HE$6M@b4<|wJ;Q_rRz0!k{r~_w CxuydE diff --git a/docker/Dockerfile b/docker/Dockerfile new file mode 100644 index 00000000..6baec36b --- /dev/null +++ b/docker/Dockerfile @@ -0,0 +1,33 @@ +FROM fedora:37 + +RUN dnf -y update \ + && dnf -y install \ + gcc-fortran \ + gcc-c++ \ + gcc \ + gdb \ + git \ + netcdf-fortran-devel \ + cmake \ + make \ + lcov \ + valgrind \ + python3 \ + python3-pip \ + lapack-devel \ + yaml-cpp-devel \ + && dnf clean all + +RUN pip3 install numpy scipy + +ENV LD_LIBRARY_PATH=/usr/local/lib64 + +# build the tuv-x tool +COPY . /tuv-x/ +RUN mkdir /build \ + && cd /build \ + && cmake -D CMAKE_BUILD_TYPE=release \ + /tuv-x \ + && make install -j 8 + +WORKDIR /build diff --git a/Dockerfile.memcheck b/docker/Dockerfile.coverage similarity index 59% rename from Dockerfile.memcheck rename to docker/Dockerfile.coverage index 18187aab..26c827f4 100644 --- a/Dockerfile.memcheck +++ b/docker/Dockerfile.coverage @@ -1,4 +1,4 @@ -FROM fedora:35 +FROM fedora:37 RUN dnf -y update \ && dnf -y install \ @@ -15,25 +15,15 @@ RUN dnf -y update \ python3 \ python3-pip \ lapack-devel \ + yaml-cpp-devel \ && dnf clean all RUN pip3 install numpy scipy -# install json-fortran -RUN curl -LO https://github.com/jacobwilliams/json-fortran/archive/8.2.0.tar.gz \ - && tar -zxvf 8.2.0.tar.gz \ - && cd json-fortran-8.2.0 \ - && export FC=gfortran \ - && mkdir build \ - && cd build \ - && cmake -D SKIP_DOC_GEN:BOOL=TRUE .. \ - && sudo make install - # build the tuv-x tool COPY . /tuv-x/ RUN mkdir /build \ && cd /build \ - && export JSON_FORTRAN_HOME="/usr/local/jsonfortran-gnu-8.2.0" \ && cmake -D ENABLE_COVERAGE:BOOL=TRUE \ -D CMAKE_BUILD_TYPE=COVERAGE \ /tuv-x \ diff --git a/Dockerfile.docs b/docker/Dockerfile.docs similarity index 63% rename from Dockerfile.docs rename to docker/Dockerfile.docs index 51dd6d18..4868ebd1 100644 --- a/Dockerfile.docs +++ b/docker/Dockerfile.docs @@ -1,4 +1,4 @@ -FROM fedora:35 +FROM fedora:37 RUN dnf -y update \ && dnf -y install \ @@ -16,18 +16,9 @@ RUN dnf -y update \ python3 \ python3-pip \ lapack-devel \ + yaml-cpp-devel \ && dnf clean all -# install json-fortran -RUN curl -LO https://github.com/jacobwilliams/json-fortran/archive/8.2.0.tar.gz \ - && tar -zxvf 8.2.0.tar.gz \ - && cd json-fortran-8.2.0 \ - && export FC=gfortran \ - && mkdir build \ - && cd build \ - && cmake -D SKIP_DOC_GEN:BOOL=TRUE .. \ - && sudo make install - # build the tuv-x tool COPY . /tuv-x/ @@ -40,7 +31,6 @@ RUN echo "The suffix is '$SWITCHER_SUFFIX'" RUN mkdir /build \ && cd /build \ - && export JSON_FORTRAN_HOME="/usr/local/jsonfortran-gnu-8.2.0" \ && cmake -D ENABLE_TESTS=OFF \ -D BUILD_DOCS=ON \ /tuv-x \ diff --git a/docker/Dockerfile.memcheck b/docker/Dockerfile.memcheck new file mode 100644 index 00000000..ebcbec3e --- /dev/null +++ b/docker/Dockerfile.memcheck @@ -0,0 +1,32 @@ +FROM fedora:37 + +RUN dnf -y update \ + && dnf -y install \ + gcc-fortran \ + gcc-c++ \ + gcc \ + gdb \ + git \ + netcdf-fortran-devel \ + cmake \ + make \ + lcov \ + valgrind \ + python3 \ + python3-pip \ + lapack-devel \ + yaml-cpp-devel \ + && dnf clean all + +RUN pip3 install numpy scipy + +# build the tuv-x tool +COPY . /tuv-x/ +RUN mkdir /build \ + && cd /build \ + && cmake \ + -DENABLE_MEMCHECK:BOOL=TRUE \ + /tuv-x \ + && make -j 8 + +WORKDIR /build diff --git a/Dockerfile.mpi b/docker/Dockerfile.mpi similarity index 69% rename from Dockerfile.mpi rename to docker/Dockerfile.mpi index 79065e3e..c04e987c 100644 --- a/Dockerfile.mpi +++ b/docker/Dockerfile.mpi @@ -1,4 +1,4 @@ -FROM fedora:35 +FROM fedora:37 RUN dnf -y update \ && dnf install -y sudo \ @@ -24,6 +24,7 @@ RUN sudo dnf -y install \ python3-pip \ valgrind-openmpi \ lapack-devel \ + yaml-cpp-devel \ && sudo dnf clean all ENV PATH="${PATH}:/usr/lib64/openmpi/bin/" @@ -31,27 +32,16 @@ ENV OMP_NUM_THREADS=5 RUN pip3 install numpy scipy -# install json-fortran -RUN curl -LO https://github.com/jacobwilliams/json-fortran/archive/8.2.0.tar.gz \ - && tar -zxvf 8.2.0.tar.gz \ - && cd json-fortran-8.2.0 \ - && export FC=gfortran \ - && mkdir build \ - && cd build \ - && cmake -D SKIP_DOC_GEN:BOOL=TRUE .. \ - && sudo make install - - # build the tuv-x tool COPY . tuv-x/ RUN mkdir build \ && cd build \ - && export JSON_FORTRAN_HOME="/usr/local/jsonfortran-gnu-8.2.0" \ && cmake -D CMAKE_BUILD_TYPE=release \ -D CMAKE_Fortran_COMPILER=/usr/lib64/openmpi/bin/mpif90 \ + -D CMAKE_C_COMPILER=/usr/lib64/openmpi/bin/mpicc \ + -D CMAKE_CXX_COMPILER=/usr/lib64/openmpi/bin/mpicxx \ -D ENABLE_OPENMP:BOOL=TRUE \ -D ENABLE_MPI:BOOL=TRUE \ - -D ENABLE_MEMCHECK:BOOL=FALSE \ ../tuv-x \ && make -j 8 diff --git a/Dockerfile.mpi.memcheck b/docker/Dockerfile.mpi.memcheck similarity index 73% rename from Dockerfile.mpi.memcheck rename to docker/Dockerfile.mpi.memcheck index 6856fa4c..7d1eb662 100644 --- a/Dockerfile.mpi.memcheck +++ b/docker/Dockerfile.mpi.memcheck @@ -1,4 +1,4 @@ -FROM fedora:35 +FROM fedora:37 RUN dnf -y update \ && dnf install -y sudo \ @@ -24,6 +24,7 @@ RUN sudo dnf -y install \ python3-pip \ valgrind-openmpi \ lapack-devel \ + yaml-cpp-devel \ && sudo dnf clean all ENV PATH="${PATH}:/usr/lib64/openmpi/bin/" @@ -31,23 +32,14 @@ ENV OMP_NUM_THREADS=5 RUN pip3 install numpy scipy -# install json-fortran -RUN curl -LO https://github.com/jacobwilliams/json-fortran/archive/8.2.0.tar.gz \ - && tar -zxvf 8.2.0.tar.gz \ - && cd json-fortran-8.2.0 \ - && export FC=gfortran \ - && mkdir build \ - && cd build \ - && cmake -D SKIP_DOC_GEN:BOOL=TRUE .. \ - && sudo make install - # build the tuv-x tool COPY . tuv-x/ RUN mkdir build \ && cd build \ - && export JSON_FORTRAN_HOME="/usr/local/jsonfortran-gnu-8.2.0" \ && cmake -D CMAKE_BUILD_TYPE=debug \ -D CMAKE_Fortran_COMPILER=/usr/lib64/openmpi/bin/mpif90 \ + -D CMAKE_C_COMPILER=/usr/lib64/openmpi/bin/mpicc \ + -D CMAKE_CXX_COMPILER=/usr/lib64/openmpi/bin/mpicxx \ -D ENABLE_OPENMP:BOOL=TRUE \ -D ENABLE_MPI:BOOL=TRUE \ -D ENABLE_MEMCHECK:BOOL=TRUE \ diff --git a/docs/source/conf.py b/docs/source/conf.py index 7ac7dd1f..42db23e8 100644 --- a/docs/source/conf.py +++ b/docs/source/conf.py @@ -26,7 +26,7 @@ suffix = os.getenv("SWITCHER_SUFFIX", "") # The full version, including alpha/beta/rc tags -release = f'v0.7{suffix}' +release = f'v0.8{suffix}' # -- General configuration --------------------------------------------------- diff --git a/docs/switcher.json b/docs/switcher.json index 4b19298e..0aaa0b03 100644 --- a/docs/switcher.json +++ b/docs/switcher.json @@ -1,6 +1,6 @@ [ { - "name": "v0.7 (stable)", + "name": "v0.8 (stable)", "version": "stable", "url": "https://ncar.github.io/tuv-x/versions/stable/" }, @@ -18,5 +18,10 @@ "name": "v0.7", "version": "0.7", "url": "https://ncar.github.io/tuv-x/versions/0.7/" + }, + { + "name": "v0.8", + "version": "0.8", + "url": "https://ncar.github.io/tuv-x/versions/0.8/" } -] +] \ No newline at end of file diff --git a/examples/ts1_tsmlt.json b/examples/ts1_tsmlt.json new file mode 100644 index 00000000..7ea1806e --- /dev/null +++ b/examples/ts1_tsmlt.json @@ -0,0 +1,2095 @@ +{ + "__description": "TUV-x configuration for the MOZART-TS1 and MOZART-TSMLT chemical mechanisms", + "O2 absorption" : { + "cross section parameters file": "data/cross_sections/O2_parameters.txt" + }, + "grids": [ + { + "name": "height", + "type": "equal interval", + "units": "km", + "begins at" : 0.0, + "ends at" : 120.0, + "cell delta" : 1.0 + }, + { + "name": "wavelength", + "type": "from csv file", + "units": "nm", + "file path": "data/grids/wavelength/cam.csv" + }, + { + "name": "time", + "type": "from config file", + "units": "hours", + "values": [ 12.0, 14.0 ] + } + ], + "profiles": [ + { + "name": "O3", + "type": "O3", + "units": "molecule cm-3", + "file path": "data/profiles/atmosphere/ussa.ozone" + }, + { + "name": "air", + "type": "air", + "units": "molecule cm-3", + "file path": "data/profiles/atmosphere/ussa.dens" + }, + { + "name": "O2", + "type": "O2", + "units": "molecule cm-3", + "file path": "data/profiles/atmosphere/ussa.dens" + }, + { + "name": "temperature", + "type": "from csv file", + "units": "K", + "file path": "data/profiles/atmosphere/ussa.temp", + "grid": { + "name": "height", + "units": "km" + } + }, + { + "name": "solar zenith angle", + "type": "solar zenith angle", + "units": "degrees", + "year" : 2002, + "month": 3, + "day": 21, + "longitude": 0.0, + "latitude": 0.0 + }, + { + "name": "Earth-Sun distance", + "type": "Earth-Sun distance", + "units": "AU", + "year" : 2002, + "month": 3, + "day": 21 + }, + { + "name": "surface albedo", + "type": "from config file", + "units": "none", + "uniform value": 0.10, + "grid": { + "name": "wavelength", + "units": "nm" + } + }, + { + "name": "extraterrestrial flux", + "enable diagnostics" : true, + "type": "extraterrestrial flux", + "units": "photon cm-2 s-1", + "file path": ["data/profiles/solar/susim_hi.flx", + "data/profiles/solar/atlas3_1994_317_a.dat", + "data/profiles/solar/sao2010.solref.converted", + "data/profiles/solar/neckel.flx"], + "interpolator": ["","","","fractional target"] + } + ], + "radiative transfer": { + "__output": true, + "solver" : { + "type" : "delta eddington" + }, + "cross sections": [ + { + "name": "air", + "type": "air" + }, + { + "name": "O3", + "netcdf files": [ + { "file path": "data/cross_sections/O3_1.nc" }, + { "file path": "data/cross_sections/O3_2.nc" }, + { "file path": "data/cross_sections/O3_3.nc" }, + { "file path": "data/cross_sections/O3_4.nc" } + ], + "type": "O3" + }, + { + "name": "O2", + "netcdf files": [ + { + "file path": "data/cross_sections/O2_1.nc", + "lower extrapolation": { "type": "boundary" } + } + ], + "type": "base" + } + ], + "radiators": [ + { + "enable diagnostics" : true, + "name": "air", + "type": "base", + "treat as air": true, + "cross section": "air", + "vertical profile": "air", + "vertical profile units": "molecule cm-3" + }, + { + "enable diagnostics" : true, + "name": "O2", + "type": "base", + "cross section": "O2", + "vertical profile": "O2", + "vertical profile units": "molecule cm-3" + }, + { + "enable diagnostics" : true, + "name": "O3", + "type": "base", + "cross section": "O3", + "vertical profile": "O3", + "vertical profile units": "molecule cm-3" + }, + { + "enable diagnostics" : true, + "name": "aerosols", + "type": "aerosol", + "optical depths": [2.40e-01, 1.06e-01, 4.56e-02, 1.91e-02, 1.01e-02, 7.63e-03, + 5.38e-03, 5.00e-03, 5.15e-03, 4.94e-03, 4.82e-03, 4.51e-03, + 4.74e-03, 4.37e-03, 4.28e-03, 4.03e-03, 3.83e-03, 3.78e-03, + 3.88e-03, 3.08e-03, 2.26e-03, 1.64e-03, 1.23e-03, 9.45e-04, + 7.49e-04, 6.30e-04, 5.50e-04, 4.21e-04, 3.22e-04, 2.48e-04, + 1.90e-04, 1.45e-04, 1.11e-04, 8.51e-05, 6.52e-05, 5.00e-05, + 3.83e-05, 2.93e-05, 2.25e-05, 1.72e-05, 1.32e-05, 1.01e-05, + 7.72e-06, 5.91e-06, 4.53e-06, 3.46e-06, 2.66e-06, 2.04e-06, + 1.56e-06, 1.19e-06, 9.14e-07], + "single scattering albedo": 0.99, + "asymmetry factor": 0.61, + "550 nm optical depth": 0.235 + } + ] + }, + "photolysis": { + "reactions": [ + { + "name": "jo2_a", + "__reaction": "O2 + hv -> O + O1D", + "cross section": { + "apply O2 bands": true, + "netcdf files": [ + { + "file path": "data/cross_sections/O2_1.nc", + "lower extrapolation": { "type": "boundary" }, + "interpolator": { "type": "fractional target" } + } + ], + "type": "base" + }, + "quantum yield": { + "type": "base", + "constant value": 0, + "override bands": [ + { + "band": "lyman-alpha", + "value": 0.53 + }, + { + "band": "schumann-runge continuum", + "value": 1.0 + } + ] + }, + "heating" : { + "energy term": 175.05 + } + }, + { + "name": "jo2_b", + "__reaction": "O2 + hv -> O + O", + "cross section": { + "apply O2 bands": true, + "netcdf files": [ + { + "file path": "data/cross_sections/O2_1.nc", + "lower extrapolation": { "type": "boundary" }, + "interpolator": { "type": "fractional target" } + } + ], + "type": "base" + }, + "quantum yield": { + "type": "base", + "constant value": 1.0, + "override bands": [ + { + "band": "lyman-alpha", + "value": 0.47 + }, + { + "band": "schumann-runge continuum", + "value": 0.0 + } + ] + }, + "heating" : { + "energy term": 242.37 + } + }, + { + "name": "jo3_a", + "__reaction": "O3 + hv -> O2 + O(1D)", + "cross section": { + "netcdf files": [ + { "file path": "data/cross_sections/O3_1.nc" }, + { "file path": "data/cross_sections/O3_2.nc" }, + { "file path": "data/cross_sections/O3_3.nc" }, + { "file path": "data/cross_sections/O3_4.nc" } + ], + "type": "O3" + }, + "quantum yield": { + "type": "O3+hv->O2+O(1D)" + }, + "heating" : { + "energy term": 310.32 + } + }, + { + "name": "jo3_b", + "__reaction": "O3 + hv -> O2 + O(3P)", + "cross section": { + "netcdf files": [ + { "file path": "data/cross_sections/O3_1.nc" }, + { "file path": "data/cross_sections/O3_2.nc" }, + { "file path": "data/cross_sections/O3_3.nc" }, + { "file path": "data/cross_sections/O3_4.nc" } + ], + "type": "O3" + }, + "quantum yield": { + "type": "O3+hv->O2+O(3P)" + }, + "heating" : { + "energy term": 1179.87 + } + }, + { + "name": "jn2o", + "__reaction": "N2O + hv -> N2 + O(1D)", + "cross section": { + "type": "N2O+hv->N2+O(1D)" + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + } + }, + { + "name": "jno2", + "__reaction": "NO2 + hv -> NO + O(3P)", + "cross section": { + "netcdf files": [ + { "file path": "data/cross_sections/NO2_1.nc" } + ], + "type": "NO2 tint" + }, + "quantum yield": { + "netcdf files": ["data/quantum_yields/NO2_1.nc"], + "type": "NO2 tint", + "lower extrapolation": { "type": "boundary" } + } + }, + { + "name": "jn2o5_a", + "__reaction": "N2O5 + hv -> NO2 + NO3", + "cross section": { + "type":"temperature based", + "netcdf file": "data/cross_sections/N2O5_JPL06.nc", + "parameterization": { + "type": "HARWOOD", + "aa": [ -18.27, -18.42, -18.59, -18.72, -18.84, + -18.90, -18.93, -18.87, -18.77, -18.71, + -18.31, -18.14, -18.01, -18.42, -18.59, + -18.13 ], + "bb": [ -91.0, -104.0, -112.0, -135.0, -170.0, + -226.0, -294.0, -388.0, -492.0, -583.0, + -770.0, -885.0, -992.0, -949.0, -966.0, + -1160.0 ], + "base temperature": 0.0, + "base wavelength": 0.0, + "logarithm": "base 10", + "minimum wavelength": 260.0, + "maximum wavelength": 410.0, + "temperature ranges": [ + { + "maximum": 199.999999999999, + "fixed value": 200 + }, + { + "minimum": 200, + "maximum": 295 + }, + { + "minimum": 295.00000000001, + "fixed value": 295.0 + } + ] + }, + "parameterization wavelength grid": { + "name": "custom wavelengths", + "type": "from config file", + "units": "nm", + "values": [ + 255.0, 265.0, 275.0, 285.0, 295.0, 305.0, + 315.0, 325.0, 335.0, 345.0, 355.0, 365.0, + 375.0, 385.0, 395.0, 405.0, 415.0 + ] + } + }, + "quantum yield": { + "type": "Taylor series", + "constant value": 0.0, + "coefficients": [ -2.832441, 0.012809638 ], + "override bands": [ + { + "band": "range", + "minimum wavelength": 300.0, + "value": 1.0 + } + ] + } + }, + { + "name": "jn2o5_b", + "__reaction": "N2O5 + hv -> NO + O + NO3", + "cross section": { + "type":"temperature based", + "netcdf file": "data/cross_sections/N2O5_JPL06.nc", + "parameterization": { + "type": "HARWOOD", + "aa": [ -18.27, -18.42, -18.59, -18.72, -18.84, + -18.90, -18.93, -18.87, -18.77, -18.71, + -18.31, -18.14, -18.01, -18.42, -18.59, + -18.13 ], + "bb": [ -91.0, -104.0, -112.0, -135.0, -170.0, + -226.0, -294.0, -388.0, -492.0, -583.0, + -770.0, -885.0, -992.0, -949.0, -966.0, + -1160.0 ], + "base temperature": 0.0, + "base wavelength": 0.0, + "logarithm": "base 10", + "minimum wavelength": 260.0, + "maximum wavelength": 410.0, + "temperature ranges": [ + { + "maximum": 199.999999999999, + "fixed value": 200 + }, + { + "minimum": 200, + "maximum": 295 + }, + { + "minimum": 295.00000000001, + "fixed value": 295.0 + } + ] + }, + "parameterization wavelength grid": { + "name": "custom wavelengths", + "type": "from config file", + "units": "nm", + "values": [ + 255.0, 265.0, 275.0, 285.0, 295.0, 305.0, + 315.0, 325.0, 335.0, 345.0, 355.0, 365.0, + 375.0, 385.0, 395.0, 405.0, 415.0 + ] + } + }, + "quantum yield": { + "type": "Taylor series", + "constant value": 0.0, + "coefficients": [ 3.832441, -0.012809638 ], + "override bands": [ + { + "band": "range", + "minimum wavelength": 300.0, + "value": 0.0 + } + ] + } + }, + { + "name": "jhno3", + "__reaction": "HNO3 + hv -> OH + NO2", + "cross section": { + "netcdf files": [ + { "file path": "data/cross_sections/HNO3_JPL06.nc" } + ], + "type": "HNO3+hv->OH+NO2" + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + } + }, + { + "name": "jno3_a", + "__reaction": "NO3 + hv -> NO2 + O(3P)", + "cross section": { + "netcdf files": [ + { "file path": "data/cross_sections/NO3_1.nc" } + ], + "type": "base" + }, + "quantum yield": { + "netcdf files": [ + "data/quantum_yields/NO3-NO2+O(3P)_1.nc" + ], + "type": "tint", + "lower extrapolation": { + "type": "constant", + "value": 1.0 + } + } + }, + { + "name": "jno3_b", + "__reaction": "NO3 + hv -> NO + O2", + "cross section": { + "netcdf files": [ + { "file path": "data/cross_sections/NO3_1.nc" } + ], + "type": "base" + }, + "quantum yield": { + "netcdf files": [ + "data/quantum_yields/NO3-NO+O2_1.nc" + ], + "type": "tint" + } + }, + { + "name": "jch3ooh", + "__reaction": "CH3OOH + hv -> CH3O + OH", + "cross section": { + "netcdf files": [ + { "file path": "data/cross_sections/CH3OOH_1.nc" } + ], + "type": "base" + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + } + }, + { + "name": "jch2o_a", + "__reaction": "CH2O + hv -> H + HCO", + "cross section": { + "netcdf files": [ + { "file path": "data/cross_sections/CH2O_1.nc" } + ], + "type": "CH2O" + }, + "quantum yield": { + "netcdf files": [ + "data/quantum_yields/CH2O_1.nc" + ], + "type": "base", + "lower extrapolation": { + "type": "boundary" + } + } + }, + { + "name": "jch2o_b", + "__reaction": "CH2O + hv -> H2 + CO", + "cross section": { + "netcdf files": [ + { "file path": "data/cross_sections/CH2O_1.nc" } + ], + "type": "CH2O" + }, + "quantum yield": { + "netcdf files": [ + "data/quantum_yields/CH2O_1.nc" + ], + "type": "CH2O", + "lower extrapolation": { + "type": "boundary" + } + } + }, + { + "name": "jh2o2", + "__reaction": "H2O2 + hv -> OH + OH", + "cross section": { + "netcdf files": [ + { "file path": "data/cross_sections/H2O2_1.nc" } + ], + "type": "H2O2+hv->OH+OH" + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + } + }, + { + "name": "jch3cho", + "__reaction": "CH3CHO + hv -> CH3 + HCO", + "cross section": { + "netcdf files": [ + { "file path": "data/cross_sections/CH3CHO_1.nc" } + ], + "type": "base" + }, + "quantum yield": { + "netcdf files": [ + "data/quantum_yields/CH3CHO_1.nc" + ], + "type": "CH3CHO+hv->CH3+HCO" + } + }, + { + "name": "jpan", + "__reaction": "PAN + hv -> 0.6*CH3CO3 + 0.6*NO2 + 0.4*CH3O2 + 0.4*NO3 + 0.4*CO2", + "cross section": { + "netcdf files": [ + { "file path": "data/cross_sections/PAN_1.nc" } + ], + "type": "CH3ONO2+hv->CH3O+NO2" + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + } + }, + { + "name": "jmvk", + "__reaction": "MVK + hv -> 0.7*C3H6 + 0.7*CO + 0.3*CH3O2 + 0.3*CH3CO3", + "cross section": { + "netcdf files": [ + { "file path": "data/cross_sections/MVK_1.nc" } + ], + "type": "base" + }, + "quantum yield": { + "type": "MVK+hv->Products" + } + }, + { + "name": "jacet", + "__reaction": "CH3COCH3 + hv -> CH3CO + CH3", + "cross section": { + "type": "temperature based", + "parameterization": { + "type": "TAYLOR_SERIES", + "netcdf file": { + "file path": "data/cross_sections/ACETONE_JPL06.nc" + }, + "base temperature": 0.0, + "temperature ranges": [ + { + "maximum": 234.999999999999, + "fixed value": 235.0 + }, + { + "minimum": 235.0, + "maximum": 298.0 + }, + { + "minimum": 298.00000000001, + "fixed value": 298.0 + } + ] + } + }, + "quantum yield": { + "type": "CH3COCH3+hv->CH3CO+CH3", + "branch": "CO+CH3CO", + "low wavelength value": 1, + "minimum temperature": 218, + "maximum temperature": 295 + } + }, + { + "name": "jmgly", + "__reaction": "CH3COCHO + hv -> CH3CO3 + CO + HO2", + "cross section": { + "netcdf files": [ + { "file path": "data/cross_sections/CH3COCHO_1.nc" } + ], + "type": "base" + }, + "quantum yield": { + "type": "CH3COCHO+hv->CH3CO+HCO" + } + }, + { + "name": "jglyald", + "__reaction": "GLYALD + hv -> 2*HO2 + CO + CH2O", + "cross section": { + "netcdf files": [ + { "file path": "data/cross_sections/HOCH2CHO_1.nc" } + ], + "type": "base" + }, + "quantum yield": { + "type": "base", + "constant value": 0.5 + } + }, + { + "name": "jbrcl", + "__reaction": "BrCl + hv -> Br + Cl", + "cross section": { + "netcdf files": [ + { "file path": "data/cross_sections/BrCl_1.nc" } + ], + "type": "base" + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + } + }, + { + "name": "jbro", + "__reaction": "BrO + hv -> Br + O", + "cross section": { + "netcdf files": [ + { + "file path": "data/cross_sections/BRO_JPL06.nc" + } + ], + "type": "base" + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + } + }, + { + "name": "jbrono2_a", + "__reaction": "BrONO2 + hv -> Br + NO3", + "cross section": { + "type": "temperature based", + "parameterization": { + "type": "TAYLOR_SERIES", + "netcdf file": { + "file path": "data/cross_sections/BRONO2_JPL06.nc" + }, + "base temperature": 296.0, + "temperature ranges": [ + { + "maximum": 199.999999999999, + "fixed value": 200.0 + }, + { + "minimum": 200.0, + "maximum": 296.0 + }, + { + "minimum": 296.00000000001, + "fixed value": 296.0 + } + ] + } + }, + "quantum yield": { + "type": "base", + "constant value": 0.85 + } + }, + { + "name": "jbrono2_b", + "__reaction": "BrONO2 + hv -> BrO + NO2", + "cross section": { + "type": "temperature based", + "parameterization": { + "type": "TAYLOR_SERIES", + "netcdf file": { + "file path": "data/cross_sections/BRONO2_JPL06.nc" + }, + "base temperature": 296.0, + "temperature ranges": [ + { + "maximum": 199.999999999999, + "fixed value": 200.0 + }, + { + "minimum": 200.0, + "maximum": 296.0 + }, + { + "minimum": 296.00000000001, + "fixed value": 296.0 + } + ] + } + }, + "quantum yield": { + "type": "base", + "constant value": 0.15 + } + }, + { + "name": "jccl4", + "__reaction": "CCl4 + hv -> Products", + "cross section": { + "netcdf files": [ + { "file path": "data/cross_sections/CCl4_1.nc" } + ], + "type": "CCl4+hv->Products" + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + } + }, + { + "name": "jcf2clbr", + "__reaction": "CF2BrCl + hv -> Products", + "cross section": { + "netcdf files": [ + { "file path": "data/cross_sections/CF2BrCl_1.nc" } + ], + "type": "base" + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + } + }, + { + "name": "jcf3br", + "__reaction": "CF3Br + hv -> Products", + "cross section": { + "type": "temperature based", + "netcdf file": "data/cross_sections/H1301_JPL06.nc", + "parameterization": { + "AA": [ 62.563, -2.0068, 1.6592e-2, -5.6465e-5, 6.7459e-8 ], + "BB": [ -9.1755e-1, 1.8575e-2, -1.3857e-4, 4.5066e-7, -5.3803e-10 ], + "lp": [ 0.0, 1.0, 2.0, 3.0, 4.0 ], + "minimum wavelength": 178.0, + "maximum wavelength": 280.0, + "base temperature": 273.0, + "base wavelength": 0.0, + "logarithm": "base 10", + "temperature ranges": [ + { + "maximum": 209.999999999999, + "fixed value": 210.0 + }, + { + "minimum": 210.0, + "maximum": 300.0 + }, + { + "minimum": 300.00000000001, + "fixed value": 300.0 + } + ] + } + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + } + }, + { + "name": "jcfcl3", + "__reaction": "CCl3F + hv -> Products", + "cross section": { + "type": "temperature based", + "netcdf file": "data/cross_sections/CFCL3_JPL06.nc", + "parameterization": { + "AA": [ -84.611, 7.9551e-1, -2.0550e-3, -4.4812e-6, 1.5838e-8 ], + "BB": [ -5.7912, 1.1689e-1, -8.8069e-4, 2.9335e-6, -3.6421e-9 ], + "lp": [ 0.0, 1.0, 2.0, 3.0, 4.0 ], + "minimum wavelength": 174.1, + "maximum wavelength": 230.0, + "base temperature": 273.0, + "base wavelength": 0.0, + "logarithm": "base 10", + "temperature ranges": [ + { + "maximum": 209.999999999999, + "fixed value": 210.0 + }, + { + "minimum": 210, + "maximum": 300 + }, + { + "minimum": 300.00000000001, + "fixed value": 300.0 + } + ] + } + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + } + }, + { + "name": "jcfc113", + "__reaction": "CFC-113 + hv -> Products", + "cross section": { + "type": "temperature based", + "netcdf file": "data/cross_sections/CFC113_JPL06.nc", + "parameterization": { + "AA": [ -1087.9, 20.004, -1.3920e-1, 4.2828e-4, -4.9384e-7 ], + "BB": [ 12.493, -2.3937e-1, 1.7142e-3, -5.4393e-6, 6.4548e-9 ], + "lp": [ 0.0, 1.0, 2.0, 3.0, 4.0 ], + "minimum wavelength": 182.0, + "maximum wavelength": 230.0, + "base temperature": 273.0, + "base wavelength": 0.0, + "logarithm": "base 10", + "temperature ranges": [ + { + "maximum": 209.999999999999, + "fixed value": 210.0 + }, + { + "minimum": 210, + "maximum": 300 + }, + { + "minimum": 300.00000000001, + "fixed value": 300.0 + } + ] + } + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + } + }, + { + "name": "jcfc114", + "__reaction": "CFC-114 + hv -> Products", + "cross section": { + "type": "temperature based", + "netcdf file": "data/cross_sections/CFC114_JPL10.nc", + "parameterization": { + "AA": [ -160.50, 2.4807, -1.5202e-2, 3.8412e-5, -3.4373e-8 ], + "BB": [ -1.5296, 3.5248e-2, -2.9951e-4, 1.1129e-6, -1.5259e-9 ], + "lp": [ 0.0, 1.0, 2.0, 3.0, 4.0 ], + "minimum wavelength": 172.0, + "maximum wavelength": 220.0, + "base temperature": 273.0, + "base wavelength": 0.0, + "logarithm": "base 10", + "temperature ranges": [ + { + "maximum": 209.999999999999, + "fixed value": 210.0 + }, + { + "minimum": 210, + "maximum": 300 + }, + { + "minimum": 300.00000000001, + "fixed value": 300.0 + } + ] + } + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + } + }, + { + "name": "jcfc115", + "__reaction": "CFC-115 + hv -> Products", + "cross section": { + "type": "base", + "netcdf files": [ + { "file path": "data/cross_sections/CFC115_JPL10.nc" } + ] + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + } + }, + { + "name": "jcf2cl2", + "__reaction": "CCl2F2 + hv -> Products", + "cross section": { + "type": "temperature based", + "netcdf file": "data/cross_sections/CF2CL2_JPL06.nc", + "parameterization": { + "AA": [ -43.8954569, -2.403597e-1, -4.2619e-4, 9.8743e-6, 0.0 ], + "BB": [ 4.8438e-3, 4.96145e-4, -5.6953e-6, 0.0, 0.0 ], + "lp": [ 0.0, 1.0, 2.0, 3.0, 4.0 ], + "minimum wavelength": 200.0, + "maximum wavelength": 231.0, + "base temperature": 296.0, + "base wavelength": 200.0, + "logarithm": "natural", + "temperature ranges": [ + { + "maximum": 219.999999999999, + "fixed value": 220.0 + }, + { + "minimum": 220, + "maximum": 296 + }, + { + "minimum": 296.00000000001, + "fixed value": 296.0 + } + ] + } + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + } + }, + { + "name": "jch2br2", + "__reaction": "CH2BR2 + hv -> 2*BR", + "cross section": { + "type": "temperature based", + "netcdf file": "data/cross_sections/CH2BR2_1.nc", + "parameterization": { + "AA": [ -70.211776, 1.940326e-1, 2.726152e-3, -1.695472e-5, 2.500066e-8 ], + "BB": [ 2.899280, -4.327724e-2, 2.391599e-4, -5.807506e-7, 5.244883e-10 ], + "lp": [ 0.0, 1.0, 2.0, 3.0, 4.0 ], + "minimum wavelength": 210.0, + "maximum wavelength": 290.0, + "base temperature": 273.0, + "base wavelength": 0.0, + "logarithm": "base 10", + "temperature ranges": [ + { + "maximum": 209.999999999999, + "fixed value": 210.0 + }, + { + "minimum": 210, + "maximum": 300 + }, + { + "minimum": 300.00000000001, + "fixed value": 300.0 + } + ] + } + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + } + }, + { + "name": "jch3br", + "__reaction": "CH3Br + hv -> Products", + "cross section": { + "type": "temperature based", + "netcdf file": "data/cross_sections/CH3BR_JPL06.nc", + "parameterization": { + "AA": [ 46.520, -1.4580, 1.1469e-2, -3.7627e-5, 4.3264e-8 ], + "BB": [ 9.3408e-1, -1.6887e-2, 1.1487e-4, -3.4881e-7, 3.9945e-10 ], + "lp": [ 0.0, 1.0, 2.0, 3.0, 4.0 ], + "minimum wavelength": 200.0, + "maximum wavelength": 280.0, + "base temperature": 273.0, + "base wavelength": 0.0, + "logarithm": "base 10", + "temperature ranges": [ + { + "maximum": 209.999999999999, + "fixed value": 210.0 + }, + { + "minimum": 210, + "maximum": 300 + }, + { + "minimum": 300.00000000001, + "fixed value": 300.0 + } + ] + } + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + } + }, + { + "name": "jch3ccl3", + "__reaction": "CH3CCl3+hv->Products", + "cross section": { + "netcdf files": [ + { "file path": "data/cross_sections/CH3CCl3_1.nc" } + ], + "type": "tint" + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + } + }, + { + "name": "jch3cl", + "__reaction": "CH3Cl + hv -> Products", + "cross section": { + "type": "temperature based", + "netcdf file": "data/cross_sections/CH3CL_JPL06.nc", + "parameterization": { + "AA": [ -299.80, 5.1047, -3.3630e-2, 9.5805e-5, -1.0135e-7 ], + "BB": [ -7.1727, 1.4837e-1, -1.1463e-3, 3.9188e-6, -4.9994e-9 ], + "lp": [ 0.0, 1.0, 2.0, 3.0, 4.0 ], + "minimum wavelength": 174.1, + "maximum wavelength": 216.0, + "base temperature": 273.0, + "base wavelength": 0.0, + "logarithm": "base 10", + "temperature ranges": [ + { + "maximum": 209.999999999999, + "fixed value": 210.0 + }, + { + "minimum": 210, + "maximum": 300 + }, + { + "minimum": 300.00000000001, + "fixed value": 300.0 + } + ] + } + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + } + }, + { + "name": "jchbr3", + "__reaction": "CHBr3 + hv -> Products", + "cross section": { + "type": "temperature based", + "netcdf file": "data/cross_sections/CHBR3_JPL10.nc", + "parameterization": { + "AA": [ -32.6067, 0.10308, 6.39e-5, -7.7392e-7, -2.2513e-9, 6.1376e-12 ], + "BB": [ 0.1582, -0.0014758, 3.8058e-6, 9.187e-10, -1.0772e-11, 0.0 ], + "lp": [ 0.0, 1.0, 2.0, 3.0, 4.0, 5.0 ], + "minimum wavelength": 260.0, + "maximum wavelength": 362.0, + "base temperature": 296.0, + "base wavelength": 0.0, + "logarithm": "base 10", + "invert temperature offset": true, + "temperature ranges": [ + { + "maximum": 259.999999999999, + "fixed value": 260.0 + }, + { + "minimum": 260.0 + } + ] + } + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + } + }, + { + "name": "jcl2", + "__reaction": "Cl2 + hv -> Cl + Cl", + "cross section": { + "type": "Cl2+hv->Cl+Cl" + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + } + }, + { + "name": "jcl2o2", + "__reaction": "ClOOCl + hv -> Cl + ClOO", + "__comments": "TODO - this doesn't exactly match the products in TS1", + "cross section": { + "netcdf files": [ + { "file path": "data/cross_sections/CL2O2_JPL10.nc" } + ], + "type": "base" + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + } + }, + { + "name": "jclo", + "__reaction": "ClO + hv -> Cl + O", + "cross section": { + "netcdf files": [ + { "file path": "data/cross_sections/CLO_JPL06.nc" } + ], + "type": "base" + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + } + }, + { + "name": "jclono2_a", + "__reaction": "ClONO2 + hv -> Cl + NO3", + "cross section": { + "netcdf files": [ + { "file path": "data/cross_sections/ClONO2_1.nc" } + ], + "type": "ClONO2" + }, + "quantum yield": { + "type": "ClONO2+hv->Cl+NO3" + } + }, + { + "name": "jclono2_b", + "__reaction": "ClONO2 + hv -> ClO + NO2", + "cross section": { + "netcdf files": [ + { "file path": "data/cross_sections/ClONO2_1.nc" } + ], + "type": "ClONO2" + }, + "quantum yield": { + "type": "ClONO2+hv->ClO+NO2" + } + }, + { + "name": "jcof2", + "__reaction": "CF2O + hv -> Products", + "cross section": { + "netcdf files": [ + { "file path": "data/cross_sections/CF2O_1.nc" } + ], + "type": "base" + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + } + }, + { + "name": "jcofcl", + "__reaction": "CClFO + hv -> Products", + "cross section": { + "netcdf files": [ + { "file path": "data/cross_sections/CClFO_1.nc" } + ], + "type": "base" + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + } + }, + { + "name": "jh2402", + "__reaction": "H2402 + hv -> 2*BR + 2*COF2", + "__comments": "TUV data set name CF2BrCF2Br", + "cross section": { + "type": "temperature based", + "netcdf file": "data/cross_sections/H2402_JPL06.nc", + "parameterization": { + "AA": [ 34.026, -1.152616, 8.959798e-3, -2.9089e-5, 3.307212e-8 ], + "BB": [ 4.010664e-1, -8.358968e-3, 6.415741e-5, -2.157554e-7, 2.691871e-10 ], + "lp": [ 0.0, 1.0, 2.0, 3.0, 4.0 ], + "minimum wavelength": 190.0, + "maximum wavelength": 290.0, + "base temperature": 273.0, + "base wavelength": 0.0, + "logarithm": "base 10", + "temperature ranges": [ + { + "maximum": 209.999999999999, + "fixed value": 210.0 + }, + { + "minimum": 210.0, + "maximum": 300.0 + }, + { + "minimum": 300.00000000001, + "fixed value": 300.0 + } + ] + } + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + } + }, + { + "name": "jhcfc141b", + "__reaction": "HCFC-141b + hv -> Products", + "cross section": { + "type": "temperature based", + "netcdf file": "data/cross_sections/HCFC141b_JPL10.nc", + "parameterization": { + "AA": [ -682.913042, 12.122290, -8.187699e-2, 2.437244e-4, -2.719103e-7 ], + "BB": [ 4.074747, -8.053899e-2, 5.946552e-4, -1.945048e-6, 2.380143e-9 ], + "lp": [ 0.0, 1.0, 2.0, 3.0, 4.0 ], + "minimum wavelength": 172.0, + "maximum wavelength": 240.0, + "base temperature": 273.0, + "base wavelength": 0.0, + "logarithm": "base 10", + "temperature ranges": [ + { + "maximum": 209.999999999999, + "fixed value": 210.0 + }, + { + "minimum": 210.0, + "maximum": 300.0 + }, + { + "minimum": 300.00000000001, + "fixed value": 300.0 + } + ] + } + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + } + }, + { + "name": "jhcfc142b", + "__reaction": "HCFC-142b + hv -> Products", + "cross section": { + "type": "temperature based", + "netcdf file": "data/cross_sections/HCFC142b_JPL10.nc", + "parameterization": { + "AA": [ -328.092008, 6.342799, -4.810362e-2, 1.611991e-4, -2.042613e-7 ], + "BB": [ 4.289533e-1, -9.042817e-3, 7.018009e-5, -2.389064e-7, 3.039799e-10 ], + "lp": [ 0.0, 1.0, 2.0, 3.0, 4.0 ], + "minimum wavelength": 172.0, + "maximum wavelength": 230.0, + "base temperature": 273.0, + "base wavelength": 0.0, + "logarithm": "base 10", + "temperature ranges": [ + { + "maximum": 209.999999999999, + "fixed value": 210.0 + }, + { + "minimum": 210.0, + "maximum": 300.0 + }, + { + "minimum": 300.00000000001, + "fixed value": 300.0 + } + ] + } + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + } + }, + { + "name": "jhcfc22", + "__reaction": "HCFC-22 + hv -> Products", + "cross section": { + "type": "temperature based", + "netcdf file": "data/cross_sections/HCFC22_JPL06.nc", + "parameterization wavelength grid": { + "name": "custom wavelengths", + "type": "from config file", + "units": "nm", + "values": [ + 169.0, 171.0, 173.0, 175.0, 177.0, 179.0, 181.0, 183.0, 185.0, + 187.0, 189.0, 191.0, 193.0, 195.0, 197.0, 199.0, 201.0, 203.0, + 205.0, 207.0, 209.0, 211.0, 213.0, 215.0, 217.0, 219.0, 221.0 + ] + }, + "parameterization": { + "AA": [ -106.029, 1.5038, -8.2476e-3, 1.4206e-5 ], + "BB": [ -1.3399e-1, 2.7405e-3, -1.8028e-5, 3.8504e-8 ], + "lp": [ 0.0, 1.0, 2.0, 3.0 ], + "minimum wavelength": 174.0, + "maximum wavelength": 204.0, + "base temperature": 273.0, + "base wavelength": 0.0, + "logarithm": "base 10", + "temperature ranges": [ + { + "maximum": 209.999999999999, + "fixed value": 210.0 + }, + { + "minimum": 210.0, + "maximum": 300.0 + }, + { + "minimum": 300.00000000001, + "fixed value": 300.0 + } + ] + } + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + } + }, + { + "name": "jhcl", + "__reaction": "HCl + hv -> H + Cl", + "cross section": { + "netcdf files": [ + { "file path": "data/cross_sections/HCl_1.nc" } + ], + "type": "base" + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + } + }, + { + "name": "jhobr", + "__reaction": "HOBr + hv -> OH + Br", + "cross section": { + "type": "HOBr+hv->OH+Br" + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + } + }, + { + "name": "jhocl", + "__reaction": "HOCl + hv -> HO + Cl", + "cross section": { + "netcdf files": [ + { "file path": "data/cross_sections/HOCl_1.nc" } + ], + "type": "base" + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + } + }, + { + "name": "joclo", + "__reaction": "OClO + hv -> Products", + "cross section": { + "netcdf files": [ + { "file path": "data/cross_sections/OClO_1.nc" }, + { "file path": "data/cross_sections/OClO_2.nc" }, + { "file path": "data/cross_sections/OClO_3.nc" } + ], + "type": "OClO+hv->Products" + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + } + }, + { + "name": "jho2no2_a", + "__reaction": "HNO4 + hv -> OH + NO3", + "cross section": { + "type": "temperature based", + "netcdf file": "data/cross_sections/HO2NO2_JPL06.nc", + "parameterization": { + "type": "BURKHOLDER", + "netcdf file": { + "file path": "data/cross_sections/HO2NO2_temp_JPL06.nc" + }, + "A": -988.0, + "B": 0.69, + "temperature ranges": [ + { + "maximum": 279.999999999999, + "fixed value": 280.0 + }, + { + "minimum": 280.0, + "maximum": 350.0 + }, + { + "minimum": 350.00000000001, + "fixed value": 350.0 + } + ] + } + }, + "quantum yield": { + "type": "base", + "constant value": 0.30, + "override bands": [ + { + "band": "range", + "minimum wavelength": 200.0, + "value": 0.20 + } + ] + } + }, + { + "name": "jho2no2_b", + "__reaction": "HNO4 + hv -> HO2 + NO2", + "cross section": { + "type": "temperature based", + "netcdf file": "data/cross_sections/HO2NO2_JPL06.nc", + "parameterization": { + "type": "BURKHOLDER", + "netcdf file": { + "file path": "data/cross_sections/HO2NO2_temp_JPL06.nc" + }, + "A": -988.0, + "B": 0.69, + "temperature ranges": [ + { + "maximum": 279.999999999999, + "fixed value": 280.0 + }, + { + "minimum": 280.0, + "maximum": 350.0 + }, + { + "minimum": 350.00000000001, + "fixed value": 350.0 + } + ] + } + }, + "quantum yield": { + "type": "base", + "constant value": 0.70, + "override bands": [ + { + "band": "range", + "minimum wavelength": 200.0, + "value": 0.80 + } + ] + } + }, + { + "name": "jmacr_a", + "__reaction": "CH2=C(CH3)CHO->1.34HO2+0.66MCO3+1.34CH2O+CH3CO3", + "__comments": "Methacrolein photolysis channel 1", + "cross section": { + "netcdf files": [ + { "file path": "data/cross_sections/Methacrolein_1.nc" } + ], + "type": "base" + }, + "quantum yield": { + "type": "base", + "constant value": 0.005 + } + }, + { + "name": "jmacr_b", + "__reaction": "CH2=C(CH3)CHO->0.66OH+1.34CO", + "__comments": "Methacrolein photolysis channel 2", + "cross section": { + "netcdf files": [ + { "file path": "data/cross_sections/Methacrolein_1.nc" } + ], + "type": "base" + }, + "quantum yield": { + "type": "base", + "constant value": 0.005 + } + }, + { + "name": "jhyac", + "__reaction": "CH2(OH)COCH3->CH3CO3+HO2+CH2O", + "__comments": "hydroxy acetone TODO: the products of this reaction differ from standalone TUV-x", + "cross section": { + "netcdf files": [ + { "file path": "data/cross_sections/Hydroxyacetone_1.nc" } + ], + "type": "base" + }, + "quantum yield": { + "type": "base", + "constant value": 0.65 + } + }, + { + "name": "jh2o_a", + "__reaction": "H2O + hv -> OH + H", + "cross section": { + "type": "base", + "merge data": true, + "netcdf files": [ + { + "file path": "data/cross_sections/H2O_1.nc", + "zero above": 183.0 + }, + { + "file path": "data/cross_sections/H2O_2.nc", + "zero below": 183.00000000001, + "zero above": 190.0 + }, + { + "file path": "data/cross_sections/H2O_3.nc", + "zero below": 190.00000000001 + } + ] + }, + "quantum yield" : { + "type": "base", + "netcdf files": [ "data/quantum_yields/H2O_H_OH.nc" ] + } + }, + { + "name": "jh2o_b", + "__reaction": "H2O + hv -> H2 + O1D", + "cross section": { + "type": "base", + "merge data": true, + "netcdf files": [ + { + "file path": "data/cross_sections/H2O_1.nc", + "zero above": 183.0 + }, + { + "file path": "data/cross_sections/H2O_2.nc", + "zero below": 183.00000000001, + "zero above": 190.0 + }, + { + "file path": "data/cross_sections/H2O_3.nc", + "zero below": 190.00000000001 + } + ] + }, + "quantum yield" : { + "type": "base", + "netcdf files": [ "data/quantum_yields/H2O_H2_O1D.nc" ] + } + }, + { + "name": "jh2o_c", + "__reaction": "H2O + hv -> 2*H + O", + "cross section": { + "type": "base", + "merge data": true, + "netcdf files": [ + { + "file path": "data/cross_sections/H2O_1.nc", + "zero above": 183.0 + }, + { + "file path": "data/cross_sections/H2O_2.nc", + "zero below": 183.00000000001, + "zero above": 190.0 + }, + { + "file path": "data/cross_sections/H2O_3.nc", + "zero below": 190.00000000001 + } + ] + }, + "quantum yield" : { + "type": "base", + "netcdf files": [ "data/quantum_yields/H2O_2H_O3P.nc" ] + } + }, + { + "name": "jch4_a", + "__reaction": "CH4 + hv -> H + CH3O2", + "cross section": { + "type": "base", + "netcdf files": [ + { "file path": "data/cross_sections/CH4_1.nc" } + ] + }, + "quantum yield": { + "type": "base", + "constant value": 0.45 + } + }, + { + "name": "jch4_b", + "__reaction": "CH4 + hv -> 1.44*H2 + 0.18*CH2O + 0.18*O + 0.33*OH + 0.33*H + 0.44*CO2 + 0.38*CO + 0.05*H2O", + "cross section": { + "type": "base", + "netcdf files": [ + { "file path": "data/cross_sections/CH4_1.nc" } + ] + }, + "quantum yield": { + "type": "base", + "constant value": 0.55 + } + }, + { + "name": "jco2", + "__reaction": "CO2 + hv -> CO + O", + "cross section": { + "type": "base", + "netcdf files": [ + { "file path": "data/cross_sections/CO2_1.nc" } + ] + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + } + }, + { + "name": "jhbr", + "__reaction": "HBR + hv -> BR + H", + "cross section": { + "type": "base", + "netcdf files": [ + { "file path": "data/cross_sections/HBr_1.nc" } + ] + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + } + }, + { + "name": "jhf", + "__reaction": "HF + hv -> H + F", + "cross section": { + "type": "base", + "netcdf files": [ + { "file path": "data/cross_sections/HF_1.nc" } + ] + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + } + }, + { + "name": "jsf6", + "__reaction": "SF6 + hv -> sink", + "cross section": { + "type": "base", + "netcdf files": [ + { "file path": "data/cross_sections/SF6_1.nc" } + ] + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + } + }, + { + "name": "jh2so4", + "__reaction": "H2SO4 + hv -> SO3 + H2O", + "cross section": { + "type": "base", + "data": { + "default value": 0.0, + "point values": [ + { "wavelength": 121.65, "value": 6.3e-17 }, + { "wavelength": 525.0, "value": 1.43e-26 }, + { "wavelength": 625.0, "value": 1.8564e-25 }, + { "wavelength": 725.0, "value": 3.086999e-24 } + ] + } + }, + "quantum yield": { + "type": "H2SO4 Mills", + "netcdf files": [ + "data/quantum_yields/H2SO4_mills.nc" + ], + "parameterized wavelengths": [ + 525, + 625, + 725 + ], + "collision interval s": [ + 1.1e-9, + 8.9e-9, + 1.7e-7 + ], + "molecular diameter m": 4.18e-10, + "molecular weight kg mol-1": 98.078479e-3 + } + }, + { + "name": "jocs", + "__reaction": "OCS + hv -> S + CO", + "cross section": { + "type": "base", + "netcdf files": [ + { "file path": "data/cross_sections/OCS_1.nc" } + ] + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + } + }, + { + "name": "jso", + "__reaction": "SO + hv -> S + O", + "cross section": { + "type": "base", + "netcdf files": [ + { "file path": "data/cross_sections/SO_1.nc" } + ] + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + } + }, + { + "name": "jso2", + "__reaction": "SO2 + hv -> SO + O", + "cross section": { + "type": "base", + "netcdf files": [ + { "file path": "data/cross_sections/SO2_Mills.nc" } + ] + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + } + }, + { + "name": "jso3", + "__reaction": "SO3 + hv -> SO2 + O", + "cross section": { + "type": "base", + "netcdf files": [ + { "file path": "data/cross_sections/SO3_1.nc" } + ] + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + } + }, + { + "name": "jno_i", + "__reaction": "NO + hv -> NOp + e", + "cross section": { + "type": "base", + "data": { + "default value": 0.0, + "point values": [ + { "wavelength": 121.65, "value": 2.0e-18 } + ] + } + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + } + } + ] + }, + "__CAM options": { + "aliasing": { + "default matching": "backup", + "pairs": [ + { + "to": "jalknit", + "__reaction": "ALKNIT + hv -> NO2 + 0.4*CH3CHO + 0.1*CH2O + 0.25*CH3COCH3 + HO2 + 0.8*MEK", + "from": "jch3ooh" + }, + { + "to": "jpooh", + "__reaction": "POOH (C3H6OHOOH) + hv -> CH3CHO + CH2O + HO2 + OH", + "from": "jch3ooh" + }, + { + "to": "jch3co3h", + "__reaction": "CH3COOOH + hv -> CH3O2 + OH + CO2", + "from": "jh2o2", + "scale by": 0.28 + }, + { + "to": "jmpan", + "__reaction": "MPAN + hv -> MCO3 + NO2", + "from": "jpan" + }, + { + "to": "jc2h5ooh", + "__reaction": "C2H5OOH + hv -> CH3CHO + HO2 + OH", + "from": "jch3ooh" + }, + { + "to": "jc3h7ooh", + "__reaction": "C3H7OOH + hv -> 0.82*CH3COCH3 + OH + HO2", + "from": "jch3ooh" + }, + { + "to": "jc6h5ooh", + "__reaction": "C6H5OOH + hv -> PHENO + OH", + "from": "jch3ooh" + }, + { + "to": "jeooh", + "__reaction": "EOOH + hv -> EO + OH", + "from": "jch3ooh" + }, + { + "to": "jrooh", + "__reaction": "ROOH + hv -> CH3CO3 + CH2O + OH", + "from": "jch3ooh" + }, + { + "to": "jxooh", + "__reaction": "XOOH + hv -> OH", + "from": "jch3ooh" + }, + { + "to": "jonitr", + "__reaction": "ONITR + hv -> NO2", + "from": "jch3cho" + }, + { + "to": "jisopooh", + "__reaction": "ISOPOOH + hv -> 0.402*MVK + 0.288*MACR + 0.69*CH2O + HO2", + "from": "jch3ooh" + }, + { + "to": "jmek", + "__reaction": "MEK + hv -> CH3CO3 + C2H5O2", + "from": "jacet" + }, + { + "to": "jalkooh", + "__reaction": "ALKOOH + hv -> .4*CH3CHO + .1*CH2O + .25*CH3COCH3 + .9*HO2 + .8*MEK + OH", + "from": "jch3ooh" + }, + { + "to": "jbenzooh", + "__reaction": "BENZOOH + hv -> OH + GLYOXAL + 0.5*BIGALD1 + HO2", + "from": "jch3ooh" + }, + { + "to": "jbepomuc", + "__reaction": "BEPOMUC + hv -> BIGALD1 + 1.5*HO2 + 1.5*CO", + "from": "jno2", + "scale by": 0.1 + }, + { + "to": "jbigald", + "__reaction": "BIGALD + hv -> 0.45*CO + 0.13*GLYOXAL + 0.56*HO2 + 0.13*CH3CO3 + 0.18*CH3COCHO", + "from": "jno2", + "scale by": 0.2 + }, + { + "to": "jbigald1", + "__reaction": "BIGALD1 + hv -> 0.6*MALO2 + HO2", + "from": "jno2", + "scale by": 0.14 + }, + { + "to": "jbigald2", + "__reaction": "BIGALD2 + hv -> 0.6*HO2 + 0.6*DICARBO2", + "from": "jno2", + "scale by": 0.2 + }, + { + "to": "jbigald3", + "__reaction": "BIGALD3 + hv -> 0.6*HO2 + 0.6*CO + 0.6*MDIALO2", + "from": "jno2", + "scale by": 0.2 + }, + { + "to": "jbigald4", + "__reaction": "BIGALD4 + hv -> HO2 + CO + CH3COCHO + CH3CO3", + "from": "jno2", + "scale by": 0.006 + }, + { + "to": "jbzooh", + "__reaction": "BZOOH + hv -> BZALD + OH + HO2", + "from": "jch3ooh" + }, + { + "to": "jmekooh", + "__reaction": "MEKOOH + hv -> OH + CH3CO3 + CH3CHO", + "from": "jch3ooh" + }, + { + "to": "jtolooh", + "__reaction": "TOLOOH + hv -> OH + .45*GLYOXAL + .45*CH3COCHO + .9*BIGALD", + "from": "jch3ooh" + }, + { + "to": "jterpooh", + "__reaction": "TERPOOH + hv -> OH + .1*CH3COCH3 + HO2 + MVK + MACR", + "from": "jch3ooh" + }, + { + "to": "jhonitr", + "__reaction": "HONITR + hv -> NO2 + 0.67*HO2 + 0.33*CH3CHO + 0.33*CH2O + 0.33*CO + 0.33*GLYALD + 0.33*CH3CO3 + 0.17*HYAC + 0.17*CH3COCH3", + "from": "jch2o_a" + }, + { + "to": "jhpald", + "__reaction": "HPALD + hv -> BIGALD3 + OH + HO2", + "from": "jno2", + "scale by": 0.006 + }, + { + "to": "jisopnooh", + "__reaction": "ISOPNOOH + hv -> NO2 + HO2 + ISOPOOH", + "from": "jch3ooh" + }, + { + "to": "jnc4cho", + "__reaction": "NC4CHO + hv -> BIGALD3 + NO2 + HO2", + "from": "jch2o_a" + }, + { + "to": "jnoa", + "__reaction": "NOA + hv -> NO2 + CH2O + CH3CO3", + "from": "jch2o_a" + }, + { + "to": "jnterpooh", + "__reaction": "NTERPOOH + hv -> TERPROD1 + NO2 + OH", + "from": "jch3ooh" + }, + { + "to": "jphenooh", + "__reaction": "PHENOOH + hv -> OH + HO2 + 0.7*GLYOXAL", + "from": "jch3ooh" + }, + { + "to": "jtepomuc", + "__reaction": "TEPOMUC + hv -> 0.5*CH3CO3 + HO2 + 1.5*CO", + "from": "jno2", + "scale by": 0.1 + }, + { + "to": "jterp2ooh", + "__reaction": "TERP2OOH + hv -> OH + 0.375*CH2O + 0.3*CH3COCH3 + 0.25*CO + CO2 + TERPROD2 + HO2 + 0.25*GLYALD", + "from": "jch3ooh" + }, + { + "to": "jterpnit", + "__reaction": "TERPNIT + hv -> TERPROD1 + NO2 + HO2", + "from": "jch3ooh" + }, + { + "to": "jterprd1", + "__reaction": "TERPROD1 + hv -> HO2 + CO + TERPROD2", + "from": "jch3cho" + }, + { + "to": "jterprd2", + "__reaction": "TERPROD2 + hv -> 0.15*RO2 + 0.68*CH2O + 0.8*CO2 + 0.5*CH3COCH3 + 0.65*CH3CO3 + 1.2*HO2 + 1.7*CO", + "from": "jch3cho" + }, + { + "to": "jxylenooh", + "__reaction": "XYLENOOH + hv -> OH + HO2 + 0.34*GLYOXAL + 0.54*CH3COCHO + 0.06*BIGALD1 + 0.2*BIGALD2 + 0.15*BIGALD3 + 0.21*BIGALD4", + "from": "jch3ooh" + }, + { + "to": "jxylolooh", + "__reaction": "XYLOLOOH + hv -> OH + 0.17*GLYOXAL + 0.51*CH3COCHO + HO2", + "from": "jch3ooh" + }, + { + "to": "jsoa1_a1", + "__reaction": "soa1_a1 + hv -> Products", + "from": "jno2", + "scale by": 0.0004 + }, + { + "to": "jsoa1_a2", + "__reaction": "soa1_a2 + hv -> Products", + "from": "jno2", + "scale by": 0.0004 + }, + { + "to": "jsoa2_a1", + "__reaction": "soa2_a1 + hv -> Products", + "from": "jno2", + "scale by": 0.0004 + }, + { + "to": "jsoa2_a2", + "__reaction": "soa2_a2 + hv -> Products", + "from": "jno2", + "scale by": 0.0004 + }, + { + "to": "jsoa3_a1", + "__reaction": "soa3_a1 + hv -> Products", + "from": "jno2", + "scale by": 0.0004 + }, + { + "to": "jsoa3_a2", + "__reaction": "soa3_a2 + hv -> Products", + "from": "jno2", + "scale by": 0.0004 + }, + { + "to": "jsoa4_a1", + "__reaction": "soa4_a1 + hv -> Products", + "from": "jno2", + "scale by": 0.0004 + }, + { + "to": "jsoa4_a2", + "__reaction": "soa4_a2 + hv -> Products", + "from": "jno2", + "scale by": 0.0004 + }, + { + "to": "jsoa5_a1", + "__reaction": "soa5_a1 + hv -> Products", + "from": "jno2", + "scale by": 0.0004 + }, + { + "to": "jsoa5_a2", + "__reaction": "soa5_a2 + hv -> Products", + "from": "jno2", + "scale by": 0.0004 + }, + { + "to": "jglyoxal", + "__reaction": "GLYOXAL + hv -> 2*CO + 2*HO2", + "from": "jmgly" + } + ] + } + } +} diff --git a/examples/ts1_tsmlt.yml b/examples/ts1_tsmlt.yml new file mode 100644 index 00000000..c6d1e4e8 --- /dev/null +++ b/examples/ts1_tsmlt.yml @@ -0,0 +1,1742 @@ +O2 absorption: + cross section parameters file: data/cross_sections/O2_parameters.txt +__CAM options: + aliasing: + default matching: backup + pairs: + - __reaction: ALKNIT + hv -> NO2 + 0.4*CH3CHO + 0.1*CH2O + 0.25*CH3COCH3 + HO2 + + 0.8*MEK + from: jch3ooh + to: jalknit + - __reaction: POOH (C3H6OHOOH) + hv -> CH3CHO + CH2O + HO2 + OH + from: jch3ooh + to: jpooh + - __reaction: CH3COOOH + hv -> CH3O2 + OH + CO2 + from: jh2o2 + scale by: 0.28 + to: jch3co3h + - __reaction: MPAN + hv -> MCO3 + NO2 + from: jpan + to: jmpan + - __reaction: C2H5OOH + hv -> CH3CHO + HO2 + OH + from: jch3ooh + to: jc2h5ooh + - __reaction: C3H7OOH + hv -> 0.82*CH3COCH3 + OH + HO2 + from: jch3ooh + to: jc3h7ooh + - __reaction: C6H5OOH + hv -> PHENO + OH + from: jch3ooh + to: jc6h5ooh + - __reaction: EOOH + hv -> EO + OH + from: jch3ooh + to: jeooh + - __reaction: ROOH + hv -> CH3CO3 + CH2O + OH + from: jch3ooh + to: jrooh + - __reaction: XOOH + hv -> OH + from: jch3ooh + to: jxooh + - __reaction: ONITR + hv -> NO2 + from: jch3cho + to: jonitr + - __reaction: ISOPOOH + hv -> 0.402*MVK + 0.288*MACR + 0.69*CH2O + HO2 + from: jch3ooh + to: jisopooh + - __reaction: MEK + hv -> CH3CO3 + C2H5O2 + from: jacet + to: jmek + - __reaction: ALKOOH + hv -> .4*CH3CHO + .1*CH2O + .25*CH3COCH3 + .9*HO2 + .8*MEK + + OH + from: jch3ooh + to: jalkooh + - __reaction: BENZOOH + hv -> OH + GLYOXAL + 0.5*BIGALD1 + HO2 + from: jch3ooh + to: jbenzooh + - __reaction: BEPOMUC + hv -> BIGALD1 + 1.5*HO2 + 1.5*CO + from: jno2 + scale by: 0.1 + to: jbepomuc + - __reaction: BIGALD + hv -> 0.45*CO + 0.13*GLYOXAL + 0.56*HO2 + 0.13*CH3CO3 + + 0.18*CH3COCHO + from: jno2 + scale by: 0.2 + to: jbigald + - __reaction: BIGALD1 + hv -> 0.6*MALO2 + HO2 + from: jno2 + scale by: 0.14 + to: jbigald1 + - __reaction: BIGALD2 + hv -> 0.6*HO2 + 0.6*DICARBO2 + from: jno2 + scale by: 0.2 + to: jbigald2 + - __reaction: BIGALD3 + hv -> 0.6*HO2 + 0.6*CO + 0.6*MDIALO2 + from: jno2 + scale by: 0.2 + to: jbigald3 + - __reaction: BIGALD4 + hv -> HO2 + CO + CH3COCHO + CH3CO3 + from: jno2 + scale by: 0.006 + to: jbigald4 + - __reaction: BZOOH + hv -> BZALD + OH + HO2 + from: jch3ooh + to: jbzooh + - __reaction: MEKOOH + hv -> OH + CH3CO3 + CH3CHO + from: jch3ooh + to: jmekooh + - __reaction: TOLOOH + hv -> OH + .45*GLYOXAL + .45*CH3COCHO + .9*BIGALD + from: jch3ooh + to: jtolooh + - __reaction: TERPOOH + hv -> OH + .1*CH3COCH3 + HO2 + MVK + MACR + from: jch3ooh + to: jterpooh + - __reaction: HONITR + hv -> NO2 + 0.67*HO2 + 0.33*CH3CHO + 0.33*CH2O + 0.33*CO + + 0.33*GLYALD + 0.33*CH3CO3 + 0.17*HYAC + 0.17*CH3COCH3 + from: jch2o_a + to: jhonitr + - __reaction: HPALD + hv -> BIGALD3 + OH + HO2 + from: jno2 + scale by: 0.006 + to: jhpald + - __reaction: ISOPNOOH + hv -> NO2 + HO2 + ISOPOOH + from: jch3ooh + to: jisopnooh + - __reaction: NC4CHO + hv -> BIGALD3 + NO2 + HO2 + from: jch2o_a + to: jnc4cho + - __reaction: NOA + hv -> NO2 + CH2O + CH3CO3 + from: jch2o_a + to: jnoa + - __reaction: NTERPOOH + hv -> TERPROD1 + NO2 + OH + from: jch3ooh + to: jnterpooh + - __reaction: PHENOOH + hv -> OH + HO2 + 0.7*GLYOXAL + from: jch3ooh + to: jphenooh + - __reaction: TEPOMUC + hv -> 0.5*CH3CO3 + HO2 + 1.5*CO + from: jno2 + scale by: 0.1 + to: jtepomuc + - __reaction: TERP2OOH + hv -> OH + 0.375*CH2O + 0.3*CH3COCH3 + 0.25*CO + CO2 + + TERPROD2 + HO2 + 0.25*GLYALD + from: jch3ooh + to: jterp2ooh + - __reaction: TERPNIT + hv -> TERPROD1 + NO2 + HO2 + from: jch3ooh + to: jterpnit + - __reaction: TERPROD1 + hv -> HO2 + CO + TERPROD2 + from: jch3cho + to: jterprd1 + - __reaction: TERPROD2 + hv -> 0.15*RO2 + 0.68*CH2O + 0.8*CO2 + 0.5*CH3COCH3 + + 0.65*CH3CO3 + 1.2*HO2 + 1.7*CO + from: jch3cho + to: jterprd2 + - __reaction: XYLENOOH + hv -> OH + HO2 + 0.34*GLYOXAL + 0.54*CH3COCHO + 0.06*BIGALD1 + + 0.2*BIGALD2 + 0.15*BIGALD3 + 0.21*BIGALD4 + from: jch3ooh + to: jxylenooh + - __reaction: XYLOLOOH + hv -> OH + 0.17*GLYOXAL + 0.51*CH3COCHO + HO2 + from: jch3ooh + to: jxylolooh + - __reaction: soa1_a1 + hv -> Products + from: jno2 + scale by: 0.0004 + to: jsoa1_a1 + - __reaction: soa1_a2 + hv -> Products + from: jno2 + scale by: 0.0004 + to: jsoa1_a2 + - __reaction: soa2_a1 + hv -> Products + from: jno2 + scale by: 0.0004 + to: jsoa2_a1 + - __reaction: soa2_a2 + hv -> Products + from: jno2 + scale by: 0.0004 + to: jsoa2_a2 + - __reaction: soa3_a1 + hv -> Products + from: jno2 + scale by: 0.0004 + to: jsoa3_a1 + - __reaction: soa3_a2 + hv -> Products + from: jno2 + scale by: 0.0004 + to: jsoa3_a2 + - __reaction: soa4_a1 + hv -> Products + from: jno2 + scale by: 0.0004 + to: jsoa4_a1 + - __reaction: soa4_a2 + hv -> Products + from: jno2 + scale by: 0.0004 + to: jsoa4_a2 + - __reaction: soa5_a1 + hv -> Products + from: jno2 + scale by: 0.0004 + to: jsoa5_a1 + - __reaction: soa5_a2 + hv -> Products + from: jno2 + scale by: 0.0004 + to: jsoa5_a2 + - __reaction: GLYOXAL + hv -> 2*CO + 2*HO2 + from: jmgly + to: jglyoxal +__description: TUV-x configuration for the MOZART-TS1 and MOZART-TSMLT chemical mechanisms +grids: +- begins at: 0.0 + cell delta: 1.0 + ends at: 120.0 + name: height + type: equal interval + units: km +- file path: data/grids/wavelength/cam.csv + name: wavelength + type: from csv file + units: nm +- name: time + type: from config file + units: hours + values: + - 12.0 + - 14.0 +photolysis: + reactions: + - __reaction: O2 + hv -> O + O1D + cross section: + apply O2 bands: true + netcdf files: + - file path: data/cross_sections/O2_1.nc + interpolator: + type: fractional target + lower extrapolation: + type: boundary + type: base + heating: + energy term: 175.05 + name: jo2_a + quantum yield: + constant value: 0 + override bands: + - band: lyman-alpha + value: 0.53 + - band: schumann-runge continuum + value: 1.0 + type: base + - __reaction: O2 + hv -> O + O + cross section: + apply O2 bands: true + netcdf files: + - file path: data/cross_sections/O2_1.nc + interpolator: + type: fractional target + lower extrapolation: + type: boundary + type: base + heating: + energy term: 242.37 + name: jo2_b + quantum yield: + constant value: 1.0 + override bands: + - band: lyman-alpha + value: 0.47 + - band: schumann-runge continuum + value: 0.0 + type: base + - __reaction: O3 + hv -> O2 + O(1D) + cross section: + netcdf files: + - file path: data/cross_sections/O3_1.nc + - file path: data/cross_sections/O3_2.nc + - file path: data/cross_sections/O3_3.nc + - file path: data/cross_sections/O3_4.nc + type: O3 + heating: + energy term: 310.32 + name: jo3_a + quantum yield: + type: O3+hv->O2+O(1D) + - __reaction: O3 + hv -> O2 + O(3P) + cross section: + netcdf files: + - file path: data/cross_sections/O3_1.nc + - file path: data/cross_sections/O3_2.nc + - file path: data/cross_sections/O3_3.nc + - file path: data/cross_sections/O3_4.nc + type: O3 + heating: + energy term: 1179.87 + name: jo3_b + quantum yield: + type: O3+hv->O2+O(3P) + - __reaction: N2O + hv -> N2 + O(1D) + cross section: + type: N2O+hv->N2+O(1D) + name: jn2o + quantum yield: + constant value: 1.0 + type: base + - __reaction: NO2 + hv -> NO + O(3P) + cross section: + netcdf files: + - file path: data/cross_sections/NO2_1.nc + type: NO2 tint + name: jno2 + quantum yield: + lower extrapolation: + type: boundary + netcdf files: + - data/quantum_yields/NO2_1.nc + type: NO2 tint + - __reaction: N2O5 + hv -> NO2 + NO3 + cross section: + netcdf file: data/cross_sections/N2O5_JPL06.nc + parameterization: + aa: + - -18.27 + - -18.42 + - -18.59 + - -18.72 + - -18.84 + - -18.9 + - -18.93 + - -18.87 + - -18.77 + - -18.71 + - -18.31 + - -18.14 + - -18.01 + - -18.42 + - -18.59 + - -18.13 + base temperature: 0.0 + base wavelength: 0.0 + bb: + - -91.0 + - -104.0 + - -112.0 + - -135.0 + - -170.0 + - -226.0 + - -294.0 + - -388.0 + - -492.0 + - -583.0 + - -770.0 + - -885.0 + - -992.0 + - -949.0 + - -966.0 + - -1160.0 + logarithm: base 10 + maximum wavelength: 410.0 + minimum wavelength: 260.0 + temperature ranges: + - fixed value: 200 + maximum: 199.999999999999 + - maximum: 295 + minimum: 200 + - fixed value: 295.0 + minimum: 295.00000000001 + type: HARWOOD + parameterization wavelength grid: + name: custom wavelengths + type: from config file + units: nm + values: + - 255.0 + - 265.0 + - 275.0 + - 285.0 + - 295.0 + - 305.0 + - 315.0 + - 325.0 + - 335.0 + - 345.0 + - 355.0 + - 365.0 + - 375.0 + - 385.0 + - 395.0 + - 405.0 + - 415.0 + type: temperature based + name: jn2o5_a + quantum yield: + coefficients: + - -2.832441 + - 0.012809638 + constant value: 0.0 + override bands: + - band: range + minimum wavelength: 300.0 + value: 1.0 + type: Taylor series + - __reaction: N2O5 + hv -> NO + O + NO3 + cross section: + netcdf file: data/cross_sections/N2O5_JPL06.nc + parameterization: + aa: + - -18.27 + - -18.42 + - -18.59 + - -18.72 + - -18.84 + - -18.9 + - -18.93 + - -18.87 + - -18.77 + - -18.71 + - -18.31 + - -18.14 + - -18.01 + - -18.42 + - -18.59 + - -18.13 + base temperature: 0.0 + base wavelength: 0.0 + bb: + - -91.0 + - -104.0 + - -112.0 + - -135.0 + - -170.0 + - -226.0 + - -294.0 + - -388.0 + - -492.0 + - -583.0 + - -770.0 + - -885.0 + - -992.0 + - -949.0 + - -966.0 + - -1160.0 + logarithm: base 10 + maximum wavelength: 410.0 + minimum wavelength: 260.0 + temperature ranges: + - fixed value: 200 + maximum: 199.999999999999 + - maximum: 295 + minimum: 200 + - fixed value: 295.0 + minimum: 295.00000000001 + type: HARWOOD + parameterization wavelength grid: + name: custom wavelengths + type: from config file + units: nm + values: + - 255.0 + - 265.0 + - 275.0 + - 285.0 + - 295.0 + - 305.0 + - 315.0 + - 325.0 + - 335.0 + - 345.0 + - 355.0 + - 365.0 + - 375.0 + - 385.0 + - 395.0 + - 405.0 + - 415.0 + type: temperature based + name: jn2o5_b + quantum yield: + coefficients: + - 3.832441 + - -0.012809638 + constant value: 0.0 + override bands: + - band: range + minimum wavelength: 300.0 + value: 0.0 + type: Taylor series + - __reaction: HNO3 + hv -> OH + NO2 + cross section: + netcdf files: + - file path: data/cross_sections/HNO3_JPL06.nc + type: HNO3+hv->OH+NO2 + name: jhno3 + quantum yield: + constant value: 1.0 + type: base + - __reaction: NO3 + hv -> NO2 + O(3P) + cross section: + netcdf files: + - file path: data/cross_sections/NO3_1.nc + type: base + name: jno3_a + quantum yield: + lower extrapolation: + type: constant + value: 1.0 + netcdf files: + - data/quantum_yields/NO3-NO2+O(3P)_1.nc + type: tint + - __reaction: NO3 + hv -> NO + O2 + cross section: + netcdf files: + - file path: data/cross_sections/NO3_1.nc + type: base + name: jno3_b + quantum yield: + netcdf files: + - data/quantum_yields/NO3-NO+O2_1.nc + type: tint + - __reaction: CH3OOH + hv -> CH3O + OH + cross section: + netcdf files: + - file path: data/cross_sections/CH3OOH_1.nc + type: base + name: jch3ooh + quantum yield: + constant value: 1.0 + type: base + - __reaction: CH2O + hv -> H + HCO + cross section: + netcdf files: + - file path: data/cross_sections/CH2O_1.nc + type: CH2O + name: jch2o_a + quantum yield: + lower extrapolation: + type: boundary + netcdf files: + - data/quantum_yields/CH2O_1.nc + type: base + - __reaction: CH2O + hv -> H2 + CO + cross section: + netcdf files: + - file path: data/cross_sections/CH2O_1.nc + type: CH2O + name: jch2o_b + quantum yield: + lower extrapolation: + type: boundary + netcdf files: + - data/quantum_yields/CH2O_1.nc + type: CH2O + - __reaction: H2O2 + hv -> OH + OH + cross section: + netcdf files: + - file path: data/cross_sections/H2O2_1.nc + type: H2O2+hv->OH+OH + name: jh2o2 + quantum yield: + constant value: 1.0 + type: base + - __reaction: CH3CHO + hv -> CH3 + HCO + cross section: + netcdf files: + - file path: data/cross_sections/CH3CHO_1.nc + type: base + name: jch3cho + quantum yield: + netcdf files: + - data/quantum_yields/CH3CHO_1.nc + type: CH3CHO+hv->CH3+HCO + - __reaction: PAN + hv -> 0.6*CH3CO3 + 0.6*NO2 + 0.4*CH3O2 + 0.4*NO3 + 0.4*CO2 + cross section: + netcdf files: + - file path: data/cross_sections/PAN_1.nc + type: CH3ONO2+hv->CH3O+NO2 + name: jpan + quantum yield: + constant value: 1.0 + type: base + - __reaction: MVK + hv -> 0.7*C3H6 + 0.7*CO + 0.3*CH3O2 + 0.3*CH3CO3 + cross section: + netcdf files: + - file path: data/cross_sections/MVK_1.nc + type: base + name: jmvk + quantum yield: + type: MVK+hv->Products + - __reaction: CH3COCH3 + hv -> CH3CO + CH3 + cross section: + parameterization: + base temperature: 0.0 + netcdf file: + file path: data/cross_sections/ACETONE_JPL06.nc + temperature ranges: + - fixed value: 235.0 + maximum: 234.999999999999 + - maximum: 298.0 + minimum: 235.0 + - fixed value: 298.0 + minimum: 298.00000000001 + type: TAYLOR_SERIES + type: temperature based + name: jacet + quantum yield: + branch: CO+CH3CO + low wavelength value: 1 + maximum temperature: 295 + minimum temperature: 218 + type: CH3COCH3+hv->CH3CO+CH3 + - __reaction: CH3COCHO + hv -> CH3CO3 + CO + HO2 + cross section: + netcdf files: + - file path: data/cross_sections/CH3COCHO_1.nc + type: base + name: jmgly + quantum yield: + type: CH3COCHO+hv->CH3CO+HCO + - __reaction: GLYALD + hv -> 2*HO2 + CO + CH2O + cross section: + netcdf files: + - file path: data/cross_sections/HOCH2CHO_1.nc + type: base + name: jglyald + quantum yield: + constant value: 0.5 + type: base + - __reaction: BrCl + hv -> Br + Cl + cross section: + netcdf files: + - file path: data/cross_sections/BrCl_1.nc + type: base + name: jbrcl + quantum yield: + constant value: 1.0 + type: base + - __reaction: BrO + hv -> Br + O + cross section: + netcdf files: + - file path: data/cross_sections/BRO_JPL06.nc + type: base + name: jbro + quantum yield: + constant value: 1.0 + type: base + - __reaction: BrONO2 + hv -> Br + NO3 + cross section: + parameterization: + base temperature: 296.0 + netcdf file: + file path: data/cross_sections/BRONO2_JPL06.nc + temperature ranges: + - fixed value: 200.0 + maximum: 199.999999999999 + - maximum: 296.0 + minimum: 200.0 + - fixed value: 296.0 + minimum: 296.00000000001 + type: TAYLOR_SERIES + type: temperature based + name: jbrono2_a + quantum yield: + constant value: 0.85 + type: base + - __reaction: BrONO2 + hv -> BrO + NO2 + cross section: + parameterization: + base temperature: 296.0 + netcdf file: + file path: data/cross_sections/BRONO2_JPL06.nc + temperature ranges: + - fixed value: 200.0 + maximum: 199.999999999999 + - maximum: 296.0 + minimum: 200.0 + - fixed value: 296.0 + minimum: 296.00000000001 + type: TAYLOR_SERIES + type: temperature based + name: jbrono2_b + quantum yield: + constant value: 0.15 + type: base + - __reaction: CCl4 + hv -> Products + cross section: + netcdf files: + - file path: data/cross_sections/CCl4_1.nc + type: CCl4+hv->Products + name: jccl4 + quantum yield: + constant value: 1.0 + type: base + - __reaction: CF2BrCl + hv -> Products + cross section: + netcdf files: + - file path: data/cross_sections/CF2BrCl_1.nc + type: base + name: jcf2clbr + quantum yield: + constant value: 1.0 + type: base + - __reaction: CF3Br + hv -> Products + cross section: + netcdf file: data/cross_sections/H1301_JPL06.nc + parameterization: + AA: + - 62.563 + - -2.0068 + - 0.016592 + - -5.6465e-05 + - 6.7459e-08 + BB: + - -0.91755 + - 0.018575 + - -0.00013857 + - 4.5066e-07 + - -5.3803e-10 + base temperature: 273.0 + base wavelength: 0.0 + logarithm: base 10 + lp: + - 0.0 + - 1.0 + - 2.0 + - 3.0 + - 4.0 + maximum wavelength: 280.0 + minimum wavelength: 178.0 + temperature ranges: + - fixed value: 210.0 + maximum: 209.999999999999 + - maximum: 300.0 + minimum: 210.0 + - fixed value: 300.0 + minimum: 300.00000000001 + type: temperature based + name: jcf3br + quantum yield: + constant value: 1.0 + type: base + - __reaction: CCl3F + hv -> Products + cross section: + netcdf file: data/cross_sections/CFCL3_JPL06.nc + parameterization: + AA: + - -84.611 + - 0.79551 + - -0.002055 + - -4.4812e-06 + - 1.5838e-08 + BB: + - -5.7912 + - 0.11689 + - -0.00088069 + - 2.9335e-06 + - -3.6421e-09 + base temperature: 273.0 + base wavelength: 0.0 + logarithm: base 10 + lp: + - 0.0 + - 1.0 + - 2.0 + - 3.0 + - 4.0 + maximum wavelength: 230.0 + minimum wavelength: 174.1 + temperature ranges: + - fixed value: 210.0 + maximum: 209.999999999999 + - maximum: 300 + minimum: 210 + - fixed value: 300.0 + minimum: 300.00000000001 + type: temperature based + name: jcfcl3 + quantum yield: + constant value: 1.0 + type: base + - __reaction: CFC-113 + hv -> Products + cross section: + netcdf file: data/cross_sections/CFC113_JPL06.nc + parameterization: + AA: + - -1087.9 + - 20.004 + - -0.1392 + - 0.00042828 + - -4.9384e-07 + BB: + - 12.493 + - -0.23937 + - 0.0017142 + - -5.4393e-06 + - 6.4548e-09 + base temperature: 273.0 + base wavelength: 0.0 + logarithm: base 10 + lp: + - 0.0 + - 1.0 + - 2.0 + - 3.0 + - 4.0 + maximum wavelength: 230.0 + minimum wavelength: 182.0 + temperature ranges: + - fixed value: 210.0 + maximum: 209.999999999999 + - maximum: 300 + minimum: 210 + - fixed value: 300.0 + minimum: 300.00000000001 + type: temperature based + name: jcfc113 + quantum yield: + constant value: 1.0 + type: base + - __reaction: CFC-114 + hv -> Products + cross section: + netcdf file: data/cross_sections/CFC114_JPL10.nc + parameterization: + AA: + - -160.5 + - 2.4807 + - -0.015202 + - 3.8412e-05 + - -3.4373e-08 + BB: + - -1.5296 + - 0.035248 + - -0.00029951 + - 1.1129e-06 + - -1.5259e-09 + base temperature: 273.0 + base wavelength: 0.0 + logarithm: base 10 + lp: + - 0.0 + - 1.0 + - 2.0 + - 3.0 + - 4.0 + maximum wavelength: 220.0 + minimum wavelength: 172.0 + temperature ranges: + - fixed value: 210.0 + maximum: 209.999999999999 + - maximum: 300 + minimum: 210 + - fixed value: 300.0 + minimum: 300.00000000001 + type: temperature based + name: jcfc114 + quantum yield: + constant value: 1.0 + type: base + - __reaction: CFC-115 + hv -> Products + cross section: + netcdf files: + - file path: data/cross_sections/CFC115_JPL10.nc + type: base + name: jcfc115 + quantum yield: + constant value: 1.0 + type: base + - __reaction: CCl2F2 + hv -> Products + cross section: + netcdf file: data/cross_sections/CF2CL2_JPL06.nc + parameterization: + AA: + - -43.8954569 + - -0.2403597 + - -0.00042619 + - 9.8743e-06 + - 0.0 + BB: + - 0.0048438 + - 0.000496145 + - -5.6953e-06 + - 0.0 + - 0.0 + base temperature: 296.0 + base wavelength: 200.0 + logarithm: natural + lp: + - 0.0 + - 1.0 + - 2.0 + - 3.0 + - 4.0 + maximum wavelength: 231.0 + minimum wavelength: 200.0 + temperature ranges: + - fixed value: 220.0 + maximum: 219.999999999999 + - maximum: 296 + minimum: 220 + - fixed value: 296.0 + minimum: 296.00000000001 + type: temperature based + name: jcf2cl2 + quantum yield: + constant value: 1.0 + type: base + - __reaction: CH2BR2 + hv -> 2*BR + cross section: + netcdf file: data/cross_sections/CH2BR2_1.nc + parameterization: + AA: + - -70.211776 + - 0.1940326 + - 0.002726152 + - -1.695472e-05 + - 2.500066e-08 + BB: + - 2.89928 + - -0.04327724 + - 0.0002391599 + - -5.807506e-07 + - 5.244883e-10 + base temperature: 273.0 + base wavelength: 0.0 + logarithm: base 10 + lp: + - 0.0 + - 1.0 + - 2.0 + - 3.0 + - 4.0 + maximum wavelength: 290.0 + minimum wavelength: 210.0 + temperature ranges: + - fixed value: 210.0 + maximum: 209.999999999999 + - maximum: 300 + minimum: 210 + - fixed value: 300.0 + minimum: 300.00000000001 + type: temperature based + name: jch2br2 + quantum yield: + constant value: 1.0 + type: base + - __reaction: CH3Br + hv -> Products + cross section: + netcdf file: data/cross_sections/CH3BR_JPL06.nc + parameterization: + AA: + - 46.52 + - -1.458 + - 0.011469 + - -3.7627e-05 + - 4.3264e-08 + BB: + - 0.93408 + - -0.016887 + - 0.00011487 + - -3.4881e-07 + - 3.9945e-10 + base temperature: 273.0 + base wavelength: 0.0 + logarithm: base 10 + lp: + - 0.0 + - 1.0 + - 2.0 + - 3.0 + - 4.0 + maximum wavelength: 280.0 + minimum wavelength: 200.0 + temperature ranges: + - fixed value: 210.0 + maximum: 209.999999999999 + - maximum: 300 + minimum: 210 + - fixed value: 300.0 + minimum: 300.00000000001 + type: temperature based + name: jch3br + quantum yield: + constant value: 1.0 + type: base + - __reaction: CH3CCl3+hv->Products + cross section: + netcdf files: + - file path: data/cross_sections/CH3CCl3_1.nc + type: tint + name: jch3ccl3 + quantum yield: + constant value: 1.0 + type: base + - __reaction: CH3Cl + hv -> Products + cross section: + netcdf file: data/cross_sections/CH3CL_JPL06.nc + parameterization: + AA: + - -299.8 + - 5.1047 + - -0.03363 + - 9.5805e-05 + - -1.0135e-07 + BB: + - -7.1727 + - 0.14837 + - -0.0011463 + - 3.9188e-06 + - -4.9994e-09 + base temperature: 273.0 + base wavelength: 0.0 + logarithm: base 10 + lp: + - 0.0 + - 1.0 + - 2.0 + - 3.0 + - 4.0 + maximum wavelength: 216.0 + minimum wavelength: 174.1 + temperature ranges: + - fixed value: 210.0 + maximum: 209.999999999999 + - maximum: 300 + minimum: 210 + - fixed value: 300.0 + minimum: 300.00000000001 + type: temperature based + name: jch3cl + quantum yield: + constant value: 1.0 + type: base + - __reaction: CHBr3 + hv -> Products + cross section: + netcdf file: data/cross_sections/CHBR3_JPL10.nc + parameterization: + AA: + - -32.6067 + - 0.10308 + - 6.39e-05 + - -7.7392e-07 + - -2.2513e-09 + - 6.1376e-12 + BB: + - 0.1582 + - -0.0014758 + - 3.8058e-06 + - 9.187e-10 + - -1.0772e-11 + - 0.0 + base temperature: 296.0 + base wavelength: 0.0 + invert temperature offset: true + logarithm: base 10 + lp: + - 0.0 + - 1.0 + - 2.0 + - 3.0 + - 4.0 + - 5.0 + maximum wavelength: 362.0 + minimum wavelength: 260.0 + temperature ranges: + - fixed value: 260.0 + maximum: 259.999999999999 + - minimum: 260.0 + type: temperature based + name: jchbr3 + quantum yield: + constant value: 1.0 + type: base + - __reaction: Cl2 + hv -> Cl + Cl + cross section: + type: Cl2+hv->Cl+Cl + name: jcl2 + quantum yield: + constant value: 1.0 + type: base + - __comments: TODO - this doesn't exactly match the products in TS1 + __reaction: ClOOCl + hv -> Cl + ClOO + cross section: + netcdf files: + - file path: data/cross_sections/CL2O2_JPL10.nc + type: base + name: jcl2o2 + quantum yield: + constant value: 1.0 + type: base + - __reaction: ClO + hv -> Cl + O + cross section: + netcdf files: + - file path: data/cross_sections/CLO_JPL06.nc + type: base + name: jclo + quantum yield: + constant value: 1.0 + type: base + - __reaction: ClONO2 + hv -> Cl + NO3 + cross section: + netcdf files: + - file path: data/cross_sections/ClONO2_1.nc + type: ClONO2 + name: jclono2_a + quantum yield: + type: ClONO2+hv->Cl+NO3 + - __reaction: ClONO2 + hv -> ClO + NO2 + cross section: + netcdf files: + - file path: data/cross_sections/ClONO2_1.nc + type: ClONO2 + name: jclono2_b + quantum yield: + type: ClONO2+hv->ClO+NO2 + - __reaction: CF2O + hv -> Products + cross section: + netcdf files: + - file path: data/cross_sections/CF2O_1.nc + type: base + name: jcof2 + quantum yield: + constant value: 1.0 + type: base + - __reaction: CClFO + hv -> Products + cross section: + netcdf files: + - file path: data/cross_sections/CClFO_1.nc + type: base + name: jcofcl + quantum yield: + constant value: 1.0 + type: base + - __comments: TUV data set name CF2BrCF2Br + __reaction: H2402 + hv -> 2*BR + 2*COF2 + cross section: + netcdf file: data/cross_sections/H2402_JPL06.nc + parameterization: + AA: + - 34.026 + - -1.152616 + - 0.008959798 + - -2.9089e-05 + - 3.307212e-08 + BB: + - 0.4010664 + - -0.008358968 + - 6.415741e-05 + - -2.157554e-07 + - 2.691871e-10 + base temperature: 273.0 + base wavelength: 0.0 + logarithm: base 10 + lp: + - 0.0 + - 1.0 + - 2.0 + - 3.0 + - 4.0 + maximum wavelength: 290.0 + minimum wavelength: 190.0 + temperature ranges: + - fixed value: 210.0 + maximum: 209.999999999999 + - maximum: 300.0 + minimum: 210.0 + - fixed value: 300.0 + minimum: 300.00000000001 + type: temperature based + name: jh2402 + quantum yield: + constant value: 1.0 + type: base + - __reaction: HCFC-141b + hv -> Products + cross section: + netcdf file: data/cross_sections/HCFC141b_JPL10.nc + parameterization: + AA: + - -682.913042 + - 12.12229 + - -0.08187699 + - 0.0002437244 + - -2.719103e-07 + BB: + - 4.074747 + - -0.08053899 + - 0.0005946552 + - -1.945048e-06 + - 2.380143e-09 + base temperature: 273.0 + base wavelength: 0.0 + logarithm: base 10 + lp: + - 0.0 + - 1.0 + - 2.0 + - 3.0 + - 4.0 + maximum wavelength: 240.0 + minimum wavelength: 172.0 + temperature ranges: + - fixed value: 210.0 + maximum: 209.999999999999 + - maximum: 300.0 + minimum: 210.0 + - fixed value: 300.0 + minimum: 300.00000000001 + type: temperature based + name: jhcfc141b + quantum yield: + constant value: 1.0 + type: base + - __reaction: HCFC-142b + hv -> Products + cross section: + netcdf file: data/cross_sections/HCFC142b_JPL10.nc + parameterization: + AA: + - -328.092008 + - 6.342799 + - -0.04810362 + - 0.0001611991 + - -2.042613e-07 + BB: + - 0.4289533 + - -0.009042817 + - 7.018009e-05 + - -2.389064e-07 + - 3.039799e-10 + base temperature: 273.0 + base wavelength: 0.0 + logarithm: base 10 + lp: + - 0.0 + - 1.0 + - 2.0 + - 3.0 + - 4.0 + maximum wavelength: 230.0 + minimum wavelength: 172.0 + temperature ranges: + - fixed value: 210.0 + maximum: 209.999999999999 + - maximum: 300.0 + minimum: 210.0 + - fixed value: 300.0 + minimum: 300.00000000001 + type: temperature based + name: jhcfc142b + quantum yield: + constant value: 1.0 + type: base + - __reaction: HCFC-22 + hv -> Products + cross section: + netcdf file: data/cross_sections/HCFC22_JPL06.nc + parameterization: + AA: + - -106.029 + - 1.5038 + - -0.0082476 + - 1.4206e-05 + BB: + - -0.13399 + - 0.0027405 + - -1.8028e-05 + - 3.8504e-08 + base temperature: 273.0 + base wavelength: 0.0 + logarithm: base 10 + lp: + - 0.0 + - 1.0 + - 2.0 + - 3.0 + maximum wavelength: 204.0 + minimum wavelength: 174.0 + temperature ranges: + - fixed value: 210.0 + maximum: 209.999999999999 + - maximum: 300.0 + minimum: 210.0 + - fixed value: 300.0 + minimum: 300.00000000001 + parameterization wavelength grid: + name: custom wavelengths + type: from config file + units: nm + values: + - 169.0 + - 171.0 + - 173.0 + - 175.0 + - 177.0 + - 179.0 + - 181.0 + - 183.0 + - 185.0 + - 187.0 + - 189.0 + - 191.0 + - 193.0 + - 195.0 + - 197.0 + - 199.0 + - 201.0 + - 203.0 + - 205.0 + - 207.0 + - 209.0 + - 211.0 + - 213.0 + - 215.0 + - 217.0 + - 219.0 + - 221.0 + type: temperature based + name: jhcfc22 + quantum yield: + constant value: 1.0 + type: base + - __reaction: HCl + hv -> H + Cl + cross section: + netcdf files: + - file path: data/cross_sections/HCl_1.nc + type: base + name: jhcl + quantum yield: + constant value: 1.0 + type: base + - __reaction: HOBr + hv -> OH + Br + cross section: + type: HOBr+hv->OH+Br + name: jhobr + quantum yield: + constant value: 1.0 + type: base + - __reaction: HOCl + hv -> HO + Cl + cross section: + netcdf files: + - file path: data/cross_sections/HOCl_1.nc + type: base + name: jhocl + quantum yield: + constant value: 1.0 + type: base + - __reaction: OClO + hv -> Products + cross section: + netcdf files: + - file path: data/cross_sections/OClO_1.nc + - file path: data/cross_sections/OClO_2.nc + - file path: data/cross_sections/OClO_3.nc + type: OClO+hv->Products + name: joclo + quantum yield: + constant value: 1.0 + type: base + - __reaction: HNO4 + hv -> OH + NO3 + cross section: + netcdf file: data/cross_sections/HO2NO2_JPL06.nc + parameterization: + A: -988.0 + B: 0.69 + netcdf file: + file path: data/cross_sections/HO2NO2_temp_JPL06.nc + temperature ranges: + - fixed value: 280.0 + maximum: 279.999999999999 + - maximum: 350.0 + minimum: 280.0 + - fixed value: 350.0 + minimum: 350.00000000001 + type: BURKHOLDER + type: temperature based + name: jho2no2_a + quantum yield: + constant value: 0.3 + override bands: + - band: range + minimum wavelength: 200.0 + value: 0.2 + type: base + - __reaction: HNO4 + hv -> HO2 + NO2 + cross section: + netcdf file: data/cross_sections/HO2NO2_JPL06.nc + parameterization: + A: -988.0 + B: 0.69 + netcdf file: + file path: data/cross_sections/HO2NO2_temp_JPL06.nc + temperature ranges: + - fixed value: 280.0 + maximum: 279.999999999999 + - maximum: 350.0 + minimum: 280.0 + - fixed value: 350.0 + minimum: 350.00000000001 + type: BURKHOLDER + type: temperature based + name: jho2no2_b + quantum yield: + constant value: 0.7 + override bands: + - band: range + minimum wavelength: 200.0 + value: 0.8 + type: base + - __comments: Methacrolein photolysis channel 1 + __reaction: CH2=C(CH3)CHO->1.34HO2+0.66MCO3+1.34CH2O+CH3CO3 + cross section: + netcdf files: + - file path: data/cross_sections/Methacrolein_1.nc + type: base + name: jmacr_a + quantum yield: + constant value: 0.005 + type: base + - __comments: Methacrolein photolysis channel 2 + __reaction: CH2=C(CH3)CHO->0.66OH+1.34CO + cross section: + netcdf files: + - file path: data/cross_sections/Methacrolein_1.nc + type: base + name: jmacr_b + quantum yield: + constant value: 0.005 + type: base + - __comments: 'hydroxy acetone TODO: the products of this reaction differ from standalone + TUV-x' + __reaction: CH2(OH)COCH3->CH3CO3+HO2+CH2O + cross section: + netcdf files: + - file path: data/cross_sections/Hydroxyacetone_1.nc + type: base + name: jhyac + quantum yield: + constant value: 0.65 + type: base + - __reaction: H2O + hv -> OH + H + cross section: + merge data: true + netcdf files: + - file path: data/cross_sections/H2O_1.nc + zero above: 183.0 + - file path: data/cross_sections/H2O_2.nc + zero above: 190.0 + zero below: 183.00000000001 + - file path: data/cross_sections/H2O_3.nc + zero below: 190.00000000001 + type: base + name: jh2o_a + quantum yield: + netcdf files: + - data/quantum_yields/H2O_H_OH.nc + type: base + - __reaction: H2O + hv -> H2 + O1D + cross section: + merge data: true + netcdf files: + - file path: data/cross_sections/H2O_1.nc + zero above: 183.0 + - file path: data/cross_sections/H2O_2.nc + zero above: 190.0 + zero below: 183.00000000001 + - file path: data/cross_sections/H2O_3.nc + zero below: 190.00000000001 + type: base + name: jh2o_b + quantum yield: + netcdf files: + - data/quantum_yields/H2O_H2_O1D.nc + type: base + - __reaction: H2O + hv -> 2*H + O + cross section: + merge data: true + netcdf files: + - file path: data/cross_sections/H2O_1.nc + zero above: 183.0 + - file path: data/cross_sections/H2O_2.nc + zero above: 190.0 + zero below: 183.00000000001 + - file path: data/cross_sections/H2O_3.nc + zero below: 190.00000000001 + type: base + name: jh2o_c + quantum yield: + netcdf files: + - data/quantum_yields/H2O_2H_O3P.nc + type: base + - __reaction: CH4 + hv -> H + CH3O2 + cross section: + netcdf files: + - file path: data/cross_sections/CH4_1.nc + type: base + name: jch4_a + quantum yield: + constant value: 0.45 + type: base + - __reaction: CH4 + hv -> 1.44*H2 + 0.18*CH2O + 0.18*O + 0.33*OH + 0.33*H + 0.44*CO2 + + 0.38*CO + 0.05*H2O + cross section: + netcdf files: + - file path: data/cross_sections/CH4_1.nc + type: base + name: jch4_b + quantum yield: + constant value: 0.55 + type: base + - __reaction: CO2 + hv -> CO + O + cross section: + netcdf files: + - file path: data/cross_sections/CO2_1.nc + type: base + name: jco2 + quantum yield: + constant value: 1.0 + type: base + - __reaction: HBR + hv -> BR + H + cross section: + netcdf files: + - file path: data/cross_sections/HBr_1.nc + type: base + name: jhbr + quantum yield: + constant value: 1.0 + type: base + - __reaction: HF + hv -> H + F + cross section: + netcdf files: + - file path: data/cross_sections/HF_1.nc + type: base + name: jhf + quantum yield: + constant value: 1.0 + type: base + - __reaction: SF6 + hv -> sink + cross section: + netcdf files: + - file path: data/cross_sections/SF6_1.nc + type: base + name: jsf6 + quantum yield: + constant value: 1.0 + type: base + - __reaction: H2SO4 + hv -> SO3 + H2O + cross section: + data: + default value: 0.0 + point values: + - value: 6.3e-17 + wavelength: 121.65 + - value: 1.43e-26 + wavelength: 525.0 + - value: 1.8564e-25 + wavelength: 625.0 + - value: 3.086999e-24 + wavelength: 725.0 + type: base + name: jh2so4 + quantum yield: + collision interval s: + - 1.1e-09 + - 8.9e-09 + - 1.7e-07 + molecular diameter m: 4.18e-10 + molecular weight kg mol-1: 0.098078479 + netcdf files: + - data/quantum_yields/H2SO4_mills.nc + parameterized wavelengths: + - 525 + - 625 + - 725 + type: H2SO4 Mills + - __reaction: OCS + hv -> S + CO + cross section: + netcdf files: + - file path: data/cross_sections/OCS_1.nc + type: base + name: jocs + quantum yield: + constant value: 1.0 + type: base + - __reaction: SO + hv -> S + O + cross section: + netcdf files: + - file path: data/cross_sections/SO_1.nc + type: base + name: jso + quantum yield: + constant value: 1.0 + type: base + - __reaction: SO2 + hv -> SO + O + cross section: + netcdf files: + - file path: data/cross_sections/SO2_Mills.nc + type: base + name: jso2 + quantum yield: + constant value: 1.0 + type: base + - __reaction: SO3 + hv -> SO2 + O + cross section: + netcdf files: + - file path: data/cross_sections/SO3_1.nc + type: base + name: jso3 + quantum yield: + constant value: 1.0 + type: base + - __reaction: NO + hv -> NOp + e + cross section: + data: + default value: 0.0 + point values: + - value: 2.0e-18 + wavelength: 121.65 + type: base + name: jno_i + quantum yield: + constant value: 1.0 + type: base +profiles: +- file path: data/profiles/atmosphere/ussa.ozone + name: O3 + type: O3 + units: molecule cm-3 +- file path: data/profiles/atmosphere/ussa.dens + name: air + type: air + units: molecule cm-3 +- file path: data/profiles/atmosphere/ussa.dens + name: O2 + type: O2 + units: molecule cm-3 +- file path: data/profiles/atmosphere/ussa.temp + grid: + name: height + units: km + name: temperature + type: from csv file + units: K +- day: 21 + latitude: 0.0 + longitude: 0.0 + month: 3 + name: solar zenith angle + type: solar zenith angle + units: degrees + year: 2002 +- day: 21 + month: 3 + name: Earth-Sun distance + type: Earth-Sun distance + units: AU + year: 2002 +- grid: + name: wavelength + units: nm + name: surface albedo + type: from config file + uniform value: 0.1 + units: none +- enable diagnostics: true + file path: + - data/profiles/solar/susim_hi.flx + - data/profiles/solar/atlas3_1994_317_a.dat + - data/profiles/solar/sao2010.solref.converted + - data/profiles/solar/neckel.flx + interpolator: + - '' + - '' + - '' + - fractional target + name: extraterrestrial flux + type: extraterrestrial flux + units: photon cm-2 s-1 +radiative transfer: + __output: true + cross sections: + - name: air + type: air + - name: O3 + netcdf files: + - file path: data/cross_sections/O3_1.nc + - file path: data/cross_sections/O3_2.nc + - file path: data/cross_sections/O3_3.nc + - file path: data/cross_sections/O3_4.nc + type: O3 + - name: O2 + netcdf files: + - file path: data/cross_sections/O2_1.nc + lower extrapolation: + type: boundary + type: base + radiators: + - cross section: air + enable diagnostics: true + name: air + treat as air: true + type: base + vertical profile: air + vertical profile units: molecule cm-3 + - cross section: O2 + enable diagnostics: true + name: O2 + type: base + vertical profile: O2 + vertical profile units: molecule cm-3 + - cross section: O3 + enable diagnostics: true + name: O3 + type: base + vertical profile: O3 + vertical profile units: molecule cm-3 + - 550 nm optical depth: 0.235 + asymmetry factor: 0.61 + enable diagnostics: true + name: aerosols + optical depths: + - 0.24 + - 0.106 + - 0.0456 + - 0.0191 + - 0.0101 + - 0.00763 + - 0.00538 + - 0.005 + - 0.00515 + - 0.00494 + - 0.00482 + - 0.00451 + - 0.00474 + - 0.00437 + - 0.00428 + - 0.00403 + - 0.00383 + - 0.00378 + - 0.00388 + - 0.00308 + - 0.00226 + - 0.00164 + - 0.00123 + - 0.000945 + - 0.000749 + - 0.00063 + - 0.00055 + - 0.000421 + - 0.000322 + - 0.000248 + - 0.00019 + - 0.000145 + - 0.000111 + - 8.51e-05 + - 6.52e-05 + - 5.0e-05 + - 3.83e-05 + - 2.93e-05 + - 2.25e-05 + - 1.72e-05 + - 1.32e-05 + - 1.01e-05 + - 7.72e-06 + - 5.91e-06 + - 4.53e-06 + - 3.46e-06 + - 2.66e-06 + - 2.04e-06 + - 1.56e-06 + - 1.19e-06 + - 9.14e-07 + single scattering albedo: 0.99 + type: aerosol + solver: + type: delta eddington diff --git a/examples/full_config.json b/examples/tuv_5_4.json similarity index 99% rename from examples/full_config.json rename to examples/tuv_5_4.json index d79d2628..861236cf 100644 --- a/examples/full_config.json +++ b/examples/tuv_5_4.json @@ -1,4 +1,8 @@ { + "__description": [ + "TUV-x configuration that reporoduces photolysis rate constants of the TUV 5.4 calculator", + "The original TUV 5.4 source code and data sets can be found here: https://www2.acom.ucar.edu/modeling/tuv-download" + ], "O2 absorption" : { "cross section parameters file": "data/cross_sections/O2_parameters.txt" }, @@ -169,7 +173,6 @@ } ] }, - "__description": "This file contains configurations for each of the photolysis rate constants that can be calculated using data from this folder", "photolysis": { "enable diagnostics" : true, "reactions": [ diff --git a/examples/tuv_5_4.yml b/examples/tuv_5_4.yml new file mode 100644 index 00000000..ca2b53ba --- /dev/null +++ b/examples/tuv_5_4.yml @@ -0,0 +1,1218 @@ +O2 absorption: + cross section parameters file: data/cross_sections/O2_parameters.txt +__description: +- TUV-x configuration that reporoduces photolysis rate constants of the TUV 5.4 calculator +- 'The original TUV 5.4 source code and data sets can be found here: https://www2.acom.ucar.edu/modeling/tuv-download' +dose rates: + enable diagnostics: true + rates: + - name: RB Meter, model 501 + weights: + lower extrapolation: + type: boundary + netcdf files: + - data/spectral_weights/RB-Meter,model_501_spectral_wght_1.nc + type: base + - name: Eppley UV Photometer + weights: + lower extrapolation: + type: boundary + netcdf files: + - data/spectral_weights/Eppley-UV-Photometer_spectral_wght_1.nc + type: Eppley UV Photometer + - name: UV-A, 315-400 nm + weights: + notch filter begin: 315.0 + notch filter end: 400.0 + type: Notch Filter + - name: UV-B, 280-315 nm + weights: + notch filter begin: 280.0 + notch filter end: 315.0 + type: Notch Filter + - name: UV-B*, 280-320 nm + weights: + notch filter begin: 280.0 + notch filter end: 320.0 + type: Notch Filter + - name: vis+, > 400 nm + weights: + notch filter begin: 400.0 + notch filter end: 700.0 + type: Notch Filter + - name: Gaussian, 305 nm, 10 nm FWHM + weights: + centroid: 305.0 + type: Gaussian + - name: Gaussian, 320 nm, 10 nm FWHM + weights: + centroid: 320.0 + type: Gaussian + - name: Gaussian, 340 nm, 10 nm FWHM + weights: + centroid: 340.0 + type: Gaussian + - name: Gaussian, 380 nm, 10 nm FWHM + weights: + centroid: 380.0 + type: Gaussian + - name: SCUP-human (de Gruijl and van der Leun, 1994) + weights: + lower extrapolation: + type: boundary + netcdf files: + - data/spectral_weights/SCUP-human(de Gruijl and van der Leun,1994)_spectral_wght_1.nc + type: base + - name: PAR, 400-700 nm, umol m-2 s-1 + weights: + type: PAR, 400-700 nm, umol m-2 s-1 + - name: Exponential decay, 14 nm/10 + weights: + type: Exponential decay, 14 nm/10 + - name: SCUP-mice (de Gruijl et al., 1993) + weights: + type: SCUP-mice (de Gruijl et al., 1993) + - name: Standard human erythema (Webb et al., 2011) + weights: + type: Standard human erythema (Webb et al., 2011) + - name: UV index (WMO, 1994; Webb et al., 2011) + weights: + type: UV index (WMO, 1994; Webb et al., 2011) + - name: Phytoplankton (Boucher et al., 1994) + weights: + type: Phytoplankton (Boucher et al., 1994) + - name: Plant damage (Caldwell, 1971) + weights: + type: Plant damage (Caldwell, 1971) + - name: Plant damage,Flint&Caldwell,2003,orig. + weights: + type: Plant damage,Flint&Caldwell,2003,orig. + - name: Plant damage,Flint&Caldwell,2003,ext390 + weights: + type: Plant damage,Flint&Caldwell,2003,ext390 + - name: Occupational TLV (ACGIH, 1992) + weights: + lower extrapolation: + type: boundary + netcdf files: + - data/spectral_weights/Occupational TLV (ACGIH,1992)_spectral_wght_1.nc + type: base + - name: Phytoplankton, phaeo (Cullen et al., 1992) + weights: + lower extrapolation: + type: boundary + netcdf files: + - data/spectral_weights/Phytoplankton, phaeo(Cullen et al. 1992)_spectral_wght_1.nc + type: base + - name: Phytoplankton, proro (Cullen et al., 1992) + weights: + lower extrapolation: + type: boundary + netcdf files: + - data/spectral_weights/Phytoplankton, proro(Cullen et al. 1992)_spectral_wght_1.nc + type: base + - name: Cataract, pig (Oriowo et al., 2001) + weights: + lower extrapolation: + type: boundary + netcdf files: + - data/spectral_weights/Cataract, pig(Oriowo et al.,2001)_spectral_wght_1.nc + type: base + - name: Previtamin-D3 (CIE 2006) + weights: + lower extrapolation: + type: boundary + netcdf files: + - data/spectral_weights/Previtamin-D3 (CIE 2006)_spectral_wght_1.nc + type: base + - name: NMSC (CIE 2006) + weights: + lower extrapolation: + type: boundary + netcdf files: + - data/spectral_weights/NMSC (CIE 2006)_spectral_wght_1.nc + type: base + - name: DNA damage, in vitro (Setlow, 1974) + weights: + lower extrapolation: + type: boundary + netcdf files: + - data/spectral_weights/DNA_damage_in_vitro(Setlow,1974)_spectral_wght_1.nc + type: base + - name: Erythema, humans (Anders et al., 1995) + weights: + lower extrapolation: + type: boundary + netcdf files: + - data/spectral_weights/Erythema,humans(Anders et al.,1995)_spectral_wght_1.nc + type: base +grids: +- begins at: 0.0 + cell delta: 1.0 + ends at: 120.0 + name: height + type: equal interval + units: km +- file path: data/grids/wavelength/combined.grid + name: wavelength + type: from csv file + units: nm +- name: time + type: from config file + units: hours + values: + - 12.0 + - 14.0 +photolysis: + enable diagnostics: true + reactions: + - cross section: + apply O2 bands: true + netcdf files: + - file path: data/cross_sections/O2_1.nc + lower extrapolation: + type: boundary + type: base + name: O2+hv->O+O + quantum yield: + constant value: 1.0 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/HNO4_1.nc + type: base + name: HNO4+hv->HO2+NO2 + quantum yield: + constant value: 1.0 + type: base + - cross section: + __output: true + netcdf files: + - file path: data/cross_sections/O3_1.nc + - file path: data/cross_sections/O3_2.nc + - file path: data/cross_sections/O3_3.nc + - file path: data/cross_sections/O3_4.nc + type: O3 + name: O3+hv->O2+O(1D) + quantum yield: + type: O3+hv->O2+O(1D) + - cross section: + __output: true + netcdf files: + - file path: data/cross_sections/O3_1.nc + - file path: data/cross_sections/O3_2.nc + - file path: data/cross_sections/O3_3.nc + - file path: data/cross_sections/O3_4.nc + type: O3 + name: O3+hv->O2+O(3P) + quantum yield: + __output: true + type: O3+hv->O2+O(3P) + - cross section: + netcdf files: + - file path: data/cross_sections/NO3-(aq)_1.nc + type: base + name: NO3-(aq)+hv->NO2(aq)+O- + quantum yield: + type: NO3-_(aq)+hv->NO2(aq)+O- + - cross section: + netcdf files: + - file path: data/cross_sections/NO3-(aq)_1.nc + type: base + name: NO3-(aq)+hv->NO2-(aq)+O(3P) + quantum yield: + __output: true + constant value: 0.0011 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/NOCl_1.nc + type: tint + name: NOCl+hv->NO+Cl + quantum yield: + constant value: 1.0 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/CH3Cl_1.nc + type: tint + name: CH3Cl+hv->Products + quantum yield: + constant value: 1.0 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/CH3CCl3_1.nc + type: tint + name: CH3CCl3+hv->Products + quantum yield: + constant value: 1.0 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/CCl2O_1.nc + type: base + name: CCl2O+hv->Products + quantum yield: + constant value: 1.0 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/CClFO_1.nc + type: base + name: CClFO+hv->Products + quantum yield: + constant value: 1.0 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/CH3OOH_1.nc + type: base + name: CH3OOH+hv->CH3O+OH + quantum yield: + constant value: 1.0 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/HOCH2OOH_1.nc + type: base + name: HOCH2OOH+hv->CH2(OH)O+OH + quantum yield: + constant value: 1.0 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/HO2_1.nc + type: base + name: HO2+hv->OH+O + quantum yield: + type: HO2 + - cross section: + netcdf files: + - file path: data/cross_sections/H2O2_1.nc + type: H2O2+hv->OH+OH + name: H2O2+hv->OH+OH + quantum yield: + constant value: 1.0 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/NO3_1.nc + type: base + name: NO3+hv->NO+O2 + quantum yield: + netcdf files: + - data/quantum_yields/NO3-NO+O2_1.nc + type: tint + - cross section: + netcdf files: + - file path: data/cross_sections/NO3_1.nc + type: base + name: NO3+hv->NO2+O(3P) + quantum yield: + lower extrapolation: + type: constant + value: 1.0 + netcdf files: + - data/quantum_yields/NO3-NO2+O(3P)_1.nc + type: tint + - cross section: + netcdf files: + - file path: data/cross_sections/HNO3_1.nc + type: HNO3+hv->OH+NO2 + name: HNO3+hv->OH+NO2 + quantum yield: + constant value: 1.0 + type: base + - cross section: + type: N2O+hv->N2+O(1D) + name: N2O+hv->N2+O(1D) + quantum yield: + constant value: 1.0 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/N2O5_1.nc + - file path: data/cross_sections/N2O5_2.nc + type: N2O5+hv->NO2+NO3 + name: N2O5+hv->NO2+NO3 + quantum yield: + constant value: 1.0 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/NO2_1.nc + type: NO2 tint + name: NO2+hv->NO+O(3P) + quantum yield: + lower extrapolation: + type: boundary + netcdf files: + - data/quantum_yields/NO2_1.nc + type: NO2 tint + - cross section: + netcdf files: + - file path: data/cross_sections/C2H5CHO_1.nc + type: base + name: C2H5CHO+hv->C2H5+HCO + quantum yield: + netcdf files: + - data/quantum_yields/C2H5CHO_1.nc + type: C2H5CHO + - cross section: + netcdf files: + - file path: data/cross_sections/CH2CHCHO_1.nc + type: base + name: CH2CHCHO+hv->Products + quantum yield: + type: CH2CHCHO+hv->Products + - cross section: + netcdf files: + - file path: data/cross_sections/CH3CHO_1.nc + type: base + name: CH3CHO+hv->CH3+HCO + quantum yield: + netcdf files: + - data/quantum_yields/CH3CHO_1.nc + type: CH3CHO+hv->CH3+HCO + - cross section: + netcdf files: + - file path: data/cross_sections/CH2O_1.nc + type: CH2O + name: CH2O+hv->H+HCO + quantum yield: + lower extrapolation: + type: boundary + netcdf files: + - data/quantum_yields/CH2O_1.nc + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/CH2O_1.nc + type: CH2O + name: CH2O+hv->H2+CO + quantum yield: + lower extrapolation: + type: boundary + netcdf files: + - data/quantum_yields/CH2O_1.nc + type: CH2O + - cross section: + netcdf files: + - file path: data/cross_sections/CH3COCH2CH3_1.nc + type: base + name: CH3COCH2CH3+hv->CH3CO+CH2CH3 + quantum yield: + type: CH3COCH2CH3+hv->CH3CO+CH2CH3 + - cross section: + netcdf files: + - file path: data/cross_sections/HNO2_1.nc + type: base + name: HNO2+hv->OH+NO + quantum yield: + constant value: 1.0 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/CHBr3_1.nc + lower extrapolation: + type: boundary + type: CHBr3+hv->Products + name: CHBr3+hv->Products + quantum yield: + constant value: 1.0 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/CF2Br2_1.nc + type: base + name: CF2Br2+hv->Products + quantum yield: + constant value: 1.0 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/CF2BrCl_1.nc + type: base + name: CF2BrCl+hv->Products + quantum yield: + constant value: 1.0 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/CF3Br_1.nc + type: base + name: CF3Br+hv->Products + quantum yield: + constant value: 1.0 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/CF2BrCF2Br_1.nc + type: base + name: CF2BrCF2Br+hv->Products + quantum yield: + constant value: 1.0 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/I2_1.nc + type: base + name: I2+hv->I+I + quantum yield: + lower extrapolation: + type: constant + value: 1.0 + netcdf files: + - data/quantum_yields/I2_1.nc + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/IO_1.nc + type: base + name: IO+hv->I+O + quantum yield: + constant value: 1.0 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/IOH_1.nc + type: base + name: IOH+hv->I+OH + quantum yield: + constant value: 1.0 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/perfluoro 1-iodopropane_1.nc + type: base + name: perfluoro-1-iodopropane+hv->Products + quantum yield: + constant value: 1.0 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/CH3OCl_1.nc + type: base + name: CH3OCl+hv->CH3O+Cl + quantum yield: + constant value: 1.0 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/CHCl3_1.nc + type: CHCl3+hv->Products + name: CHCl3+hv->Products + quantum yield: + constant value: 1.0 + type: base + - cross section: + type: Cl2+hv->Cl+Cl + name: Cl2+hv->Cl+Cl + quantum yield: + constant value: 1.0 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/CCl4_1.nc + type: CCl4+hv->Products + name: CCl4+hv->Products + quantum yield: + constant value: 1.0 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/ClO_1.nc + type: tint + name: ClO+hv->Cl+O(1D) + quantum yield: + type: ClO+hv->Cl+O(1D) + - cross section: + netcdf files: + - file path: data/cross_sections/ClO_1.nc + type: tint + name: ClO+hv->Cl+O(3P) + quantum yield: + type: ClO+hv->Cl+O(3P) + - cross section: + netcdf files: + - file path: data/cross_sections/ClOO_1.nc + type: base + name: ClOO+hv->Products + quantum yield: + constant value: 1.0 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/ClOOCl_1.nc + type: base + name: ClOOCl+hv->Cl+ClOO + quantum yield: + constant value: 1.0 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/HCl_1.nc + type: base + name: HCl+hv->H+Cl + quantum yield: + constant value: 1.0 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/HOCl_1.nc + type: base + name: HOCl+hv->HO+Cl + quantum yield: + constant value: 1.0 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/ClNO2_1.nc + type: base + name: ClNO2+hv->Cl+NO2 + quantum yield: + constant value: 1.0 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/ClONO_1.nc + type: base + name: ClONO+hv->Cl+NO2 + quantum yield: + constant value: 1.0 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/ClONO2_1.nc + type: ClONO2 + name: ClONO2+hv->Cl+NO3 + quantum yield: + type: ClONO2+hv->Cl+NO3 + - cross section: + netcdf files: + - file path: data/cross_sections/ClONO2_1.nc + type: ClONO2 + name: ClONO2+hv->ClO+NO2 + quantum yield: + type: ClONO2+hv->ClO+NO2 + - cross section: + netcdf files: + - file path: data/cross_sections/OClO_1.nc + - file path: data/cross_sections/OClO_2.nc + - file path: data/cross_sections/OClO_3.nc + type: OClO+hv->Products + name: OClO+hv->Products + quantum yield: + constant value: 1.0 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/Br2_1.nc + type: base + name: Br2+hv->Br+Br + quantum yield: + constant value: 1.0 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/BrO_1.nc + interpolator: + fold in: true + type: fractional target + type: base + name: BrO+hv->Br+O + quantum yield: + constant value: 1.0 + type: base + - cross section: + type: HOBr+hv->OH+Br + name: HOBr+hv->OH+Br + quantum yield: + constant value: 1.0 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/BrNO_1.nc + type: base + name: BrNO+hv->Br+NO + quantum yield: + constant value: 1.0 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/BrONO_1.nc + type: base + name: BrONO+hv->Br+NO2 + quantum yield: + constant value: 0.5 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/BrONO_1.nc + type: base + name: BrONO+hv->BrO+NO + quantum yield: + constant value: 0.5 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/BrNO2_1.nc + type: base + name: BrNO2+hv->Br+NO2 + quantum yield: + constant value: 1.0 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/BrONO2_1.nc + type: base + name: BrONO2+hv->BrO+NO2 + quantum yield: + constant value: 0.15 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/BrONO2_1.nc + type: base + name: BrONO2+hv->Br+NO3 + quantum yield: + constant value: 0.85 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/BrCl_1.nc + type: base + name: BrCl+hv->Br+Cl + quantum yield: + constant value: 1.0 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/CH3Br_1.nc + type: base + name: CH3Br+hv->Products + quantum yield: + constant value: 1.0 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/CH3ONO2_1.nc + type: CH3ONO2+hv->CH3O+NO2 + name: CH3ONO2+hv->CH3O+NO2 + quantum yield: + constant value: 1.0 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/CH3OONO2_1.nc + type: base + name: CH3(OONO2)+hv->CH3OO+NO2 + quantum yield: + constant value: 1.0 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/C2H5ONO2_1.nc + type: CH3ONO2+hv->CH3O+NO2 + name: C2H5ONO2+hv->C2H5O+NO2 + quantum yield: + constant value: 1.0 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/nC3H7ONO2_1.nc + type: base + name: nC3H7ONO2+hv->C3H7O+NO2 + quantum yield: + constant value: 1.0 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/1-C4H9ONO2_1.nc + type: base + name: 1-C4H9ONO2+hv->1-C4H9O+NO2 + quantum yield: + constant value: 1.0 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/2-C4H9ONO2_1.nc + type: base + name: 2-C4H9ONO2+hv->2-C4H9O+NO2 + quantum yield: + constant value: 1.0 + type: base + - cross section: + type: CH3COCH2(ONO2)+hv->CH3COCH2(O.)+NO2 + name: nitro_acetone+hv->Products + quantum yield: + constant value: 1.0 + type: base + - cross section: + type: CH2(OH)CH2(ONO2)+hv->CH2(OH)CH2(O.)+NO2 + name: nitro_ethanol+hv->Products + quantum yield: + constant value: 1.0 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/CH3CH2ONO2_1.nc + type: RONO2 + name: CH3CH2ONO2+hv->CH3CH2O+NO2 + quantum yield: + constant value: 1.0 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/CH3CHONO2CH3_1.nc + type: RONO2 + name: CH3CHONO2CH3+hv->CH3CHOCH3+NO2 + quantum yield: + constant value: 1.0 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/CH3COCH3_1.nc + type: CH3COCH3+hv->CH3CO+CH3 + name: CH3COCH3+hv->CH3CO+CH3 + quantum yield: + type: CH3COCH3+hv->CH3CO+CH3 + - cross section: + netcdf files: + - file path: data/cross_sections/CFC-11_1.nc + type: CCl3F+hv->Products + name: CCl3F+hv->Products + quantum yield: + constant value: 1.0 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/CFC-12_1.nc + type: CCl3F+hv->Products + name: CCl2F2+hv->Products + quantum yield: + constant value: 1.0 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/CFC-113_1.nc + type: tint + name: CFC-113+hv->Products + quantum yield: + constant value: 1.0 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/CFC-114_1.nc + type: tint + name: CFC-114+hv->Products + quantum yield: + constant value: 1.0 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/CFC-115_1.nc + type: base + name: CFC-115+hv->Products + quantum yield: + constant value: 1.0 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/CHClF2_1.nc + type: tint + name: HCFC-22+hv->Products + quantum yield: + constant value: 1.0 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/CF3CHCl2_1.nc + type: HCFC+hv->Products + name: CF3CHCl2+hv->Products + quantum yield: + constant value: 1.0 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/CF3CHFCl_1.nc + type: HCFC+hv->Products + name: CF3CHFCl+hv->Products + quantum yield: + constant value: 1.0 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/CH3CFCl2_1.nc + type: base + name: HCFC-141b+hv->Products + quantum yield: + constant value: 1.0 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/CH3CF2Cl_1.nc + type: HCFC+hv->Products + name: HCFC-142b+hv->Products + quantum yield: + constant value: 1.0 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/CF3CF2CHCl2_1.nc + type: base + name: HCFC-225ca+hv->Products + quantum yield: + constant value: 1.0 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/CF2ClCF2CHFCl_1.nc + type: base + name: HCFC-225cb+hv->Products + quantum yield: + constant value: 1.0 + type: base + - cross section: + type: t_butyl_nitrate+hv->Products + name: C(CH3)3(ONO2)+hv->C(CH3)(O.)+NO2 + quantum yield: + constant value: 1.0 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/t-butyl-nitrite_1.nc + type: base + name: C(CH3)3(ONO)+hv->C(CH3)3(O)+NO + quantum yield: + constant value: 1.0 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/PAN_1.nc + type: CH3ONO2+hv->CH3O+NO2 + name: PAN+hv->CH3CO(OO)+NO2 + quantum yield: + constant value: 0.7 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/PAN_1.nc + type: CH3ONO2+hv->CH3O+NO2 + name: PAN+hv->CH3CO(O)+NO3 + quantum yield: + constant value: 0.3 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/PPN_1.nc + type: CH3ONO2+hv->CH3O+NO2 + name: PPN+hv->CH3CH2CO(OO)+NO2 + quantum yield: + constant value: 0.61 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/PPN_1.nc + type: CH3ONO2+hv->CH3O+NO2 + name: PPN+hv->CH3CH2CO(O)+NO3 + quantum yield: + constant value: 0.39 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/Methacrolein_1.nc + type: base + name: CH2=C(CH3)CHO+hv->Products + quantum yield: + constant value: 0.01 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/MVK_1.nc + type: base + name: MVK+hv->Products + quantum yield: + type: MVK+hv->Products + - cross section: + netcdf files: + - file path: data/cross_sections/HOCH2CHO_1.nc + type: base + name: HOCH2CHO+hv->CH2OH+HCO + quantum yield: + constant value: 0.83 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/HOCH2CHO_1.nc + type: base + name: HOCH2CHO+hv->CH3OH+CO + quantum yield: + constant value: 0.1 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/HOCH2CHO_1.nc + type: base + name: HOCH2CHO+hv->CH2CHO+OH + quantum yield: + constant value: 0.07 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/Hydroxyacetone_1.nc + type: base + name: CH2(OH)COCH3+hv->CH3CO+CH2(OH) + quantum yield: + constant value: 0.325 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/Hydroxyacetone_1.nc + type: base + name: CH2(OH)COCH3+hv->CH2(OH)CO+CH3 + quantum yield: + constant value: 0.325 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/CHOCHO_1.nc + type: base + name: CHOCHO+hv->HCO+HCO + quantum yield: + lower extrapolation: + type: boundary + netcdf files: + - data/quantum_yields/CHOCHO-HCO_HCO_1.nc + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/CHOCHO_1.nc + type: base + name: CHOCHO+hv->H2+CO+CO + quantum yield: + lower extrapolation: + type: boundary + netcdf files: + - data/quantum_yields/CHOCHO-H2_CO_CO_1.nc + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/CHOCHO_1.nc + type: base + name: CHOCHO+hv->CH2O+CO + quantum yield: + lower extrapolation: + type: boundary + netcdf files: + - data/quantum_yields/CHOCHO-CH2O_CO_1.nc + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/CH3COCHO_1.nc + type: base + name: CH3COCHO+hv->CH3CO+HCO + quantum yield: + type: CH3COCHO+hv->CH3CO+HCO + - cross section: + netcdf files: + - file path: data/cross_sections/CH3COCOCH3_1.nc + type: base + name: CH3COCOCH3+hv->Products + quantum yield: + constant value: 0.158 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/CH3COOH_1.nc + type: base + name: CH3COOH+hv->CH3+COOH + quantum yield: + constant value: 0.55 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/CH3COOOH_1.nc + type: base + name: CH3COOOH+hv->Products + quantum yield: + constant value: 1.0 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/CH3COCOOH_1.nc + type: base + name: CH3COCOOH+hv->Products + quantum yield: + constant value: 1.0 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/CH3CH3NNO_1.nc + type: base + name: CH3CH3NNO+hv->Products + quantum yield: + constant value: 1.0 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/CF2O_1.nc + type: base + name: CF2O+hv->Products + quantum yield: + constant value: 1.0 + type: base +profiles: +- file path: data/profiles/atmosphere/ussa.ozone + name: O3 + type: O3 + units: molecule cm-3 +- file path: data/profiles/atmosphere/ussa.dens + name: air + type: air + units: molecule cm-3 +- file path: data/profiles/atmosphere/ussa.dens + name: O2 + type: O2 + units: molecule cm-3 +- file path: data/profiles/atmosphere/ussa.temp + grid: + name: height + units: km + name: temperature + type: from csv file + units: K +- day: 21 + latitude: 0.0 + longitude: 0.0 + month: 3 + name: solar zenith angle + type: solar zenith angle + units: degrees + year: 2002 +- day: 21 + month: 3 + name: Earth-Sun distance + type: Earth-Sun distance + units: AU + year: 2002 +- grid: + name: wavelength + units: nm + name: surface albedo + type: from config file + uniform value: 0.1 + units: none +- enable diagnostics: true + file path: + - data/profiles/solar/susim_hi.flx + - data/profiles/solar/atlas3_1994_317_a.dat + - data/profiles/solar/sao2010.solref.converted + - data/profiles/solar/neckel.flx + interpolator: + - '' + - '' + - '' + - fractional target + name: extraterrestrial flux + type: extraterrestrial flux + units: photon cm-2 s-1 +radiative transfer: + __output: true + cross sections: + - name: air + type: air + - name: O3 + netcdf files: + - file path: data/cross_sections/O3_1.nc + - file path: data/cross_sections/O3_2.nc + - file path: data/cross_sections/O3_3.nc + - file path: data/cross_sections/O3_4.nc + type: O3 + - name: O2 + netcdf files: + - file path: data/cross_sections/O2_1.nc + lower extrapolation: + type: boundary + type: base + radiators: + - cross section: air + enable diagnostics: true + name: air + treat as air: true + type: base + vertical profile: air + vertical profile units: molecule cm-3 + - cross section: O2 + enable diagnostics: true + name: O2 + type: base + vertical profile: O2 + vertical profile units: molecule cm-3 + - cross section: O3 + enable diagnostics: true + name: O3 + type: base + vertical profile: O3 + vertical profile units: molecule cm-3 + - 550 nm optical depth: 0.235 + asymmetry factor: 0.61 + enable diagnostics: true + name: aerosols + optical depths: + - 0.24 + - 0.106 + - 0.0456 + - 0.0191 + - 0.0101 + - 0.00763 + - 0.00538 + - 0.005 + - 0.00515 + - 0.00494 + - 0.00482 + - 0.00451 + - 0.00474 + - 0.00437 + - 0.00428 + - 0.00403 + - 0.00383 + - 0.00378 + - 0.00388 + - 0.00308 + - 0.00226 + - 0.00164 + - 0.00123 + - 0.000945 + - 0.000749 + - 0.00063 + - 0.00055 + - 0.000421 + - 0.000322 + - 0.000248 + - 0.00019 + - 0.000145 + - 0.000111 + - 8.51e-05 + - 6.52e-05 + - 5.0e-05 + - 3.83e-05 + - 2.93e-05 + - 2.25e-05 + - 1.72e-05 + - 1.32e-05 + - 1.01e-05 + - 7.72e-06 + - 5.91e-06 + - 4.53e-06 + - 3.46e-06 + - 2.66e-06 + - 2.04e-06 + - 1.56e-06 + - 1.19e-06 + - 9.14e-07 + single scattering albedo: 0.99 + type: aerosol + solver: + type: delta eddington diff --git a/include/util/config_yaml.h b/include/util/config_yaml.h new file mode 100644 index 00000000..7fcd6111 --- /dev/null +++ b/include/util/config_yaml.h @@ -0,0 +1,285 @@ +// Copyright (C) 2024 National Center for Atmospheric Research +// SPDX-License-Identifier: Apache-2.0 +#pragma once + +#include + +#ifdef __cplusplus +#include + +extern "C" { + typedef YAML::Node Yaml; + typedef YAML::iterator YamlIterator; +#endif + +/// @brief Interoperatble string type +struct string_t { + char* ptr_; + int size_; +}; + +/// @brief Interoperable array type for strings +struct string_array_t { + string_t* ptr_; + int size_; +}; + +/// @brief Interoperable array type for doubles +struct double_array_t { + double* ptr_; + int size_; +}; + +/// @brief Interoperable array type for YAML nodes +struct node_array_t { + Yaml** ptr_; + int size_; +}; + +/// @brief Creates a YAML node from a string +/// @param yaml_string YAML in string form +/// @return pointer to the new YAML node +Yaml* yaml_create_from_string(const char* yaml_string); + +/// @brief Creates a YAML node from a YAML file +/// @param file_path path to the YAML file +/// @return pointer to the new YAML node +Yaml* yaml_create_from_file(const char* file_path); + +/// @brief Outputs a YAML node to a file +/// @param node YAML node to output +/// @param file_path path to file to create (any existing file will be overwritten) +void yaml_to_file(Yaml* node, const char* file_path); + +/// @brief Returns the number of child elements in the node +/// This works for vectors and maps +/// @param node YAML node to return size of +/// @return number of node elements +int yaml_size(Yaml* node); + +/// @brief Returns an iterator to the first child node +/// @param node YAML node to iterate over +/// @return beginning iterator +YamlIterator* yaml_begin(Yaml* node); + +/// @brief Returns an iterator to one element past the last child node +/// @param node YAML node to iterator over +/// @return ending iterator +YamlIterator* yaml_end(Yaml* node); + +/// @brief Increments a YAML iterator +/// @param iter YAML iterator to increment +/// @param end YAML iterator one element past end +/// @return true if incremented iter < end, false otherwise +bool yaml_increment(YamlIterator* iter, YamlIterator* end); + +/// @brief Checks if a YAML iterator is at the end +/// @param iter YAML iterator to check +/// @param end YAML iterator one element past end +/// @return true if iter == end, false otherwise +bool yaml_at_end(YamlIterator* iter, YamlIterator* end); + +/// @brief Returns the key associated with a YAML iterator +/// @param iter YAML iterator to return key for +/// @return key as a c string +string_t yaml_key(YamlIterator* iter); + +/// @brief Returns a sub-node +/// @param node parent YAML node +/// @param key key to find +/// @param found true if successful, false otherwise +/// @return sub-node +Yaml* yaml_get_node(Yaml* node, const char* key, bool& found); + +/// @brief Gets a string from a YAML node +/// @param node YAML node +/// @param key key to search for +/// @param found true if successful, false otherwise +/// @return Pointer to string as const char array +string_t yaml_get_string(Yaml* node, const char* key, bool& found); + +/// @brief Gets an integer from a YAML node +/// @param node YAML node +/// @param key key to search for +/// @param found true if successful, false otherwise +/// @return integer value +int yaml_get_int(Yaml* node, const char* key, bool& found); + +/// @brief Gets a float from a YAML node +/// @param node YAML node +/// @param key key to search for +/// @param found true if successful, false otherwise +/// @return float value +float yaml_get_float(Yaml* node, const char* key, bool& found); + +/// @brief Gets a double from a YAML node +/// @param node YAML node +/// @param key key to search for +/// @param found true if successful, false otherwise +/// @return double value +double yaml_get_double(Yaml* node, const char* key, bool& found); + +/// @brief Gets a boolean from a YAML node +/// @param node YAML node +/// @param key key to search for +/// @param found true if successful, false otherwise +/// @return boolean value +bool yaml_get_bool(Yaml* node, const char* key, bool& found); + +/// @brief Gets an array of strings from a YAML node +/// @param node YAML node +/// @param key key to search for +/// @param found true if successful, false otherwise +/// @return string array +string_array_t yaml_get_string_array(Yaml* node, const char* key, bool& found); + +/// @brief Gets an array of doubles from a YAML node +/// @param node YAML node +/// @param key key to search for +/// @param found true if successful, false otherwise +/// @return double array +double_array_t yaml_get_double_array(Yaml* node, const char* key, bool& found); + +/// @brief Gets an array of YAML nodes from a YAML node +/// @details It is expected that the caller takes ownership of the individual +/// pointers to YAML nodes in the array +/// @param node YAML node +/// @param key key to search for +/// @param found true if successful, false otherwise +/// @return node array +node_array_t yaml_get_node_array(Yaml* node, const char* key, bool& found); + +/// @brief Gets a node from a YAML iterator +/// @param iter YAML iterator +/// @return YAML node +Yaml* yaml_get_node_from_iterator(YamlIterator* iter); + +/// @brief Gets a string from a YAML iterator +/// @param iter YAML iterator +/// @return string as a c string +string_t yaml_get_string_from_iterator(YamlIterator* iter); + +/// @brief Gets an int from a YAML iterator +/// @param iter YAML iterator +/// @return integer value +int yaml_get_int_from_iterator(YamlIterator* iter); + +/// @brief Gets a float from a YAML iterator +/// @param iter YAML iterator +/// @return float value +float yaml_get_float_from_iterator(YamlIterator* iter); + +/// @brief Gets a double from a YAML iterator +/// @param iter YAML iterator +/// @return double value +double yaml_get_double_from_iterator(YamlIterator* iter); + +/// @brief Gets a boolean from a YAML iterator +/// @param iter YAML iterator +/// @return boolean value +bool yaml_get_bool_from_iterator(YamlIterator* iter); + +/// @brief Gets an array of strings from a YAML iterator +/// @param iter YAML iterator +/// @return string array +string_array_t yaml_get_string_array_from_iterator(YamlIterator* iter); + +/// @brief Adds a YAML node to a YAML node +/// @param node YAML node +/// @param key key to apply value to +/// @param value YAML node to add +void yaml_add_node(Yaml* node, const char* key, Yaml* value); + +/// @brief Adds a string to a YAML node +/// @param node YAML node +/// @param key key to apply value to +/// @param value string to add +void yaml_add_string(Yaml* node, const char* key, const char* value); + +/// @brief Adds an int to a YAML node +/// @param node YAML node +/// @param key key to apply value to +/// @param value integer to add +void yaml_add_int(Yaml* node, const char* key, int value); + +/// @brief Adds a float to a YAML node +/// @param node YAML node +/// @param key key to apply value to +/// @param value float to add +void yaml_add_float(Yaml* node, const char* key, float value); + +/// @brief Adds a double to a YAML node +/// @param node YAML node +/// @param key key to apply value to +/// @param value double to add +void yaml_add_double(Yaml* node, const char* key, double value); + +/// @brief Adds a boolean to a YAML node +/// @param node YAML node +/// @param key key to apply value to +/// @param value boolean to add +void yaml_add_bool(Yaml* node, const char* key, bool value); + +/// @brief Adds an array of strings to a YAML node +/// @param node YAML node +/// @param key key to apply value to +/// @param value string array to add +void yaml_add_string_array(Yaml* node, const char* key, string_array_t value); + +/// @brief Adds an array of doubles to a YAML node +/// @param node YAML node +/// @param key key to apply value to +/// @param value double array to add +void yaml_add_double_array(Yaml* node, const char* key, double_array_t value); + +/// @brief Adds an array of YAML nodes to a YAML node +/// @param node YAML node +/// @param key key to apply value to +/// @param value node array to add +void yaml_add_node_array(Yaml* node, const char* key, node_array_t value); + +/// @brief Copies a YAML node +/// @param node YAML node to copy +/// @return pointer to the new YAML node +Yaml* yaml_copy_node(Yaml* node); + +/// @brief Copies a YAML node to a string +/// @param node YAML node to copy +/// @return pointer to the new string +string_t yaml_to_string(Yaml* node); + +/// @brief Merges one YAML node into another +/// @param dest destination YAML node +/// @param src source YAML node +/// @return true if successful, false otherwise +bool yaml_merge_node(Yaml* dest, const Yaml* src); + +/// @brief Cleans up memory for a YAML node +/// @param ptr Node pointer to free memory for +void yaml_delete_node(Yaml* ptr); + +/// @brief Cleans up memory for a char array +/// @param string String to free memory for +void yaml_delete_string(string_t string); + +/// @brief Cleans up memory for an array of strings +/// @param array array to free memory for +void yaml_delete_string_array(string_array_t array); + +/// @brief Cleans up memory for an array of doubles +/// @param array array to free memory for +void yaml_delete_double_array(double_array_t array); + +/// @brief Cleans up memory for an array of YAML nodes +/// @details It is expected that the caller retains ownership of the +/// individual node pointers in the array +/// @param array array to free memory for +void yaml_delete_node_array(node_array_t array); + +/// @brief Cleans up memory for a YAML iterator +/// @param ptr Iterator to free memory for +void yaml_delete_iterator(YamlIterator* ptr); + +#ifdef __cplusplus +} +#endif \ No newline at end of file diff --git a/packaging/CMakeLists.txt b/packaging/CMakeLists.txt index 59973b4f..430f418e 100644 --- a/packaging/CMakeLists.txt +++ b/packaging/CMakeLists.txt @@ -11,6 +11,14 @@ install( RUNTIME DESTINATION ${CMAKE_INSTALL_BINDIR} ) +# install yaml-cpp +install( + TARGETS + yaml-cpp + EXPORT + tuvx_Exports +) + # install the mod files install( DIRECTORY diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt index 37b64f99..c147d1cd 100644 --- a/src/CMakeLists.txt +++ b/src/CMakeLists.txt @@ -3,19 +3,27 @@ # object library add_library(tuvx_object OBJECT) + +target_compile_features(tuvx_object INTERFACE cxx_std_11) + set_target_properties(tuvx_object PROPERTIES Fortran_MODULE_DIRECTORY ${TUVX_MOD_DIR} ) +target_include_directories(tuvx_object + PUBLIC + $ + $ +) + message(INFO "lapack libraries: ${LAPACK_LIBRARIES}") target_link_libraries(tuvx_object PUBLIC - musica::musicacore PkgConfig::netcdff + yaml-cpp::yaml-cpp ${BLAS_LIBRARIES} ${LAPACK_LIBRARIES} - ${JSON_LIB} ) # tuvx library @@ -28,10 +36,20 @@ set_target_properties(tuvx PROPERTIES SOVERSION ${PROJECT_VERSION_MAJOR} ) +target_link_libraries(tuvx + PUBLIC + PkgConfig::netcdff + yaml-cpp::yaml-cpp + ${BLAS_LIBRARIES} + ${LAPACK_LIBRARIES} +) + target_include_directories(tuvx PUBLIC $ + $ $ + $ ) target_sources(tuvx_object @@ -46,6 +64,7 @@ target_sources(tuvx_object grid.F90 grid_factory.F90 grid_warehouse.F90 + heating_rates.F90 interpolate.F90 la_sr_bands.F90 linear_algebra.F90 @@ -70,6 +89,6 @@ add_subdirectory(profiles) add_subdirectory(quantum_yields) add_subdirectory(radiative_transfer) add_subdirectory(spectral_weights) - +add_subdirectory(util) ################################################################################ diff --git a/src/constants.F90 b/src/constants.F90 index 42d88026..43829d33 100644 --- a/src/constants.F90 +++ b/src/constants.F90 @@ -22,5 +22,7 @@ module tuvx_constants real(dk), parameter :: pi = 3.1415926535898_dk ! Pi real(dk), parameter :: radius = 6.371E+3_dk ! Radius of the Earth [km] real(dk), parameter :: hc = 6.626068e-34_dk * 2.99792458e8_dk ! Plank's constants x speed of light [J m] - + real(dk), parameter :: Avogadro = 6.02214076e23_dk ! Avogadro's number [mol-1] + real(dk), parameter :: gas_constant = 8.31446261815324_dk ! Ideal gas constant [J K-1 mol-1] + end module tuvx_constants diff --git a/src/core.F90 b/src/core.F90 index 43c7e482..72828dda 100644 --- a/src/core.F90 +++ b/src/core.F90 @@ -9,6 +9,7 @@ module tuvx_core use musica_constants, only : dk => musica_dk use tuvx_dose_rates, only : dose_rates_t use tuvx_grid_warehouse, only : grid_warehouse_t + use tuvx_heating_rates, only : heating_rates_t use tuvx_la_sr_bands, only : la_sr_bands_t use tuvx_photolysis_rates, only : photolysis_rates_t use tuvx_profile_warehouse, only : profile_warehouse_t @@ -32,10 +33,11 @@ module tuvx_core type(radiative_transfer_t), pointer :: radiative_transfer_ => null() type(photolysis_rates_t), pointer :: photolysis_rates_ => null() type(dose_rates_t), pointer :: dose_rates_ => null() + type(heating_rates_t), pointer :: heating_rates_ => null() type(radiation_field_t), pointer :: radiation_field_ => null() logical :: enable_diagnostics_ ! determines if diagnostic output is written or not contains - ! Calculate photolysis rate constants and dose rates + ! Calculate photolysis rate constants, dose rates, and heating rates procedure :: run ! Returns a grid from the warehouse procedure :: get_grid @@ -50,10 +52,14 @@ module tuvx_core procedure :: number_of_photolysis_reactions ! Returns the number of dose rates procedure :: number_of_dose_rates + ! Returns the number of heating rates + procedure :: number_of_heating_rates ! Returns the set of photolysis reaction labels procedure :: photolysis_reaction_labels ! Returns the set of dose rate labels procedure :: dose_rate_labels + ! Returns the set of heating rate labels + procedure :: heating_rate_labels ! Returns the photolysis reaction cross section for the current conditions procedure :: get_photolysis_cross_section ! Returns the photolysis reaction quantum yield for the current conditions @@ -165,6 +171,9 @@ function constructor( config, grids, profiles, radiators ) result( new_core ) photolysis_rates_t( child_config, & new_core%grid_warehouse_, & new_core%profile_warehouse_ ) + new_core%heating_rates_ => heating_rates_t( child_config, & + new_core%grid_warehouse_, & + new_core%profile_warehouse_ ) end if ! dose rates @@ -191,7 +200,7 @@ end function constructor !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine run( this, solar_zenith_angle, earth_sun_distance, & - photolysis_rate_constants, dose_rates, diagnostic_label ) + photolysis_rate_constants, dose_rates, heating_rates, diagnostic_label ) ! Performs calculations for specified photolysis and dose rates for a ! given set of conditions @@ -205,6 +214,7 @@ subroutine run( this, solar_zenith_angle, earth_sun_distance, & real(dk), intent(in) :: earth_sun_distance ! [AU] real(dk), optional, intent(out) :: photolysis_rate_constants(:,:) ! (vertical level, reaction) [s-1] real(dk), optional, intent(out) :: dose_rates(:,:) ! (vertical level, reaction) [s-1] + real(dk), optional, intent(out) :: heating_rates(:,:) ! (vertical level, reaction) [J s-1] character(len=*), optional, intent(in) :: diagnostic_label ! label used in diagnostic file names ! Local variables @@ -247,6 +257,14 @@ subroutine run( this, solar_zenith_angle, earth_sun_distance, & photolysis_rate_constants, & diag_label ) end if + if( associated( this%heating_rates_ ) .and. present( heating_rates ) ) then + call this%heating_rates_%get( this%la_sr_bands_, & + this%spherical_geometry_, & + this%grid_warehouse_, & + this%profile_warehouse_, & + this%radiation_field_, & + heating_rates ) + end if if( associated( this%dose_rates_ ) .and. present( dose_rates ) ) then call this%dose_rates_%get( this%grid_warehouse_, & this%profile_warehouse_, & @@ -410,6 +428,20 @@ integer function number_of_dose_rates( this ) end function number_of_dose_rates +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + integer function number_of_heating_rates( this ) + ! Returns the number of heating rates + + class(core_t), intent(in) :: this + + number_of_heating_rates = 0 + if( associated( this%heating_rates_ ) ) then + number_of_heating_rates = this%heating_rates_%size( ) + end if + + end function number_of_heating_rates + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! function photolysis_reaction_labels( this ) result( labels ) @@ -442,6 +474,22 @@ function dose_rate_labels( this ) result( labels ) end function dose_rate_labels +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + function heating_rate_labels( this ) result( labels ) + ! Returns the set of heating rate labels + + class(core_t), intent(in) :: this + type(string_t), allocatable :: labels(:) + + if( associated( this%heating_rates_ ) ) then + labels = this%heating_rates_%labels( ) + else + allocate( labels( 0 ) ) + end if + + end function heating_rate_labels + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! function get_photolysis_cross_section( this, reaction_label, found ) & @@ -558,6 +606,11 @@ integer function pack_size( this, comm ) if( associated( this%dose_rates_ ) ) then pack_size = pack_size + this%dose_rates_%pack_size( comm ) end if + pack_size = pack_size + & + musica_mpi_pack_size( associated( this%heating_rates_ ), comm ) + if( associated( this%heating_rates_ ) ) then + pack_size = pack_size + this%heating_rates_%pack_size( comm ) + end if #else pack_size = 0 #endif @@ -617,6 +670,11 @@ subroutine mpi_pack( this, buffer, position, comm ) if( associated( this%dose_rates_ ) ) then call this%dose_rates_%mpi_pack( buffer, position, comm ) end if + call musica_mpi_pack( buffer, position, & + associated( this%heating_rates_ ), comm ) + if( associated( this%heating_rates_ ) ) then + call this%heating_rates_%mpi_pack( buffer, position, comm ) + end if call assert( 332208077, position - prev_pos <= this%pack_size( comm ) ) #endif @@ -676,6 +734,11 @@ subroutine mpi_unpack( this, buffer, position, comm ) allocate( this%dose_rates_ ) call this%dose_rates_%mpi_unpack( buffer, position, comm ) end if + call musica_mpi_unpack( buffer, position, alloced, comm ) + if( alloced ) then + allocate( this%heating_rates_ ) + call this%heating_rates_%mpi_unpack( buffer, position, comm ) + end if call assert( 332208077, position - prev_pos <= this%pack_size( comm ) ) #endif @@ -713,6 +776,9 @@ subroutine finalize( this ) if( associated( this%radiation_field_ ) ) then deallocate( this%radiation_field_ ) end if + if( associated( this%heating_rates_ ) ) then + deallocate( this%heating_rates_ ) + end if end subroutine finalize diff --git a/src/cross_section.F90 b/src/cross_section.F90 index 5c06d10f..f7750317 100644 --- a/src/cross_section.F90 +++ b/src/cross_section.F90 @@ -75,6 +75,8 @@ module tuvx_cross_section procedure :: mpi_unpack ! Processes a NetCDF input file procedure :: process_file + ! Apply cross section profile from configuration file + procedure :: cross_section_from_config end type cross_section_t interface cross_section_t @@ -108,7 +110,7 @@ function constructor( config, grid_warehouse, profile_warehouse ) & type(grid_warehouse_t), intent(inout) :: grid_warehouse ! A :f:type:`~tuvx_grid_warehouse/grid_warehouse_t` type(profile_warehouse_t), intent(inout) :: profile_warehouse ! A :f:type:`~tuvx_profile_warehouse/profile_warehouse_t` - type(string_t) :: required_keys(1), optional_keys(5) + type(string_t) :: required_keys(1), optional_keys(6) required_keys(1) = "type" optional_keys(1) = "netcdf files" @@ -116,6 +118,7 @@ function constructor( config, grid_warehouse, profile_warehouse ) & optional_keys(3) = "merge data" optional_keys(4) = "override bands" optional_keys(5) = "apply O2 bands" + optional_keys(6) = "data" call assert_msg( 124969900, & config%validate( required_keys, optional_keys ), & "Bad configuration data format for "// & @@ -147,7 +150,8 @@ subroutine base_constructor( this, config, grid_warehouse, & character(len=*), parameter :: Iam = 'base cross section initialize' integer :: i_param, i_file, i_override logical :: found - type(config_t) :: netcdf_files, netcdf_file, overrides, override + type(config_t) :: netcdf_files, netcdf_file, overrides, override, & + data_config class(iterator_t), pointer :: iter logical :: merge_data class(grid_t), pointer :: wavelengths @@ -157,7 +161,7 @@ subroutine base_constructor( this, config, grid_warehouse, & this%height_grid_ = grid_warehouse%get_ptr( "height", "km" ) this%temperature_profile_ = profile_warehouse%get_ptr( "temperature", "K" ) - ! get cross section netcdf filespec + ! get cross section netcdf data or data specified in config file call config%get( 'netcdf files', netcdf_files, Iam, found = found ) if( found ) then iter => netcdf_files%get_iterator( ) @@ -174,6 +178,12 @@ subroutine base_constructor( this, config, grid_warehouse, & deallocate( iter ) end if + ! get cross section data points specified in configuration + call config%get( 'data', data_config, Iam, found = found ) + if( found ) then + call this%cross_section_from_config( data_config, grid_warehouse ) + end if + ! get values to overlay for specific bands call config%get( "override bands", overrides, Iam, found = found ) if( found ) then @@ -311,6 +321,74 @@ subroutine process_file( this, config, grid_warehouse, parameters ) end subroutine process_file +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Apply cross section data points specified in configuration + subroutine cross_section_from_config( this, config, grid_warehouse ) + + use musica_assert, only : assert_msg, almost_equal + use musica_config, only : config_t + use musica_iterator, only : iterator_t + use musica_string, only : string_t, to_char + use tuvx_grid, only : grid_t + use tuvx_grid_warehouse, only : grid_warehouse_t + + !> Cross section calculator + class(cross_section_t), intent(inout) :: this + !> Configuration data + type(config_t), intent(inout) :: config + !> Grids + type(grid_warehouse_t), intent(inout) :: grid_warehouse + + character(len=*), parameter :: Iam = 'base cross section data' + class(grid_t), pointer :: wavelengths + type(config_t) :: points, point + class(iterator_t), pointer :: iter + real(kind=dk) :: value, wl + integer :: i_wl + logical :: found + type(string_t) :: required_keys(0), optional_keys(2) + + optional_keys(1) = "default value" + optional_keys(2) = "point values" + call assert_msg( 246462484, & + config%validate( required_keys, optional_keys ), & + "Invalid configuration for cross section data" ) + + wavelengths => grid_warehouse%get_grid( this%wavelength_grid_ ) + call config%get( "default value", value, Iam, default = 0.0_dk ) + if( .not. allocated( this%cross_section_parms ) ) then + allocate( this%cross_section_parms( 1 ) ) + allocate( this%cross_section_parms( 1 )%array( wavelengths%ncells_, 1 ) ) + this%cross_section_parms( 1 )%array(:,:) = value + end if + call assert_msg( 952054750, size( this%cross_section_parms ) .eq. 1, & + "Cross section data points cannot be specified when "// & + "multiple input files are being used." ) + call config%get( "point values", points, Iam, found = found ) + if( found ) then + iter => points%get_iterator( ) + do while( iter%next( ) ) + call points%get( iter, point, Iam ) + call point%get( "wavelength", wl, Iam ) + call point%get( "value", value, Iam ) + do i_wl = 1, wavelengths%ncells_ + if( almost_equal( wl, wavelengths%mid_( i_wl ) ) ) then + this%cross_section_parms( 1 )%array( i_wl, 1 ) = value + exit + end if + call assert_msg( 534489163, i_wl .ne. wavelengths%ncells_, & + "Cross section wavelength point "// & + trim( to_char( wl ) )// & + " does not exist on wavelength grid." ) + end do + end do + deallocate( iter ) + end if + deallocate( wavelengths ) + + end subroutine cross_section_from_config + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! function calculate( this, grid_warehouse, profile_warehouse, at_mid_point ) & diff --git a/src/cross_sections/CMakeLists.txt b/src/cross_sections/CMakeLists.txt index 64db6ead..66ab8245 100644 --- a/src/cross_sections/CMakeLists.txt +++ b/src/cross_sections/CMakeLists.txt @@ -31,4 +31,6 @@ target_sources(tuvx_object rayliegh.F90 ) +add_subdirectory(util) + ################################################################################ diff --git a/src/cross_sections/o3_tint.F90 b/src/cross_sections/o3_tint.F90 index 826bacfd..9e485ae8 100644 --- a/src/cross_sections/o3_tint.F90 +++ b/src/cross_sections/o3_tint.F90 @@ -157,7 +157,7 @@ function constructor( config, grid_warehouse, profile_warehouse ) & monopos = all( Xsection%deltaT > rZERO ) if( .not. monopos ) then if( any( Xsection%deltaT > rZERO ) ) then - write(msg,*) Iam//'File: '//file_path// & + write(msg,*) Iam//'File: '//file_path%val_// & ' temperature array not monotonic' call die_msg( 175583000, msg ) endif diff --git a/src/cross_sections/temperature_based.F90 b/src/cross_sections/temperature_based.F90 index 13aaf6ed..882495ca 100644 --- a/src/cross_sections/temperature_based.F90 +++ b/src/cross_sections/temperature_based.F90 @@ -1,4 +1,4 @@ -! Copyright (C) 2020 National Center for Atmospheric Research +! Copyright (C) 2020-4 National Center for Atmospheric Research ! SPDX-License-Identifier: Apache-2.0 module tuvx_cross_section_temperature_based @@ -10,92 +10,25 @@ module tuvx_cross_section_temperature_based use musica_constants, only : dk => musica_dk use tuvx_cross_section, only : cross_section_t use tuvx_interpolate, only : interpolator_conserving_t + use tuvx_temperature_parameterization, & + only : temperature_parameterization_t implicit none private public :: cross_section_temperature_based_t - !> Range for temperature-based calculations - type :: temperature_range_t - !> Minimum temperature [K] for inclusion in range - real(kind=dk) :: min_temperature_ = 0.0_dk - !> Maximum temperature [K] for include in range - real(kind=dk) :: max_temperature_ = huge(1.0_dk) - !> Indicates whether to use a fixed temperature for the - !! parameterization calculation. If FALSE, the actual - !! temperature is used. - logical :: is_fixed_ = .false. - !> Fixed temperature [K] to use in paramterization calculation - !! - !! Is only used if is_fixed == TRUE - real(kind=dk) :: fixed_temperature_ = 0.0_dk - contains - !> Returns the number of bytes required to pack the range onto a - !! character buffer - procedure :: pack_size => temperature_range_pack_size - !> Packs the range onto a character buffer - procedure :: mpi_pack => temperature_range_mpi_pack - !> Unpacks a range from a character buffer - procedure :: mpi_unpack => temperature_range_mpi_unpack - end type temperature_range_t - - !> Constructor for temperature_range_t - interface temperature_range_t - module procedure :: temperature_range_constructor - end interface temperature_range_t - - !> Parameters for calculating cross section values based on - !! temperature - !! - !! Cross section elements are calculated as: - !! - !! \f[ - !! 10^{\sum_i{(AA_i + (T-273)*BB_i)*\lambda^{lp_i}}} - !! \f] - !! - !! where \f$\lambda\f$ is the wavelength [nm] and - !! \f$T\f$ is the temperature [K]. - type :: temperature_parameterization_t - integer :: n_sets_ = 0 - real(kind=dk), allocatable :: AA_(:) - real(kind=dk), allocatable :: BB_(:) - real(kind=dk), allocatable :: lp_(:) - !> Minimum wavelength [nm] to calculate values for - real(kind=dk) :: min_wavelength_ - !> Maximum wavelength [nm] to calculate values for - real(kind=dk) :: max_wavelength_ - !> Index of minimum wavelength [nm] to calculate values for - integer :: min_wavelength_index_ - !> Index of maximum wavelength to calculate values for - integer :: max_wavelength_index_ - !> Temperature ranges used in parameterization - type(temperature_range_t), allocatable :: ranges_(:) - contains - !> Merges NetCDF wavelength grid with parameterization grid - procedure :: merge_wavelength_grids - !> Calculate the cross section value for a specific temperature - !! and wavelength - procedure :: calculate => temperature_parameterization_calculate - !> Returns the number of bytes required to pack the parameterization - !! onto a character buffer - procedure :: pack_size => temperature_parameterization_pack_size - !> Packs the parameterization onto a character buffer - procedure :: mpi_pack => temperature_parameterization_mpi_pack - !> Unpacks the parameterization from a character buffer - procedure :: mpi_unpack => temperature_parameterization_mpi_unpack - end type temperature_parameterization_t - - !> Constructor for temperature_parameterization_t - interface temperature_parameterization_t - module procedure :: temperature_parameterization_constructor - end interface temperature_parameterization_t + integer, parameter :: PARAM_BASE = 1 + integer, parameter :: PARAM_TAYLOR_SERIES = 2 + integer, parameter :: PARAM_BURKHOLDER = 3 + integer, parameter :: PARAM_HARWOOD = 4 !> Calculator for temperature-based cross sections type, extends(cross_section_t) :: cross_section_temperature_based_t real(kind=dk), allocatable :: raw_wavelengths_(:) ! [nm] real(kind=dk), allocatable :: raw_data_(:) - type(temperature_parameterization_t) :: parameterization_ + class(temperature_parameterization_t), pointer :: parameterization_ => & + null( ) type(interpolator_conserving_t) :: interpolator_ contains !> Calculate the cross section @@ -107,6 +40,8 @@ module tuvx_cross_section_temperature_based procedure :: mpi_pack !> Unpacks a cross section from a character buffer procedure :: mpi_unpack + !> Clean up memory + final :: finalize end type cross_section_temperature_based_t !> Constructor @@ -122,14 +57,20 @@ function constructor( config, grid_warehouse, profile_warehouse ) & result( this ) ! Constructs cross_section_temperature_based_t objects - use musica_assert, only : assert, assert_msg + use musica_assert, only : assert, assert_msg, die_msg use musica_string, only : string_t use tuvx_cross_section, only : base_constructor use tuvx_grid, only : grid_t + use tuvx_grid_factory, only : grid_builder use tuvx_grid_warehouse, only : grid_warehouse_t use tuvx_netcdf, only : netcdf_t use tuvx_profile_warehouse, only : profile_warehouse_t - use tuvx_util, only : add_point + use tuvx_temperature_parameterization_burkholder, & + only : temperature_parameterization_burkholder_t + use tuvx_temperature_parameterization_harwood, & + only : temperature_parameterization_harwood_t + use tuvx_temperature_parameterization_taylor_series, & + only : temperature_parameterization_taylor_series_t class(cross_section_t), pointer :: this type(config_t), intent(inout) :: config @@ -139,11 +80,10 @@ function constructor( config, grid_warehouse, profile_warehouse ) & ! local variables character(len=*), parameter :: my_name = & 'Temperature-based cross section constructor' - real(kind=dk), parameter :: deltax = 1.0e-5 - type(string_t) :: required_keys(3), optional_keys(1) + type(string_t) :: required_keys(2), optional_keys(3) class(grid_t), pointer :: wavelengths - type(config_t) :: param_config, interpolator_config - type(string_t) :: file_path + type(config_t) :: param_config, interpolator_config, grid_config + type(string_t) :: file_path, param_type type(netcdf_t) :: netcdf real(kind=dk), allocatable :: file_data(:), file_wl(:) logical :: found @@ -151,8 +91,9 @@ function constructor( config, grid_warehouse, profile_warehouse ) & required_keys(1) = "type" required_keys(2) = "parameterization" - required_keys(3) = "netcdf file" optional_keys(1) = "name" + optional_keys(2) = "parameterization wavelength grid" + optional_keys(3) = "netcdf file" call assert_msg( 483410000, & config%validate( required_keys, optional_keys ), & "Bad configuration for temperature-based cross section" ) @@ -166,31 +107,57 @@ function constructor( config, grid_warehouse, profile_warehouse ) & ! Load NetCDF files call config%get( "netcdf file", file_path, my_name, found = found ) - call netcdf%read_netcdf_file( file_path = file_path%to_char( ), & - variable_name = "cross_section_" ) - call assert_msg( 793476078, size( netcdf%parameters, dim = 2 ) == 1, & - "File: "//file_path//" should contain 1 parameter" ) - file_data = netcdf%parameters(:,1) - file_wl = netcdf%wavelength(:) - call add_point( x = file_wl, y = file_data, & - xnew = ( 1.0_dk - deltax ) * file_wl(1), ynew = 0.0_dk ) - call add_point( x = file_wl, y = file_data, & - xnew = 0.0_dk, ynew = 0.0_dk ) - call add_point( x = file_wl, y = file_data, & - xnew = ( 1.0_dk + deltax ) * file_wl( size( file_wl ) ), & - ynew = 0.0_dk ) - call add_point( x = file_wl, y = file_data, & - xnew = 1.0e38_dk, ynew = 0.0_dk ) + if( found ) then + call netcdf%read_netcdf_file( file_path = file_path%to_char( ), & + variable_name = "cross_section_" ) + call assert_msg( 793476078, size( netcdf%parameters, dim = 2 ) == 1, & + "File: "//file_path//" should contain 1 parameter" ) + file_data = netcdf%parameters(:,1) + file_wl = netcdf%wavelength(:) + else + allocate( file_data(0) ) + allocate( file_wl(0) ) + end if + + ! Check for custom wavelength grid for parameterization + call config%get( "parameterization wavelength grid", grid_config, my_name,& + found = found) + if( found ) then + wavelengths => grid_builder( grid_config ) + call assert_msg( 993335233, wavelengths%units( ) .eq. "nm", & + "Invalid units for custom wavelength grid in "// & + "temperature-based cross section. Expected 'nm' "// & + "but got '"//wavelengths%units( )//"'" ) + else + wavelengths => grid_warehouse%get_grid( this%wavelength_grid_ ) + end if ! Load parameters select type( this ) type is( cross_section_temperature_based_t ) - wavelengths => grid_warehouse%get_grid( this%wavelength_grid_ ) call config%get( "parameterization", param_config, my_name ) - this%parameterization_ = & - temperature_parameterization_t( param_config, wavelengths ) + call param_config%get( "type", param_type, my_name, found = found ) + if( found ) then + if( param_type == "TAYLOR_SERIES" ) then + allocate( this%parameterization_, source = & + temperature_parameterization_taylor_series_t( param_config ) ) + else if( param_type == "BURKHOLDER" ) then + allocate( this%parameterization_, source = & + temperature_parameterization_burkholder_t( param_config ) ) + else if( param_type == "HARWOOD" ) then + allocate( this%parameterization_, source = & + temperature_parameterization_harwood_t( param_config, & + wavelengths ) ) + else + call die_msg( 370773773, "Invalid temperature-based "// & + "parameterization type: '"//param_type//"'" ) + end if + else + allocate( this%parameterization_, source = & + temperature_parameterization_t( param_config, wavelengths ) ) + end if this%raw_wavelengths_ = & - this%parameterization_%merge_wavelength_grids( file_wl, wavelengths ) + this%parameterization_%merge_wavelength_grids( file_wl ) allocate( this%raw_data_( size( this%raw_wavelengths_ ) ) ) i_file = 1 do i_wl = 1, size( this%raw_wavelengths_ ) @@ -205,9 +172,9 @@ function constructor( config, grid_warehouse, profile_warehouse ) & this%raw_data_( i_wl ) = file_data( i_file ) i_file = i_file + 1 end do - call assert( 950874524, i_file == size( file_data ) + 1 ) - deallocate( wavelengths ) + call assert( 950874524, i_file <= size( file_data ) + 1 ) end select + deallocate( wavelengths ) end function constructor @@ -222,6 +189,7 @@ function calculate( this, grid_warehouse, profile_warehouse, at_mid_point ) & use tuvx_grid_warehouse, only : grid_warehouse_t use tuvx_profile_warehouse, only : profile_warehouse_t use tuvx_profile, only : profile_t + use tuvx_util, only : add_point real(kind=dk), allocatable :: cross_section(:,:) class(cross_section_temperature_based_t), intent(in) :: this @@ -232,11 +200,12 @@ function calculate( this, grid_warehouse, profile_warehouse, at_mid_point ) & ! local variables character(len=*), parameter :: Iam = & 'Temperature-based cross section calculate' + real(kind=dk), parameter :: deltax = 1.0e-5 class(grid_t), pointer :: heights class(grid_t), pointer :: wavelengths class(profile_t), pointer :: temperatures real(kind=dk) :: temperature - real(kind=dk), allocatable :: raw_data(:) + real(kind=dk), allocatable :: raw_data(:), raw_wl(:) logical :: l_at_mid_point integer :: i_wl, i_height @@ -261,11 +230,20 @@ function calculate( this, grid_warehouse, profile_warehouse, at_mid_point ) & temperature = temperatures%edge_val_( i_height ) end if raw_data = this%raw_data_ - call this%parameterization_%calculate( temperature, & - this%raw_wavelengths_, raw_data ) + raw_wl = this%raw_wavelengths_ + call this%parameterization_%calculate( temperature, raw_wl, raw_data ) + call add_point( x = raw_wl, y = raw_data, & + xnew = ( 1.0_dk - deltax ) * raw_wl(1), ynew = 0.0_dk ) + call add_point( x = raw_wl, y = raw_data, & + xnew = 0.0_dk, ynew = 0.0_dk ) + call add_point( x = raw_wl, y = raw_data, & + xnew = ( 1.0_dk + deltax ) * raw_wl( size( raw_wl ) ), & + ynew = 0.0_dk ) + call add_point( x = raw_wl, y = raw_data, & + xnew = 1.0e38_dk, ynew = 0.0_dk ) cross_section( i_height, : ) = & this%interpolator_%interpolate( x_target = wavelengths%edge_, & - x_source = this%raw_wavelengths_, & + x_source = raw_wl, & y_source = raw_data, & requested_by = & "temperature based cross section wavelength grid" ) @@ -289,8 +267,13 @@ integer function pack_size( this, comm ) #ifdef MUSICA_USE_MPI pack_size = this%cross_section_t%pack_size( comm ) + & musica_mpi_pack_size( this%raw_wavelengths_, comm ) + & - musica_mpi_pack_size( this%raw_data_, comm ) + & - this%parameterization_%pack_size( comm ) + musica_mpi_pack_size( this%raw_data_, comm ) + & + musica_mpi_pack_size( .false., comm ) + if( associated( this%parameterization_ ) ) then + pack_size = pack_size + & + musica_mpi_pack_size( 1, comm ) + & + this%parameterization_%pack_size( comm ) + end if #else pack_size = this%cross_section_t%pack_size( comm ) #endif @@ -302,8 +285,14 @@ end function pack_size subroutine mpi_pack( this, buffer, position, comm ) ! Packs the cross section onto a character buffer - use musica_assert, only : assert + use musica_assert, only : assert, die use musica_mpi, only : musica_mpi_pack + use tuvx_temperature_parameterization_burkholder, & + only : temperature_parameterization_burkholder_t + use tuvx_temperature_parameterization_harwood, & + only : temperature_parameterization_harwood_t + use tuvx_temperature_parameterization_taylor_series, & + only : temperature_parameterization_taylor_series_t class(cross_section_temperature_based_t), intent(in) :: this ! cross section to be packed character, intent(inout) :: buffer(:) ! memory buffer @@ -311,13 +300,32 @@ subroutine mpi_pack( this, buffer, position, comm ) integer, intent(in) :: comm ! MPI communicator #ifdef MUSICA_USE_MPI - integer :: prev_pos + integer :: prev_pos, param_type + logical :: is_alloced + + is_alloced = associated( this%parameterization_ ) prev_pos = position call this%cross_section_t%mpi_pack( buffer, position, comm ) call musica_mpi_pack( buffer, position, this%raw_wavelengths_, comm ) - call musica_mpi_pack( buffer, position, this%raw_data_, comm ) - call this%parameterization_%mpi_pack( buffer, position, comm ) + call musica_mpi_pack( buffer, position, this%raw_data_, comm ) + call musica_mpi_pack( buffer, position, is_alloced, comm ) + if( is_alloced ) then + select type( param => this%parameterization_ ) + type is( temperature_parameterization_t ) + param_type = PARAM_BASE + type is( temperature_parameterization_taylor_series_t ) + param_type = PARAM_TAYLOR_SERIES + type is( temperature_parameterization_burkholder_t ) + param_type = PARAM_BURKHOLDER + type is( temperature_parameterization_harwood_t ) + param_type = PARAM_HARWOOD + class default + call die( 424852458 ) + end select + call musica_mpi_pack( buffer, position, param_type, comm ) + call this%parameterization_%mpi_pack( buffer, position, comm ) + end if call assert( 322345685, position - prev_pos <= this%pack_size( comm ) ) #endif @@ -328,8 +336,14 @@ end subroutine mpi_pack subroutine mpi_unpack( this, buffer, position, comm ) ! Unpacks a cross section from a character buffer - use musica_assert, only : assert + use musica_assert, only : assert, die use musica_mpi, only : musica_mpi_unpack + use tuvx_temperature_parameterization_burkholder, & + only : temperature_parameterization_burkholder_t + use tuvx_temperature_parameterization_harwood, & + only : temperature_parameterization_harwood_t + use tuvx_temperature_parameterization_taylor_series, & + only : temperature_parameterization_taylor_series_t class(cross_section_temperature_based_t), intent(out) :: this ! cross section to be unpacked character, intent(inout) :: buffer(:) ! memory buffer @@ -337,13 +351,33 @@ subroutine mpi_unpack( this, buffer, position, comm ) integer, intent(in) :: comm ! MPI communicator #ifdef MUSICA_USE_MPI - integer :: prev_pos + integer :: prev_pos, param_type + logical :: is_alloced prev_pos = position call this%cross_section_t%mpi_unpack( buffer, position, comm ) call musica_mpi_unpack( buffer, position, this%raw_wavelengths_, comm ) - call musica_mpi_unpack( buffer, position, this%raw_data_, comm ) - call this%parameterization_%mpi_unpack( buffer, position, comm ) + call musica_mpi_unpack( buffer, position, this%raw_data_, comm ) + call musica_mpi_unpack( buffer, position, is_alloced, comm ) + if( is_alloced ) then + call musica_mpi_unpack( buffer, position, param_type, comm ) + select case( param_type ) + case( PARAM_BASE ) + allocate( temperature_parameterization_t :: this%parameterization_ ) + case( PARAM_TAYLOR_SERIES ) + allocate( temperature_parameterization_taylor_series_t :: & + this%parameterization_ ) + case( PARAM_BURKHOLDER ) + allocate( temperature_parameterization_burkholder_t :: & + this%parameterization_ ) + case( PARAM_HARWOOD ) + allocate( temperature_parameterization_harwood_t :: & + this%parameterization_ ) + case default + call die( 324803089 ) + end select + call this%parameterization_%mpi_unpack( buffer, position, comm ) + end if call assert( 820834544, position - prev_pos <= this%pack_size( comm ) ) #endif @@ -351,427 +385,16 @@ end subroutine mpi_unpack !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - function temperature_range_constructor( config ) result( this ) - ! Constructs temperature range objects - - use musica_assert, only : assert_msg - use musica_config, only : config_t - use musica_string, only : string_t - - type(temperature_range_t) :: this - type(config_t), intent(inout) :: config - - character(len=*), parameter :: my_name = "temperature range constructor" - type(string_t) :: required_keys(0), optional_keys(3) - logical :: found - - optional_keys(1) = "minimum" - optional_keys(2) = "maximum" - optional_keys(3) = "fixed value" - call assert_msg( 355912601, & - config%validate( required_keys, optional_keys ), & - "Bad configuration for temperature range" ) - - call config%get( "minimum", this%min_temperature_, my_name, & - default = 0.0_dk ) - call config%get( "maximum", this%max_temperature_, my_name, & - default = huge(1.0_dk) ) - call config%get( "fixed value", this%fixed_temperature_, my_name, & - found = found ) - this%is_fixed_ = found - - end function temperature_range_constructor - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - integer function temperature_range_pack_size( this, comm ) & - result( pack_size ) - ! Returns the size of a character buffer required to pack the range - - use musica_mpi, only : musica_mpi_pack_size - - class(temperature_range_t), intent(in) :: this ! temperature range to be packed - integer, intent(in) :: comm ! MPI communicator - -#ifdef MUSICA_USE_MPI - pack_size = musica_mpi_pack_size( this%min_temperature_, comm ) + & - musica_mpi_pack_size( this%max_temperature_, comm ) + & - musica_mpi_pack_size( this%is_fixed_, comm ) + & - musica_mpi_pack_size( this%fixed_temperature_, comm ) -#else - pack_size = 0 -#endif - - end function temperature_range_pack_size - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - subroutine temperature_range_mpi_pack( this, buffer, position, comm ) - ! Packs the temperature range onto a character buffer - - use musica_assert, only : assert - use musica_mpi, only : musica_mpi_pack - - class(temperature_range_t), intent(in) :: this ! temperature range to be packed - character, intent(inout) :: buffer(:) ! memory buffer - integer, intent(inout) :: position ! current buffer position - integer, intent(in) :: comm ! MPI communicator - -#ifdef MUSICA_USE_MPI - integer :: prev_pos - - prev_pos = position - call musica_mpi_pack( buffer, position, this%min_temperature_, comm ) - call musica_mpi_pack( buffer, position, this%max_temperature_, comm ) - call musica_mpi_pack( buffer, position, this%is_fixed_, comm ) - call musica_mpi_pack( buffer, position, this%fixed_temperature_, comm ) - call assert( 409699380, position - prev_pos <= this%pack_size( comm ) ) -#endif - - end subroutine temperature_range_mpi_pack - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - subroutine temperature_range_mpi_unpack( this, buffer, position, comm ) - ! Unpacks a temperature range from a character buffer - - use musica_assert, only : assert - use musica_mpi, only : musica_mpi_unpack - - class(temperature_range_t), intent(out) :: this ! temperature range to be unpacked - character, intent(inout) :: buffer(:) ! memory buffer - integer, intent(inout) :: position ! current buffer position - integer, intent(in) :: comm ! MPI communicator - -#ifdef MUSICA_USE_MPI - integer :: prev_pos - - prev_pos = position - call musica_mpi_unpack( buffer, position, this%min_temperature_, comm ) - call musica_mpi_unpack( buffer, position, this%max_temperature_, comm ) - call musica_mpi_unpack( buffer, position, this%is_fixed_, comm ) - call musica_mpi_unpack( buffer, position, this%fixed_temperature_, comm ) - call assert( 164457757, position - prev_pos <= this%pack_size( comm ) ) -#endif - - end subroutine temperature_range_mpi_unpack - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - function temperature_parameterization_constructor( config, wavelengths ) & - result( this ) - ! Constructs temperature_parameterization_t objects - - use musica_assert, only : assert_msg - use musica_config, only : config_t - use musica_iterator, only : iterator_t - use musica_string, only : string_t - use tuvx_grid, only : grid_t - - type(temperature_parameterization_t) :: this - type(config_t), intent(inout) :: config - class(grid_t), intent(in) :: wavelengths - - character(len=*), parameter :: my_name = & - "temperature parameterization constructor" - type(string_t) :: required_keys(3), optional_keys(3) - type(config_t) :: temp_ranges, temp_range - class(iterator_t), pointer :: iter - integer :: i_range - logical :: found - - required_keys(1) = "AA" - required_keys(2) = "BB" - required_keys(3) = "lp" - optional_keys(1) = "minimum wavelength" - optional_keys(2) = "maximum wavelength" - optional_keys(3) = "temperature ranges" - call assert_msg( 256315527, & - config%validate( required_keys, optional_keys ), & - "Bad configuration for temperature parameterization." ) - - call config%get( "AA", this%AA_, my_name ) - call config%get( "BB", this%BB_, my_name ) - call config%get( "lp", this%lp_, my_name ) - call assert_msg( 467090427, size( this%AA_ ) == size( this%BB_ ) .and. & - size( this%AA_ ) == size( this%lp_ ), & - "Arrays AA, BB, and lp must be the same size for "// & - "temperature-based cross sections." ) - call config%get( "minimum wavelength", this%min_wavelength_, my_name, & - default = 0.0_dk ) - call config%get( "maximum wavelength", this%max_wavelength_, my_name, & - default = huge(1.0_dk) ) - this%min_wavelength_index_ = 1 - do while( wavelengths%mid_( this%min_wavelength_index_ ) & - < this%min_wavelength_ & - .and. this%min_wavelength_index_ <= wavelengths%ncells_ ) - this%min_wavelength_index_ = this%min_wavelength_index_ + 1 - end do - call assert_msg( 286143383, & - wavelengths%mid_( this%min_wavelength_index_ ) & - >= this%min_wavelength_, & - "Minimum wavelength for temperature-based cross section is "// & - "outside the bounds of the wavelength grid." ) - this%max_wavelength_index_ = wavelengths%ncells_ - do while( wavelengths%mid_( this%max_wavelength_index_ ) & - > this%max_wavelength_ & - .and. this%max_wavelength_index_ >= 1 ) - this%max_wavelength_index_ = this%max_wavelength_index_ - 1 - end do - call assert_msg( 490175140, & - wavelengths%mid_( this%max_wavelength_index_ ) & - <= this%max_wavelength_, & - "Maximum wavelength for temperature-based cross section is "// & - "outside the bounds of the wavelength grid." ) - call config%get( "temperature ranges", temp_ranges, my_name, & - found = found ) - if( .not. found ) then - allocate( this%ranges_( 1 ) ) - return - end if - allocate( this%ranges_( temp_ranges%number_of_children( ) ) ) - iter => temp_ranges%get_iterator( ) - i_range = 0 - do while( iter%next( ) ) - i_range = i_range + 1 - call temp_ranges%get( iter, temp_range, my_name ) - this%ranges_( i_range ) = temperature_range_t( temp_range ) - end do - deallocate( iter ) - - end function temperature_parameterization_constructor - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - function merge_wavelength_grids( this, input_grid, tuv_grid ) & - result( merged_grid ) - ! Merges wavelength grid from NetCDF input data with parameterization - ! grid (same as the TUV-x grid). - ! Where they overlap, the parameterization is used. - ! Updates the parameterization wavelength indices for new grid. - ! Returns merged wavelength grid. - ! - ! NOTE: Uses mid-points on the TUV-x wavelength grid - - use musica_assert, only : assert - use tuvx_grid, only : grid_t - - class(temperature_parameterization_t), intent(inout) :: this - real(kind=dk), intent(in) :: input_grid(:) - class(grid_t), intent(in) :: tuv_grid - real(kind=dk), allocatable :: merged_grid(:) + !> Clean-up memory + subroutine finalize( this ) - logical :: found_min - integer :: i_wl, n_wl, i_input_wl, i_tuv_wl, n_tuv_wl + type(cross_section_temperature_based_t), intent(inout) :: this - if( size( input_grid ) == 0 ) then - merged_grid = tuv_grid%mid_ - return + if( associated( this%parameterization_ ) ) then + deallocate( this%parameterization_ ) end if - associate( wl_min_index => this%min_wavelength_index_, & - wl_max_index => this%max_wavelength_index_, & - min_wl => this%min_wavelength_, & - max_wl => this%max_wavelength_ ) - n_wl = 0 - do i_input_wl = 1, size( input_grid(:) ) - if( min_wl > input_grid( i_input_wl ) .or. & - max_wl < input_grid( i_input_wl ) ) n_wl = n_wl + 1 - end do - i_tuv_wl = wl_min_index - n_tuv_wl = wl_max_index - n_wl = n_wl + ( n_tuv_wl - i_tuv_wl + 1 ) - allocate( merged_grid( n_wl ) ) - i_input_wl = 1 - i_wl = 1 - found_min = .false. - do - if( i_wl > n_wl ) then - ! end of merged grid - exit - else if( i_tuv_wl > n_tuv_wl .and. & - input_grid( i_input_wl ) <= max_wl ) then - ! skipping input data wavelengths in parameterization range - i_input_wl = i_input_wl + 1 - else if( .not. ( min_wl <= input_grid( i_input_wl ) .and. & - max_wl >= input_grid( i_input_wl ) ) ) then - ! adding input data wavelengths outside of parameterization range - merged_grid( i_wl ) = input_grid( i_input_wl ) - i_input_wl = i_input_wl + 1 - i_wl = i_wl + 1 - else if( i_tuv_wl <= n_tuv_wl ) then - ! adding TUV-x wavelengths in parameterization range - ! - ! TODO This follows logic from original TUV, but perhaps should - ! be modified to assign TUV-x wavelength edges - merged_grid( i_wl ) = tuv_grid%mid_( i_tuv_wl ) - if( .not. found_min ) then - found_min = .true. - wl_min_index = i_wl - end if - wl_max_index = i_wl - i_tuv_wl = i_tuv_wl + 1 - i_wl = i_wl + 1 - end if - end do - call assert( 265861594, i_tuv_wl == n_tuv_wl + 1 ) - call assert( 537808229, i_input_wl == size( input_grid ) + 1 ) - call assert( 422870529, i_wl == n_wl + 1 ) - end associate - - end function merge_wavelength_grids - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - subroutine temperature_parameterization_calculate( this, temperature, & - wavelengths, cross_section ) - - use tuvx_profile, only : profile_t - - class(temperature_parameterization_t), intent(in) :: this - real(kind=dk), intent(in) :: temperature - real(kind=dk), intent(in) :: wavelengths(:) - real(kind=dk), intent(inout) :: cross_section(:) - - ! local variables - real(kind=dk) :: temp, temp_xs( size( cross_section ) ) - integer :: i_lp, i_range, w_min, w_max - - w_min = this%min_wavelength_index_ - w_max = this%max_wavelength_index_ - do i_range = 1, size( this%ranges_ ) - associate( temp_range => this%ranges_( i_range ) ) - if( temperature < temp_range%min_temperature_ .or. & - temperature > temp_range%max_temperature_ ) cycle - if( temp_range%is_fixed_ ) then - temp = temp_range%fixed_temperature_ - else - temp = temperature - end if - temp_xs(:) = 0.0_dk - do i_lp = 1, size( this%lp_ ) - temp_xs( w_min:w_max ) = temp_xs( w_min:w_max ) + & - ( this%AA_( i_lp ) + (temp - 273.0_dk) * this%BB_( i_lp ) ) * & - wavelengths( w_min:w_max )**this%lp_( i_lp ) - end do - cross_section( w_min:w_max ) = cross_section( w_min:w_max ) & - + 10**temp_xs( w_min:w_max ) - end associate - end do - - end subroutine temperature_parameterization_calculate - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - integer function temperature_parameterization_pack_size( this, comm ) & - result( pack_size ) - ! Returns the size of a character buffer required to pack the - ! parameterization - - use musica_mpi, only : musica_mpi_pack_size - - class(temperature_parameterization_t), intent(in) :: this ! parameterization to be packed - integer, intent(in) :: comm ! MPI communicator - -#ifdef MUSICA_USE_MPI - integer :: i_range - - pack_size = musica_mpi_pack_size( this%AA_, comm ) + & - musica_mpi_pack_size( this%BB_, comm ) + & - musica_mpi_pack_size( this%lp_, comm ) + & - musica_mpi_pack_size( this%min_wavelength_, comm ) + & - musica_mpi_pack_size( this%max_wavelength_, comm ) + & - musica_mpi_pack_size( this%min_wavelength_index_, comm ) + & - musica_mpi_pack_size( this%max_wavelength_index_, comm ) + & - musica_mpi_pack_size( allocated( this%ranges_ ), comm ) - if( allocated( this%ranges_ ) ) then - pack_size = pack_size + & - musica_mpi_pack_size( size( this%ranges_ ), comm ) - do i_range = 1, size( this%ranges_ ) - pack_size = pack_size + this%ranges_( i_range )%pack_size( comm ) - end do - end if -#else - pack_size = 0 -#endif - - end function temperature_parameterization_pack_size - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - subroutine temperature_parameterization_mpi_pack( this, buffer, position, & - comm ) - ! Packs the parameterization onto a character buffer - - use musica_assert, only : assert - use musica_mpi, only : musica_mpi_pack - - class(temperature_parameterization_t), intent(in) :: this ! parameterization to be packed - character, intent(inout) :: buffer(:) ! memory buffer - integer, intent(inout) :: position ! current buffer position - integer, intent(in) :: comm ! MPI communicator - -#ifdef MUSICA_USE_MPI - integer :: prev_pos, i_range - - prev_pos = position - call musica_mpi_pack( buffer, position, this%AA_, comm ) - call musica_mpi_pack( buffer, position, this%BB_, comm ) - call musica_mpi_pack( buffer, position, this%lp_, comm ) - call musica_mpi_pack( buffer, position, this%min_wavelength_, comm ) - call musica_mpi_pack( buffer, position, this%max_wavelength_, comm ) - call musica_mpi_pack( buffer, position, this%min_wavelength_index_, comm ) - call musica_mpi_pack( buffer, position, this%max_wavelength_index_, comm ) - call musica_mpi_pack( buffer, position, allocated( this%ranges_ ), comm ) - if( allocated( this%ranges_ ) ) then - call musica_mpi_pack( buffer, position, size( this%ranges_ ), comm ) - do i_range = 1, size( this%ranges_ ) - call this%ranges_( i_range )%mpi_pack( buffer, position, comm ) - end do - end if - call assert( 267439201, position - prev_pos <= this%pack_size( comm ) ) -#endif - - end subroutine temperature_parameterization_mpi_pack - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - subroutine temperature_parameterization_mpi_unpack( this, buffer, position, & - comm ) - ! Unpacks a parameterization from a character buffer - - use musica_assert, only : assert - use musica_mpi, only : musica_mpi_unpack - - class(temperature_parameterization_t), intent(out) :: this ! parameterization to be unpacked - character, intent(inout) :: buffer(:) ! memory buffer - integer, intent(inout) :: position ! current buffer position - integer, intent(in) :: comm ! MPI communicator - -#ifdef MUSICA_USE_MPI - integer :: prev_pos, i_range, n_ranges - logical :: alloced - - prev_pos = position - call musica_mpi_unpack( buffer, position, this%AA_, comm ) - call musica_mpi_unpack( buffer, position, this%BB_, comm ) - call musica_mpi_unpack( buffer, position, this%lp_, comm ) - call musica_mpi_unpack( buffer, position, this%min_wavelength_, comm ) - call musica_mpi_unpack( buffer, position, this%max_wavelength_, comm ) - call musica_mpi_unpack( buffer, position, this%min_wavelength_index_,comm ) - call musica_mpi_unpack( buffer, position, this%max_wavelength_index_,comm ) - call musica_mpi_unpack( buffer, position, alloced, comm ) - if( alloced ) then - call musica_mpi_unpack( buffer, position, n_ranges, comm ) - allocate( this%ranges_( n_ranges ) ) - do i_range = 1, size( this%ranges_ ) - call this%ranges_( i_range )%mpi_unpack( buffer, position, comm ) - end do - end if - call assert( 483905106, position - prev_pos <= this%pack_size( comm ) ) -#endif - - end subroutine temperature_parameterization_mpi_unpack + end subroutine finalize !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/src/cross_sections/util/CMakeLists.txt b/src/cross_sections/util/CMakeLists.txt new file mode 100644 index 00000000..546c0260 --- /dev/null +++ b/src/cross_sections/util/CMakeLists.txt @@ -0,0 +1,13 @@ +################################################################################ +# utilities for cross section parameterizations + +target_sources(tuvx_object + PRIVATE + temperature_parameterization.F90 + temperature_parameterization_burkholder.F90 + temperature_parameterization_harwood.F90 + temperature_parameterization_taylor_series.F90 + temperature_range.F90 +) + +################################################################################ \ No newline at end of file diff --git a/src/cross_sections/util/temperature_parameterization.F90 b/src/cross_sections/util/temperature_parameterization.F90 new file mode 100644 index 00000000..32b863dc --- /dev/null +++ b/src/cross_sections/util/temperature_parameterization.F90 @@ -0,0 +1,436 @@ +! Copyright (C) 2020-4 National Center for Atmospheric Research +! SPDX-License-Identifier: Apache-2.0 + +module tuvx_temperature_parameterization +! Calculates cross-section elements based on a temperature parameterization + + ! Including musica_config at the module level to avoid an ICE + ! with Intel 2022.1 compiler + use musica_config, only : config_t + use musica_constants, only : dk => musica_dk + use tuvx_temperature_range, only : temperature_range_t + + implicit none + + private + public :: temperature_parameterization_t + + !> Parameters for calculating cross section values based on + !! temperature + !! + !! Cross section elements are calculated as: + !! + !! \f[ + !! 10^{\sum_i{(AA_i + (T-273)*BB_i)*\lambda^{lp_i}}} + !! \f] + !! + !! where \f$\lambda\f$ is the wavelength [nm] and + !! \f$T\f$ is the temperature [K]. + type :: temperature_parameterization_t + integer :: n_sets_ = 0 + real(kind=dk), allocatable :: AA_(:) + real(kind=dk), allocatable :: BB_(:) + real(kind=dk), allocatable :: lp_(:) + !> Wavelengths in parameterization range [nm] + real(kind=dk), allocatable :: wavelengths_(:) + !> Base temperature [K] to use in calculations + real(kind=dk) :: base_temperature_ = 0.0_dk + !> Base wavelength [nm] to use in calcuations + real(kind=dk) :: base_wavelength_ = 0.0_dk + !> Flag indicating whether cross section algorithm is base 10 (true) + !! or base e (false) + logical :: is_base_10_ = .true. + !> Flad indicating whether to subtract base temperature from + !! actual temperature (false) or to subtract actual temperature + !! from base temperature (true) + logical :: is_temperature_inverted_ = .false. + !> Minimum wavelength [nm] to calculate values for + real(kind=dk) :: min_wavelength_ = 0.0_dk + !> Maximum wavelength [nm] to calculate values for + real(kind=dk) :: max_wavelength_ = 0.0_dk + !> Index of minimum wavelength [nm] to calculate values for + integer :: min_wavelength_index_ = 0 + !> Index of maximum wavelength to calculate values for + integer :: max_wavelength_index_ = 0 + !> Temperature ranges used in parameterization + type(temperature_range_t), allocatable :: ranges_(:) + contains + !> Merges NetCDF wavelength grid with parameterization grid + procedure :: merge_wavelength_grids + !> Calculate the cross section value for a specific temperature + !! and wavelength + procedure :: calculate => calculate + !> Returns the number of bytes required to pack the parameterization + !! onto a character buffer + procedure :: pack_size => pack_size + !> Packs the parameterization onto a character buffer + procedure :: mpi_pack => mpi_pack + !> Unpacks the parameterization from a character buffer + procedure :: mpi_unpack => mpi_unpack + end type temperature_parameterization_t + + !> Constructor for temperature_parameterization_t + interface temperature_parameterization_t + module procedure :: constructor + end interface temperature_parameterization_t + +contains + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + function constructor( config, wavelengths ) result( this ) + ! Constructs temperature_parameterization_t objects + + use musica_assert, only : assert_msg, die_msg + use musica_config, only : config_t + use musica_iterator, only : iterator_t + use musica_string, only : string_t + use tuvx_grid, only : grid_t + + type(temperature_parameterization_t) :: this + type(config_t), intent(inout) :: config + class(grid_t), intent(in) :: wavelengths + + character(len=*), parameter :: my_name = & + "temperature parameterization constructor" + type(string_t) :: required_keys(6), optional_keys(4), exp_base + type(config_t) :: temp_ranges, temp_range + class(iterator_t), pointer :: iter + integer :: i_range + logical :: found + + required_keys(1) = "AA" + required_keys(2) = "BB" + required_keys(3) = "lp" + required_keys(4) = "base temperature" + required_keys(5) = "base wavelength" + required_keys(6) = "logarithm" + optional_keys(1) = "minimum wavelength" + optional_keys(2) = "maximum wavelength" + optional_keys(3) = "temperature ranges" + optional_keys(4) = "invert temperature offset" + call assert_msg( 256315527, & + config%validate( required_keys, optional_keys ), & + "Bad configuration for temperature parameterization." ) + + call config%get( "AA", this%AA_, my_name ) + call config%get( "BB", this%BB_, my_name ) + call config%get( "lp", this%lp_, my_name ) + call config%get( "base temperature", this%base_temperature_, my_name ) + call config%get( "base wavelength", this%base_wavelength_, my_name ) + call config%get( "logarithm", exp_base, my_name ) + call config%get( "invert temperature offset", & + this%is_temperature_inverted_, my_name, default = .false.) + if( exp_base == "base 10" ) then + this%is_base_10_ = .true. + else if( exp_base == "natural" ) then + this%is_base_10_ = .false. + else + call die_msg( 104603249, "Invalid logarithm type in temperature-based"//& + " cross section: '"//exp_base//"'" ) + end if + call assert_msg( 467090427, size( this%AA_ ) == size( this%BB_ ) .and. & + size( this%AA_ ) == size( this%lp_ ), & + "Arrays AA, BB, and lp must be the same size for "// & + "temperature-based cross sections." ) + call config%get( "minimum wavelength", this%min_wavelength_, my_name, & + default = 0.0_dk ) + call config%get( "maximum wavelength", this%max_wavelength_, my_name, & + default = huge(1.0_dk) ) + this%min_wavelength_index_ = 1 + do while( wavelengths%mid_( this%min_wavelength_index_ ) & + < this%min_wavelength_ & + .and. this%min_wavelength_index_ <= wavelengths%ncells_ ) + this%min_wavelength_index_ = this%min_wavelength_index_ + 1 + end do + call assert_msg( 286143383, & + wavelengths%mid_( this%min_wavelength_index_ ) & + >= this%min_wavelength_, & + "Minimum wavelength for temperature-based cross section is "// & + "outside the bounds of the wavelength grid." ) + this%max_wavelength_index_ = wavelengths%ncells_ + do while( wavelengths%mid_( this%max_wavelength_index_ ) & + > this%max_wavelength_ & + .and. this%max_wavelength_index_ >= 1 ) + this%max_wavelength_index_ = this%max_wavelength_index_ - 1 + end do + call assert_msg( 490175140, & + wavelengths%mid_( this%max_wavelength_index_ ) & + <= this%max_wavelength_, & + "Maximum wavelength for temperature-based cross section is "// & + "outside the bounds of the wavelength grid." ) + ! TODO This follows logic from original TUV, but perhaps should + ! be modified to assign TUV-x wavelength edges + this%wavelengths_ = wavelengths%mid_( this%min_wavelength_index_ : & + this%max_wavelength_index_ ) + call config%get( "temperature ranges", temp_ranges, my_name, & + found = found ) + if( .not. found ) then + allocate( this%ranges_( 1 ) ) + return + end if + allocate( this%ranges_( temp_ranges%number_of_children( ) ) ) + iter => temp_ranges%get_iterator( ) + i_range = 0 + do while( iter%next( ) ) + i_range = i_range + 1 + call temp_ranges%get( iter, temp_range, my_name ) + this%ranges_( i_range ) = temperature_range_t( temp_range ) + end do + deallocate( iter ) + + end function constructor + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + function merge_wavelength_grids( this, input_grid ) result( merged_grid ) + ! Merges wavelength grid from NetCDF input data with parameterization + ! grid. + ! Where they overlap, the parameterization is used. + ! Updates the parameterization wavelength indices for new grid. + ! Returns merged wavelength grid. + + use musica_assert, only : assert + use tuvx_grid, only : grid_t + + class(temperature_parameterization_t), intent(inout) :: this + real(kind=dk), intent(in) :: input_grid(:) + real(kind=dk), allocatable :: merged_grid(:) + + logical :: found_min + integer :: i_wl, n_wl, i_input_wl, i_param_wl + + if( size( input_grid ) == 0 ) then + merged_grid = this%wavelengths_ + this%min_wavelength_index_ = 1 + this%max_wavelength_index_ = size( merged_grid ) + return + end if + + associate( wl_min_index => this%min_wavelength_index_, & + wl_max_index => this%max_wavelength_index_, & + min_wl => this%min_wavelength_, & + max_wl => this%max_wavelength_ ) + n_wl = 0 + do i_input_wl = 1, size( input_grid(:) ) + if( min_wl > input_grid( i_input_wl ) .or. & + max_wl < input_grid( i_input_wl ) ) n_wl = n_wl + 1 + end do + n_wl = n_wl + size( this%wavelengths_ ) + allocate( merged_grid( n_wl ) ) + i_input_wl = 1 + i_param_wl = 1 + i_wl = 1 + found_min = .false. + do + if( i_wl > n_wl ) then + ! end of merged grid + exit + else if( i_param_wl > size( this%wavelengths_ ) .and. & + input_grid( i_input_wl ) <= max_wl ) then + ! skipping input data wavelengths in parameterization range + i_input_wl = i_input_wl + 1 + else if( .not. ( min_wl <= input_grid( i_input_wl ) .and. & + max_wl >= input_grid( i_input_wl ) ) ) then + ! adding input data wavelengths outside of parameterization range + merged_grid( i_wl ) = input_grid( i_input_wl ) + i_input_wl = i_input_wl + 1 + i_wl = i_wl + 1 + else if( i_param_wl <= size( this%wavelengths_ ) ) then + ! adding TUV-x wavelengths in parameterization range + merged_grid( i_wl ) = this%wavelengths_( i_param_wl ) + if( .not. found_min ) then + found_min = .true. + wl_min_index = i_wl + end if + wl_max_index = i_wl + i_param_wl = i_param_wl + 1 + i_wl = i_wl + 1 + end if + end do + call assert( 265861594, i_param_wl == size( this%wavelengths_ ) + 1 ) + call assert( 537808229, i_input_wl <= size( input_grid ) + 1 ) + call assert( 422870529, i_wl == n_wl + 1 ) + end associate + + end function merge_wavelength_grids + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine calculate( this, temperature, wavelengths, cross_section ) + + use tuvx_profile, only : profile_t + + class(temperature_parameterization_t), intent(in) :: this + real(kind=dk), intent(in) :: temperature + real(kind=dk), intent(in) :: wavelengths(:) + real(kind=dk), intent(inout) :: cross_section(:) + + ! local variables + real(kind=dk) :: temp, temp_xs( size( cross_section ) ) + integer :: i_lp, i_range, w_min, w_max + + w_min = this%min_wavelength_index_ + w_max = this%max_wavelength_index_ + do i_range = 1, size( this%ranges_ ) + associate( temp_range => this%ranges_( i_range ) ) + if( temperature < temp_range%min_temperature_ .or. & + temperature > temp_range%max_temperature_ ) cycle + if( temp_range%is_fixed_ ) then + temp = temp_range%fixed_temperature_ + else + temp = temperature + end if + if ( this%is_temperature_inverted_ ) then + temp = this%base_temperature_ - temp + else + temp = temp - this%base_temperature_ + end if + temp_xs(:) = 0.0_dk + do i_lp = 1, size( this%lp_ ) + temp_xs( w_min:w_max ) = temp_xs( w_min:w_max ) + & + ( this%AA_( i_lp ) + temp * this%BB_( i_lp ) ) * & + ( wavelengths( w_min:w_max ) & + - this%base_wavelength_ )**this%lp_( i_lp ) + end do + if (this%is_base_10_) then + cross_section( w_min:w_max ) = cross_section( w_min:w_max ) & + + 10**temp_xs( w_min:w_max ) + else + cross_section( w_min:w_max ) = cross_section( w_min:w_max ) & + + exp( temp_xs( w_min:w_max ) ) + end if + end associate + end do + + end subroutine calculate + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + integer function pack_size( this, comm ) + ! Returns the size of a character buffer required to pack the + ! parameterization + + use musica_mpi, only : musica_mpi_pack_size + + class(temperature_parameterization_t), intent(in) :: this ! parameterization to be packed + integer, intent(in) :: comm ! MPI communicator + +#ifdef MUSICA_USE_MPI + integer :: i_range + + pack_size = musica_mpi_pack_size( this%AA_, comm ) + & + musica_mpi_pack_size( this%BB_, comm ) + & + musica_mpi_pack_size( this%lp_, comm ) + & + musica_mpi_pack_size( this%wavelengths_, comm ) + & + musica_mpi_pack_size( this%base_temperature_, comm ) + & + musica_mpi_pack_size( this%base_wavelength_, comm ) + & + musica_mpi_pack_size( this%is_base_10_, comm ) + & + musica_mpi_pack_size( this%is_temperature_inverted_, comm ) + & + musica_mpi_pack_size( this%min_wavelength_, comm ) + & + musica_mpi_pack_size( this%max_wavelength_, comm ) + & + musica_mpi_pack_size( this%min_wavelength_index_, comm ) + & + musica_mpi_pack_size( this%max_wavelength_index_, comm ) + & + musica_mpi_pack_size( allocated( this%ranges_ ), comm ) + if( allocated( this%ranges_ ) ) then + pack_size = pack_size + & + musica_mpi_pack_size( size( this%ranges_ ), comm ) + do i_range = 1, size( this%ranges_ ) + pack_size = pack_size + this%ranges_( i_range )%pack_size( comm ) + end do + end if +#else + pack_size = 0 +#endif + + end function pack_size + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine mpi_pack( this, buffer, position, comm ) + ! Packs the parameterization onto a character buffer + + use musica_assert, only : assert + use musica_mpi, only : musica_mpi_pack + + class(temperature_parameterization_t), intent(in) :: this ! parameterization to be packed + character, intent(inout) :: buffer(:) ! memory buffer + integer, intent(inout) :: position ! current buffer position + integer, intent(in) :: comm ! MPI communicator + +#ifdef MUSICA_USE_MPI + integer :: prev_pos, i_range + + prev_pos = position + call musica_mpi_pack( buffer, position, this%AA_, comm ) + call musica_mpi_pack( buffer, position, this%BB_, comm ) + call musica_mpi_pack( buffer, position, this%lp_, comm ) + call musica_mpi_pack( buffer, position, this%wavelengths_, comm ) + call musica_mpi_pack( buffer, position, this%base_temperature_, comm ) + call musica_mpi_pack( buffer, position, this%base_wavelength_, comm ) + call musica_mpi_pack( buffer, position, this%is_base_10_, comm ) + call musica_mpi_pack( buffer, position, this%is_temperature_inverted_, & + comm ) + call musica_mpi_pack( buffer, position, this%min_wavelength_, comm ) + call musica_mpi_pack( buffer, position, this%max_wavelength_, comm ) + call musica_mpi_pack( buffer, position, this%min_wavelength_index_, comm ) + call musica_mpi_pack( buffer, position, this%max_wavelength_index_, comm ) + call musica_mpi_pack( buffer, position, allocated( this%ranges_ ), comm ) + if( allocated( this%ranges_ ) ) then + call musica_mpi_pack( buffer, position, size( this%ranges_ ), comm ) + do i_range = 1, size( this%ranges_ ) + call this%ranges_( i_range )%mpi_pack( buffer, position, comm ) + end do + end if + call assert( 267439201, position - prev_pos <= this%pack_size( comm ) ) +#endif + + end subroutine mpi_pack + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine mpi_unpack( this, buffer, position, comm ) + ! Unpacks a parameterization from a character buffer + + use musica_assert, only : assert + use musica_mpi, only : musica_mpi_unpack + + class(temperature_parameterization_t), intent(out) :: this ! parameterization to be unpacked + character, intent(inout) :: buffer(:) ! memory buffer + integer, intent(inout) :: position ! current buffer position + integer, intent(in) :: comm ! MPI communicator + +#ifdef MUSICA_USE_MPI + integer :: prev_pos, i_range, n_ranges + logical :: alloced + + prev_pos = position + call musica_mpi_unpack( buffer, position, this%AA_, comm ) + call musica_mpi_unpack( buffer, position, this%BB_, comm ) + call musica_mpi_unpack( buffer, position, this%lp_, comm ) + call musica_mpi_unpack( buffer, position, this%wavelengths_, comm ) + call musica_mpi_unpack( buffer, position, this%base_temperature_, comm ) + call musica_mpi_unpack( buffer, position, this%base_wavelength_, comm ) + call musica_mpi_unpack( buffer, position, this%is_base_10_, comm ) + call musica_mpi_unpack( buffer, position, this%is_temperature_inverted_, & + comm ) + call musica_mpi_unpack( buffer, position, this%min_wavelength_, comm ) + call musica_mpi_unpack( buffer, position, this%max_wavelength_, comm ) + call musica_mpi_unpack( buffer, position, this%min_wavelength_index_,comm ) + call musica_mpi_unpack( buffer, position, this%max_wavelength_index_,comm ) + call musica_mpi_unpack( buffer, position, alloced, comm ) + if( alloced ) then + call musica_mpi_unpack( buffer, position, n_ranges, comm ) + allocate( this%ranges_( n_ranges ) ) + do i_range = 1, size( this%ranges_ ) + call this%ranges_( i_range )%mpi_unpack( buffer, position, comm ) + end do + end if + call assert( 483905106, position - prev_pos <= this%pack_size( comm ) ) +#endif + + end subroutine mpi_unpack + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +end module tuvx_temperature_parameterization \ No newline at end of file diff --git a/src/cross_sections/util/temperature_parameterization_burkholder.F90 b/src/cross_sections/util/temperature_parameterization_burkholder.F90 new file mode 100644 index 00000000..b483775f --- /dev/null +++ b/src/cross_sections/util/temperature_parameterization_burkholder.F90 @@ -0,0 +1,257 @@ +! Copyright (C) 2024 National Center for Atmospheric Research +! SPDX-License-Identifier: Apache-2.0 + +module tuvx_temperature_parameterization_burkholder +! Calculates cross-section elements using a temperature-based +! parameterization from Burkholder et al. Phys. Chem. Chem. Phys. 4, 1432-1437 (2002). + + ! Including musica_config at the module level to avoid an ICE + ! with Intel 2022.1 compiler + use musica_config, only : config_t + use musica_constants, only : dk => musica_dk + use tuvx_temperature_parameterization, & + only : temperature_parameterization_t + use tuvx_temperature_range, only : temperature_range_t + + implicit none + + private + public :: temperature_parameterization_burkholder_t + + !> Parameters for calculating cross section values based on + !! temperature using the algoritm in Burkholder et al. + !! Phys. Chem. Chem. Phys. 4, 1432-1437 (2002). + !! + !! Cross section elements are calculated as: + !! + !! \f[ + !! Q(T) = 1 + e^{\frac{A}{B*T}} + !! \sigma(T,\lambda) = \frac{aa(\lambda)}{Q(T)} + bb(\lambda)*\[1-\frac{1}{Q(T)}\] + !! \f] + !! + !! where A, B, aa, and bb are constants, T is temperature [K] and \f$\lambda\f$ is + !! wavelength [nm]. + type, extends(temperature_parameterization_t) :: temperature_parameterization_burkholder_t + real(kind=dk) :: A_ + real(kind=dk) :: B_ + contains + !> Calculate the cross section value for a specific temperature and wavelength + procedure :: calculate + !> Returns the number of bytes required to pack the parameterization + !! onto a character buffer + procedure :: pack_size => pack_size + !> Packs the parameterization onto a character buffer + procedure :: mpi_pack => mpi_pack + !> Unpacks the parameterization from a character buffer + procedure :: mpi_unpack => mpi_unpack + end type temperature_parameterization_burkholder_t + + !> Constructor for temperature_parameterization_burkholder_t + interface temperature_parameterization_burkholder_t + module procedure :: constructor + end interface temperature_parameterization_burkholder_t + +contains + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Constructs a Burkholder (2002) temperature-based parameterization + function constructor( config ) result ( this ) + + use musica_assert, only : assert_msg + use musica_config, only : config_t + use musica_iterator, only : iterator_t + use musica_string, only : string_t + use tuvx_grid, only : grid_t + use tuvx_netcdf, only : netcdf_t + + type(temperature_parameterization_burkholder_t) :: this + type(config_t), intent(inout) :: config + + character(len=*), parameter :: my_name = & + "Burkholder (2002) temperature parameterization constructor" + type(string_t) :: required_keys(3), optional_keys(4), file_path + type(config_t) :: temp_ranges, temp_range, netcdf_file + class(iterator_t), pointer :: iter + type(netcdf_t) :: netcdf + integer :: i_range, i_param, n_param + logical :: found + + required_keys(1) = "netcdf file" + required_keys(2) = "A" + required_keys(3) = "B" + optional_keys(1) = "type" + optional_keys(2) = "temperature ranges" + optional_keys(3) = "minimum wavelength" + optional_keys(4) = "maximum wavelength" + call assert_msg( 235183546, & + config%validate( required_keys, optional_keys ), & + "Bad configuration for Burkholder (2002) temperature "// & + "parameterization." ) + + ! Load NetCDF file + call config%get( "netcdf file", netcdf_file, my_name ) + call netcdf_file%get( "file path", file_path, my_name ) + call netcdf%read_netcdf_file( file_path = file_path%to_char( ), & + variable_name = "temperature_" ) + n_param = size( netcdf%parameters, dim = 2 ) + call assert_msg( 164185428, n_param >= 2, "Burkholder (2002) "// & + "parameterization must have at two sets of "// & + "coefficients" ) + + call config%get( "minimum wavelength", this%min_wavelength_, my_name, & + default = netcdf%wavelength(1) ) + call config%get( "maximum wavelength", this%max_wavelength_, my_name, & + default = netcdf%wavelength( size( netcdf%wavelength ) ) ) + this%min_wavelength_ = max( this%min_wavelength_, netcdf%wavelength(1) ) + this%max_wavelength_ = min( this%max_wavelength_, & + netcdf%wavelength( size( netcdf%wavelength ) ) ) + call assert_msg( 856954069, this%min_wavelength_ < this%max_wavelength_, & + "Invalid wavelength range for Burkholder temperature "// & + "parameterization" ) + + ! Load parameters + call config%get( "A", this%A_, my_name ) + call config%get( "B", this%B_, my_name ) + this%wavelengths_ = netcdf%wavelength(:) + this%AA_ = netcdf%parameters(:,1) + this%BB_ = netcdf%parameters(:,2) + call config%get( "temperature ranges", temp_ranges, my_name, & + found = found ) + if( .not. found ) then + allocate( this%ranges_( 1 ) ) + return + end if + allocate( this%ranges_( temp_ranges%number_of_children( ) ) ) + iter => temp_ranges%get_iterator( ) + i_range = 0 + do while( iter%next( ) ) + i_range = i_range + 1 + call temp_ranges%get( iter, temp_range, my_name ) + this%ranges_( i_range ) = temperature_range_t( temp_range ) + end do + deallocate( iter ) + + ! initialize unused data members + allocate( this%lp_(0) ) + + end function constructor + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine calculate( this, temperature, wavelengths, cross_section ) + + use tuvx_profile, only : profile_t + + class(temperature_parameterization_burkholder_t), intent(in) :: this + real(kind=dk), intent(in) :: temperature + real(kind=dk), intent(in) :: wavelengths(:) + real(kind=dk), intent(inout) :: cross_section(:) + + real(kind=dk) :: temp, Q + integer :: i_range, w_min, w_max + + w_min = this%min_wavelength_index_ + w_max = this%max_wavelength_index_ + do i_range = 1, size( this%ranges_ ) + associate( temp_range => this%ranges_( i_range ) ) + if( temperature < temp_range%min_temperature_ .or. & + temperature > temp_range%max_temperature_ ) cycle + if( temp_range%is_fixed_ ) then + temp = temp_range%fixed_temperature_ - this%base_temperature_ + else + temp = temperature - this%base_temperature_ + end if + Q = 1.0_dk + exp( this%A_ / ( this%B_ * temp ) ) + cross_section( w_min:w_max ) = ( this%AA_(:) / Q + & + this%BB_(:) * ( 1.0_dk - 1.0_dk / Q ) & + ) * 1.0e-20_dk + end associate + end do + + end subroutine calculate + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Returns the size of a character buffer required to pack the + !! parameterization + integer function pack_size( this, comm ) + + use musica_mpi, only : musica_mpi_pack_size + + !> Parameterization to be packed + class(temperature_parameterization_burkholder_t), intent(in) :: this + !> MPI communicator + integer, intent(in) :: comm + +#ifdef MUSICA_USE_MPI + pack_size = this%temperature_parameterization_t%pack_size( comm ) + & + musica_mpi_pack_size( this%A_, comm ) + & + musica_mpi_pack_size( this%B_, comm ) +#else + pack_size = 0 +#endif + + end function pack_size + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Packs the parameterization onto a character buffer + subroutine mpi_pack( this, buffer, position, comm ) + + use musica_assert, only : assert + use musica_mpi, only : musica_mpi_pack + + !> Parameterization to be packed + class(temperature_parameterization_burkholder_t), intent(in) :: this + !> Memory buffer + character, intent(inout) :: buffer(:) + !> Current buffer position + integer, intent(inout) :: position + !> MPI communicator + integer, intent(in) :: comm + +#ifdef MUSICA_USE_MPI + integer :: prev_pos + + prev_pos = position + call this%temperature_parameterization_t%mpi_pack( buffer, position, comm ) + call musica_mpi_pack( buffer, position, this%A_, comm ) + call musica_mpi_pack( buffer, position, this%B_, comm ) + call assert( 190816083, position - prev_pos <= this%pack_size( comm ) ) +#endif + + end subroutine mpi_pack + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Unpacks a parameterization from a character buffer + subroutine mpi_unpack( this, buffer, position, comm ) + + use musica_assert, only : assert + use musica_mpi, only : musica_mpi_unpack + + !> The parameterization to be unpacked + class(temperature_parameterization_burkholder_t), intent(out) :: this + !> Memory buffer + character, intent(inout) :: buffer(:) + !> Current buffer position + integer, intent(inout) :: position + !> MPI communicator + integer, intent(in) :: comm + +#ifdef MUSICA_USE_MPI + integer :: prev_pos + + prev_pos = position + call this%temperature_parameterization_t%mpi_unpack( buffer, position, comm ) + call musica_mpi_unpack( buffer, position, this%A_, comm ) + call musica_mpi_unpack( buffer, position, this%B_, comm ) + call assert( 634825156, position - prev_pos <= this%pack_size( comm ) ) +#endif + + end subroutine mpi_unpack + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +end module tuvx_temperature_parameterization_burkholder \ No newline at end of file diff --git a/src/cross_sections/util/temperature_parameterization_harwood.F90 b/src/cross_sections/util/temperature_parameterization_harwood.F90 new file mode 100644 index 00000000..877885a7 --- /dev/null +++ b/src/cross_sections/util/temperature_parameterization_harwood.F90 @@ -0,0 +1,195 @@ +! Copyright (C) 2024 National Center for Atmospheric Research +! SPDX-License-Identifier: Apache-2.0 + +module tuvx_temperature_parameterization_harwood +! Calculates cross-section elements using a temperature-based +! parameterization. TODO: need reference + + use musica_config, only : config_t + use musica_constants, only : dk => musica_dk + use tuvx_temperature_parameterization, & + only : temperature_parameterization_t + use tuvx_temperature_range, only : temperature_range_t + + implicit none + + private + public :: temperature_parameterization_harwood_t + + !> Parameterization for calculating cross section values + !! TODO: need reference + !! + !! Cross section elements are calculated as: + !! + !! \f[ + !! \sigma(T,\lambda_i) = 10^{\(aa_i + bb_i / T\)} + !! \f] + !! + !! where aa_i and bb_i are constants, T is temperature [K], and + !! \f$\lambda_i\f$ is wavelength [nm]. The size of the aa and bb + !! arrays must equal the number of wavelengths in the parameterization + !! range. + type, extends(temperature_parameterization_t) :: temperature_parameterization_harwood_t + contains + !> Calculate the cross section value for a specific temperature and wavelength + procedure :: calculate + end type temperature_parameterization_harwood_t + + !> Constructor for temperature_parameterization_harwood_t + interface temperature_parameterization_harwood_t + module procedure :: constructor + end interface temperature_parameterization_harwood_t + +contains + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Constructs a Harwood (TODO: need ref) temperature-based parameterization + function constructor( config, wavelengths ) result( this ) + + use musica_assert, only : assert_msg, die_msg + use musica_config, only : config_t + use musica_iterator, only : iterator_t + use musica_string, only : string_t, to_char + use tuvx_grid, only : grid_t + + type(temperature_parameterization_harwood_t) :: this + type(config_t), intent(inout) :: config + class(grid_t), intent(in) :: wavelengths + + character(len=*), parameter :: my_name = & + "Harwood temperature parameterization" + type(string_t) :: required_keys(5), optional_keys(5), exp_base + type(config_t) :: temp_ranges, temp_range + class(iterator_t), pointer :: iter + integer :: i_range, i_param, n_param, n_wl + logical :: found + + required_keys(1) = "aa" + required_keys(2) = "bb" + required_keys(3) = "base temperature" + required_keys(4) = "base wavelength" + required_keys(5) = "logarithm" + optional_keys(1) = "type" + optional_keys(2) = "minimum wavelength" + optional_keys(3) = "maximum wavelength" + optional_keys(4) = "temperature ranges" + optional_keys(5) = "invert temperature offset" + call assert_msg( 581965121, & + config%validate( required_keys, optional_keys ), & + "Bad configuration for Harwood temperature "// & + "parameterization." ) + call config%get( "aa", this%aa_, my_name ) + call config%get( "bb", this%bb_, my_name ) + call config%get( "base temperature", this%base_temperature_, my_name ) + call config%get( "base wavelength", this%base_wavelength_, my_name ) + call config%get( "logarithm", exp_base, my_name ) + + call config%get( "invert temperature offset", & + this%is_temperature_inverted_, my_name, default = .false.) + if( exp_base == "base 10" ) then + this%is_base_10_ = .true. + else if( exp_base == "natural" ) then + this%is_base_10_ = .false. + else + call die_msg( 768514789, "Invalid logarithm type in Harwood "// & + "temperature-based cross section: '"// & + exp_base//"'" ) + end if + call config%get( "minimum wavelength", this%min_wavelength_, my_name, & + default = 0.0_dk ) + call config%get( "maximum wavelength", this%max_wavelength_, my_name, & + default = huge(1.0_dk) ) + this%min_wavelength_index_ = 1 + do while( wavelengths%mid_( this%min_wavelength_index_ ) & + < this%min_wavelength_ & + .and. this%min_wavelength_index_ <= wavelengths%ncells_ ) + this%min_wavelength_index_ = this%min_wavelength_index_ + 1 + end do + call assert_msg( 654743205, & + wavelengths%mid_( this%min_wavelength_index_ ) & + >= this%min_wavelength_, & + "Minimum wavelength for Harawood temperature-based cross "// & + "section is outside the bounds of the wavelength grid." ) + this%max_wavelength_index_ = wavelengths%ncells_ + do while( wavelengths%mid_( this%max_wavelength_index_ ) & + > this%max_wavelength_ & + .and. this%max_wavelength_index_ >= 1 ) + this%max_wavelength_index_ = this%max_wavelength_index_ - 1 + end do + call assert_msg( 309165090, & + wavelengths%mid_( this%max_wavelength_index_ ) & + <= this%max_wavelength_, & + "Maximum wavelength for Harwood temperature-based cross "// & + "section is outside the bounds of the wavelength grid." ) + ! TODO This follows logic from original TUV, but perhaps should + ! be modified to assign TUV-x wavelength edges + this%wavelengths_ = wavelengths%mid_( this%min_wavelength_index_ : & + this%max_wavelength_index_ ) + call assert_msg( 760344004, size( this%aa_ ) .eq. size( this%bb_ ), & + "Parameter arrays for Harwood temperature-based cross "//& + "section (aa and bb) must be of the same size." ) + n_param = size( this%aa_ ) + n_wl = this%max_wavelength_index_ - this%min_wavelength_index_ + 1 + call assert_msg( 641308113, n_param .eq. n_wl, & + "Parameter arrays for Harwood temperature-based cross "//& + "section (aa and bb) must be the same size as the "// & + "parameterized portion of the wavelength grid. "// & + "Expected "//trim( to_char( n_wl ) )//" but got "// & + trim( to_char( n_param ) )//"." ) + call config%get( "temperature ranges", temp_ranges, my_name, & + found = found ) + if( .not. found ) then + allocate( this%ranges_( 1 ) ) + return + end if + allocate( this%ranges_( temp_ranges%number_of_children( ) ) ) + iter => temp_ranges%get_iterator( ) + i_range = 0 + do while( iter%next( ) ) + i_range = i_range + 1 + call temp_ranges%get( iter, temp_range, my_name ) + this%ranges_( i_range ) = temperature_range_t( temp_range ) + end do + deallocate( iter ) + allocate( this%lp_( 0 ) ) + + end function constructor + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine calculate( this, temperature, wavelengths, cross_section ) + + use tuvx_profile, only : profile_t + + class(temperature_parameterization_harwood_t), intent(in) :: this + real(kind=dk), intent(in) :: temperature + real(kind=dk), intent(in) :: wavelengths(:) + real(kind=dk), intent(inout) :: cross_section(:) + + real(kind=dk) :: temp + integer :: i_range, i_wl, w_min, w_max + + w_min = this%min_wavelength_index_ + w_max = this%max_wavelength_index_ + do i_range = 1, size( this%ranges_ ) + associate( temp_range => this%ranges_( i_range ) ) + if( temperature < temp_range%min_temperature_ .or. & + temperature > temp_range%max_temperature_ ) cycle + if( temp_range%is_fixed_ ) then + temp = temp_range%fixed_temperature_ - this%base_temperature_ + else + temp = temperature - this%base_temperature_ + end if + do i_wl = 1, w_max - w_min + 1 + cross_section( w_min + i_wl - 1 ) = & + 10.0d0**( this%aa_( i_wl ) + this%bb_( i_wl ) / temp ) + end do + end associate + end do + + end subroutine calculate + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +end module tuvx_temperature_parameterization_harwood \ No newline at end of file diff --git a/src/cross_sections/util/temperature_parameterization_taylor_series.F90 b/src/cross_sections/util/temperature_parameterization_taylor_series.F90 new file mode 100644 index 00000000..8003af83 --- /dev/null +++ b/src/cross_sections/util/temperature_parameterization_taylor_series.F90 @@ -0,0 +1,273 @@ +! Copyright (C) 2020-4 National Center for Atmospheric Research +! SPDX-License-Identifier: Apache-2.0 + +module tuvx_temperature_parameterization_taylor_series +! Calculates cross-section elements using a Taylor-series temperature-based +! parameterization + + ! Including musica_config at the module level to avoid an ICE + ! with Intel 2022.1 compiler + use musica_config, only : config_t + use musica_constants, only : dk => musica_dk + use tuvx_temperature_parameterization, & + only : temperature_parameterization_t + use tuvx_temperature_range, only : temperature_range_t + + implicit none + + private + public :: temperature_parameterization_taylor_series_t + + !> Parameters for calculating cross section values based on + !! temperature using a Taylor series + !! + !! Cross section elements are calculated as: + !! + !! \f[ + !! \sigma(T_{base}) * \[ 1.0 + A_1 * (T - T_{base}) + A_2 * (T - T_{base})^2 \] + !! \f] + !! + !! where \f$\sigma\f$ is a reference cross section at temperature [K] + !! \f$T_{base}\f$, \f$A_1\f$ and \f$A_2\f$ are fitting parameters, and + !! \f$T\f$ is temperature [K]. + type, extends(temperature_parameterization_t) :: temperature_parameterization_taylor_series_t + !> Base cross section element + real(kind=dk), allocatable :: sigma_(:) + !> Taylor-series coefficients A_n (n,wavelength) + real(kind=dk), allocatable :: A_(:,:) + contains + !> Calculate the cross section value for a specific temperature and wavelength + procedure :: calculate + !> Returns the number of bytes required to pack the parameterization + !! onto a character buffer + procedure :: pack_size => pack_size + !> Packs the parameterization onto a character buffer + procedure :: mpi_pack => mpi_pack + !> Unpacks the parameterization from a character buffer + procedure :: mpi_unpack => mpi_unpack + end type temperature_parameterization_taylor_series_t + + !> Constructor for temperature_parameterization_taylor_series_t + interface temperature_parameterization_taylor_series_t + module procedure :: constructor + end interface temperature_parameterization_taylor_series_t + +contains + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Constructs a Taylor-series temperature-based parameterization + function constructor( config ) result ( this ) + + use musica_assert, only : assert_msg + use musica_config, only : config_t + use musica_iterator, only : iterator_t + use musica_string, only : string_t + use tuvx_grid, only : grid_t + use tuvx_netcdf, only : netcdf_t + + type(temperature_parameterization_taylor_series_t) :: this + type(config_t), intent(inout) :: config + + character(len=*), parameter :: my_name = & + "Taylor-series temperature parameterization constructor" + type(string_t) :: required_keys(2), optional_keys(4), file_path + type(config_t) :: temp_ranges, temp_range, netcdf_file + class(iterator_t), pointer :: iter + type(netcdf_t) :: netcdf + integer :: i_range, i_param, n_param, i_min_wl, i_max_wl + logical :: found + + required_keys(1) = "netcdf file" + required_keys(2) = "base temperature" + optional_keys(1) = "minimum wavelength" + optional_keys(2) = "maximum wavelength" + optional_keys(3) = "temperature ranges" + optional_keys(4) = "type" + call assert_msg( 235183546, & + config%validate( required_keys, optional_keys ), & + "Bad configuration for temperature parameterization." ) + + ! Load NetCDF file + call config%get( "netcdf file", netcdf_file, my_name ) + call netcdf_file%get( "file path", file_path, my_name ) + call netcdf%read_netcdf_file( file_path = file_path%to_char( ), & + variable_name = "temperature_" ) + n_param = size( netcdf%parameters, dim = 2 ) - 1 + call assert_msg( 164185428, n_param >= 1, "Taylor-series temperature "// & + "parameterization must have at least one set of "// & + "coefficients" ) + + ! Load parameters + call config%get( "base temperature", this%base_temperature_, my_name ) + call config%get( "minimum wavelength", this%min_wavelength_, my_name, & + default = 0.0_dk ) + call config%get( "maximum wavelength", this%max_wavelength_, my_name, & + default = huge( 1.0_dk ) ) + i_min_wl = 1 + do while( netcdf%wavelength( i_min_wl ) < this%min_wavelength_ & + .and. i_min_wl <= size( netcdf%wavelength ) ) + i_min_wl = i_min_wl + 1 + end do + call assert_msg( 504874740, & + netcdf%wavelength( i_min_wl ) >= this%min_wavelength_, & + "Minimum wavelength for Taylor-series temperature-based cross "//& + "section is outside the bounds of the wavelength grid." ) + i_max_wl = size( netcdf%wavelength ) + do while( netcdf%wavelength( i_max_wl ) > this%max_wavelength_ & + .and. i_max_wl >= 1 ) + i_max_wl = i_max_wl - 1 + end do + call assert_msg( 587703546, & + netcdf%wavelength( i_max_wl ) <= this%max_wavelength_, & + "Maximum wavelength for Taylor-series temperature-based cross "//& + "section is outside the bounds of the wavelength grid." ) + allocate( this%A_( n_param, i_max_wl - i_min_wl + 1 ) ) + this%wavelengths_ = netcdf%wavelength( i_min_wl:i_max_wl ) + this%sigma_ = netcdf%parameters( i_min_wl:i_max_wl, 1 ) + do i_param = 1, n_param + this%A_( i_param, : ) = & + netcdf%parameters( i_min_wl:i_max_wl , i_param + 1 ) + end do + call config%get( "temperature ranges", temp_ranges, my_name, & + found = found ) + if( .not. found ) then + allocate( this%ranges_( 1 ) ) + return + end if + allocate( this%ranges_( temp_ranges%number_of_children( ) ) ) + iter => temp_ranges%get_iterator( ) + i_range = 0 + do while( iter%next( ) ) + i_range = i_range + 1 + call temp_ranges%get( iter, temp_range, my_name ) + this%ranges_( i_range ) = temperature_range_t( temp_range ) + end do + deallocate( iter ) + + ! initialize unused data members + allocate( this%AA_(0) ) + allocate( this%BB_(0) ) + allocate( this%lp_(0) ) + + end function constructor + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine calculate( this, temperature, wavelengths, cross_section ) + + use tuvx_profile, only : profile_t + + class(temperature_parameterization_taylor_series_t), intent(in) :: this + real(kind=dk), intent(in) :: temperature + real(kind=dk), intent(in) :: wavelengths(:) + real(kind=dk), intent(inout) :: cross_section(:) + + real(kind=dk) :: temp, temp_xs( size( this%wavelengths_ ) ) + integer :: i_A, i_range, w_min, w_max + + w_min = this%min_wavelength_index_ + w_max = this%max_wavelength_index_ + do i_range = 1, size( this%ranges_ ) + associate( temp_range => this%ranges_( i_range ) ) + if( temperature < temp_range%min_temperature_ .or. & + temperature > temp_range%max_temperature_ ) cycle + if( temp_range%is_fixed_ ) then + temp = temp_range%fixed_temperature_ - this%base_temperature_ + else + temp = temperature - this%base_temperature_ + end if + temp_xs(:) = 1.0 + do i_A = 1, size( this%A_, dim = 1 ) + temp_xs(:) = temp_xs(:) + this%A_(i_A,:) * temp**i_A + end do + cross_section( w_min:w_max ) = temp_xs(:) * this%sigma_(:) + end associate + end do + + end subroutine calculate + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Returns the size of a character buffer required to pack the + !! parameterization + integer function pack_size( this, comm ) + + use musica_mpi, only : musica_mpi_pack_size + + !> Parameterization to be packed + class(temperature_parameterization_taylor_series_t), intent(in) :: this + !> MPI communicator + integer, intent(in) :: comm + +#ifdef MUSICA_USE_MPI + pack_size = this%temperature_parameterization_t%pack_size( comm ) + & + musica_mpi_pack_size( this%sigma_, comm ) + & + musica_mpi_pack_size( this%A_, comm ) +#else + pack_size = 0 +#endif + + end function pack_size + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Packs the parameterization onto a character buffer + subroutine mpi_pack( this, buffer, position, comm ) + + use musica_assert, only : assert + use musica_mpi, only : musica_mpi_pack + + !> Parameterization to be packed + class(temperature_parameterization_taylor_series_t), intent(in) :: this + !> Memory buffer + character, intent(inout) :: buffer(:) + !> Current buffer position + integer, intent(inout) :: position + !> MPI communicator + integer, intent(in) :: comm + +#ifdef MUSICA_USE_MPI + integer :: prev_pos + + prev_pos = position + call this%temperature_parameterization_t%mpi_pack( buffer, position, comm ) + call musica_mpi_pack( buffer, position, this%sigma_, comm ) + call musica_mpi_pack( buffer, position, this%A_, comm ) + call assert( 342538714, position - prev_pos <= this%pack_size( comm ) ) +#endif + + end subroutine mpi_pack + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Unpacks a parameterization from a character buffer + subroutine mpi_unpack( this, buffer, position, comm ) + + use musica_assert, only : assert + use musica_mpi, only : musica_mpi_unpack + + !> The parameterization to be unpacked + class(temperature_parameterization_taylor_series_t), intent(out) :: this + !> Memory buffer + character, intent(inout) :: buffer(:) + !> Current buffer position + integer, intent(inout) :: position + !> MPI communicator + integer, intent(in) :: comm + +#ifdef MUSICA_USE_MPI + integer :: prev_pos + + prev_pos = position + call this%temperature_parameterization_t%mpi_unpack( buffer, position, comm ) + call musica_mpi_unpack( buffer, position, this%sigma_, comm ) + call musica_mpi_unpack( buffer, position, this%A_, comm ) + call assert( 966515884, position - prev_pos <= this%pack_size( comm ) ) +#endif + + end subroutine mpi_unpack + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +end module tuvx_temperature_parameterization_taylor_series \ No newline at end of file diff --git a/src/cross_sections/util/temperature_range.F90 b/src/cross_sections/util/temperature_range.F90 new file mode 100644 index 00000000..19dbdaf0 --- /dev/null +++ b/src/cross_sections/util/temperature_range.F90 @@ -0,0 +1,158 @@ +! Copyright (C) 2020-4 National Center for Atmospheric Research +! SPDX-License-Identifier: Apache-2.0 + +module tuvx_temperature_range +! Defines a temperature range for use in temperature-based cross +! section parameterizations + + ! Including musica_config at the module level to avoid an ICE + ! with Intel 2022.1 compiler + use musica_config, only : config_t + use musica_constants, only : dk => musica_dk + + implicit none + + private + public :: temperature_range_t + + + !> Range for temperature-based calculations + type :: temperature_range_t + !> Minimum temperature [K] for inclusion in range + real(kind=dk) :: min_temperature_ = 0.0_dk + !> Maximum temperature [K] for include in range + real(kind=dk) :: max_temperature_ = huge(1.0_dk) + !> Indicates whether to use a fixed temperature for the + !! parameterization calculation. If FALSE, the actual + !! temperature is used. + logical :: is_fixed_ = .false. + !> Fixed temperature [K] to use in paramterization calculation + !! + !! Is only used if is_fixed == TRUE + real(kind=dk) :: fixed_temperature_ = 0.0_dk + contains + !> Returns the number of bytes required to pack the range onto a + !! character buffer + procedure :: pack_size => pack_size + !> Packs the range onto a character buffer + procedure :: mpi_pack => mpi_pack + !> Unpacks a range from a character buffer + procedure :: mpi_unpack => mpi_unpack + end type temperature_range_t + + !> Constructor for temperature_range_t + interface temperature_range_t + module procedure :: constructor + end interface temperature_range_t + +contains + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + function constructor( config ) result( this ) + ! Constructs temperature range objects + + use musica_assert, only : assert_msg + use musica_config, only : config_t + use musica_string, only : string_t + + type(temperature_range_t) :: this + type(config_t), intent(inout) :: config + + character(len=*), parameter :: my_name = "temperature range constructor" + type(string_t) :: required_keys(0), optional_keys(3) + logical :: found + + optional_keys(1) = "minimum" + optional_keys(2) = "maximum" + optional_keys(3) = "fixed value" + call assert_msg( 355912601, & + config%validate( required_keys, optional_keys ), & + "Bad configuration for temperature range" ) + + call config%get( "minimum", this%min_temperature_, my_name, & + default = 0.0_dk ) + call config%get( "maximum", this%max_temperature_, my_name, & + default = huge(1.0_dk) ) + call config%get( "fixed value", this%fixed_temperature_, my_name, & + found = found ) + this%is_fixed_ = found + + end function constructor + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + integer function pack_size( this, comm ) + ! Returns the size of a character buffer required to pack the range + + use musica_mpi, only : musica_mpi_pack_size + + class(temperature_range_t), intent(in) :: this ! temperature range to be packed + integer, intent(in) :: comm ! MPI communicator + +#ifdef MUSICA_USE_MPI + pack_size = musica_mpi_pack_size( this%min_temperature_, comm ) + & + musica_mpi_pack_size( this%max_temperature_, comm ) + & + musica_mpi_pack_size( this%is_fixed_, comm ) + & + musica_mpi_pack_size( this%fixed_temperature_, comm ) +#else + pack_size = 0 +#endif + + end function pack_size + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine mpi_pack( this, buffer, position, comm ) + ! Packs the temperature range onto a character buffer + + use musica_assert, only : assert + use musica_mpi, only : musica_mpi_pack + + class(temperature_range_t), intent(in) :: this ! temperature range to be packed + character, intent(inout) :: buffer(:) ! memory buffer + integer, intent(inout) :: position ! current buffer position + integer, intent(in) :: comm ! MPI communicator + +#ifdef MUSICA_USE_MPI + integer :: prev_pos + + prev_pos = position + call musica_mpi_pack( buffer, position, this%min_temperature_, comm ) + call musica_mpi_pack( buffer, position, this%max_temperature_, comm ) + call musica_mpi_pack( buffer, position, this%is_fixed_, comm ) + call musica_mpi_pack( buffer, position, this%fixed_temperature_, comm ) + call assert( 409699380, position - prev_pos <= this%pack_size( comm ) ) +#endif + + end subroutine mpi_pack + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine mpi_unpack( this, buffer, position, comm ) + ! Unpacks a temperature range from a character buffer + + use musica_assert, only : assert + use musica_mpi, only : musica_mpi_unpack + + class(temperature_range_t), intent(out) :: this ! temperature range to be unpacked + character, intent(inout) :: buffer(:) ! memory buffer + integer, intent(inout) :: position ! current buffer position + integer, intent(in) :: comm ! MPI communicator + +#ifdef MUSICA_USE_MPI + integer :: prev_pos + + prev_pos = position + call musica_mpi_unpack( buffer, position, this%min_temperature_, comm ) + call musica_mpi_unpack( buffer, position, this%max_temperature_, comm ) + call musica_mpi_unpack( buffer, position, this%is_fixed_, comm ) + call musica_mpi_unpack( buffer, position, this%fixed_temperature_, comm ) + call assert( 164457757, position - prev_pos <= this%pack_size( comm ) ) +#endif + + end subroutine mpi_unpack + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +end module tuvx_temperature_range \ No newline at end of file diff --git a/src/grid_warehouse.F90 b/src/grid_warehouse.F90 index 04f68d8f..fa14251b 100644 --- a/src/grid_warehouse.F90 +++ b/src/grid_warehouse.F90 @@ -152,10 +152,10 @@ function get_grid_string( this, name, units ) result( a_grid_ptr ) use musica_string, only : string_t use tuvx_grid, only : grid_t - class(grid_warehouse_t), intent(inout) :: this ! This :f:type:`~tuvx_grid_warehouse/grid_warehouse_t` - type(string_t), intent(in) :: name ! The name of a grid, see :ref:`configuration-grids` for grid names - type(string_t), intent(in) :: units ! The units of the grid - class(grid_t), pointer :: a_grid_ptr ! The :f:type:`~tuvx_grid/grid_t` which matches the name passed in + class(grid_warehouse_t), intent(in) :: this ! This :f:type:`~tuvx_grid_warehouse/grid_warehouse_t` + type(string_t), intent(in) :: name ! The name of a grid, see :ref:`configuration-grids` for grid names + type(string_t), intent(in) :: units ! The units of the grid + class(grid_t), pointer :: a_grid_ptr ! The :f:type:`~tuvx_grid/grid_t` which matches the name passed in a_grid_ptr => this%get_grid_char( name%to_char( ), units%to_char( ) ) @@ -169,9 +169,9 @@ function get_grid_ptr( this, ptr ) result( grid ) use musica_assert, only : assert_msg use tuvx_grid, only : grid_t - class(grid_warehouse_t), intent(inout) :: this ! This grid warehouse - type(grid_warehouse_ptr), intent(in) :: ptr ! Pointer to a grid in the warehouse - class(grid_t), pointer :: grid + class(grid_warehouse_t), intent(in) :: this ! This grid warehouse + type(grid_warehouse_ptr), intent(in) :: ptr ! Pointer to a grid in the warehouse + class(grid_t), pointer :: grid call assert_msg( 870082797, ptr%index_ > 0, "Invalid grid pointer" ) allocate( grid, source = this%grids_( ptr%index_ )%val_ ) diff --git a/src/heating_rates.F90 b/src/heating_rates.F90 new file mode 100644 index 00000000..5ee76c16 --- /dev/null +++ b/src/heating_rates.F90 @@ -0,0 +1,584 @@ +! Copyright (C) 2024 National Center for Atmospheric Research +! SPDX-License-Identifier: Apache-2.0 +! +module tuvx_heating_rates + ! The chemical potential heating rates type heating_rates_t and related functions + + use musica_assert, only : assert, assert_msg + use musica_config, only : config_t + use musica_constants, only : dk => musica_dk + use musica_iterator, only : iterator_t + use musica_mpi, only : musica_mpi_pack, musica_mpi_pack_size, musica_mpi_unpack + use musica_string, only : string_t + use tuvx_constants, only : hc + use tuvx_cross_section, only : cross_section_ptr + use tuvx_cross_section_factory, only : cross_section_allocate, cross_section_builder, cross_section_type_name + use tuvx_grid, only : grid_t + use tuvx_grid_warehouse, only : grid_warehouse_ptr, grid_warehouse_t + use tuvx_la_sr_bands, only : la_sr_bands_t + use tuvx_profile, only : profile_t + use tuvx_profile_warehouse, only : profile_warehouse_ptr, profile_warehouse_t + use tuvx_quantum_yield, only : quantum_yield_ptr + use tuvx_quantum_yield_factory, only : quantum_yield_allocate, quantum_yield_builder, quantum_yield_type_name + use tuvx_solver, only : radiation_field_t + use tuvx_spherical_geometry, only : spherical_geometry_t + + implicit none + + private + public :: heating_rates_t + + type :: heating_parameters_t + ! Heating parameters for a single photolyzing species + type(string_t) :: label_ ! label for the heating rate + type(cross_section_ptr) :: cross_section_ ! cross section + type(quantum_yield_ptr) :: quantum_yield_ ! quantum yield + real(kind=dk) :: scaling_factor_ ! scaling factor for the heating rate + real(kind=dk), allocatable :: energy_(:) ! wavelength resolved bond-dissociation energy [J] + contains + !> Returns the size of a character buffer needed to pack the heating parameters + procedure :: pack_size => heating_parameters_pack_size + !> Packs the heating parameters into a character buffer + procedure :: mpi_pack => heating_parameters_mpi_pack + !> Unpacks the heating parameters from a character buffer + procedure :: mpi_unpack => heating_parameters_mpi_unpack + end type heating_parameters_t + + !> heating_parameters_t constructor + interface heating_parameters_t + module procedure :: heating_parameters_constructor + end interface heating_parameters_t + + type, public :: heating_rates_t + type(heating_parameters_t), allocatable :: heating_parameters_(:) ! heating parameters for each photolyzing species + type(grid_warehouse_ptr) :: height_grid_ ! height grid + type(grid_warehouse_ptr) :: wavelength_grid_ ! wavelength grid + type(profile_warehouse_ptr) :: etfl_profile_ ! Extraterrestrial flux profile + type(profile_warehouse_ptr) :: air_profile_ ! Air profile + integer, allocatable :: o2_rate_indices_(:) ! indices in the heating rates array where O2 + ! corrections to the cross-section in the + ! Lyman-Alpha and Schumann-Runge bands should + ! be applied + contains + !> Calulates the heating rates + procedure :: get + !> Returns the names of each photolysis reaction with a heating rate + procedure :: labels + !> Returns the number of heating rates + procedure :: size => get_number + !> Returns the size of a character buffer needed to pack the heating rates + procedure :: pack_size + !> Packs the heating rates into a character buffer + procedure :: mpi_pack + !> Unpacks the heating rates from a character buffer + procedure :: mpi_unpack + !> Cleans up memory + final :: destructor + end type heating_rates_t + + !> heating_rates_t constructor + interface heating_rates_t + module procedure :: constructor + end interface heating_rates_t + +contains +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> heating_rates_t constructor + function constructor( config, grids, profiles ) result( this ) + + + !> Heating rate collection + type(heating_rates_t), pointer :: this + !> Configuration + type(config_t), intent(inout) :: config + !> Grids + type(grid_warehouse_t), intent(inout) :: grids + !> Profiles + type(profile_warehouse_t), intent(inout) :: profiles + + character(len=*), parameter :: Iam = 'heating rates constructor' + type(config_t) :: reaction_set, reaction_config, heating_config + class(iterator_t), pointer :: iter + type(string_t) :: label + type(string_t) :: required_keys(1), optional_keys(1) + logical :: found, do_apply_bands + integer :: n_hr, i_hr, n_O2, i_O2 + + required_keys(1) = "reactions" + optional_keys(1) = "enable diagnostics" + + call assert_msg( 310567326, & + config%validate( required_keys, optional_keys ), & + "Invalid configuration for heating rates" ) + + allocate( this ) + this%height_grid_ = grids%get_ptr( "height", "km" ) + this%wavelength_grid_ = grids%get_ptr( "wavelength", "nm" ) + this%etfl_profile_ = profiles%get_ptr( "extraterrestrial flux", & + "photon cm-2 s-1" ) + this%air_profile_ = profiles%get_ptr( "air", "molecule cm-3" ) + + ! iterate over photolysis reactions looking for those with + ! heating rate parameters + allocate( this%o2_rate_indices_( 0 ) ) + call config%get( "reactions", reaction_set, Iam ) + iter => reaction_set%get_iterator( ) + n_hr = 0 + n_O2 = 0 + do while( iter%next( ) ) + call reaction_set%get( iter, reaction_config, Iam ) + call reaction_config%get( "heating", heating_config, Iam, found = found ) + if( found ) then + n_hr = n_hr + 1 + call reaction_config%get( "apply O2 bands", do_apply_bands, Iam, & + default = .false. ) + if( do_apply_bands ) n_O2 = n_O2 + 1 + end if + end do + allocate( this%heating_parameters_( n_hr ) ) + call iter%reset( ) + i_hr = 0 + i_O2 = 0 + do while( iter%next( ) ) + call reaction_set%get( iter, reaction_config, Iam ) + call reaction_config%get( "heating", heating_config, Iam, found = found ) + if( found ) then + i_hr = i_hr + 1 + call reaction_config%get( "name", label, Iam ) + this%heating_parameters_( i_hr ) = & + heating_parameters_constructor( reaction_config, grids, profiles ) + call reaction_config%get( "apply O2 bands", do_apply_bands, Iam, & + default = .false. ) + if( do_apply_bands ) then + i_O2 = i_O2 + 1 + this%o2_rate_indices_( i_O2 ) = i_hr + end if + end if + end do + call assert( 357615745, i_hr .eq. n_hr ) + call assert( 336635308, i_O2 .eq. n_O2 ) + deallocate( iter ) + + end function constructor + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> heating_parameters_t constructor + function heating_parameters_constructor( config, grids, profiles ) & + result( this ) + + + !> Heating parameters for a single photolyzing species + type(heating_parameters_t) :: this + !> Configuration for the photolysis reaction + type(config_t), intent(inout) :: config + !> Grids + type(grid_warehouse_t), intent(inout) :: grids + !> Profiles + type(profile_warehouse_t), intent(inout) :: profiles + + character(len=*), parameter :: Iam = 'heating parameters constructor' + type(config_t) :: heating_config, cs_config, qy_config + class(grid_t), pointer :: wavelengths + real(kind=dk) :: energy_term + type(string_t) :: required_keys(4), optional_keys(1) + type(string_t) :: heating_required_keys(1), heating_optional_keys(0) + + required_keys(1) = "name" + required_keys(2) = "cross section" + required_keys(3) = "quantum yield" + required_keys(4) = "heating" + optional_keys(1) = "scaling factor" + + call assert_msg( 316144353, & + config%validate( required_keys, optional_keys ), & + "Invalid configuration for photolysis reactions with "// & + "heating parameters" ) + + call config%get( "heating", heating_config, Iam ) + + heating_required_keys(1) = "energy term" + + call assert_msg( 316144354, & + heating_config%validate( heating_required_keys, & + heating_optional_keys ), & + "Invalid configuration for heating parameters" ) + + call config%get( "name", this%label_, Iam ) + call config%get( "cross section", cs_config, Iam ) + this%cross_section_%val_ => cross_section_builder( cs_config, grids, & + profiles ) + call config%get( "quantum yield", qy_config, Iam ) + this%quantum_yield_%val_ => quantum_yield_builder( qy_config, grids, & + profiles ) + call config%get( "scaling factor", this%scaling_factor_, Iam, & + default = 1.0_dk ) + call heating_config%get( "energy term", energy_term, Iam ) + wavelengths => grids%get_grid( "wavelength", "nm" ) + allocate( this%energy_( wavelengths%ncells_ ) ) + this%energy_(:) = & + max( 0.0_dk, hc * 1.0e9_dk * ( energy_term - wavelengths%mid_(:) ) / & + ( energy_term * wavelengths%mid_(:) ) ) + deallocate( wavelengths ) + + end function heating_parameters_constructor + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> calculate heating rates + subroutine get( this, la_srb, spherical_geometry, grids, profiles, & + radiation_field, heating_rates ) + + + !> Heating rate collection + class(heating_rates_t), intent(in) :: this + !> Lyman Alpha and Schumann-Runge bands + class(la_sr_bands_t), intent(inout) :: la_srb + !> Spherical geometry + class(spherical_geometry_t), intent(inout) :: spherical_geometry + !> Grids + class(grid_warehouse_t), intent(inout) :: grids + !> Profiles + class(profile_warehouse_t), intent(inout) :: profiles + !> Radiation field + class(radiation_field_t), intent(in) :: radiation_field + !> Heating rates (vertical interface, reaction) [J s-1] + real(kind=dk), intent(inout) :: heating_rates(:,:) + + character(len=*), parameter :: Iam = 'heating rates get' + class(grid_t), pointer :: heights, wavelengths + class(profile_t), pointer :: etfl, air + real(kind=dk), allocatable :: actinic_flux(:,:), xsqy(:,:) + real(kind=dk), allocatable :: cross_section(:,:), quantum_yield(:,:) + real(kind=dk), allocatable :: air_vertical_column(:), air_slant_column(:) + integer :: i_rate, n_rates, i_height + + heights => grids%get_grid( this%height_grid_ ) + wavelengths => grids%get_grid( this%wavelength_grid_ ) + etfl => profiles%get_profile( this%etfl_profile_ ) + air => profiles%get_profile( this%air_profile_ ) + + n_rates = size( this%heating_parameters_ ) + call assert( 966855732, & + size( heating_rates, 1 ) .eq. heights%ncells_ + 1 .and. & + size( heating_rates, 2 ) .eq. n_rates ) + + actinic_flux = transpose( radiation_field%fdr_ + radiation_field%fup_ + & + radiation_field%fdn_ ) + do i_height = 1, heights%ncells_ + 1 + actinic_flux( :, i_height ) = actinic_flux( :, i_height ) * etfl%mid_val_ + end do + where( actinic_flux < 0.0_dk ) + actinic_flux = 0.0_dk + end where + + do i_rate = 1, n_rates + associate( params => this%heating_parameters_( i_rate ) ) + cross_section = params%cross_section_%val_%calculate( grids, profiles ) + quantum_yield = params%quantum_yield_%val_%calculate( grids, profiles ) + + ! O2 photolysis can have special la & srb band handling + if( any( this%o2_rate_indices_ == i_rate ) ) then + allocate( air_vertical_column( air%ncells_ ), & + air_slant_column( air%ncells_ + 1 ) ) + call spherical_geometry%air_mass( air%exo_layer_dens_, & + air_vertical_column, & + air_slant_column ) + call la_srb%cross_section( grids, profiles, air_vertical_column, & + air_slant_column, cross_section, & + spherical_geometry ) + deallocate( air_vertical_column, air_slant_column ) + end if + + xsqy = transpose( cross_section * quantum_yield ) + do i_height = 1, heights%ncells_ + 1 + heating_rates( i_height, i_rate ) = & + dot_product( actinic_flux( :, i_height ), & + params%energy_(:) * xsqy( :, i_height ) ) * & + params%scaling_factor_ + end do + end associate + end do + + deallocate( heights ) + deallocate( wavelengths ) + deallocate( etfl ) + deallocate( air ) + + end subroutine get + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Returns the names of each photolysis reaction with a heating rate + function labels( this ) + + !> Photolysis reaction labels + type(string_t), allocatable :: labels(:) + !> Heating rate collection + class(heating_rates_t), intent(in) :: this + + allocate( labels( size( this%heating_parameters_ ) ) ) + labels(:) = this%heating_parameters_(:)%label_ + + end function labels + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Returns the number of heating rates + function get_number( this ) result( n_rates ) + + !> Number of heating rates + integer :: n_rates + !> Heating rate collection + class(heating_rates_t), intent(in) :: this + + n_rates = 0 + if( allocated( this%heating_parameters_ ) ) then + n_rates = size( this%heating_parameters_ ) + end if + + end function get_number + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Returns the size of a character buffer needed to pack the heating rates + function pack_size( this, comm ) + + + !> Heating rate collection + class(heating_rates_t), intent(in) :: this + !> MPI communicator + integer, intent(in) :: comm + !> Size of the character buffer + integer :: pack_size + +#ifdef MUSICA_USE_MPI + integer :: i_elem + + pack_size = musica_mpi_pack_size( allocated( this%heating_parameters_ ), & + comm ) + if( allocated( this%heating_parameters_ ) ) then + pack_size = pack_size + & + musica_mpi_pack_size( size( this%heating_parameters_ ), comm ) + do i_elem = 1, size( this%heating_parameters_ ) + pack_size = pack_size + & + this%heating_parameters_( i_elem )%pack_size( comm ) + end do + end if + pack_size = pack_size + & + this%height_grid_%pack_size( comm ) + & + this%wavelength_grid_%pack_size( comm ) + & + this%etfl_profile_%pack_size( comm ) + & + this%air_profile_%pack_size( comm ) + & + musica_mpi_pack_size( this%o2_rate_indices_, comm ) +#else + pack_size = 0 +#endif + + end function pack_size + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Packs the heating rates into a character buffer + subroutine mpi_pack( this, buffer, position, comm ) + + !> Heating rate collection + class(heating_rates_t), intent(in) :: this + !> Character buffer + character, intent(inout) :: buffer(:) + !> Position in the buffer + integer, intent(inout) :: position + !> MPI communicator + integer, intent(in) :: comm + +#ifdef MUSICA_USE_MPI + integer :: prev_pos, i_elem + + prev_pos = position + call musica_mpi_pack( buffer, position, & + allocated( this%heating_parameters_ ), comm ) + if( allocated( this%heating_parameters_ ) ) then + call musica_mpi_pack( buffer, position, & + size( this%heating_parameters_ ), comm ) + do i_elem = 1, size( this%heating_parameters_ ) + call this%heating_parameters_( i_elem )%mpi_pack( buffer, position, & + comm ) + end do + end if + call this%height_grid_%mpi_pack( buffer, position, comm ) + call this%wavelength_grid_%mpi_pack( buffer, position, comm ) + call this%etfl_profile_%mpi_pack( buffer, position, comm ) + call this%air_profile_%mpi_pack( buffer, position, comm ) + call musica_mpi_pack( buffer, position, this%o2_rate_indices_, comm ) + call assert( 247051769, position - prev_pos <= this%pack_size( comm ) ) +#endif + + end subroutine mpi_pack + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Unpacks the heating rates from a character buffer + subroutine mpi_unpack( this, buffer, position, comm ) + + !> Heating rate collection + class(heating_rates_t), intent(out) :: this + !> Character buffer + character, intent(inout) :: buffer(:) + !> Position in the buffer + integer, intent(inout) :: position + !> MPI communicator + integer, intent(in) :: comm + +#ifdef MUSICA_USE_MPI + integer :: prev_pos, i_elem, n_elems + logical :: is_allocated + + prev_pos = position + call musica_mpi_unpack( buffer, position, is_allocated, comm ) + if( is_allocated ) then + call musica_mpi_unpack( buffer, position, n_elems, comm ) + allocate( this%heating_parameters_( n_elems ) ) + do i_elem = 1, n_elems + call this%heating_parameters_( i_elem )%mpi_unpack( buffer, position, & + comm ) + end do + end if + call this%height_grid_%mpi_unpack( buffer, position, comm ) + call this%wavelength_grid_%mpi_unpack( buffer, position, comm ) + call this%etfl_profile_%mpi_unpack( buffer, position, comm ) + call this%air_profile_%mpi_unpack( buffer, position, comm ) + call musica_mpi_unpack( buffer, position, this%o2_rate_indices_, comm ) + call assert( 631316749, position - prev_pos <= this%pack_size( comm ) ) +#endif + + end subroutine mpi_unpack + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Returns the size of a character buffer needed to pack the heating + !! parameters + function heating_parameters_pack_size( this, comm ) result( pack_size ) + + !> Heating parameters for a single photolyzing species + class(heating_parameters_t), intent(in) :: this + !> MPI communicator + integer, intent(in) :: comm + !> Size of the character buffer + integer :: pack_size + +#ifdef MUSICA_USE_MPI + type(string_t) :: cs_type_name, qy_type_name + + cs_type_name = cross_section_type_name( this%cross_section_%val_ ) + qy_type_name = quantum_yield_type_name( this%quantum_yield_%val_ ) + pack_size = this%label_%pack_size( comm ) + & + cs_type_name%pack_size( comm ) + & + this%cross_section_%val_%pack_size( comm ) + & + qy_type_name%pack_size( comm ) + & + this%quantum_yield_%val_%pack_size( comm ) + & + musica_mpi_pack_size( this%scaling_factor_, comm ) + & + musica_mpi_pack_size( this%energy_, comm ) +#else + pack_size = 0 +#endif + + end function heating_parameters_pack_size + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Packs the heating parameters into a character buffer + subroutine heating_parameters_mpi_pack( this, buffer, position, comm ) + + !> Heating parameters for a single photolyzing species + class(heating_parameters_t), intent(in) :: this + !> Character buffer + character, intent(inout) :: buffer(:) + !> Position in the buffer + integer, intent(inout) :: position + !> MPI communicator + integer, intent(in) :: comm + +#ifdef MUSICA_USE_MPI + integer :: prev_pos + type(string_t) :: cs_type_name, qy_type_name + + prev_pos = position + cs_type_name = cross_section_type_name( this%cross_section_%val_ ) + qy_type_name = quantum_yield_type_name( this%quantum_yield_%val_ ) + call this%label_%mpi_pack( buffer, position, comm ) + call cs_type_name%mpi_pack( buffer, position, comm ) + call this%cross_section_%val_%mpi_pack( buffer, position, comm ) + call qy_type_name%mpi_pack( buffer, position, comm ) + call this%quantum_yield_%val_%mpi_pack( buffer, position, comm ) + call musica_mpi_pack( buffer, position, this%scaling_factor_, comm ) + call musica_mpi_pack( buffer, position, this%energy_, comm ) + call assert( 243240701, position - prev_pos <= this%pack_size( comm ) ) +#endif + + end subroutine heating_parameters_mpi_pack + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Unpacks the heating parameters from a character buffer + subroutine heating_parameters_mpi_unpack( this, buffer, position, comm ) + + !> Heating parameters for a single photolyzing species + class(heating_parameters_t), intent(out) :: this + !> Character buffer + character, intent(inout) :: buffer(:) + !> Position in the buffer + integer, intent(inout) :: position + !> MPI communicator + integer, intent(in) :: comm + +#ifdef MUSICA_USE_MPI + integer :: prev_pos + type(string_t) :: cs_type_name, qy_type_name + + prev_pos = position + call this%label_%mpi_unpack( buffer, position, comm ) + call cs_type_name%mpi_unpack( buffer, position, comm ) + this%cross_section_%val_ => cross_section_allocate( cs_type_name ) + call this%cross_section_%val_%mpi_unpack( buffer, position, comm ) + call qy_type_name%mpi_unpack( buffer, position, comm ) + this%quantum_yield_%val_ => quantum_yield_allocate( qy_type_name ) + call this%quantum_yield_%val_%mpi_unpack( buffer, position, comm ) + call musica_mpi_unpack( buffer, position, this%scaling_factor_, comm ) + call musica_mpi_unpack( buffer, position, this%energy_, comm ) + call assert( 243240702, position - prev_pos <= this%pack_size( comm ) ) +#endif + + end subroutine heating_parameters_mpi_unpack + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Cleans up memory + elemental subroutine destructor( this ) + + !> Heating rates + type(heating_rates_t), intent(inout) :: this + + integer :: i_rate + + if( allocated( this%heating_parameters_ ) ) then + do i_rate = 1, size( this%heating_parameters_ ) + associate( params => this%heating_parameters_( i_rate ) ) + if( associated( params%cross_section_%val_ ) ) then + deallocate( params%cross_section_%val_ ) + nullify( params%cross_section_%val_ ) + end if + if( associated( params%quantum_yield_%val_ ) ) then + deallocate( params%quantum_yield_%val_ ) + nullify( params%quantum_yield_%val_ ) + end if + end associate + end do + deallocate( this%heating_parameters_ ) + end if + + end subroutine destructor + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +end module tuvx_heating_rates \ No newline at end of file diff --git a/src/output.F90 b/src/output.F90 index faf041a7..e2561a93 100644 --- a/src/output.F90 +++ b/src/output.F90 @@ -23,9 +23,11 @@ module tuvx_output class(io_t), pointer :: file_ => null( ) logical :: do_photo_ = .false. logical :: do_dose_ = .false. + logical :: do_heating_ = .false. logical :: do_radiation_ = .false. type(string_t), allocatable :: photo_labels_(:) type(string_t), allocatable :: dose_labels_(:) + type(string_t), allocatable :: heating_labels_(:) type(string_t), allocatable :: photo_cross_sections_(:) type(string_t), allocatable :: photo_quantum_yields_(:) contains @@ -58,13 +60,14 @@ function constructor( config, core ) result( this ) character(len=*), parameter :: Iam = "output writer" integer :: stat type(string_t) :: file_path - type(string_t) :: required_keys(2), optional_keys(3) + type(string_t) :: required_keys(2), optional_keys(4) type(config_t) :: tuvx_config, rad_config required_keys(1) = "file path" required_keys(2) = "tuv-x configuration" optional_keys(1) = "include photolysis" optional_keys(2) = "include dose rates" + optional_keys(3) = "include heating rates" call assert_msg( 215370625, & config%validate( required_keys, optional_keys ), & @@ -93,6 +96,10 @@ function constructor( config, core ) result( this ) default = .false. ) if( this%do_dose_ ) this%dose_labels_ = core%dose_rate_labels( ) + call config%get( "include heating rates", this%do_heating_, Iam, & + default = .false. ) + if( this%do_heating_ ) this%heating_labels_ = core%heating_rate_labels( ) + ! Add custom diagnostics call config%get( "tuv-x configuration", tuvx_config, Iam ) call this%add_photolysis_diagnostics( tuvx_config ) @@ -106,7 +113,7 @@ end function constructor !> Outputs results subroutine output( this, step, core, photolysis_rate_constants, dose_rates, & - time, solar_zenith_angle, earth_sun_distance ) + heating_rates, time, solar_zenith_angle, earth_sun_distance ) use musica_assert, only : assert_msg use musica_constants, only : dk => musica_dk @@ -124,6 +131,8 @@ subroutine output( this, step, core, photolysis_rate_constants, dose_rates, & real(dk), optional, intent(in) :: photolysis_rate_constants(:,:) !> Dose rates (vertical level, dose rate type) real(dk), optional, intent(in) :: dose_rates(:,:) + !> Heating rates (vertical level, reaction) + real(dk), optional, intent(in) :: heating_rates(:,:) !> Time [hours] real(dk), optional, intent(in) :: time !> Solar zenith angle [degrees] @@ -209,6 +218,18 @@ subroutine output( this, step, core, photolysis_rate_constants, dose_rates, & end do end if + if( present( heating_rates ) ) then + call assert_msg( 935671025, this%do_heating_, "Heating rates are not " & + //"configured to be output" ) + dim_names(1) = "vertical_level" + units = "J s-1" + do i_rate = 1, size( this%heating_labels_ ) + var_name = clean_string( this%heating_labels_( i_rate ) ) + call this%file_%append( var_name, units, append_dim, step, & + dim_names(1), heating_rates( :, i_rate ), Iam ) + end do + end if + dim_names(1) = "vertical_level" dim_names(2) = "wavelength" units = "cm2 molecule-1" diff --git a/src/photolysis_rates.F90 b/src/photolysis_rates.F90 index 682ba14d..cdfbfa8f 100644 --- a/src/photolysis_rates.F90 +++ b/src/photolysis_rates.F90 @@ -178,7 +178,7 @@ subroutine add( this, config, grid_warehouse, profile_warehouse ) real(dk) :: scale_factor type(string_t) :: reaction_key logical :: do_apply_bands, found - type(string_t) :: required_keys(3), optional_keys(1) + type(string_t) :: required_keys(3), optional_keys(2) type(cross_section_ptr), allocatable :: temp_cs(:) type(quantum_yield_ptr), allocatable :: temp_qy(:) type(string_t), allocatable :: temp_handle(:) @@ -190,6 +190,7 @@ subroutine add( this, config, grid_warehouse, profile_warehouse ) required_keys(2) = "cross section" required_keys(3) = "quantum yield" optional_keys(1) = "scaling factor" + optional_keys(2) = "heating" call assert_msg( 780273355, & config%validate( required_keys, optional_keys ), & @@ -294,7 +295,7 @@ subroutine get( this, la_srb, spherical_geometry, grid_warehouse, & !> Local variables character(len=*), parameter :: Iam = "photolysis rates calculator" integer :: vertNdx, rateNdx, nRates - real(dk), allocatable :: airVcol(:), airScol(:) + real(dk), allocatable :: air_vertical_column(:), air_slant_column(:) real(dk), allocatable :: xsqyWrk(:) real(dk), allocatable :: cross_section(:,:) real(dk), allocatable :: quantum_yield(:,:) @@ -343,13 +344,15 @@ subroutine get( this, la_srb, spherical_geometry, grid_warehouse, & ! O2 photolysis can have special la & srb band handling if( any( this%o2_rate_indices_ == rateNdx ) ) then airProfile => profile_warehouse%get_profile( this%air_profile_ ) - allocate( airVcol( airProfile%ncells_ ), & - airScol( airProfile%ncells_ + 1 ) ) - call spherical_geometry%air_mass( airProfile%exo_layer_dens_, airVcol,& - airScol ) - call la_srb%cross_section( grid_warehouse, profile_warehouse, airVcol,& - airScol, cross_section, spherical_geometry ) - deallocate( airVcol, airScol ) + allocate( air_vertical_column( airProfile%ncells_ ), & + air_slant_column( airProfile%ncells_ + 1 ) ) + call spherical_geometry%air_mass( airProfile%exo_layer_dens_, & + air_vertical_column, & + air_slant_column ) + call la_srb%cross_section( grid_warehouse, profile_warehouse, & + air_vertical_column, air_slant_column, & + cross_section, spherical_geometry ) + deallocate( air_vertical_column, air_slant_column ) deallocate( airProfile ) endif @@ -370,7 +373,8 @@ subroutine get( this, la_srb, spherical_geometry, grid_warehouse, & xsqy = transpose( cross_section * quantum_yield ) do vertNdx = 1, zGrid%ncells_ + 1 photolysis_rates( vertNdx, rateNdx ) = & - dot_product( actinicFlux( :, vertNdx ), xsqy( :, vertNdx ) ) + dot_product( actinicFlux( :, vertNdx ), xsqy( :, vertNdx ) ) * & + this%scaling_factors_( rateNdx ) enddo if( allocated( cross_section ) ) deallocate( cross_section ) if( allocated( quantum_yield ) ) deallocate( quantum_yield ) diff --git a/src/quantum_yield.F90 b/src/quantum_yield.F90 index 2f388e39..6a316e96 100644 --- a/src/quantum_yield.F90 +++ b/src/quantum_yield.F90 @@ -226,12 +226,10 @@ subroutine base_constructor( this, config, grid_warehouse, & else has_netcdf_file ! check for quantum yield constant call config%get( 'constant value', quantum_yield_constant, Iam, & - found = found ) - if( found ) then - allocate( this%quantum_yield_parms(1) ) - allocate( this%quantum_yield_parms(1)%array( lambdaGrid%ncells_, 1 ) ) - this%quantum_yield_parms(1)%array(:,1) = quantum_yield_constant - endif + default = 0.0_dk ) + allocate( this%quantum_yield_parms(1) ) + allocate( this%quantum_yield_parms(1)%array( lambdaGrid%ncells_, 1 ) ) + this%quantum_yield_parms(1)%array(:,1) = quantum_yield_constant endif has_netcdf_file ! get values to overlay for specific bands @@ -601,16 +599,43 @@ function override_constructor( config, wavelengths ) result( this ) character(len=*), parameter :: my_name = & "quantum yield band override constructor" type(string_t) :: type_name - type(string_t) :: required_keys(2), optional_keys(0) + type(string_t) :: required_keys(2), optional_keys(2) + real(kind=dk) :: min_wl, max_wl + integer :: i_wl required_keys(1) = "band" required_keys(2) = "value" + optional_keys(1) = "minimum wavelength" + optional_keys(2) = "maximum wavelength" call assert_msg( 257437273, & config%validate( required_keys, optional_keys ), & "Bad configuration for quantum yield band averride" ) call config%get( "band", type_name, my_name ) - this%min_wavelength_index_ = get_band_min_index( type_name, wavelengths ) - this%max_wavelength_index_ = get_band_max_index( type_name, wavelengths ) + if( type_name == "range" ) then + call config%get( "minimum wavelength", min_wl, my_name, & + default = 0.0_dk ) + call config%get( "maximum wavelength", max_wl, my_name, & + default = huge(1.0_dk) ) + call assert_msg( 976365464, & + min_wl <= wavelengths%mid_( wavelengths%ncells_ ), & + "Minimum wavelength is out-of-bounds for quantum yield") + call assert_msg( 166625638, & + max_wl >= wavelengths%mid_( 1 ), & + "Maximum wavelength is out-of-bounds for quantum yield") + do i_wl = 1, wavelengths%ncells_ + if( wavelengths%mid_( i_wl ) < min_wl ) then + this%min_wavelength_index_ = i_wl + 1 + end if + if( wavelengths%mid_( i_wl ) <= max_wl ) then + this%max_wavelength_index_ = i_wl + else + exit + end if + end do + else + this%min_wavelength_index_ = get_band_min_index( type_name, wavelengths ) + this%max_wavelength_index_ = get_band_max_index( type_name, wavelengths ) + end if call config%get( "value", this%value_, my_name ) end function override_constructor diff --git a/src/quantum_yield_factory.F90 b/src/quantum_yield_factory.F90 index 240bcc6d..466c99a2 100644 --- a/src/quantum_yield_factory.F90 +++ b/src/quantum_yield_factory.F90 @@ -29,6 +29,8 @@ module tuvx_quantum_yield_factory use tuvx_quantum_yield_clono2_cl_no3,only : quantum_yield_clono2_cl_no3_t use tuvx_quantum_yield_clono2_clo_no2, & only : quantum_yield_clono2_clo_no2_t + use tuvx_quantum_yield_h2so4_mills, only : quantum_yield_h2so4_mills_t + use tuvx_quantum_yield_taylor_series, only : quantum_yield_taylor_series_t implicit none @@ -125,6 +127,13 @@ function quantum_yield_builder( config, grid_warehouse, profile_warehouse ) & quantum_yield => quantum_yield_clono2_clo_no2_t( config, & grid_warehouse, & profile_warehouse ) + case( 'H2SO4 Mills' ) + quantum_yield => quantum_yield_h2so4_mills_t( config, grid_warehouse, & + profile_warehouse ) + case( 'Taylor series' ) + quantum_yield => quantum_yield_taylor_series_t( config, & + grid_warehouse, & + profile_warehouse ) case default call die_msg( 450768214, "Invalid quantum yield type: '"// & quantum_yield_type%to_char( )//"'" ) @@ -182,6 +191,10 @@ type(string_t) function quantum_yield_type_name( quantum_yield ) & name = "quantum_yield_clono2_cl_no3_t" type is( quantum_yield_clono2_clo_no2_t ) name = "quantum_yield_clono2_clo_no2_t" + type is( quantum_yield_h2so4_mills_t ) + name = "quantum_yield_h2so4_mills_t" + type is( quantum_yield_taylor_series_t ) + name = "quantum_yield_taylor_series_t" class default call die( 853572483 ) end select @@ -238,6 +251,10 @@ function quantum_yield_allocate( type_name ) result( quantum_yield ) allocate( quantum_yield_clono2_cl_no3_t :: quantum_yield ) case( 'quantum_yield_clono2_clo_no2_t' ) allocate( quantum_yield_clono2_clo_no2_t :: quantum_yield ) + case( 'quantum_yield_h2so4_mills_t' ) + allocate( quantum_yield_h2so4_mills_t :: quantum_yield ) + case( 'quantum_yield_taylor_series_t' ) + allocate( quantum_yield_taylor_series_t :: quantum_yield ) case default call die_msg( 894617177, "Invalid quantum yield type: '"//type_name//"'" ) end select diff --git a/src/quantum_yields/CMakeLists.txt b/src/quantum_yields/CMakeLists.txt index fa93b668..1b089e5f 100644 --- a/src/quantum_yields/CMakeLists.txt +++ b/src/quantum_yields/CMakeLists.txt @@ -15,11 +15,13 @@ target_sources(tuvx_object clono2-clo_no2.F90 clono2-cl_no3.F90 ho2-oh_o.F90 + h2so4_mills.F90 mvk.F90 no2_tint.F90 no3_aq.F90 o3-o2_o1d.F90 o3-o2_o3p.F90 + taylor_series.F90 tint.F90 ) diff --git a/src/quantum_yields/acetone-ch3co_ch3.F90 b/src/quantum_yields/acetone-ch3co_ch3.F90 index 9cfd92f5..7f4d8bb7 100644 --- a/src/quantum_yields/acetone-ch3co_ch3.F90 +++ b/src/quantum_yields/acetone-ch3co_ch3.F90 @@ -6,6 +6,7 @@ module tuvx_quantum_yield_ch3coch3_ch3co_ch3 ! Including musica_config at the module level to avoid an ICE ! with Intel 2022.1 compiler + use musica_constants, only : dk => musica_dk use musica_config, only : config_t use tuvx_quantum_yield, only : quantum_yield_t, base_constructor @@ -16,9 +17,21 @@ module tuvx_quantum_yield_ch3coch3_ch3co_ch3 type, extends(quantum_yield_t) :: quantum_yield_ch3coch3_ch3co_ch3_t ! Calculator for acetone quantum_yield + logical :: do_CO_ = .false. + logical :: do_CH3CO_ = .false. + real(kind=dk) :: low_wavelength_value_ + real(kind=dk) :: high_wavelength_value_ + real(kind=dk) :: minimum_temperature_ + real(kind=dk) :: maximum_temperature_ contains !> Initialize the quantum_yield procedure :: calculate => run + ! returns the number of bytes required to pack the object onto a buffer + procedure :: pack_size + ! packs the object onto a character buffer + procedure :: mpi_pack + ! unpacks an object from a character buffer + procedure :: mpi_unpack end type quantum_yield_ch3coch3_ch3co_ch3_t interface quantum_yield_ch3coch3_ch3co_ch3_t @@ -33,17 +46,54 @@ function constructor( config, grid_warehouse, profile_warehouse ) & result( this ) ! Build the quantum yield + use musica_assert, only : assert_msg, die_msg + use musica_string, only : string_t use tuvx_grid_warehouse, only : grid_warehouse_t use tuvx_profile_warehouse, only : profile_warehouse_t - class(quantum_yield_t), pointer :: this ! This :f:type:`~tuvx_quantum_yield/quantum_yield_t` calculator - type(config_t), intent(inout) :: config ! Quantum yield configuration data - type(grid_warehouse_t), intent(inout) :: grid_warehouse ! A :f:type:`~tuvx_grid_warehouse/grid_warehouse_t` - type(profile_warehouse_t), intent(inout) :: profile_warehouse ! A :f:type:`~tuvx_profile_warehouse/profile_warehouse_t` - - allocate ( quantum_yield_ch3coch3_ch3co_ch3_t :: this ) - + type(quantum_yield_ch3coch3_ch3co_ch3_t), pointer :: this ! This :f:type:`~tuvx_quantum_yield/quantum_yield_t` calculator + type(config_t), intent(inout) :: config ! Quantum yield configuration data + type(grid_warehouse_t), intent(inout) :: grid_warehouse ! A :f:type:`~tuvx_grid_warehouse/grid_warehouse_t` + type(profile_warehouse_t), intent(inout) :: profile_warehouse ! A :f:type:`~tuvx_profile_warehouse/profile_warehouse_t` + + character(len=*), parameter :: my_name = & + "Acetone quantum yield constructor" + type(string_t) :: required_keys(1), optional_keys(6), branch + + required_keys(1) = "type" + optional_keys(1) = "name" + optional_keys(2) = "low wavelength value" + optional_keys(3) = "high wavelength value" + optional_keys(4) = "minimum temperature" + optional_keys(5) = "maximum temperature" + optional_keys(6) = "branch" + call assert_msg( 253342443, & + config%validate( required_keys, optional_keys ), & + "Bad configuration for acetone quantum yield." ) + allocate ( this ) call base_constructor( this, config, grid_warehouse, profile_warehouse ) + call config%get( "low wavelength value", this%low_wavelength_value_, & + my_name, default = 0.95_dk ) + call config%get( "high wavelength value", this%high_wavelength_value_, & + my_name, default = 0.0_dk ) + call config%get( "minimum temperature", this%minimum_temperature_, & + my_name, default = 0.0_dk ) + call config%get( "maximum temperature", this%maximum_temperature_, & + my_name, default = huge( 1.0_dk ) ) + call config%get( "branch", branch, my_name, default = "CH3CO" ) + if( branch .eq. "CO" ) then + this%do_CO_ = .true. + this%do_CH3CO_ = .false. + else if( branch .eq. "CH3CO" ) then + this%do_CO_ = .false. + this%do_CH3CO_ = .true. + else if( branch .eq. "CO+CH3CO" ) then + this%do_CO_ = .true. + this%do_CH3CO_ = .true. + else + call die_msg( 534162111, "Invalid branch for acetone quantum yield: '"//& + branch//"'." ) + end if end function constructor @@ -62,7 +112,6 @@ function run( this, grid_warehouse, profile_warehouse ) & ! Res. Lett., 31, L06111, `doi:10.1029/2003GL018793. ! `_ - use musica_constants, only : dk => musica_dk use tuvx_grid, only : grid_t use tuvx_grid_warehouse, only : grid_warehouse_t use tuvx_profile, only : profile_t @@ -95,7 +144,7 @@ function run( this, grid_warehouse, profile_warehouse ) & real(dk) :: c3 real(dk) :: cA0, cA1, cA2, cA3, cA4 real(dk) :: dumexp - real(dk) :: fco, fac + real(dk) :: fco, fac, qy zGrid => grid_warehouse%get_grid( this%height_grid_ ) lambdaGrid => grid_warehouse%get_grid( this%wavelength_grid_ ) @@ -112,15 +161,17 @@ function run( this, grid_warehouse, profile_warehouse ) & vert_loop: & do vertNdx = 1, nzdim - Tadj = modelTemp( vertNdx ) / 295._dk + Tadj = max( this%minimum_temperature_, & + min( this%maximum_temperature_, modelTemp( vertNdx ) ) ) & + / 295._dk M = modelDens( vertNdx ) lambda_loop: & do lambdaNdx = 1, lambdaGrid%ncells_ w = lambdaGrid%mid_( lambdaNdx ) if( w < 279._dk ) then - fac = 0.95_dk + qy = this%low_wavelength_value_ elseif( w > 327._dk ) then - fac = rZERO + qy = this%high_wavelength_value_ else ! CO (carbon monoxide) quantum yields: a0 = 0.350_dk * Tadj**( -1.28_dk ) @@ -158,8 +209,11 @@ function run( this, grid_warehouse, profile_warehouse ) & fac = ( rONE - fco ) * ( rONE + cA3 + cA4 * M ) & / ( ( rONE + cA3 + cA2 * M ) * ( rONE + cA4 * M ) ) endif + qy = 0.0_dk + if( this%do_CO_ ) qy = qy + fco + if( this%do_CH3CO_ ) qy = qy + fac endif - quantum_yield( lambdaNdx, vertNdx ) = fac + quantum_yield( lambdaNdx, vertNdx ) = qy enddo lambda_loop enddo vert_loop @@ -172,6 +226,98 @@ function run( this, grid_warehouse, profile_warehouse ) & end function run +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Returns the number of bytes required to pack the object onto a buffer + integer function pack_size( this, comm ) + + use musica_mpi, only : musica_mpi_pack_size + + !> Quantum yield to be packed + class(quantum_yield_ch3coch3_ch3co_ch3_t), intent(in) :: this + !> MPI communicator + integer, intent(in) :: comm + +#ifdef MUSICA_USE_MPI + pack_size = this%quantum_yield_t%pack_size( comm ) + & + musica_mpi_pack_size( this%do_CO_, comm ) + & + musica_mpi_pack_size( this%do_CH3CO_, comm ) + & + musica_mpi_pack_size( this%low_wavelength_value_, comm ) + & + musica_mpi_pack_size( this%high_wavelength_value_, comm ) + & + musica_mpi_pack_size( this%minimum_temperature_, comm ) + & + musica_mpi_pack_size( this%maximum_temperature_, comm ) +#else + pack_size = 0 +#endif + + end function pack_size + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Packs the quantum yield onto a character buffer + subroutine mpi_pack( this, buffer, position, comm ) + + use musica_assert, only : assert + use musica_mpi, only : musica_mpi_pack + + !> Quantum yield to pack + class(quantum_yield_ch3coch3_ch3co_ch3_t), intent(in) :: this + !> Memory buffer + character, intent(inout) :: buffer(:) + !> Current buffer position + integer, intent(inout) :: position + !> MPI communicator + integer, intent(in) :: comm + +#ifdef MUSICA_USE_MPI + integer :: prev_pos + + prev_pos = position + call this%quantum_yield_t%mpi_pack( buffer, position, comm ) + call musica_mpi_pack( buffer, position, this%do_CO_, comm ) + call musica_mpi_pack( buffer, position, this%do_CH3CO_, comm ) + call musica_mpi_pack( buffer, position, this%low_wavelength_value_, comm ) + call musica_mpi_pack( buffer, position, this%high_wavelength_value_, comm ) + call musica_mpi_pack( buffer, position, this%minimum_temperature_, comm ) + call musica_mpi_pack( buffer, position, this%maximum_temperature_, comm ) + call assert( 985830490, position - prev_pos <= this%pack_size( comm ) ) +#endif + + end subroutine mpi_pack + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Unpacks a quantum yield calculator from a character buffer + subroutine mpi_unpack( this, buffer, position, comm ) + + use musica_assert, only : assert + use musica_mpi, only : musica_mpi_unpack + + !> Quantum yield to unpack + class(quantum_yield_ch3coch3_ch3co_ch3_t), intent(out) :: this + !> Memory buffer + character, intent(inout) :: buffer(:) + !> Current buffer position + integer, intent(inout) :: position + !> MPI communicator + integer, intent(in) :: comm + +#ifdef MUSICA_USE_MPI + integer :: prev_pos + + prev_pos = position + call this%quantum_yield_t%mpi_unpack( buffer, position, comm ) + call musica_mpi_unpack( buffer, position, this%do_CO_, comm ) + call musica_mpi_unpack( buffer, position, this%do_CH3CO_, comm ) + call musica_mpi_unpack( buffer, position, this%low_wavelength_value_, comm ) + call musica_mpi_unpack( buffer, position, this%high_wavelength_value_, comm ) + call musica_mpi_unpack( buffer, position, this%minimum_temperature_, comm ) + call musica_mpi_unpack( buffer, position, this%maximum_temperature_, comm ) + call assert( 301844101, position - prev_pos <= this%pack_size( comm ) ) +#endif + + end subroutine mpi_unpack + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! end module tuvx_quantum_yield_ch3coch3_ch3co_ch3 diff --git a/src/quantum_yields/h2so4_mills.F90 b/src/quantum_yields/h2so4_mills.F90 new file mode 100644 index 00000000..63538e65 --- /dev/null +++ b/src/quantum_yields/h2so4_mills.F90 @@ -0,0 +1,262 @@ +! Copyright (C) 2024 National Center for Atmospheric Research +! SPDX-License-Identifier: Apache-2.0 + +module tuvx_quantum_yield_h2so4_mills + ! The temperature and pressure dependent quantum yield calculations + ! used in WACCM simulations + + use musica_constants, only : dk => musica_dk + use tuvx_quantum_yield + + implicit none + + private + public :: quantum_yield_h2so4_mills_t + + !> Quantum yield calculator for H2SO4 + !! + !! See Miller et al. (GRL, 2007) + !! + !! Quantum yields qy_x are based on parameters r_x set in the + !! configuration: + !! + !! lambda = R T / ( 2^(1/2) pi d^2 Na P ) + !! v = ( 8 R T / ( pi MW ) )^(1/2) + !! qy_x = r_x / ( r_x + v / lambda ) + !! + !! where R is the universal gas constant (J mol-1 K-1 ), T is + !! temperature (K), P is pressure (Pa), Na is Avogadro's number (mol-1) + !! and MW is the molecular weight of H2SO4 (kg mol-1), d is the + !! molecular diameter (m), and x corresponds to the wavelength band + !! being parameterized. + type, extends(quantum_yield_t) :: quantum_yield_h2so4_mills_t + !> Indices for wavelengths to update + integer, allocatable :: wavelength_indices_(:) + !> Collision rate [s-1] + real(kind=dk), allocatable :: collision_rate_(:) + !> Molecular diameter [m] + real(kind=dk) :: molecular_diameter_ + !> Molecular weight [kg mol-1] + real(kind=dk) :: molecular_weight_ + contains + !> Calculate the quantum yields + procedure :: calculate + ! returns the number of bytes required to pack the object onto a buffer + procedure :: pack_size + ! packs the object onto a character buffer + procedure :: mpi_pack + ! unpacks an object from a character buffer + procedure :: mpi_unpack + end type quantum_yield_h2so4_mills_t + + interface quantum_yield_h2so4_mills_t + module procedure :: constructor + end interface quantum_yield_h2so4_mills_t + +contains + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Constructor of H2SO4 quantum yield calculators + function constructor( config, grids, profiles ) result ( this ) + + use musica_assert, only : assert_msg + use musica_config, only : config_t + use musica_string, only : string_t, to_char + use tuvx_grid, only : grid_t + use tuvx_grid_warehouse, only : grid_warehouse_t + use tuvx_profile_warehouse, only : profile_warehouse_t + + class(quantum_yield_h2so4_mills_t), pointer :: this + type(config_t), intent(inout) :: config + type(grid_warehouse_t), intent(inout) :: grids + type(profile_warehouse_t), intent(inout) :: profiles + + character(len=*), parameter :: my_name = "H2SO4 quantum yield constructor" + type(string_t) :: required_keys(5), optional_keys(6) + real(kind=dk), allocatable :: param_wavelengths(:) + type(grid_t), pointer :: wavelengths + integer :: i_param, i_wl + + required_keys(1) = "type" + required_keys(2) = "parameterized wavelengths" + required_keys(3) = "collision interval s" + required_keys(4) = "molecular diameter m" + required_keys(5) = "molecular weight kg mol-1" + optional_keys(1) = "netcdf files" + optional_keys(2) = "lower extrapolation" + optional_keys(3) = "upper extrapolation" + optional_keys(4) = "name" + optional_keys(5) = "constant value" + optional_keys(6) = "override bands" + call assert_msg( 157064056, & + config%validate( required_keys, optional_keys ), & + "Bad configration data format for H2SO4 quantum yield." ) + allocate( this ) + call base_constructor( this, config, grids, profiles ) + + call config%get( "parameterized wavelengths", param_wavelengths, my_name ) + call config%get( "collision interval s", this%collision_rate_, & + my_name ) + this%collision_rate_(:) = 1.0_dk / this%collision_rate_(:) + call config%get( "molecular diameter m", this%molecular_diameter_, & + my_name ) + call config%get( "molecular weight kg mol-1", this%molecular_weight_, & + my_name ) + call assert_msg( 472700337, size( param_wavelengths ) .eq. & + size( this%collision_rate_ ), & + "Size mismatch between parameterized wavelengths and "// & + "collision frequency in H2SO4 quantum yield calculator" ) + wavelengths => grids%get_grid( "wavelength", "nm" ) + allocate( this%wavelength_indices_( size( param_wavelengths ) ) ) + this%wavelength_indices_(:) = 0 + do i_param = 1, size( param_wavelengths ) + do i_wl = 1, wavelengths%ncells_ + if( wavelengths%mid_( i_wl ) .eq. param_wavelengths( i_param ) ) then + this%wavelength_indices_( i_param ) = i_wl + exit + end if + end do + call assert_msg( 170811868, this%wavelength_indices_( i_param ) > 0, & + "Parameterized wavelength in H2SO4 quantum yield "// & + "configuration not on wavelength grid: "// & + trim( to_char( param_wavelengths( i_param ) ) ) ) + end do + deallocate( wavelengths ) + + end function constructor + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Calculates the quantum yield + function calculate( this, grid_warehouse, profile_warehouse ) & + result( quantum_yield ) + + use tuvx_constants, only : gas_constant, Avogadro, pi + use tuvx_grid, only : grid_t + use tuvx_grid_warehouse, only : grid_warehouse_t + use tuvx_profile, only : profile_t + use tuvx_profile_warehouse, only : profile_warehouse_t + + class(quantum_yield_h2so4_mills_t), intent(in) :: this + type(grid_warehouse_t), intent(inout) :: grid_warehouse + type(profile_warehouse_t), intent(inout) :: profile_warehouse + real(dk), allocatable :: quantum_yield(:,:) + + class(profile_t), pointer :: temperature, air + integer :: i_wl + real(dk) :: lambda, velocity + + quantum_yield = & + this%quantum_yield_t%calculate( grid_warehouse, profile_warehouse ) + temperature => profile_warehouse%get_profile( this%temperature_profile_ ) + air => profile_warehouse%get_profile( this%air_profile_ ) + + ! Overwrite the quantum yields for the parameterized wavelengths + do i_wl = 1, size( this%wavelength_indices_ ) + quantum_yield( :, this%wavelength_indices_( i_wl ) ) = & + this%collision_rate_( i_wl ) / & + ( this%collision_rate_( i_wl ) + & + sqrt( 16.0_dk * gas_constant * temperature%edge_val_(:) & + / ( pi * this%molecular_weight_ ) ) & + * ( pi * this%molecular_diameter_**2 * & + air%edge_val_(:) * 1.0e6_dk ) ) + end do + ! The top layer has quantum yields set to 1.0 + quantum_yield( size( quantum_yield, dim=1 ), & + this%wavelength_indices_(:) ) = 1.0_dk + + deallocate( temperature ) + deallocate( air ) + + end function calculate + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Returns the number of bytes required to pack the object onto a buffer + integer function pack_size( this, comm ) + + use musica_mpi, only : musica_mpi_pack_size + + !> Quantum yield to be packed + class(quantum_yield_h2so4_mills_t), intent(in) :: this + !> MPI communicator + integer, intent(in) :: comm + +#ifdef MUSICA_USE_MPI + pack_size = this%quantum_yield_t%pack_size( comm ) + & + musica_mpi_pack_size( this%wavelength_indices_, comm ) + & + musica_mpi_pack_size( this%collision_rate_, comm ) + & + musica_mpi_pack_size( this%molecular_diameter_, comm ) + & + musica_mpi_pack_size( this%molecular_weight_, comm ) +#else + pack_size = 0 +#endif + + end function pack_size + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Packs the quantum yield onto a character buffer + subroutine mpi_pack( this, buffer, position, comm ) + + use musica_assert, only : assert + use musica_mpi, only : musica_mpi_pack + + !> Quantum yield to pack + class(quantum_yield_h2so4_mills_t), intent(in) :: this + !> Memory buffer + character, intent(inout) :: buffer(:) + !> Current buffer position + integer, intent(inout) :: position + !> MPI communicator + integer, intent(in) :: comm + +#ifdef MUSICA_USE_MPI + integer :: prev_pos + + prev_pos = position + call this%quantum_yield_t%mpi_pack( buffer, position, comm ) + call musica_mpi_pack( buffer, position, this%wavelength_indices_, comm ) + call musica_mpi_pack( buffer, position, this%collision_rate_, comm ) + call musica_mpi_pack( buffer, position, this%molecular_diameter_, comm ) + call musica_mpi_pack( buffer, position, this%molecular_weight_, comm ) + call assert( 931898871, position - prev_pos <= this%pack_size( comm ) ) +#endif + + end subroutine mpi_pack + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Unpacks a quantum yield calculator from a character buffer + subroutine mpi_unpack( this, buffer, position, comm ) + + use musica_assert, only : assert + use musica_mpi, only : musica_mpi_unpack + + !> Quantum yield to unpack + class(quantum_yield_h2so4_mills_t), intent(out) :: this + !> Memory buffer + character, intent(inout) :: buffer(:) + !> Current buffer position + integer, intent(inout) :: position + !> MPI communicator + integer, intent(in) :: comm + +#ifdef MUSICA_USE_MPI + integer :: prev_pos + + prev_pos = position + call this%quantum_yield_t%mpi_unpack( buffer, position, comm ) + call musica_mpi_unpack( buffer, position, this%wavelength_indices_, comm ) + call musica_mpi_unpack( buffer, position, this%collision_rate_, comm ) + call musica_mpi_unpack( buffer, position, this%molecular_diameter_, comm ) + call musica_mpi_unpack( buffer, position, this%molecular_weight_, comm ) + call assert( 237836163, position - prev_pos <= this%pack_size( comm ) ) +#endif + + end subroutine mpi_unpack + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +end module tuvx_quantum_yield_h2so4_mills \ No newline at end of file diff --git a/src/quantum_yields/taylor_series.F90 b/src/quantum_yields/taylor_series.F90 new file mode 100644 index 00000000..7ed16c68 --- /dev/null +++ b/src/quantum_yields/taylor_series.F90 @@ -0,0 +1,99 @@ +! Copyright (C) 2024 National Center for Atmospheric Research +! SPDX-License-Identifier: Apache-2.0 + +module tuvx_quantum_yield_taylor_series + ! A quantum yield calculator based on a Taylor series + + use musica_config, only : config_t + use tuvx_quantum_yield, only : quantum_yield_t, base_constructor + + implicit none + + private + public :: quantum_yield_taylor_series_t + + type, extends(quantum_yield_t) :: quantum_yield_taylor_series_t + ! Calculator of quantum yields using a Taylor series + contains + end type quantum_yield_taylor_series_t + + interface quantum_yield_taylor_series_t + module procedure :: constructor + end interface quantum_yield_taylor_series_t + +contains + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + function constructor( config, grid_warehouse, profile_warehouse ) & + result( this ) + ! Constructor + + use musica_assert, only : assert_msg + use musica_constants, only : dk => musica_dk + use musica_string, only : string_t + use tuvx_grid, only : grid_t + use tuvx_grid_warehouse, only : grid_warehouse_t + use tuvx_profile_warehouse, only : profile_warehouse_t + + class(quantum_yield_t), pointer :: this ! This :f:type:`~tuvx_quantum_yield/quantum_yield_t` calculator + type(config_t), intent(inout) :: config ! Quantum yield configuration data + type(grid_warehouse_t), intent(inout) :: grid_warehouse ! A :f:type:`~tuvx_grid_warehouse/grid_warehouse_t` + type(profile_warehouse_t), intent(inout) :: profile_warehouse ! A :f:type:`~tuvx_profile_warehouse/profile_warehouse_t` + + character(len=*), parameter :: my_name = "Taylor-series quantum yield constructor" + type(string_t) :: required_keys(1), optional_keys(9) + real(kind=dk) :: min_wl, max_wl + class(grid_t), pointer :: wavelengths + real(kind=dk), allocatable :: coeff(:) + integer :: i_wl, i_coeff + + required_keys(1) = "coefficients" + optional_keys(1) = "type" + optional_keys(2) = "netcdf files" + optional_keys(3) = "lower extrapolation" + optional_keys(4) = "upper extrapolation" + optional_keys(5) = "name" + optional_keys(6) = "constant value" + optional_keys(7) = "override bands" + optional_keys(8) = "minimum wavelength" + optional_keys(9) = "maximum wavelength" + + allocate( quantum_yield_taylor_series_t :: this ) + + call assert_msg( 268043622, & + config%validate( required_keys, optional_keys ), & + "Bad configuration for Taylor-series quantum yield." ) + call base_constructor( this, config, grid_warehouse, profile_warehouse ) + + call config%get( "coefficients", coeff, my_name ) + call assert_msg( 589032591, size( coeff ) .ge. 1, & + "Taylor-series quantum yield must have at least one "// & + "coefficient.") + call config%get( "minimum wavelength", min_wl, my_name, default = 0.0_dk ) + call config%get( "maximum wavelength", max_wl, my_name, & + default = huge(1.0_dk) ) + wavelengths => grid_warehouse%get_grid( this%wavelength_grid_ ) + call assert_msg( 401342404, size( this%quantum_yield_parms ) .eq. 1, & + "Taylor-series quantum yield cannot be used with "// & + "multiple data files" ) + associate( params => this%quantum_yield_parms(1)%array ) + do i_wl = 1, wavelengths%ncells_ + if( wavelengths%mid_( i_wl ) .lt. min_wl .or. & + wavelengths%mid_( i_wl ) .gt. max_wl ) cycle + params( i_wl, 1 ) = coeff(1) + do i_coeff = 2, size( coeff ) + params( i_wl, 1 ) = params( i_wl, 1 ) + & + coeff( i_coeff ) & + * wavelengths%mid_( i_wl )**( i_coeff - 1 ) + end do + params( i_wl, 1 ) = max( 0.0, min( 1.0, params( i_wl, 1 ) ) ) + end do + end associate + deallocate( wavelengths ) + + end function constructor + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +end module tuvx_quantum_yield_taylor_series \ No newline at end of file diff --git a/src/radiative_transfer/radiative_transfer.F90 b/src/radiative_transfer/radiative_transfer.F90 index edece329..50f02daf 100644 --- a/src/radiative_transfer/radiative_transfer.F90 +++ b/src/radiative_transfer/radiative_transfer.F90 @@ -4,13 +4,26 @@ module tuvx_radiative_transfer ! A calculator for atmospheric radiation - use musica_config, only : config_t - use musica_constants, only : dk => musica_dk - use tuvx_cross_section_warehouse, only : cross_section_warehouse_t - use tuvx_profile_warehouse, only : profile_warehouse_ptr - use tuvx_radiator_warehouse, only : radiator_warehouse_t, & - radiator_warehouse_ptr - use tuvx_solver, only : solver_t + use musica_assert, only : assert, assert_msg, die_msg + use musica_config, only : config_t + use musica_constants, only : dk => musica_dk + use musica_mpi, only : musica_mpi_pack, musica_mpi_pack_size, musica_mpi_unpack + use musica_string, only : string_t + use tuvx_cross_section_warehouse, only : cross_section_warehouse_t + use tuvx_grid_warehouse, only : grid_warehouse_t + use tuvx_grid_warehouse, only : grid_warehouse_t + use tuvx_la_sr_bands, only : la_sr_bands_t + use tuvx_profile, only : profile_t + use tuvx_profile_warehouse, only : profile_warehouse_ptr, profile_warehouse_t + use tuvx_radiator, only : radiator_state_t, radiator_t + use tuvx_radiator_from_host, only : radiator_updater_t + use tuvx_radiator_warehouse, only : radiator_warehouse_t, radiator_warehouse_ptr + use tuvx_radiator_warehouse, only : warehouse_iterator_t + use tuvx_solver, only : solver_t, radiation_field_t + use tuvx_solver_factory, only : solver_allocate, solver_builder, solver_type_name + use tuvx_spherical_geometry, only : spherical_geometry_t + + implicit none private @@ -58,12 +71,6 @@ function constructor( config, grid_warehouse, profile_warehouse, radiators )& result( this ) ! Initializes the components necessary to solve radiative transfer - use musica_assert, only : assert_msg, die_msg - use musica_string, only : string_t - use tuvx_grid_warehouse, only : grid_warehouse_t - use tuvx_profile_warehouse, only : profile_warehouse_t - use tuvx_solver_factory, only : solver_builder - type(radiative_transfer_t), pointer :: this ! New :f:type:`~tuvx_radiative_transfer/radxfer_component_core_t` type(config_t), intent(inout) :: config ! radXfer configuration data type(grid_warehouse_t), intent(inout) :: grid_warehouse ! A :f:type:`~tuvx_grid_warehouse/grid_warehouse_t` @@ -119,7 +126,6 @@ end function constructor type(string_t) function component_name( this ) ! Model component name - use musica_string, only : string_t class(radiative_transfer_t), intent(in) :: this ! A :f:type:`~tuvx_radiative_transfer/radxfer_component_core_t` @@ -132,7 +138,6 @@ end function component_name type(string_t) function description( this ) ! Model component description - use musica_string, only : string_t class(radiative_transfer_t), intent(in) :: this ! A :f:type:`~tuvx_radiative_transfer/radxfer_component_core_t` @@ -146,17 +151,6 @@ subroutine calculate( this, la_srb, spherical_geometry, grid_warehouse, & profile_warehouse, radiation_field ) ! Calculate the radiation field - use musica_assert, only : die_msg - use tuvx_grid_warehouse, only : grid_warehouse_t - use tuvx_radiator_warehouse, only : warehouse_iterator_t - use tuvx_radiator, only : radiator_t - use tuvx_radiator, only : radiator_state_t - use tuvx_profile, only : profile_t - use tuvx_profile_warehouse, only : profile_warehouse_t - use tuvx_spherical_geometry, only : spherical_geometry_t - use tuvx_la_sr_bands, only : la_sr_bands_t - use tuvx_solver, only : radiation_field_t - class(radiative_transfer_t), intent(inout) :: this ! A :f:type:`~tuvx_radiative_transfer/radxfer_component_core_t` type(grid_warehouse_t), intent(inout) :: grid_warehouse ! :f:type:`~tuvx_grid_warehouse/grid_warehouse_t` type(profile_warehouse_t), intent(inout) :: profile_warehouse ! A :f:type:`~tuvx_profile_warehouse/profile_warehouse_t` @@ -221,10 +215,6 @@ function get_radiator_updater( this, radiator, found ) result( updater ) ! If the optional `found` flag is omitted, an error is returned if the ! radiator does not exist in TUV-x - use musica_assert, only : assert_msg - use tuvx_radiator, only : radiator_t - use tuvx_radiator_from_host, only : radiator_updater_t - class(radiative_transfer_t), intent(in) :: this ! Radiative transfer calculator class(radiator_t), intent(in) :: radiator ! The radiator to get an updater for logical, optional, intent(out) :: found ! Flag indicating whether the @@ -243,9 +233,6 @@ integer function pack_size( this, comm ) ! Returns the size of a character buffer required to pack the radiative ! transfer calculator - use musica_mpi, only : musica_mpi_pack_size - use musica_string, only : string_t - use tuvx_solver_factory, only : solver_type_name class(radiative_transfer_t), intent(inout) :: this ! radiative transfer to be packed integer, intent(in) :: comm ! MPI communicator @@ -272,11 +259,6 @@ end function pack_size subroutine mpi_pack( this, buffer, position, comm ) ! Packs the radiative transfer calculator onto a character buffer - use musica_assert, only : assert - use musica_mpi, only : musica_mpi_pack - use musica_string, only : string_t - use tuvx_solver_factory, only : solver_type_name - class(radiative_transfer_t), intent(inout) :: this ! radiative transfer to be packed character, intent(inout) :: buffer(:) ! memory buffer integer, intent(inout) :: position ! current buffer position @@ -306,10 +288,6 @@ end subroutine mpi_pack subroutine mpi_unpack( this, buffer, position, comm ) ! Unpacks a radiative transfer calculator from a character buffer - use musica_assert, only : assert, die_msg - use musica_string, only : string_t - use musica_mpi, only : musica_mpi_unpack - use tuvx_solver_factory, only : solver_allocate class(radiative_transfer_t), intent(out) :: this ! radiative transfer to be packed character, intent(inout) :: buffer(:) ! memory buffer diff --git a/src/radiative_transfer/radiator.F90 b/src/radiative_transfer/radiator.F90 index e586a3ad..1d99f8a5 100644 --- a/src/radiative_transfer/radiator.F90 +++ b/src/radiative_transfer/radiator.F90 @@ -4,11 +4,22 @@ module tuvx_radiator ! Represents an atmospheric constituent that affects radiative transfer calculations by absorbing or scattering radiation - use musica_constants, only : dk => musica_dk - use musica_string, only : string_t - use tuvx_cross_section_warehouse, only : cross_section_warehouse_ptr - use tuvx_grid_warehouse, only : grid_warehouse_ptr - use tuvx_profile_warehouse, only : profile_warehouse_ptr + use musica_assert, only : assert, assert_msg + use musica_config, only : config_t + use musica_constants, only : dk => musica_dk + use musica_mpi, only : musica_mpi_pack, musica_mpi_pack_size, musica_mpi_unpack + use musica_string, only : string_t + use tuvx_constants, only : largest, precis + use tuvx_cross_section, only : cross_section_t + use tuvx_cross_section_warehouse, only : cross_section_warehouse_ptr + use tuvx_cross_section_warehouse, only : cross_section_warehouse_t + use tuvx_diagnostic_util, only : diagout + use tuvx_grid, only : grid_t + use tuvx_grid_warehouse, only : grid_warehouse_ptr + use tuvx_grid_warehouse, only : grid_warehouse_t + use tuvx_profile, only : profile_t + use tuvx_profile_warehouse, only : profile_warehouse_ptr + use tuvx_profile_warehouse, only : profile_warehouse_t implicit none @@ -79,11 +90,6 @@ function constructor( config, grid_warehouse, profile_warehouse, & cross_section_warehouse ) result( new_radiator ) ! Constructs a base_radiator_t object - use musica_config, only : config_t - use tuvx_cross_section_warehouse, only : cross_section_warehouse_t - use tuvx_grid_warehouse, only : grid_warehouse_t - use tuvx_profile_warehouse, only : profile_warehouse_t - class(radiator_t), pointer :: new_radiator ! New :f:type:`~tuvx_radiator/radiator_t` object type(config_t), intent(inout) :: config ! Radiator configuration type(grid_warehouse_t), intent(inout) :: grid_warehouse ! A :f:type:`~tuvx_grid_warehouse/grid_warehouse_t` @@ -103,13 +109,6 @@ subroutine base_constructor( this, config, grid_warehouse, & ! ! This should only be called by subclasses of radiator_t - use musica_assert, only : assert_msg - use musica_config, only : config_t - use tuvx_cross_section_warehouse, only : cross_section_warehouse_t - use tuvx_grid_warehouse, only : grid_warehouse_t - use tuvx_grid, only : grid_t - use tuvx_profile_warehouse, only : profile_warehouse_t - class(radiator_t), intent(inout) :: this ! New :f:type:`~tuvx_radiator/radiator_t` object type(config_t), intent(inout) :: config ! Radiator configuration type(grid_warehouse_t), intent(inout) :: grid_warehouse ! A :f:type:`~tuvx_grid_warehouse/grid_warehouse_t` @@ -175,15 +174,6 @@ subroutine update_state( this, grid_warehouse, profile_warehouse, & cross_section_warehouse ) ! Update radiator state - use musica_assert, only : assert_msg - use tuvx_cross_section, only : cross_section_t - use tuvx_cross_section_warehouse, only : cross_section_warehouse_t - use tuvx_diagnostic_util, only : diagout - use tuvx_grid, only : grid_t - use tuvx_grid_warehouse, only : grid_warehouse_t - use tuvx_profile, only : profile_t - use tuvx_profile_warehouse, only : profile_warehouse_t - class(radiator_t), intent(inout) :: this ! A :f:type:`~tuvx_radiator/radiator_state_t` type(grid_warehouse_t), intent(inout) :: grid_warehouse ! A :f:type:`~tuvx_grid_warehouse/grid_warehouse_t` type(profile_warehouse_t), intent(inout) :: profile_warehouse ! A :f:type:`~tuvx_profile_warehouse/profile_warehouse_t` @@ -246,7 +236,6 @@ end subroutine update_state !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine output_diagnostics( this ) - use tuvx_diagnostic_util, only : diagout class(radiator_t), intent(in) :: this ! A :f:type:`~tuvx_radiator/radiator_state_t` character(len=:), allocatable :: filename @@ -273,7 +262,6 @@ end subroutine output_diagnostics integer function pack_size( this, comm ) ! Returns the size of a character buffer required to pack the radiator - use musica_mpi, only : musica_mpi_pack_size class(radiator_t), intent(in) :: this ! radiator to be packed integer, intent(in) :: comm ! MPI communicator @@ -302,9 +290,6 @@ end function pack_size subroutine mpi_pack( this, buffer, position, comm ) ! Packs the radiator onto a character buffer - use musica_assert, only : assert - use musica_mpi, only : musica_mpi_pack - class(radiator_t), intent(in) :: this ! radiator to be packed character, intent(inout) :: buffer(:) ! memory buffer integer, intent(inout) :: position ! current buffer position @@ -336,9 +321,6 @@ end subroutine mpi_pack subroutine mpi_unpack( this, buffer, position, comm ) ! Unpacks a radiator from a character buffer - use musica_assert, only : assert - use musica_mpi, only : musica_mpi_unpack - class(radiator_t), intent(out) :: this ! radiator to be unpacked character, intent(inout) :: buffer(:) ! memory buffer integer, intent(inout) :: position ! current buffer position @@ -375,7 +357,6 @@ subroutine accumulate( this, radiators ) ! ! Optical properties for radiators configured to 'treat as air' are ! unique. - use tuvx_constants, only : largest, precis class(radiator_state_t), intent(inout) :: this class(radiator_ptr), intent(in) :: radiators(:) @@ -476,9 +457,6 @@ end function state_pack_size subroutine state_mpi_pack( this, buffer, position, comm ) ! Packs the radiator state onto a character buffer - use musica_assert, only : assert - use musica_mpi, only : musica_mpi_pack - class(radiator_state_t), intent(in) :: this ! radiator state to be packed character, intent(inout) :: buffer(:) ! memory buffer integer, intent(inout) :: position ! current buffer position @@ -501,9 +479,6 @@ end subroutine state_mpi_pack subroutine state_mpi_unpack( this, buffer, position, comm ) ! Unpacks a radiator state from a character buffer - use musica_assert, only : assert - use musica_mpi, only : musica_mpi_unpack - class(radiator_state_t), intent(out) :: this ! radiator state to be unpacked character, intent(inout) :: buffer(:) ! memory buffer integer, intent(inout) :: position ! current buffer position diff --git a/src/tuvx.F90 b/src/tuvx.F90 index e0e63126..b56a6602 100644 --- a/src/tuvx.F90 +++ b/src/tuvx.F90 @@ -139,11 +139,13 @@ subroutine run_tuvx( ) class(profile_t), pointer :: earth_sun_distance ! [AU] real(dk), allocatable :: photo_rates(:,:,:) ! (time, vertical level, reaction) [s-1] real(dk), allocatable :: dose_rates(:,:,:) ! (time, vertical level, dose rate) [?] + real(dk), allocatable :: heating_rates(:,:,:) ! (vertical level, reaction, thread) [K s-1] real(dk), allocatable :: thread_photo_rates(:,:,:) ! (vertical level, reaction, thread) [s-1] real(dk), allocatable :: thread_dose_rates(:,:,:) ! (vertical level, dose rate, thread) [?] + real(dk), allocatable :: thread_heating_rates(:,:,:)! (vertical level, reaction, thread) [K s-1] type(string_t) :: file_path character(len=2) :: diagnostic_label - class(output_t), pointer :: photo_output, dose_output + class(output_t), pointer :: photo_output, dose_output, heating_output type(config_t) :: config height => core%get_grid( "height", "km" ) @@ -161,10 +163,15 @@ subroutine run_tuvx( ) allocate( dose_rates( sza%ncells_ + 1, & height%ncells_ + 1, & core%number_of_dose_rates( ) ) ) + allocate( heating_rates( sza%ncells_ + 1, & + height%ncells_ + 1, & + core%number_of_heating_rates( ) ) ) + ! set up output files nullify( photo_output ) nullify( dose_output ) + nullify( heating_output ) if( core%number_of_photolysis_reactions( ) > 0 ) then call config%empty( ) call config%add( "file path", "photolysis_rate_constants.nc", Iam ) @@ -179,6 +186,13 @@ subroutine run_tuvx( ) call config%add( "tuv-x configuration", tuvx_config, Iam ) dose_output => output_t( config, core ) end if + if( core%number_of_heating_rates( ) > 0 ) then + call config%empty( ) + call config%add( "file path", "heating_rates.nc", Iam ) + call config%add( "include heating rates", .true., Iam ) + call config%add( "tuv-x configuration", tuvx_config, Iam ) + heating_output => output_t( config, core ) + end if ! calculate photolysis and dose rates do i_sza = 1, sza%ncells_ + 1 @@ -187,6 +201,7 @@ subroutine run_tuvx( ) earth_sun_distance%edge_val_( i_sza ), & photolysis_rate_constants = photo_rates( i_sza, :, : ), & dose_rates = dose_rates( i_sza, :, : ), & + heating_rates = heating_rates( i_sza, :, : ), & diagnostic_label = diagnostic_label ) ! output results @@ -204,6 +219,13 @@ subroutine run_tuvx( ) solar_zenith_angle = sza%edge_val_( i_sza ), & earth_sun_distance = earth_sun_distance%edge_val_( i_sza ) ) end if + if( associated( heating_output ) ) then + call heating_output%output( i_sza, core, & + heating_rates = heating_rates( i_sza, : , : ), & + time = time%edge_( i_sza ), & + solar_zenith_angle = sza%edge_val_( i_sza ), & + earth_sun_distance = earth_sun_distance%edge_val_( i_sza ) ) + end if end do deallocate( height ) @@ -212,6 +234,7 @@ subroutine run_tuvx( ) deallocate( earth_sun_distance ) if( associated( photo_output ) ) deallocate( photo_output ) if( associated( dose_output ) ) deallocate( dose_output ) + if( associated( heating_output ) ) deallocate( heating_output ) #if MUSICA_USE_OPENMP ! Compare results from threads for fixed solar zenith angle @@ -221,15 +244,20 @@ subroutine run_tuvx( ) allocate( thread_dose_rates( size( dose_rates, 2 ), & size( dose_rates, 3 ), & omp_get_max_threads( ) ) ) + allocate( thread_heating_rates( size( heating_rates, 2 ), & + size( heating_rates, 3 ), & + omp_get_max_threads( ) ) ) !$omp parallel & !$omp shared( threads, thread_photo_rates, thread_dose_rates ) associate( thread => threads( omp_get_thread_num( ) + 1 ), & photos => thread_photo_rates(:,:, omp_get_thread_num( ) + 1 ), & - doses => thread_dose_rates( :,:, omp_get_thread_num( ) + 1 ) ) + doses => thread_dose_rates( :,:, omp_get_thread_num( ) + 1 ), & + heat => thread_heating_rates( :,:, omp_get_thread_num( ) + 1 ) ) call thread%core_%run( 40.0_dk, & 1.0_dk, & photolysis_rate_constants = photos, & - dose_rates = doses ) + dose_rates = doses, & + heating_rates = heat ) end associate !$omp end parallel @@ -249,6 +277,13 @@ subroutine run_tuvx( ) "Thread result mismatch for thread "// & to_char( i_thread ) ) end do + do i_photo = 1, size( thread_heating_rates, 2 ) + call assert_msg( 389419926, & + thread_heating_rates( i_level, i_photo, i_thread ) & + .eq. thread_heating_rates( i_level, i_photo, 1 ), & + "Thread result mismatch for thread "// & + to_char( i_thread ) ) + end do end do end do #endif diff --git a/src/util/CMakeLists.txt b/src/util/CMakeLists.txt new file mode 100644 index 00000000..4d0e4407 --- /dev/null +++ b/src/util/CMakeLists.txt @@ -0,0 +1,21 @@ +###################################################################### +# Utility source + +target_sources(tuvx_object + PRIVATE + array.F90 + assert.F90 + config.F90 + config.cpp + constants.F90 + iterator.F90 + io.F90 + map.F90 + mpi.F90 + string.F90 + yaml_util.F90 +) + +add_subdirectory(io) + +###################################################################### diff --git a/src/util/array.F90 b/src/util/array.F90 new file mode 100644 index 00000000..18e3c40c --- /dev/null +++ b/src/util/array.F90 @@ -0,0 +1,368 @@ +! Copyright (C) 2020 National Center for Atmospheric Research +! SPDX-License-Identifier: Apache-2.0 +! +!> \file +!> The musica_array module + +!> Functions for working with allocatable arrays +module musica_array + + use musica_constants, only : musica_ik, musica_dk + + implicit none + private + + public :: find_string_in_array, find_string_in_split_array, & + merge_series, calculate_linear_array, calculate_logarithmic_array + + ! Find a string in an array of strings + interface find_string_in_array + module procedure :: find_string_in_array_string + module procedure :: find_string_in_array_char + end interface find_string_in_array + + ! Find a string in an array of split strings + interface find_string_in_split_array + module procedure :: find_string_in_split_array_string + module procedure :: find_string_in_split_array_char + end interface find_string_in_split_array + +contains + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Finds a string in a string array (case insensitive by default) + logical function find_string_in_array_char( array, string, id, & + case_sensitive ) + + use musica_string, only : string_t + + !> Array to search + type(string_t), intent(in) :: array(:) + !> String to search for + character(len=*), intent(in) :: string + !> Index of located string + integer(kind=musica_ik), intent(out) :: id + !> Do a case sensitive search + logical, intent(in), optional :: case_sensitive + + type(string_t) :: temp_string, array_string + integer :: i_str + logical :: is_case_sensitive + + is_case_sensitive = .false. + if( present( case_sensitive ) ) then + is_case_sensitive = case_sensitive + end if + id = 0 + find_string_in_array_char = .false. + temp_string = trim( string ) + if( .not. is_case_sensitive ) temp_string = temp_string%to_lower( ) + do i_str = 1, size( array ) + array_string = array( i_str ) + if( .not. is_case_sensitive ) array_string = array_string%to_lower( ) + if( temp_string .eq. array_string ) then + id = i_str + find_string_in_array_char = .true. + exit + end if + end do + + end function find_string_in_array_char + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Finds a string in an array ( case insensitive by default) + logical function find_string_in_array_string( array, string, id, & + case_sensitive ) + + use musica_string, only : string_t + + !> Array to search + type(string_t), intent(in) :: array(:) + !> String to search for + type(string_t), intent(in) :: string + !> Index of located string + integer(kind=musica_ik), intent(out) :: id + !> Do a case sensitive search + logical, intent(in), optional :: case_sensitive + + find_string_in_array_string = find_string_in_array_char( array, & + string%to_char( ), id, case_sensitive ) + + end function find_string_in_array_string + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Find a string in an array of strings after splitting the array elements + !! + !! Case insensitive by default + logical function find_string_in_split_array_char( array, string, splitter, & + element_id, id, case_sensitive ) + + use musica_string, only : string_t + + !> Array to search + type(string_t), intent(in) :: array(:) + !> String to search for + character(len=*), intent(in) :: string + !> Splitting characters + character(len=*), intent(in) :: splitter + !> Element to compare in split strings + integer(kind=musica_ik), intent(in) :: element_id + !> Index of located string + integer(kind=musica_ik), intent(out) :: id + !> Do a case sensitive search + logical, intent(in), optional :: case_sensitive + + type(string_t) :: temp_string, array_string + type(string_t), allocatable :: split_string(:) + integer :: i_str + logical :: is_case_sensitive + + is_case_sensitive = .false. + if( present( case_sensitive ) ) then + is_case_sensitive = case_sensitive + end if + id = 0 + find_string_in_split_array_char = .false. + temp_string = trim( string ) + if( .not. is_case_sensitive ) temp_string = temp_string%to_lower( ) + do i_str = 1, size( array ) + array_string = array( i_str ) + if( .not. is_case_sensitive ) array_string = array_string%to_lower( ) + split_string = array_string%split( splitter ) + if( size( split_string ) .ge. element_id ) then + array_string = split_string( element_id ) + else + cycle + end if + if( temp_string .eq. array_string ) then + id = i_str + find_string_in_split_array_char = .true. + exit + end if + end do + + end function find_string_in_split_array_char + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Find a string in an array of strings after splitting the array elements + !! + !! Case insensitive by default + logical function find_string_in_split_array_string( array, string, splitter, & + element_id, id, case_sensitive ) + + use musica_string, only : string_t + + !> Array to search + type(string_t), intent(in) :: array(:) + !> String to search for + type(string_t), intent(in) :: string + !> Splitting characters + character(len=*), intent(in) :: splitter + !> Element to compare in split strings + integer(kind=musica_ik), intent(in) :: element_id + !> Index of located string + integer(kind=musica_ik), intent(out) :: id + !> Do a case sensitive search + logical, intent(in), optional :: case_sensitive + + find_string_in_split_array_string = & + find_string_in_split_array_char( array, string%to_char( ), splitter, & + element_id, id, case_sensitive ) + + end function find_string_in_split_array_string + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Merge two sets of values into a single set without duplicates + !! + !! Both sets must be arranged in increasing order + !! + function merge_series( a, b, with_bounds_from ) result( new_set ) + + !> New series + real(kind=musica_dk), allocatable :: new_set(:) + !> First series + real(kind=musica_dk), intent(in) :: a(:) + !> Second series + real(kind=musica_dk), intent(in) :: b(:) + !> Restricts series to bounds in this array + real(kind=musica_dk), intent(in), optional :: with_bounds_from(:) + + real(kind=musica_dk) :: curr_val, val_a, val_b, min_val, max_val + integer :: n_total, i_a, i_b, n_a, n_b + + if( present( with_bounds_from ) ) then + min_val = with_bounds_from( 1 ) + max_val = with_bounds_from( size( with_bounds_from ) ) + else + min_val = -huge( 0.0_musica_dk ) + max_val = huge( 0.0_musica_dk ) + endif + + n_a = size( a ) + n_b = size( b ) + if( n_a + n_b .eq. 0 ) then + allocate( new_set( 0 ) ) + return + end if + + curr_val = huge( 1.0_musica_dk ) + if( n_a .gt. 0 ) curr_val = a( 1 ) + if( n_b .gt. 0 ) then + if( b( 1 ) .lt. curr_val ) curr_val = b( 1 ) + end if + if( curr_val .lt. min_val ) curr_val = min_val + if( curr_val .gt. max_val ) curr_val = max_val + + i_a = 1 + i_b = 1 + n_total = 0 + do while( i_a .le. n_a ) + if( a( i_a ) .ge. min_val ) exit + i_a = i_a + 1 + end do + do while( i_b .le. n_b ) + if( b( i_b ) .ge. min_val ) exit + i_b = i_b + 1 + end do + do while( i_a .le. n_a .or. i_b .le. n_b ) + if( i_a .le. n_a ) then + val_a = a( i_a ) + if( val_a .gt. max_val ) then + i_a = n_a + 1 + cycle + end if + else + val_a = huge( 1.0_musica_dk ) + end if + if( i_b .le. n_b ) then + val_b = b( i_b ) + if( val_b .gt. max_val ) then + i_b = n_b + 1 + cycle + end if + else + val_b = huge( 1.0_musica_dk ) + end if + curr_val = min( val_a, val_b ) + n_total = n_total + 1 + if( val_a .le. curr_val ) i_a = i_a + 1 + if( val_b .le. curr_val ) i_b = i_b + 1 + end do + + allocate( new_set( n_total ) ) + + i_a = 1 + i_b = 1 + n_total = 0 + do while( i_a .le. n_a ) + if( a( i_a ) .ge. min_val ) exit + i_a = i_a + 1 + end do + do while( i_b .le. n_b ) + if( b( i_b ) .ge. min_val ) exit + i_b = i_b + 1 + end do + do while( i_a .le. n_a .or. i_b .le. n_b ) + if( i_a .le. n_a ) then + val_a = a( i_a ) + if( val_a .gt. max_val ) then + i_a = n_a + 1 + cycle + end if + else + val_a = huge( 1.0_musica_dk ) + end if + if( i_b .le. n_b ) then + val_b = b( i_b ) + if( val_b .gt. max_val ) then + i_b = n_b + 1 + cycle + end if + else + val_b = huge( 1.0_musica_dk ) + end if + curr_val = min( val_a, val_b ) + n_total = n_total + 1 + new_set( n_total ) = curr_val + if( val_a .le. curr_val ) i_a = i_a + 1 + if( val_b .le. curr_val ) i_b = i_b + 1 + end do + + end function merge_series + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Allocates and calculates an array of linearly increasing value with + !! specified minimum and maximum values and number of elements + function calculate_linear_array( minimum, maximum, number_of_elements ) & + result( new_array ) + + use musica_assert, only : assert + + !> Calculated array + real(kind=musica_dk), allocatable :: new_array(:) + !> Minimum array value + real(kind=musica_dk), intent(in) :: minimum + !> Maximum array value + real(kind=musica_dk), intent(in) :: maximum + !> Number of array elements + integer(kind=musica_ik), intent(in) :: number_of_elements + + integer(kind=musica_ik) :: i_elem + real(kind=musica_dk) :: space + + call assert( 167917803, maximum .gt. minimum ) + call assert( 211868975, number_of_elements .ge. 1 ) + allocate( new_array( number_of_elements ) ) + space = ( maximum - minimum ) / & + real( number_of_elements - 1, kind=musica_dk ) + new_array( 1 ) = minimum + do i_elem = 2, number_of_elements - 1 + new_array( i_elem ) = new_array( i_elem - 1 ) + space + end do + new_array( number_of_elements ) = maximum + + end function calculate_linear_array + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Allocates and calculates an array of logarithmically increasing value + !! with specified minimum and maximum values and number of elements + function calculate_logarithmic_array( minimum, maximum, number_of_elements )& + result( new_array ) + + use musica_assert, only : assert + + !> Calculated array + real(kind=musica_dk), allocatable :: new_array(:) + !> Minimum array value + real(kind=musica_dk), intent(in) :: minimum + !> Maximum array value + real(kind=musica_dk), intent(in) :: maximum + !> Number of array elements + integer(kind=musica_ik), intent(in) :: number_of_elements + + integer(kind=musica_ik) :: i_elem + real(kind=musica_dk) :: space + + call assert( 527530853, maximum .gt. minimum ) + call assert( 752167543, number_of_elements .gt. 1 ) + allocate( new_array( number_of_elements ) ) + space = ( log( maximum ) - log( minimum ) ) / & + real( number_of_elements - 1, kind=musica_dk ) + new_array( 1 ) = minimum + do i_elem = 2, number_of_elements - 1 + new_array( i_elem ) = exp( log( new_array( i_elem - 1 ) ) + space ) + end do + new_array( number_of_elements ) = maximum + + end function calculate_logarithmic_array + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +end module musica_array diff --git a/src/util/assert.F90 b/src/util/assert.F90 new file mode 100644 index 00000000..84e4fdb2 --- /dev/null +++ b/src/util/assert.F90 @@ -0,0 +1,478 @@ +! Portions Copyright (C) 2005-2016 Nicole Riemer and Matthew West +! Licensed under the GNU General Public License version 2 or (at your +! option) any later version. See the file COPYING for details. +! +! Portions Copyright (C) 2020 National Center for Atmospheric Research +! SPDX-License-Identifier: Apache-2.0 +! +!> \file +!> The musica_assert module. + +!> Assertion functions +module musica_assert + + implicit none + + !> Unit for error output files + integer, parameter :: kErrorFileId = 10 + !> Error output id + integer, parameter :: kErrorId = 0 + + interface assert_msg + procedure :: assert_msg_string + procedure :: assert_msg_char + end interface + + interface assert_warn_msg + procedure :: assert_warn_msg_string + procedure :: assert_warn_msg_char + end interface + + interface die_msg + procedure :: die_msg_string + procedure :: die_msg_char + end interface + + interface almost_equal + procedure :: almost_equal_complex_real + procedure :: almost_equal_complex_double + procedure :: almost_equal_real + procedure :: almost_equal_double + end interface + + interface are_equal + procedure :: compare_arrays_1D_real + procedure :: compare_arrays_2D_real + procedure :: compare_arrays_1D_double + procedure :: compare_arrays_2D_double + end interface + +contains + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Asserts condition to be true or fails with provided message + subroutine assert_msg_string( code, condition, error_message ) + + use musica_string, only : string_t + + !> Unique code for the assertion + integer, intent(in) :: code + !> Condition to evaluate + logical, intent(in) :: condition + !> Message to display on failure + type(string_t), intent(in) :: error_message + + character(len=50) :: str_code + + if( .not. condition ) then + write(str_code,'(i30)') code + write(kErrorId,*) "ERROR (Musica-"//trim( adjustl( str_code ) )//"): " & + //error_message%val_ + open( unit = kErrorFileId, file = "error.json", action = "WRITE" ) + write(kErrorFileId,'(A)') '{' + write(kErrorFileId,'(A)') ' "code" : "'//trim( adjustl( str_code ) )//'",' + write(kErrorFileId,'(A)') ' "message" : "'//error_message%val_//'"' + write(kErrorFileId,'(A)') '}' + close(kErrorFileId) + stop 3 + end if + + end subroutine assert_msg_string + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Asserts condition to be true or fails with provided message + subroutine assert_msg_char( code, condition, error_message ) + + !> Unique code for the assertion + integer, intent(in) :: code + !> Condition to evaluate + logical, intent(in) :: condition + !> Message to display on failure + character(len=*), intent(in) :: error_message + + character(len=50) :: str_code + + if( .not. condition ) then + write(str_code,'(i30)') code + write(kErrorId,*) "ERROR (Musica-"//trim( adjustl( str_code ) )//"): " & + //error_message + open( unit = kErrorFileId, file = "error.json", action = "WRITE" ) + write(kErrorFileId,'(A)') '{' + write(kErrorFileId,'(A)') ' "code" : "'//trim( adjustl( str_code ) )//'",' + write(kErrorFileId,'(A)') ' "message" : "'//error_message//'"' + write(kErrorFileId,'(A)') '}' + close(kErrorFileId) + stop 3 + end if + + end subroutine assert_msg_char + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Asserts condition to be true or fails + subroutine assert( code, condition ) + + !> Unique code for the assertion + integer, intent(in) :: code + !> Condition to evaluate + logical, intent(in) :: condition + + call assert_msg( code, condition, 'assertion failed' ) + + end subroutine assert + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Asserts condition to be true or prints a provided warning message + subroutine assert_warn_msg_string( code, condition, warning_message ) + + use musica_string, only : string_t + + !> Unique code for the assertion + integer, intent(in) :: code + !> Condition to evaluate + logical, intent(in) :: condition + !> Message to display on failure + type(string_t), intent(in) :: warning_message + + character(len=50) :: str_code + + if( .not. condition ) then + write(str_code,'(i30)') code + write(kErrorId,*) "WARNING (Musica-"//trim( adjustl( str_code ) )// & + "): "//warning_message%val_ + end if + + end subroutine assert_warn_msg_string + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Asserts condition to be true or prints a provided warning message + subroutine assert_warn_msg_char( code, condition, warning_message ) + + !> Unique code for the assertion + integer, intent(in) :: code + !> Condition to evaluate + logical, intent(in) :: condition + !> Message to display on failure + character(len=*), intent(in) :: warning_message + + character(len=50) :: str_code + + if( .not. condition ) then + write(str_code,'(i30)') code + write(kErrorId,*) "WARNING (Musica-"//trim( adjustl( str_code ) )// & + "): "//warning_message + end if + + end subroutine assert_warn_msg_char + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Errors immediately and prints a provided message + subroutine die_msg_string( code, error_message ) + + use musica_string, only : string_t + + !> Unique code for the failure + integer, intent(in) :: code + !> Message to display with failure + type(string_t), intent(in) :: error_message + + call assert_msg( code, .false., error_message ) + + end subroutine die_msg_string + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Errors immediately and prints a provided message + subroutine die_msg_char( code, error_message ) + + !> Unique code for the failure + integer, intent(in) :: code + !> Message to display with failure + character(len=*), intent(in) :: error_message + + call assert_msg( code, .false., error_message ) + + end subroutine die_msg_char + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Errors immediately + subroutine die( code ) + + !> Unique code for the failure + integer, intent(in) :: code + + call die_msg( code, "Internal error" ) + + end subroutine die + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Determines whether two real numbers are equal within a provided or + !! standard tolerance + logical function almost_equal_real( a, b, relative_tolerance, & + absolute_tolerance ) result( almost_equal ) + + use musica_constants, only : musica_rk + + !> First number to compare + real(kind=musica_rk), intent(in) :: a + !> Second number to compare + real(kind=musica_rk), intent(in) :: b + !> Relative tolerance + real(kind=musica_rk), intent(in), optional :: relative_tolerance + !> Absolute tolerance + real(kind=musica_rk), intent(in), optional :: absolute_tolerance + + real(kind=musica_rk) :: rel_tol, abs_tol + + rel_tol = 1.0e-10_musica_rk + abs_tol = 1.0e-30_musica_rk + if( present( relative_tolerance ) ) rel_tol = relative_tolerance + if( present( absolute_tolerance ) ) abs_tol = absolute_tolerance + + almost_equal = .false. + if( a .eq. b ) then + almost_equal = .true. + else + if( 2.0_musica_rk * abs( a - b ) / ( abs( a ) + abs( b ) ) & + .lt. rel_tol ) then + almost_equal = .true. + else if( abs( a - b ) .le. abs_tol ) then + almost_equal = .true. + end if + end if + + end function almost_equal_real + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Determines whether two real numbers are equal within a provided or + !! standard tolerance + logical function almost_equal_double( a, b, relative_tolerance, & + absolute_tolerance ) result( almost_equal ) + + use musica_constants, only : musica_dk + + !> First number to compare + real(kind=musica_dk), intent(in) :: a + !> Second number to compare + real(kind=musica_dk), intent(in) :: b + !> Relative tolerance + real(kind=musica_dk), intent(in), optional :: relative_tolerance + !> Absolute tolerance + real(kind=musica_dk), intent(in), optional :: absolute_tolerance + + real(kind=musica_dk) :: rel_tol, abs_tol + + rel_tol = 1.0e-10_musica_dk + abs_tol = 1.0e-30_musica_dk + if( present( relative_tolerance ) ) rel_tol = relative_tolerance + if( present( absolute_tolerance ) ) abs_tol = absolute_tolerance + + almost_equal = .false. + if( a .eq. b ) then + almost_equal = .true. + else + if( 2.0_musica_dk * dabs( a - b ) / ( dabs( a ) + dabs( b ) ) & + .lt. rel_tol ) then + almost_equal = .true. + else if( dabs( a - b ) .le. abs_tol ) then + almost_equal = .true. + end if + end if + + end function almost_equal_double + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Determines whether two complex numbers are equal within a provided or + !! standard tolerance + logical function almost_equal_complex_real( a, b, relative_tolerance, & + absolute_tolerance ) result( almost_equal ) + + use musica_constants, only : musica_rk + + !> First number to compare + complex(kind=musica_rk), intent(in) :: a + !> Second number to compare + complex(kind=musica_rk), intent(in) :: b + !> Relative tolerance + real(kind=musica_rk), intent(in), optional :: relative_tolerance + !> Absolute tolerance + real(kind=musica_rk), intent(in), optional :: absolute_tolerance + + real(kind=musica_rk) :: rel_tol, abs_tol + + rel_tol = 1.0e-10_musica_rk + abs_tol = 1.0e-30_musica_rk + if( present( relative_tolerance ) ) rel_tol = relative_tolerance + if( present( absolute_tolerance ) ) abs_tol = absolute_tolerance + + almost_equal = .false. + if( a .eq. b ) then + almost_equal = .true. + else + associate( ra => real( a ), ia => aimag( a ), & + rb => real( b ), ib => aimag( b ) ) + if( 2.0_musica_rk * abs( ra - rb ) / ( abs( ra ) + abs( rb ) ) & + .lt. rel_tol .and. & + 2.0_musica_rk * abs( ia - ib ) / ( abs( ia ) + abs( ib ) ) & + .lt. rel_tol ) then + almost_equal = .true. + else if( abs( ra - rb ) .le. abs_tol .and. & + abs( ia - ib ) .le. abs_tol ) then + almost_equal = .true. + end if + end associate + end if + + end function almost_equal_complex_real + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Determines whether two complex numbers are equal within a provided or + !! standard tolerance + logical function almost_equal_complex_double( a, b, relative_tolerance, & + absolute_tolerance ) result( almost_equal ) + + use musica_constants, only : musica_dk + + !> First number to compare + complex(kind=musica_dk), intent(in) :: a + !> Second number to compare + complex(kind=musica_dk), intent(in) :: b + !> Relative tolerance + real(kind=musica_dk), intent(in), optional :: relative_tolerance + !> Absolute tolerance + real(kind=musica_dk), intent(in), optional :: absolute_tolerance + + real(kind=musica_dk) :: rel_tol, abs_tol + + rel_tol = 1.0e-10_musica_dk + abs_tol = 1.0e-30_musica_dk + if( present( relative_tolerance ) ) rel_tol = relative_tolerance + if( present( absolute_tolerance ) ) abs_tol = absolute_tolerance + + almost_equal = .false. + if( a .eq. b ) then + almost_equal = .true. + else + associate( ra => real( a, kind=musica_dk ), ia => aimag( a ), & + rb => real( b, kind=musica_dk ), ib => aimag( b ) ) + if( 2.0_musica_dk * dabs( ra - rb ) / ( dabs( ra ) + dabs( rb ) ) & + .lt. rel_tol .and. & + 2.0_musica_dk * dabs( ia - ib ) / ( dabs( ia ) + dabs( ib ) ) & + .lt. rel_tol ) then + almost_equal = .true. + else if( dabs( ra - rb ) .le. abs_tol .and. & + dabs( ia - ib ) .le. abs_tol ) then + almost_equal = .true. + end if + end associate + end if + + end function almost_equal_complex_double + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Compares two 1D arrays for equality + logical pure function compare_arrays_1D_real( a, b ) result( equal ) + + use musica_constants, only : musica_rk + + !> First array to compare + real(kind=musica_rk), intent(in) :: a(:) + !> Second array to compare + real(kind=musica_rk), intent(in) :: b(:) + + integer :: i_elem + + equal = .false. + if( size( a ) .ne. size( b ) ) return + do i_elem = 1, size( a ) + if( a( i_elem ) .ne. b( i_elem ) ) return + end do + equal = .true. + + end function compare_arrays_1D_real + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Compares two 2D arrays for equality + logical pure function compare_arrays_2D_real( a, b ) result( equal ) + + use musica_constants, only : musica_rk + + !> First array to compare + real(kind=musica_rk), intent(in) :: a(:,:) + !> Second array to compare + real(kind=musica_rk), intent(in) :: b(:,:) + + integer :: i_elem + + equal = .false. + if( size( a, 1 ) .ne. size( b, 1 ) ) return + if( size( a, 2 ) .ne. size( b, 2 ) ) return + do i_elem = 1, size( a, 1 ) + if( .not. compare_arrays_1D_real( a(:,i_elem), b(:,i_elem) ) ) return + end do + equal = .true. + + end function compare_arrays_2D_real + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Compares two 1D arrays for equality + logical pure function compare_arrays_1D_double( a, b ) result( equal ) + + use musica_constants, only : musica_dk + + !> First array to compare + real(kind=musica_dk), intent(in) :: a(:) + !> Second array to compare + real(kind=musica_dk), intent(in) :: b(:) + + integer :: i_elem + + equal = .false. + if( size( a ) .ne. size( b ) ) return + do i_elem = 1, size( a ) + if( a( i_elem ) .ne. b( i_elem ) ) return + end do + equal = .true. + + end function compare_arrays_1D_double + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Compares two 2D arrays for equality + logical pure function compare_arrays_2D_double( a, b ) result( equal ) + + use musica_constants, only : musica_dk + + !> First array to compare + real(kind=musica_dk), intent(in) :: a(:,:) + !> Second array to compare + real(kind=musica_dk), intent(in) :: b(:,:) + + integer :: i_elem + + equal = .false. + if( size( a, 1 ) .ne. size( b, 1 ) ) return + if( size( a, 2 ) .ne. size( b, 2 ) ) return + do i_elem = 1, size( a, 1 ) + if( .not. compare_arrays_1D_double( a(:,i_elem), b(:,i_elem) ) ) return + end do + equal = .true. + + end function compare_arrays_2D_double + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +end module musica_assert diff --git a/src/util/config.F90 b/src/util/config.F90 new file mode 100644 index 00000000..b9480ddb --- /dev/null +++ b/src/util/config.F90 @@ -0,0 +1,1569 @@ +! Copyright (C) 2020 National Center for Atmospheric Research +! SPDX-License-Identifier: Apache-2.0 +! +!> \file +!> The musica_config module + +!> The config_t type and related functions +module musica_config + + use iso_c_binding + use musica_constants, only : musica_ik, musica_rk, musica_dk + use musica_iterator, only : iterator_t + use musica_yaml_util + + implicit none + private + + public :: config_t + + !> Model configuration data + !! + !! Instances of type \c config_t can be used to access model configuration + !! data in \c json format. If there is a need to use model configuration + !! in another format (e.g., XML) in the future, an abstract \c config_t + !! type could be set up, that this type and an XML-based type could extend. + !! The rest of the model code would be unaffected. + !! + !! It is assumed that most configuration datasets will be small enough that + !! returned subsets of configuration data can just be a copy of the original + !! data (instead of using a pointer to the start of the subset in the original + !! dataset, or something like this). This avoids ownership problems with + !! cleaning up the memory after a \c config_t object goes out of scope. + !! + !! Only use \c config_t objects during initialization. They are not designed + !! for efficiency. + !! + !! **IMPORTANT:** The order of elements is arbitrary. No user of a \c config_t + !! object can assume anything by the order of key-value pairs in the data. + !! This dataset: + !! \code{yaml} + !! foo: 1 + !! bar: 2 + !! foobar: 3 + !! \endcode + !! ... is the same as: + !! \code{yaml} + !! bar: 2 + !! foobar: 3 + !! foo: 1 + !! \endcode + !! + !! There is no guarantee that an iterator over the elements of a config_t + !! object will return them in the same order they exist in the original + !! file or string. + !! + !! Example of a config_t object generated from a file: + !! \code{f90} + !! use musica_config, only : config_t + !! use musica_constants, only : musica_dk, musica_ik + !! use musica_iterator, only : iterator_t + !! use musica_string, only : string_t + !! + !! character(len=*), parameter :: my_name = "config file example" + !! type(config_t) :: main_config, sub_config, sub_real_config + !! real(musica_dk) :: my_real + !! integer(musica_ik) :: my_int + !! type(string_t) :: my_string + !! class(iterator_t), pointer :: iter + !! logical :: found + !! + !! call main_config%from_file( 'data/config_example.yaml' ) + !! + !! ! this would fail with an error if 'a string' is not found + !! call main_config%get( "a string", my_string, my_name ) + !! write(*,*) "a string value: ", my_string + !! + !! ! add the found argument to avoid failure if the pair is not found + !! call main_config%get( "my int", my_int, my_name, found = found ) + !! if( found ) then + !! write(*,*) "my int value: ", my_int + !! else + !! write(*,*) "'my int' was not found" + !! end if + !! + !! ! when you get a subset of the properties, a new config_t object is + !! ! created containing the subset data. The two config_t objects are + !! ! independent of one another after this point. + !! call main_config%get( "other props", sub_config, my_name ) + !! call sub_config%get( "an int", my_int, my_name ) + !! write(*,*) "other props->an int value: ", my_int + !! + !! ! you can iterate over a set of key-value pairs. but remember that + !! ! the order is always arbitrary. you also must provide the right type + !! ! of variable for the values. + !! call main_config%get( "real props", sub_real_config, my_name ) + !! iter => sub_real_config%get_iterator( ) + !! do while( iter%next( ) ) + !! my_string = sub_real_config%key( iter ) + !! call sub_real_config%get( iter, my_real, my_name ) + !! write(*,*) my_string, " value: ", my_real + !! end do + !! + !! ! you can also get the number of child objects before iterating over + !! ! them, if you want to allocate an array or something first + !! write(*,*) "number of children: ", sub_real_config%number_of_children( ) + !! + !! ! you can add key-value pairs with the add function + !! call main_config%add( "my new int", 43, my_name ) + !! call main_config%get( "my new int", my_int, my_name ) + !! write(*,*) "my new int value: ", my_int + !! + !! ! clean up memory + !! deallocate( iter ) + !! \endcode + !! + !! `data/config_example.json`: + !! \code{yaml} + !! my int: 12 + !! other props: + !! some time [min]: 12 + !! a pressure [bar]: 103.4 + !! an int: 45 + !! real props: + !! foo: 14.2 + !! bar: 64.2 + !! foobar: 920.4 + !! a string: foo + !! \endcode + !! + !! Output: + !! \code{bash} + !! a string value: foo + !! my int value: 12 + !! other props->an int value: 45 + !! other props->some time value: 720.00000000000000 s + !! other props->a pressure value: 10340000.000000000 Pa + !! foo value: 14.199999999999999 + !! bar value: 64.200000000000003 + !! foobar value: 920.39999999999998 + !! number of children: 3 + !! my new int value: 43 + !! \endcode + !! + type :: config_t + private + !> Pointer to YAML node + type(c_ptr) :: node_ = c_null_ptr + contains + !> Empties the configuration + procedure :: empty + !> Loads a configuration with data from a file + procedure :: from_file => construct_from_file + !> Writes a configuration to a file + procedure :: to_file + !> Returns the number of child objects + procedure :: number_of_children + !> Gets an iterator for the configuration data + procedure :: get_iterator + !> Gets the key name for a key-value pair + procedure :: key + !> @name Gets some configuration data + !! + !! Each function includes optional \c found and \c default arguments. If + !! neither is included and the data are not found, execution is stopped + !! with an error message. + !! + !! If a \c default value is included and the data are not found, the + !! returned argument is set to this default value, otherwise it is set to + !! a standard default value. + !! + !! If the \c found argument is included and the data are found, \c found + !! is set to \c true, otherwise it is set to \c false. + !! @{ + procedure, private :: get_config + procedure, private :: get_string_string_default + procedure, private :: get_string + procedure, private :: get_int + procedure, private :: get_float + procedure, private :: get_double + procedure, private :: get_logical + procedure, private :: get_string_array + procedure, private :: get_double_array + procedure, private :: get_config_array + procedure, private :: get_from_iterator + procedure, private :: get_array_from_iterator + generic :: get => get_config, get_string, get_string_string_default, & + get_int, get_float, get_double, & + get_logical, get_string_array, get_double_array, & + get_config_array, get_from_iterator, & + get_array_from_iterator + !> @} + !> @name Adds a named piece of configuration data + !! @{ + procedure, private :: add_config + procedure, private :: add_char_array + procedure, private :: add_string + procedure, private :: add_int + procedure, private :: add_float + procedure, private :: add_double + procedure, private :: add_logical + procedure, private :: add_string_array + procedure, private :: add_double_array + procedure, private :: add_config_array + generic :: add => add_config, add_char_array, add_string, & + add_int, add_float, add_double, add_logical, & + add_string_array, add_double_array, add_config_array + !> @} + !> @name Assignment + !! @{ + procedure, private :: config_assign_config + procedure, private :: config_assign_string + procedure, private :: config_assign_char + procedure, private, pass(config) :: string_assign_config + generic :: assignment(=) => config_assign_config, config_assign_string, & + config_assign_char, string_assign_config + !> @} + !> Merges another config_t object into the config_t object + procedure :: merge_in + !> Validates the format of the configuration file + procedure :: validate + !> Print the raw contents of the configuration + procedure :: print => do_print + !> Returns the number of bytes required to pack the object onto a buffer + procedure :: pack_size + !> Packs the object onto a character buffer + procedure :: mpi_pack + !> Unpacks an object from a character buffer + procedure :: mpi_unpack + !> Cleans up memory + final :: finalize, finalize_1D_array + !> Find a JSON key by prefix + procedure, private :: find_by_prefix + end type config_t + + !> Configuration data iterator + type, extends(iterator_t) :: config_iterator_t + !> Pointer to the node to iterator over (owned by config_t) + type(c_ptr) :: node_ = c_null_ptr + !> Current iterator + type(c_ptr) :: curr_ = c_null_ptr + !> End pointer + type(c_ptr) :: end_ = c_null_ptr + contains + !> Advances to the next key-value pair + procedure :: next => iterator_next + !> Resets the iterator + procedure :: reset => iterator_reset + !> Clean up memory + final :: iterator_finalize + end type config_iterator_t + + +contains + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Empties the configuration + subroutine empty( this ) + + !> Configuration + class(config_t), intent(out) :: this + + call initialize_config_t( this ) + + end subroutine empty + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Constructs a configuration from a file + subroutine construct_from_file( this, file_name ) + + use musica_assert, only : die + + !> New configuration + class(config_t), intent(out) :: this + !> File name containing configuration data + character(len=*), intent(in) :: file_name + + character(len=1, kind=c_char), allocatable :: c_file_name(:) + + c_file_name = to_c_string( file_name ) + select type( this ) + type is( config_t ) + call finalize( this ) + class default + call die( 316253716 ) + end select + this%node_ = yaml_create_from_file_c( c_file_name ) + + end subroutine construct_from_file + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Writes a configuration to a file + subroutine to_file( this, file_name ) + + !> Configuration + class(config_t), intent(inout) :: this + !> File name to save configuration with + character(len=*), intent(in) :: file_name + + character(len=1, kind=c_char), allocatable :: c_file_name(:) + + c_file_name = to_c_string( file_name ) + call yaml_to_file_c( this%node_, c_file_name ) + + end subroutine to_file + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Returns the number of child objects + function number_of_children( this ) + + use musica_assert, only : assert + + !> Number of child objects + integer(kind=musica_ik) :: number_of_children + !> Configuration + class(config_t), intent(inout) :: this + + number_of_children = yaml_size_c( this%node_ ) + + end function number_of_children + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Gets an interator for the configuration data + function get_iterator( this ) + + use musica_assert, only : assert + + !> Pointer to the iterator + class(iterator_t), pointer :: get_iterator + !> Configuration + class(config_t), intent(in), target :: this + + call assert( 398295168, c_associated( this%node_ ) ) + allocate( config_iterator_t :: get_iterator ) + select type( iter => get_iterator ) + type is( config_iterator_t ) + iter%node_ = this%node_ + iter%end_ = yaml_end_c( this%node_ ) + iter%curr_ = c_null_ptr + end select + + end function get_iterator + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Gets the key name using an iterator + function key( this, iterator ) + + use musica_assert, only : assert, die_msg + use musica_string, only : string_t + + !> Key name + type(string_t) :: key + !> Configuration + class(config_t), intent(inout) :: this + !> Configuration iterator + class(iterator_t), intent(in) :: iterator + + type(string_t_c) :: c_key + + select type( iterator ) + class is( config_iterator_t ) + c_key = yaml_key_c( iterator%curr_ ) + key = to_f_string( c_key ) + call yaml_delete_string_c( c_key ) + class default + call die_msg( 790805324, "Config iterator type mismatch" ) + end select + + end function key + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Gets a subset of the configuration data + subroutine get_config( this, key, value, caller, default, found ) + + use musica_assert, only : die_msg + use musica_string, only : string_t + + !> Configuration + class(config_t), intent(inout) :: this + !> Key used to find value + character(len=*), intent(in) :: key + !> Returned value + class(config_t), intent(out) :: value + !> Name of the calling function (only for use in error messages) + character(len=*), intent(in) :: caller + !> Default value if not found + class(config_t), intent(in), optional :: default + !> Flag indicating whether key was found + logical, intent(out), optional :: found + + logical(kind=c_bool) :: l_found + + value%node_ = yaml_get_node_c( this%node_, to_c_string( key ), l_found ) + if( .not. l_found .and. present( default ) ) value = default + if( present( found ) ) then + found = l_found + return + end if + if( .not. l_found .and. .not. present( default ) ) then + call die_msg( 859993455, "Key '"//trim( key )// & + "' requested by "//trim( caller )//" not found" ) + end if + + end subroutine get_config + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Gets a string from the configuration data + subroutine get_string_string_default( this, key, value, caller, default, & + found ) + + use musica_string, only : string_t + + !> Configuration + class(config_t), intent(inout) :: this + !> Key used to find value + character(len=*), intent(in) :: key + !> Returned value + class(string_t), intent(out) :: value + !> Name of the calling function (only for use in error messages) + character(len=*), intent(in) :: caller + !> Default value if not found + class(string_t), intent(in) :: default + !> Flag indicating whether key was found + logical, intent(out), optional :: found + + call get_string( this, key, value, caller, default = default%val_, & + found = found ) + + end subroutine get_string_string_default + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Gets a string from the configuration data + subroutine get_string( this, key, value, caller, default, found ) + + use musica_assert, only : die_msg + use musica_string, only : string_t + + !> Configuration + class(config_t), intent(inout) :: this + !> Key used to find value + character(len=*), intent(in) :: key + !> Returned value + class(string_t), intent(out) :: value + !> Name of the calling function (only for use in error messages) + character(len=*), intent(in) :: caller + !> Default value if not found + character(len=*), intent(in), optional :: default + !> Flag indicating whether key was found + logical, intent(out), optional :: found + + logical(kind=c_bool) :: l_found + type(string_t_c) :: c_value + + c_value = yaml_get_string_c( this%node_, to_c_string( key ), l_found ) + if( l_found ) then + value%val_ = to_f_string( c_value ) + call yaml_delete_string_c( c_value ) + end if + if( .not. l_found .and. present( default ) ) value = default + if( present( found ) ) then + found = l_found + return + end if + if( .not. l_found .and. .not. present( default ) ) then + call die_msg( 705088796, "Key '"//trim( key )// & + "' requested by "//trim( caller )//" not found" ) + end if + + end subroutine get_string + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Gets an integer from the configuration data + subroutine get_int( this, key, value, caller, default, found ) + + use musica_assert, only : die_msg + + !> Configuration + class(config_t), intent(inout) :: this + !> Key used to find value + character(len=*), intent(in) :: key + !> Returned value + integer(kind=musica_ik), intent(out) :: value + !> Name of the calling function (only for use in error messages) + character(len=*), intent(in) :: caller + !> Default value if not found + integer(kind=musica_ik), intent(in), optional :: default + !> Flag indicating whether key was found + logical, intent(out), optional :: found + + logical(kind=c_bool) :: l_found + + value = yaml_get_int_c( this%node_, to_c_string( key ), l_found ) + if( .not. l_found .and. present( default ) ) value = default + if( present( found ) ) then + found = l_found + return + end if + if( .not. l_found .and. .not. present( default ) ) then + call die_msg( 689949329, "Key '"//trim( key )// & + "' requested by "//trim( caller )//" not found" ) + end if + + end subroutine get_int + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Gets a single-precision real number from the configuration data + subroutine get_float( this, key, value, caller, default, found ) + + use musica_assert, only : die_msg + + !> Configuration + class(config_t), intent(inout) :: this + !> Key used to find value + character(len=*), intent(in) :: key + !> Returned value + real(kind=musica_rk), intent(out) :: value + !> Name of the calling function (only for use in error messages) + character(len=*), intent(in) :: caller + !> Default value if not found + real(kind=musica_rk), intent(in), optional :: default + !> Flag indicating whether key was found + logical, intent(out), optional :: found + + logical(kind=c_bool) :: l_found + + value = yaml_get_float_c( this%node_, to_c_string( key ), l_found ) + if( .not. l_found .and. present( default ) ) value = default + if( present( found ) ) then + found = l_found + return + end if + if( .not. l_found .and. .not. present( default ) ) then + call die_msg( 337653668, "Key '"//trim( key )// & + "' requested by "//trim( caller )//" not found" ) + end if + + end subroutine get_float + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Gets a double-precision real number from the configuration data + subroutine get_double( this, key, value, caller, default, found ) + + use musica_assert, only : die_msg + + !> Configuration + class(config_t), intent(inout) :: this + !> Key used to find value + character(len=*), intent(in) :: key + !> Returned value + real(kind=musica_dk), intent(out) :: value + !> Name of the calling function (only for use in error messages) + character(len=*), intent(in) :: caller + !> Default value if not found + real(kind=musica_dk), intent(in), optional :: default + !> Flag indicating whether key was found + logical, intent(out), optional :: found + + logical(kind=c_bool) :: l_found + + value = yaml_get_double_c( this%node_, to_c_string( key ), l_found ) + if( .not. l_found .and. present( default ) ) value = default + if( present( found ) ) then + found = l_found + return + end if + if( .not. l_found .and. .not. present( default ) ) then + call die_msg( 339559202, "Key '"//trim( key )// & + "' requested by "//trim( caller )//" not found" ) + end if + + end subroutine get_double + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Gets a boolean value from the configuration data + subroutine get_logical( this, key, value, caller, default, found ) + + use musica_assert, only : die_msg + + !> Configuration + class(config_t), intent(inout) :: this + !> Key used to find value + character(len=*), intent(in) :: key + !> Returned value + logical, intent(out) :: value + !> Name of the calling function (only for use in error messages) + character(len=*), intent(in) :: caller + !> Default value if not found + logical, intent(in), optional :: default + !> Flag indicating whether key was found + logical, intent(out), optional :: found + + logical(kind=c_bool) :: l_found + + value = yaml_get_bool_c( this%node_, to_c_string( key ), l_found ) + if( .not. l_found .and. present( default ) ) value = default + if( present( found ) ) then + found = l_found + return + end if + if( .not. l_found .and. .not. present( default ) ) then + call die_msg( 506357333, "Key '"//trim( key )// & + "' requested by "//trim( caller )//" not found" ) + end if + + end subroutine get_logical + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Gets an array of strings from the configuration data + subroutine get_string_array( this, key, value, caller, default, found ) + + use musica_assert, only : assert, assert_msg + use musica_string, only : string_t + + !> Configuration + class(config_t), intent(inout) :: this + !> Key used to find value + character(len=*), intent(in) :: key + !> Returned value + type(string_t), allocatable, intent(out) :: value(:) + !> Name of the calling function (only for use in error messages) + character(len=*), intent(in) :: caller + !> Default value if not found + type(string_t), intent(in), optional :: default(:) + !> Flag indicating whether key was found + logical, intent(out), optional :: found + + type(string_array_t_c) :: c_array + integer(c_int) :: size, i + type(string_t_c), pointer :: c_strings(:) + logical(kind=c_bool) :: l_found + + c_array = yaml_get_string_array_c( this%node_, to_c_string( key ), & + l_found ) + call assert_msg( 469804765, l_found .or. present( default ) .or. & + present( found ), "Key '"//trim( key )// & + "' requested by "//trim( caller )//" not found" ) + if( present( found ) ) then + found = l_found + if( .not. l_found .and. .not. present( default ) ) return + end if + if( .not. l_found .and. present( default ) ) then + value = default + return + end if + call c_f_pointer( c_array%ptr_, c_strings, [ c_array%size_ ] ) + allocate( value( c_array%size_ ) ) + do i = 1, size( c_strings ) + value(i) = to_f_string( c_strings( i ) ) + end do + call yaml_delete_string_array_c( c_array ) + + end subroutine get_string_array + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Gets an array of doubles from the configuration data + subroutine get_double_array( this, key, value, caller, default, found ) + + use musica_assert, only : assert, assert_msg + + !> Configuration + class(config_t), intent(inout) :: this + !> Key used to find value + character(len=*), intent(in) :: key + !> Returned value + real(musica_dk), allocatable, intent(out) :: value(:) + !> Name of the calling function (only for use in error messages) + character(len=*), intent(in) :: caller + !> Default value if not found + real(musica_dk), intent(in), optional :: default(:) + !> Flag indicating whether key was found + logical, intent(out), optional :: found + + type(double_array_t_c) :: c_array + real(kind=c_double), pointer :: c_doubles(:) + integer :: i + logical(kind=c_bool) :: l_found + + c_array = yaml_get_double_array_c( this%node_, to_c_string( key ), & + l_found ) + call assert_msg( 507829003, l_found .or. present( default ) & + .or. present( found ), "Key '"//trim( key )// & + "' requested by "//trim( caller )//" not found" ) + if( present( found ) ) then + found = l_found + if( .not. l_found .and. .not. present( default ) ) return + end if + if( .not. l_found .and. present( default ) ) then + value = default + return + end if + call c_f_pointer( c_array%ptr_, c_doubles, [ c_array%size_ ] ) + allocate( value( c_array%size_ ) ) + value(:) = c_doubles(:) + call yaml_delete_double_array_c( c_array ) + + end subroutine get_double_array + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Gets an array of config_t objects + subroutine get_config_array( this, key, value, caller, default, found ) + + use musica_assert, only : assert, assert_msg + + !> Configuration + class(config_t), intent(inout) :: this + !> Key used to find value + character(len=*), intent(in) :: key + !> Returned value + type(config_t), allocatable, intent(out) :: value(:) + !> Name of the calling function (only for use in error messages) + character(len=*), intent(in) :: caller + !> Default value if not found + type(config_t), intent(in), optional :: default(:) + !> Flag indicating whether key was found + logical, intent(out), optional :: found + + type(node_array_t_c) :: c_array + type(c_ptr), pointer :: c_nodes(:) + integer :: i + logical(kind=c_bool) :: l_found + + c_array = yaml_get_node_array_c( this%node_, to_c_string( key ), l_found ) + call assert_msg( 737497064, l_found .or. present( default ) & + .or. present( found ), "Key '"//trim( key )// & + "' requested by "//trim( caller )//" not found" ) + if( present( found ) ) then + found = l_found + if( .not. l_found .and. .not. present( default ) ) return + end if + if( .not. l_found .and. present( default ) ) then + value = default + return + end if + call c_f_pointer( c_array%ptr_, c_nodes, [ c_array%size_ ] ) + allocate( value( c_array%size_ ) ) + value(:)%node_ = c_nodes(:) + call yaml_delete_node_array_c( c_array ) + + end subroutine get_config_array + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Gets a value using an iterator + subroutine get_from_iterator( this, iterator, value, caller ) + + use musica_assert, only : assert, die_msg + use musica_string, only : string_t + + !> Configuration + class(config_t), intent(inout) :: this + !> Iterator to use to find value + class(iterator_t), intent(in) :: iterator + !> Returned value + class(*), intent(out) :: value + !> Name of the calling function (only for use in error messages) + character(len=*), intent(in) :: caller + + type(string_t_c) :: str + + select type( iterator ) + class is( config_iterator_t ) + select type( value ) + type is( config_t ) + value%node_ = yaml_get_node_from_iterator_c( iterator%curr_ ) + type is( integer( musica_ik ) ) + value = yaml_get_int_from_iterator_c( iterator%curr_ ) + type is( real( musica_rk ) ) + value = yaml_get_float_from_iterator_c( iterator%curr_ ) + type is( real( musica_dk ) ) + value = yaml_get_double_from_iterator_c( iterator%curr_ ) + type is( logical ) + value = yaml_get_bool_from_iterator_c( iterator%curr_ ) + type is( string_t ) + str = yaml_get_string_from_iterator_c( iterator%curr_ ) + value = to_f_string( str ) + call yaml_delete_string_c( str ) + class default + call die_msg( 227296475, "Unknown type for get function." ) + end select + class default + call die_msg( 446668858, "Iterator type mismatch. Expected "// & + "config_iterator_t" ) + end select + + end subroutine get_from_iterator + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Gets an array value using an iterator + subroutine get_array_from_iterator( this, iterator, value, caller ) + + use musica_assert, only : assert, die_msg + use musica_string, only : string_t + + !> Configuration + class(config_t), intent(inout) :: this + !> Iterator to use to find value + class(iterator_t), intent(in) :: iterator + !> Returned value + type(string_t), allocatable, intent(out) :: value(:) + !> Name of the calling function (only for use in error messages) + character(len=*), intent(in) :: caller + + integer :: i + type(string_array_t_c) :: c_array + type(string_t_c), pointer :: c_strings(:) + + select type( iterator ) + class is( config_iterator_t ) + c_array = yaml_get_string_array_from_iterator_c( iterator%curr_ ) + call c_f_pointer( c_array%ptr_, c_strings, [ c_array%size_ ] ) + allocate( value( c_array%size_ ) ) + do i = 1, size( c_strings ) + value(i) = to_f_string( c_strings( i ) ) + end do + call yaml_delete_string_array_c( c_array ) + class default + call die_msg( 217094588, "Iterator type mismatch. Expected "// & + "config_iterator_t" ) + end select + + end subroutine get_array_from_iterator + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Adds a subset of configuration data + subroutine add_config( this, key, value, caller ) + + use musica_assert, only : assert_msg + + !> Configuration + class(config_t), intent(inout) :: this + !> Key in insert + character(len=*), intent(in) :: key + !> Value to set + type(config_t), intent(in) :: value + !> Name of the calling function (only for use in error messages) + character(len=*), intent(in) :: caller + + character(len=1, kind=c_char), allocatable :: c_key(:) + + c_key = to_c_string( key ) + call assert_msg( 644309796, c_associated( value%node_ ), & + "Trying to add uninitialized config_t object by "// & + caller ) + call yaml_add_node_c( this%node_, c_key, value%node_ ) + + end subroutine add_config + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Adds a string to the configuration data + subroutine add_char_array( this, key, value, caller ) + + !> Configuration + class(config_t), intent(inout) :: this + !> Key in insert + character(len=*), intent(in) :: key + !> Value to set + character(len=*), intent(in) :: value + !> Name of the calling function (only for use in error messages) + character(len=*), intent(in) :: caller + + character(len=1, kind=c_char), allocatable :: c_key(:), c_value(:) + + c_key = to_c_string( key ) + c_value = to_c_string( value ) + if( .not. c_associated( this%node_ ) ) call initialize_config_t( this ) + call yaml_add_string_c( this%node_, c_key, c_value ) + + end subroutine add_char_array + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Adds a string to the configuration data + subroutine add_string( this, key, value, caller ) + + use musica_string, only : string_t + + !> Configuration + class(config_t), intent(inout) :: this + !> Key in insert + character(len=*), intent(in) :: key + !> Value to set + type(string_t), intent(in) :: value + !> Name of the calling function (only for use in error messages) + character(len=*), intent(in) :: caller + + character(len=1, kind=c_char), allocatable :: c_key(:), c_value(:) + + c_key = to_c_string( key ) + c_value = to_c_string( value%val_ ) + if( .not. c_associated( this%node_ ) ) call initialize_config_t( this ) + call yaml_add_string_c( this%node_, c_key, c_value ) + + end subroutine add_string + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Adds an integer to the configuration data + subroutine add_int( this, key, value, caller ) + + !> Configuration + class(config_t), intent(inout) :: this + !> Key in insert + character(len=*), intent(in) :: key + !> Value to set + integer, intent(in) :: value + !> Name of the calling function (only for use in error messages) + character(len=*), intent(in) :: caller + + character(len=1, kind=c_char), allocatable :: c_key(:) + + c_key = to_c_string( key ) + if( .not. c_associated( this%node_ ) ) call initialize_config_t( this ) + call yaml_add_int_c( this%node_, c_key, int( value, kind=c_int ) ) + + end subroutine add_int + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Adds a single-precision real number to the configuration data + subroutine add_float( this, key, value, caller ) + + !> Configuration + class(config_t), intent(inout) :: this + !> Key in insert + character(len=*), intent(in) :: key + !> Value to set + real(kind=musica_rk), intent(in) :: value + !> Name of the calling function (only for use in error messages) + character(len=*), intent(in) :: caller + + character(len=1, kind=c_char), allocatable :: c_key(:) + + c_key = to_c_string( key ) + if( .not. c_associated( this%node_ ) ) call initialize_config_t( this ) + call yaml_add_float_c( this%node_, c_key, real( value, kind=c_float ) ) + + end subroutine add_float + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Adds a double-precision real number to the configuration data + subroutine add_double( this, key, value, caller ) + + !> Configuration + class(config_t), intent(inout) :: this + !> Key in insert + character(len=*), intent(in) :: key + !> Value to set + real(kind=musica_dk), intent(in) :: value + !> Name of the calling function (only for use in error messages) + character(len=*), intent(in) :: caller + + character(len=1, kind=c_char), allocatable :: c_key(:) + + c_key = to_c_string( key ) + if( .not. c_associated( this%node_ ) ) call initialize_config_t( this ) + call yaml_add_double_c( this%node_, c_key, real( value, kind=c_double ) ) + + end subroutine add_double + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Adds a boolean to the configuration data + subroutine add_logical( this, key, value, caller ) + + !> Configuration + class(config_t), intent(inout) :: this + !> Key in insert + character(len=*), intent(in) :: key + !> Value to set + logical, intent(in) :: value + !> Name of the calling function (only for use in error messages) + character(len=*), intent(in) :: caller + + character(len=1, kind=c_char), allocatable :: c_key(:) + + c_key = to_c_string( key ) + if( .not. c_associated( this%node_ ) ) call initialize_config_t( this ) + call yaml_add_bool_c( this%node_, c_key, logical( value, kind=c_bool ) ) + + end subroutine add_logical + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Adds a string array to the configuration data + subroutine add_string_array( this, key, value, caller ) + + use musica_string, only : string_t + + !> Configuration + class(config_t), intent(inout) :: this + !> Key in insert + character(len=*), intent(in) :: key + !> Value to set + type(string_t), intent(in) :: value(:) + !> Name of the calling function (only for use in error messages) + character(len=*), intent(in) :: caller + + type(string_array_t_c) :: c_array + type(string_t_c), allocatable, target :: c_strings(:) + character(len=1, kind=c_char), pointer :: c_string(:) + integer :: i, size + + allocate( c_strings( size( value ) ) ) + do i = 1, size( value ) + allocate( c_string, source = to_c_string( value( i )%val_ ) ) + c_strings( i )%ptr_ = c_loc( c_string ) + c_strings( i )%size_ = len( value( i )%val_ ) + nullify( c_string ) + end do + c_array%ptr_ = c_loc( c_strings ) + c_array%size_ = size( c_strings ) + if( .not. c_associated( this%node_ ) ) call initialize_config_t( this ) + call yaml_add_string_array_c( this%node_, to_c_string( key ), c_array ) + do i = 1, size( value ) + call c_f_pointer( c_strings( i )%ptr_, c_string, & + [ c_strings( i )%size_ + 1 ] ) + deallocate( c_string ) + c_strings( i )%ptr_ = c_null_ptr + end do + + end subroutine add_string_array + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Adds a double array to the configuration data + subroutine add_double_array( this, key, value, caller ) + + !> Configuration + class(config_t), intent(inout) :: this + !> Key to insert + character(len=*), intent(in) :: key + !> Value to set + real(kind=musica_dk), intent(in) :: value(:) + !> Name of the calling function (only for use in error messages) + character(len=*), intent(in) :: caller + + type(double_array_t_c) :: c_array + real(kind=c_double), allocatable, target :: c_doubles(:) + + allocate( c_doubles, source = value ) + c_array%ptr_ = c_loc( c_doubles ) + c_array%size_ = size( value ) + if( .not. c_associated( this%node_ ) ) call initialize_config_t( this ) + call yaml_add_double_array_c( this%node_, to_c_string( key ), c_array ) + + end subroutine add_double_array + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Adds a config_t array to the configuration data + subroutine add_config_array( this, key, value, caller ) + + use musica_assert, only : assert_msg + + !> Configuration + class(config_t), intent(inout) :: this + !> Key in insert + character(len=*), intent(in) :: key + !> Value to set + type(config_t), intent(in) :: value(:) + !> Name of the calling function (only for use in error messages) + character(len=*), intent(in) :: caller + + type(node_array_t_c) :: c_array + type(c_ptr), allocatable, target :: c_nodes(:) + integer :: i + + allocate( c_nodes( size( value ) ) ) + do i = 1, size( value ) + c_nodes( i ) = value( i )%node_ + end do + c_array%ptr_ = c_loc( c_nodes ) + c_array%size_ = size( value ) + if( .not. c_associated( this%node_ ) ) call initialize_config_t( this ) + call yaml_add_node_array_c( this%node_, to_c_string( key ), c_array ) + + end subroutine add_config_array + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Assigns a config_t from a config_t + subroutine config_assign_config( a, b ) + + use musica_assert, only : assert + + !> Configuration to assign to + class(config_t), intent(out) :: a + !> Configuration to assign from + class(config_t), intent(in) :: b + + call assert( 864040127, c_associated( b%node_ ) ) + a%node_ = yaml_copy_node_c( b%node_ ) + + end subroutine config_assign_config + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Assigns a config_t from a string + subroutine config_assign_string( config, string ) + + use musica_string, only : string_t + + !> Configuration to assign to + class(config_t), intent(out) :: config + !> String to assign from + class(string_t), intent(in) :: string + + call initialize_config_t( config, string = string%val_ ) + + end subroutine config_assign_string + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Assigns a config_t from a character array + subroutine config_assign_char( config, string ) + + !> Configuration to assign to + class(config_t), intent(out) :: config + !> String to assign from + character(len=*), intent(in) :: string + + call initialize_config_t( config, string = string ) + + end subroutine config_assign_char + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Assigns a string from a configuration + subroutine string_assign_config( string, config ) + + use musica_assert, only : assert + use musica_string, only : string_t + + !> String to assign to + type(string_t), intent(out) :: string + !> Configuration to assign from + class(config_t), intent(in) :: config + + type(string_t_c) :: c_string + + call assert( 675183824, c_associated( config%node_ ) ) + c_string = yaml_to_string_c( config%node_ ) + string = to_f_string( c_string ) + call yaml_delete_string_c( c_string ) + + end subroutine string_assign_config + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Cleans up memory + subroutine finalize( this ) + + !> Configuration + type(config_t), intent(inout) :: this + + if( c_associated( this%node_) ) then + call yaml_delete_node_c( this%node_ ) + this%node_ = c_null_ptr + end if + + end subroutine finalize + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Cleans up memory + subroutine finalize_1D_array( this ) + + !> Configuration + type(config_t), intent(inout) :: this(:) + + integer(kind=musica_ik) :: i_elem + + do i_elem = 1, size( this ) + if( c_associated( this( i_elem )%node_ ) ) then + call yaml_delete_node_c( this( i_elem )%node_ ) + this( i_elem )%node_ = c_null_ptr + end if + end do + + end subroutine finalize_1D_array + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Finds a full key name by a prefix + !! + !! Returns the first instance of the prefix if found + subroutine find_by_prefix( this, prefix, full_key, found ) + + use musica_assert, only : assert + use musica_string, only : string_t + + !> Configuration + class(config_t), intent(inout) :: this + !> Prefix to search for (first instance is returned) + character(len=*), intent(in) :: prefix + !> Full key found + type(string_t), intent(out) :: full_key + !> Flag indicating whether the key was found + logical, intent(out) :: found + + type(string_t) :: key + class(iterator_t), pointer :: iter + integer :: length + + length = len( trim( prefix ) ) + iter => this%get_iterator( ) + found = .false. + full_key = "" + do while( iter%next( ) .and. .not. found ) + key = this%key( iter ) + if( len( key%val_ ) .gt. length ) then + if( key%val_(1:length) .eq. trim( prefix ) ) then + full_key = key + found = .true. + end if + end if + end do + deallocate( iter ) + + end subroutine find_by_prefix + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Merges another config_t object into the config_t object + recursive subroutine merge_in( this, other, caller ) + + use musica_assert, only : assert_msg + use musica_string, only : string_t + + !> Configuration + class(config_t), intent(inout) :: this + !> Configuration to merge in + class(config_t), intent(inout) :: other + !> Name of the calling function (only for use in error messages) + character(len=*), intent(in) :: caller + + logical :: success + + success = yaml_merge_node_c( this%node_, other%node_ ) + call assert_msg( 208766672, success, & + "Failed to merge configuration data for "// & + trim( caller ) ) + + end subroutine merge_in + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Returns true if the given key is in the given list of keys + logical function find_key_in_list( key_to_find, list ) result( found ) + + use musica_string, only : string_t + + type(string_t), intent(in) :: key_to_find + type(string_t), intent(in) :: list(:) + + integer :: i_elem + + found = .false. + do i_elem = 1, size( list ) + if( key_to_find .eq. list( i_elem ) ) then + found = .true. + exit + end if + end do + + end function find_key_in_list + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Validates the format of the configuration data + !! + !! Ensures that the required keys are present, and that user-defined keys + !! start with a "`__`" prefix. + logical function validate( this, required_keys, optional_keys ) + + use musica_string, only : string_t + + !> Configuration + class(config_t), intent(inout) :: this + !> Required keys + type(string_t), intent(in) :: required_keys(:) + !> Optional keys + type(string_t), intent(in) :: optional_keys(:) + + integer :: n_req_found + logical :: is_valid + type(string_t) :: key + class(iterator_t), pointer :: iter + character(len=:), allocatable :: error_message + + ! validates JSON format, including check for duplicate keys + + validate = .true. + n_req_found = 0 + iter => this%get_iterator( ) + do while( iter%next( ) ) + key = this%key( iter ) + if( key%length( ) .ge. 2 ) then + if( key%substring( 1, 2 ) .eq. "__" ) cycle + end if + if( find_key_in_list( key, required_keys ) ) then + n_req_found = n_req_found + 1 + else if( .not. find_key_in_list( key, optional_keys ) ) then + validate = .false. + exit + end if + end do + if( n_req_found .ne. size( required_keys ) ) validate = .false. + deallocate( iter ) + + end function validate + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Print out the raw contents of the configuration + subroutine do_print( this ) + + use musica_string + + !> Configuration + class(config_t), intent(inout) :: this + + type(string_t) :: str + + str = this + write(*,*) str%val_ + + end subroutine do_print + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Returns the size of a binary buffer required to pack the object + integer function pack_size( this, comm ) + + use musica_mpi + use musica_string, only : string_t + + class(config_t), intent(inout) :: this ! configuration to pack + integer, optional, intent(in) :: comm ! MPI communicator + +#ifdef MUSICA_USE_MPI + type(string_t) :: str + + str = this + pack_size = str%pack_size( comm ) +#else + pack_size = 0 +#endif + + end function pack_size + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Packs the configuration onto a character buffer + subroutine mpi_pack( this, buffer, position, comm ) + + use musica_assert, only : assert + use musica_mpi + use musica_string, only : string_t + + !> Configuration to pack + class(config_t), intent(inout) :: this + !> Memory buffer + character, intent(inout) :: buffer(:) + !> Current buffer position + integer, intent(inout) :: position + !> MPI communicator + integer, optional, intent(in) :: comm + +#ifdef MUSICA_USE_MPI + integer :: prev_position + type(string_t) :: str + + str = this + prev_position = position + call str%mpi_pack( buffer, position, comm ) + call assert( 125473981, & + position - prev_position <= this%pack_size( comm ) ) +#endif + end subroutine mpi_pack + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Unpacks the configuration from a character buffer + subroutine mpi_unpack( this, buffer, position, comm ) + + use musica_assert, only : assert + use musica_mpi + use musica_string, only : string_t + + !> Configuration to unpack + class(config_t), intent(out) :: this + !> Memory buffer + character, intent(inout) :: buffer(:) + !> Current buffer position + integer, intent(inout) :: position + !> MPI communicator + integer, optional, intent(in) :: comm + +#ifdef MUSICA_USE_MPI + integer :: prev_position, string_size + type(string_t) :: str + + prev_position = position + call str%mpi_unpack( buffer, position, comm ) + call initialize_config_t( this, string = str%val_ ) + call assert( 237792326, & + position - prev_position <= this%pack_size( comm ) ) +#endif + end subroutine mpi_unpack + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Advances the iterator + !! + !! Returns false if the end of the collection has been reached + logical function iterator_next( this ) + + use musica_assert, only : die_msg + + !> Iterator + class(config_iterator_t), intent(inout) :: this + + iterator_next = .false. + select type( this ) + class is( config_iterator_t ) + if( c_associated( this%curr_ ) ) then + iterator_next = yaml_increment_c( this%curr_, this%end_ ) + return + end if + this%curr_ = yaml_begin_c( this%node_ ) + iterator_next = .not. yaml_at_end_c( this%curr_, this%end_ ) + class default + call die_msg( 153127936, "Config iterator type mismatch" ) + end select + + end function iterator_next + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Resets the iterator + subroutine iterator_reset( this, parent ) + + use musica_assert, only : die_msg + + !> Iterator + class(config_iterator_t), intent(inout) :: this + !> Iterator for parent model element + class(iterator_t), intent(in), optional :: parent + + select type( this ) + class is( config_iterator_t ) + if( c_associated( this%curr_ ) ) then + call yaml_delete_iterator_c( this%curr_ ) + end if + this%curr_ = c_null_ptr + class default + call die_msg( 159845482, "Config iterator type mismatch" ) + end select + + end subroutine iterator_reset + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Cleans up memory assoicated with an iterator + subroutine iterator_finalize( this ) + + !> Iterator + type(config_iterator_t), intent(inout) :: this + + if( c_associated( this%curr_ ) ) call yaml_delete_iterator_c( this%curr_ ) + if( c_associated( this%end_ ) ) call yaml_delete_iterator_c( this%end_ ) + + end subroutine iterator_finalize + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Initialize a config_t object + subroutine initialize_config_t( config, string ) + + use musica_assert, only : die + + !> Configuration + class(config_t), intent(inout) :: config + !> YAML string + character(len=*), optional, intent(in) :: string + + character(len=1, kind=c_char), allocatable :: c_string(:) + integer :: N, i + + select type(config) + type is(config_t) + call finalize( config ) + if( present( string ) ) then + c_string = to_c_string( string ) + config%node_ = yaml_create_from_string_c( c_string ) + else + config%node_ = yaml_create_from_string_c( (/ c_null_char /) ) + end if + class default + call die( 288394178 ) + end select + + end subroutine initialize_config_t + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Convert a fortran character array to a c string + function to_c_string( f_string ) result( c_string ) + + !> String as const char* + character(len=1, kind=c_char), allocatable :: c_string(:) + !> Fortran string to convert + character(len=*), intent(in) :: f_string + + integer :: N, i + + N = len_trim( f_string ) + allocate( c_string( N + 1 ) ) + do i = 1, N + c_string(i) = f_string(i:i) + end do + c_string( N + 1 ) = c_null_char + + end function to_c_string + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Convert a c string to a fortran character array + function to_f_string( c_string ) result( f_string ) + + !> Converted string for fortran + character(len=:), allocatable :: f_string + !> C pointer to const char* + type(string_t_c), intent(in) :: c_string + + integer :: i + character(len=1, kind=c_char), pointer :: c_char_array(:) + + call c_f_pointer( c_string%ptr_, c_char_array, [ c_string%size_ + 1 ] ) + allocate( character( len = c_string%size_ ) :: f_string ) + do i = 1, c_string%size_ + f_string(i:i) = c_char_array(i) + end do + + end function to_f_string + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +end module musica_config \ No newline at end of file diff --git a/src/util/config.cpp b/src/util/config.cpp new file mode 100644 index 00000000..833ea1e2 --- /dev/null +++ b/src/util/config.cpp @@ -0,0 +1,349 @@ +// Copyright (C) 2024 National Center for Atmospheric Research +// SPDX-License-Identifier: Apache-2.0 +#include +#include +#include +#include + +Yaml* yaml_create_from_string(const char* yaml_string) +{ + return new YAML::Node(YAML::Load(yaml_string)); +} + +Yaml* yaml_create_from_file(const char* file_path) +{ + return new YAML::Node(YAML::LoadFile(file_path)); +} + +void yaml_to_file(Yaml* node, const char* file_path) +{ + std::ofstream file(file_path, std::ofstream::trunc); + file << *node; + file.close(); +} + +int yaml_size(Yaml* node) +{ + return node->size(); +} + +YamlIterator* yaml_begin(Yaml* node) +{ + return new YAML::iterator(node->begin()); +} + +YamlIterator* yaml_end(Yaml* node) +{ + return new YAML::iterator(node->end()); +} + +bool yaml_at_end(YamlIterator* iter, YamlIterator* end) +{ + return *iter == *end; +} + +bool yaml_increment(YamlIterator* iter, YamlIterator* end) +{ + return ++(*iter) != *end; +} + +string_t yaml_key(YamlIterator* iter) +{ + string_t string; + std::string str = (*iter)->first.as(); + string.size_ = str.length(); + string.ptr_ = new char[string.size_ + 1]; + strcpy(string.ptr_, str.c_str()); + return string; +} + +Yaml* yaml_get_node(Yaml* node, const char* key, bool& found) +{ + YAML::Node subnode = (*node)[key]; + found = subnode.IsDefined() && !subnode.IsScalar(); + return new YAML::Node(subnode); +} + +string_t yaml_get_string(Yaml* node, const char* key, bool& found) +{ + found = (*node)[key].IsDefined(); + string_t string; + if (found) { + std::string str = (*node)[key].as(); + string.size_ = str.length(); + string.ptr_ = new char[string.size_ + 1]; + strcpy(string.ptr_, str.c_str()); + return string; + } + string.ptr_ = nullptr; + string.size_ = 0; + return string; +} + +int yaml_get_int(Yaml* node, const char* key, bool& found) +{ + found = (*node)[key].IsDefined(); + if (found) return (*node)[key].as(); + return 0; +} + +float yaml_get_float(Yaml* node, const char* key, bool& found) +{ + found = (*node)[key].IsDefined(); + if (found) return (*node)[key].as(); + return 0.0f; +} + +double yaml_get_double(Yaml* node, const char* key, bool& found) +{ + found = (*node)[key].IsDefined(); + if (found) return (*node)[key].as(); + return 0.0; +} + +bool yaml_get_bool(Yaml* node, const char* key, bool& found) +{ + found = (*node)[key].IsDefined(); + if (found) return (*node)[key].as(); + return false; +} + +string_array_t yaml_get_string_array(Yaml* node, const char* key, bool& found) +{ + string_array_t array; + array.size_ = 0; + array.ptr_ = nullptr; + YAML::Node array_node = (*node)[key]; + found = array_node.IsDefined(); + if (!found) return array; + array.size_ = array_node.size(); + array.ptr_ = new string_t[ array.size_ ]; + for (std::size_t i = 0; i < array_node.size(); ++i) + { + std::string str = array_node[i].as(); + array.ptr_[i].size_ = str.length(); + array.ptr_[i].ptr_ = new char[ str.length() + 1 ]; + strcpy(array.ptr_[i].ptr_, str.c_str()); + } + return array; +} + +double_array_t yaml_get_double_array(Yaml* node, const char* key, bool& found) +{ + double_array_t array; + array.size_ = 0; + array.ptr_ = nullptr; + YAML::Node array_node = (*node)[key]; + found = array_node.IsDefined(); + if (!found) return array; + array.size_ = array_node.size(); + array.ptr_ = new double[ array.size_ ]; + for (std::size_t i = 0; i < array_node.size(); ++i) + { + array.ptr_[i] = array_node[i].as(); + } + return array; +} + +node_array_t yaml_get_node_array(Yaml* node, const char* key, bool& found) +{ + node_array_t array; + array.size_ = 0; + array.ptr_ = nullptr; + YAML::Node array_node = (*node)[key]; + found = array_node.IsDefined(); + if (!found) return array; + array.size_ = array_node.size(); + array.ptr_ = new YAML::Node*[ array.size_ ]; + for (std::size_t i = 0; i < array_node.size(); ++i) + { + array.ptr_[i] = new YAML::Node(array_node[i].as()); + } + return array; +} + +Yaml* yaml_get_node_from_iterator(YamlIterator* iter) +{ + return (*iter)->IsDefined() ? new YAML::Node((*iter)->as()) : new YAML::Node((*iter)->second.as()); +} + +string_t yaml_get_string_from_iterator(YamlIterator* iter) +{ + string_t string; + std::string str = (*iter)->IsDefined() ? (*iter)->as() : (*iter)->second.as(); + string.size_ = str.length(); + string.ptr_ = new char[string.size_ + 1]; + strcpy(string.ptr_, str.c_str()); + return string; +} + +int yaml_get_int_from_iterator(YamlIterator* iter) +{ + return (*iter)->IsDefined() ? (*iter)->as() : (*iter)->second.as(); +} + +float yaml_get_float_from_iterator(YamlIterator* iter) +{ + return (*iter)->IsDefined() ? (*iter)->as() : (*iter)->second.as(); +} + +double yaml_get_double_from_iterator(YamlIterator* iter) +{ + return (*iter)->IsDefined() ? (*iter)->as() : (*iter)->second.as(); +} + +bool yaml_get_bool_from_iterator(YamlIterator* iter) +{ + return (*iter)->IsDefined() ? (*iter)->as() : (*iter)->second.as(); +} + +string_array_t yaml_get_string_array_from_iterator(YamlIterator* iter) +{ + string_array_t array; + YAML::Node array_node = (*iter)->IsDefined() ? (*iter)->as() : (*iter)->second.as(); + array.size_ = array_node.size(); + array.ptr_ = new string_t[ array.size_ ]; + for (std::size_t i = 0; i < array_node.size(); ++i) + { + std::string str = array_node[i].as(); + array.ptr_[i].size_ = str.length(); + array.ptr_[i].ptr_ = new char[ str.length() + 1 ]; + strcpy(array.ptr_[i].ptr_, str.c_str()); + } + return array; +} + +void yaml_add_node(Yaml* node, const char* key, Yaml* value) +{ + (*node)[key] = YAML::Clone(*value); +} + +void yaml_add_string(Yaml* node, const char* key, const char* value) +{ + (*node)[key] = value; +} + +void yaml_add_int(Yaml* node, const char* key, int value) +{ + (*node)[key] = value; +} + +void yaml_add_float(Yaml* node, const char* key, float value) +{ + (*node)[key] = value; +} + +void yaml_add_double(Yaml* node, const char* key, double value) +{ + (*node)[key] = value; +} + +void yaml_add_bool(Yaml* node, const char* key, bool value) +{ + (*node)[key] = value; +} + +void yaml_add_string_array(Yaml* node, const char* key, string_array_t value) +{ + YAML::Node array; + for (std::size_t i = 0; i < value.size_; ++i) + { + array.push_back(value.ptr_[i].ptr_); + } + (*node)[key] = array; +} + +void yaml_add_double_array(Yaml* node, const char* key, double_array_t value) +{ + YAML::Node array; + for (std::size_t i = 0; i < value.size_; ++i) + { + array.push_back(value.ptr_[i]); + } + (*node)[key] = array; +} + +void yaml_add_node_array(Yaml* node, const char* key, node_array_t value) +{ + YAML::Node array; + for (std::size_t i = 0; i < value.size_; ++i) + { + array.push_back(*(value.ptr_[i])); + } + (*node)[key] = array; +} + +Yaml* yaml_copy_node(Yaml* node) +{ + return new YAML::Node(YAML::Clone(*node)); +} + +string_t yaml_to_string(Yaml* node) +{ + string_t string; + YAML::Emitter out; + out << *node; + string.size_ = out.size(); + string.ptr_ = new char[string.size_ + 1]; + strcpy(string.ptr_, out.c_str()); + return string; +} + +bool yaml_merge_node(Yaml* node, const Yaml* other) +{ + if (!node->IsMap() || !other->IsMap()) return false; + for(YAML::const_iterator it=(*other).begin(); it!=(*other).end(); ++it) + { + std::string key = it->first.as(); + if ((*node)[key].IsDefined() && (*node)[key].IsMap() && it->second.IsMap()) + { + Yaml subnode = (*node)[key]; + if (!yaml_merge_node(&subnode, &it->second)) return false; + (*node)[key] = subnode; + } + else + { + if ((*node)[key].IsDefined() && !(*node)[key].is(it->second)) + { + return false; + } + (*node)[key] = it->second; + } + } + return true; +} + +void yaml_delete_node(Yaml* ptr) +{ + delete ptr; +} + +void yaml_delete_string(string_t string) +{ + delete [] string.ptr_; +} + +void yaml_delete_string_array(string_array_t array) +{ + if (!array.ptr_) return; + for (std::size_t i = 0; i < array.size_; ++i) + { + delete [] array.ptr_[i].ptr_; + } + delete [] array.ptr_; +} + +void yaml_delete_double_array(double_array_t array) +{ + delete [] array.ptr_; +} + +void yaml_delete_node_array(node_array_t array) +{ + delete [] array.ptr_; +} + +void yaml_delete_iterator(YamlIterator* ptr) +{ + delete ptr; +} \ No newline at end of file diff --git a/src/util/constants.F90 b/src/util/constants.F90 new file mode 100644 index 00000000..44a23349 --- /dev/null +++ b/src/util/constants.F90 @@ -0,0 +1,35 @@ +! Copyright (C) 2020 National Center for Atmospheric Research +! SPDX-License-Identifier: Apache-2.0 +! +!> \file +!> The musica_constants module + +!> Common physical constants +module musica_constants + + implicit none + public + + !> @name Primitive type kinds + !! @{ + !> Kind of an integer + integer, parameter :: musica_ik = kind(1) + !> Kind of a single-precision real number + integer, parameter :: musica_rk = kind(0.0) + !> Kind of a double-precision real number + integer, parameter :: musica_dk = kind(0.0d0) + !> Kind of a boolean + integer, parameter :: musica_lk = kind(.true.) + !> @} + + !> @name Physical constants + !! @{ + !> Pi + real(kind=musica_dk), parameter :: kPi = 3.14159265358979323846d0 + !> Avagadro's number [molec mol-1] + real(kind=musica_dk), parameter :: kAvagadro = 6.02214179d23 + !> Universal gas constant [J mol-1 K-1]. + real(kind=musica_dk), parameter :: kUniversalGasConstant = 8.314472d0 + !> @} + +end module musica_constants diff --git a/src/util/io.F90 b/src/util/io.F90 new file mode 100644 index 00000000..5be73a60 --- /dev/null +++ b/src/util/io.F90 @@ -0,0 +1,479 @@ +! Copyright (C) 2021 National Center for Atmospheric Research +! SPDX-License-Identifier: Apache-2.0 +! +!> \file +!> The musica_io module + +!> The io_t type and related functions +module musica_io + + implicit none + private + + public :: io_t + + !> General input/output class + type, abstract :: io_t + contains + !> @name Data read functions + !! @{ + procedure(read_0D_double), deferred :: read_0D_double + procedure(read_1D_double), deferred :: read_1D_double + procedure(read_2D_double), deferred :: read_2D_double + procedure(read_3D_double), deferred :: read_3D_double + procedure(read_4D_double), deferred :: read_4D_double + procedure(read_0D_int), deferred :: read_0D_int + procedure(read_1D_int), deferred :: read_1D_int + generic :: read => read_0D_double, read_1D_double, read_2D_double, & + read_3D_double, read_4D_double, read_0D_int, & + read_1D_int + !> @} + !> @name Data write functions + !! @{ + procedure(write_0D_double), deferred :: write_0D_double + procedure(write_1D_double), deferred :: write_1D_double + procedure(write_2D_double), deferred :: write_2D_double + procedure(write_3D_double), deferred :: write_3D_double + procedure(write_4D_double), deferred :: write_4D_double + procedure(write_0D_int), deferred :: write_0D_int + procedure(write_1D_int), deferred :: write_1D_int + generic :: write => write_0D_double, write_1D_double, write_2D_double, & + write_3D_double, write_4D_double, write_0D_int, & + write_1D_int + !> @} + !> @name Data append functions + !! @{ + procedure(append_0D_double), deferred :: append_0D_double + procedure(append_1D_double), deferred :: append_1D_double + procedure(append_2D_double), deferred :: append_2D_double + procedure(append_3D_double), deferred :: append_3D_double + procedure(append_0D_int), deferred :: append_0D_int + generic :: append => append_0D_double, append_1D_double, append_2D_double,& + append_3D_double, append_0D_int + !> @} + !> Returns whether a variable exists in the file + !! @{ + procedure(exists_char), deferred :: exists_char + procedure(exists_string), deferred :: exists_string + generic :: exists => exists_char, exists_string + !> @} + !> Returns the dimension names for a given variable + procedure(variable_dimensions), deferred :: variable_dimensions + !> Returns the units for a given variable + procedure(variable_units), deferred :: variable_units + !> Sets the units for a given variable + procedure(set_variable_units), deferred :: set_variable_units + end type io_t + +interface + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Reads 0D double-precision floating-point data + subroutine read_0D_double( this, variable_name, container, requestor_name ) + use musica_constants, only : musica_dk + use musica_string, only : string_t + import io_t + class(io_t), intent(inout) :: this + class(string_t), intent(in) :: variable_name + real(kind=musica_dk), intent(out) :: container + character(len=*), intent(in) :: requestor_name + end subroutine read_0D_double + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Reads 1D double-precision floating-point data + !! + !! If \c container is unallocated, it will be allocated to the dimensions + !! of the read variable. Otherwise, its dimensions must match those of the + !! read variable. + !! + subroutine read_1D_double( this, variable_name, container, requestor_name ) + use musica_constants, only : musica_dk + use musica_string, only : string_t + import io_t + class(io_t), intent(inout) :: this + class(string_t), intent(in) :: variable_name + real(kind=musica_dk), allocatable, intent(inout) :: container(:) + character(len=*), intent(in) :: requestor_name + end subroutine read_1D_double + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Reads 2D double-precision floating-point data + !! + !! If \c container is unallocated, it will be allocated to the dimensions + !! of the read variable. Otherwise, its dimensions must match those of the + !! read variable. + !! + subroutine read_2D_double( this, variable_name, container, requestor_name ) + use musica_constants, only : musica_dk + use musica_string, only : string_t + import io_t + class(io_t), intent(inout) :: this + class(string_t), intent(in) :: variable_name + real(kind=musica_dk), allocatable, intent(inout) :: container(:,:) + character(len=*), intent(in) :: requestor_name + end subroutine read_2D_double + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Reads 3D double-precision floating-point data + !! + !! If \c container is unallocated, it will be allocated to the dimensions + !! of the read variable. Otherwise, its dimensions must match those of the + !! read variable. + !! + subroutine read_3D_double( this, variable_name, container, requestor_name ) + use musica_constants, only : musica_dk + use musica_string, only : string_t + import io_t + class(io_t), intent(inout) :: this + class(string_t), intent(in) :: variable_name + real(kind=musica_dk), allocatable, intent(inout) :: container(:,:,:) + character(len=*), intent(in) :: requestor_name + end subroutine read_3D_double + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Reads 4D double-precision floating-point data + !! + !! If \c container is unallocated, it will be allocated to the dimensions + !! of the read variable. Otherwise, its dimensions must match those of the + !! read variable. + !! + subroutine read_4D_double( this, variable_name, container, requestor_name ) + use musica_constants, only : musica_dk + use musica_string, only : string_t + import io_t + class(io_t), intent(inout) :: this + class(string_t), intent(in) :: variable_name + real(kind=musica_dk), allocatable, intent(inout) :: container(:,:,:,:) + character(len=*), intent(in) :: requestor_name + end subroutine read_4D_double + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Reads 0D integer data + subroutine read_0D_int( this, variable_name, container, requestor_name ) + use musica_string, only : string_t + import io_t + class(io_t), intent(inout) :: this + class(string_t), intent(in) :: variable_name + integer, intent(out) :: container + character(len=*), intent(in) :: requestor_name + end subroutine read_0D_int + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Reads 1D integer data + !! + !! If \c container is unallocated, it will be allocated to the dimensions + !! of the read variable. Otherwise, its dimensions must match those of the + !! read variable. + !! + subroutine read_1D_int( this, variable_name, container, requestor_name ) + use musica_string, only : string_t + import io_t + class(io_t), intent(inout) :: this + class(string_t), intent(in) :: variable_name + integer, allocatable, intent(inout) :: container(:) + character(len=*), intent(in) :: requestor_name + end subroutine read_1D_int + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Writes 0D double data + subroutine write_0D_double( this, variable_name, variable_data, & + requestor_name ) + use musica_constants, only : musica_dk + use musica_string, only : string_t + import io_t + class(io_t), intent(inout) :: this + type(string_t), intent(in) :: variable_name + real(kind=musica_dk), intent(in) :: variable_data + character(len=*), intent(in) :: requestor_name + end subroutine write_0D_double + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Writes 1D double data + !! + !! If the provided dimensions do not exist, they will be created based on + !! the shape of the given data. If they do exist, they must be compatible + !! with the shape of the given data. + subroutine write_1D_double( this, variable_name, dimensions, variable_data, & + requestor_name ) + use musica_constants, only : musica_dk + use musica_string, only : string_t + import io_t + class(io_t), intent(inout) :: this + type(string_t), intent(in) :: variable_name + type(string_t), intent(in) :: dimensions + real(kind=musica_dk), intent(in) :: variable_data(:) + character(len=*), intent(in) :: requestor_name + end subroutine write_1D_double + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Writes 2D double data + !! + !! If the provided dimensions do not exist, they will be created based on + !! the shape of the given data. If they do exist, they must be compatible + !! with the shape of the given data. + subroutine write_2D_double( this, variable_name, dimensions, variable_data, & + requestor_name ) + use musica_constants, only : musica_dk + use musica_string, only : string_t + import io_t + class(io_t), intent(inout) :: this + type(string_t), intent(in) :: variable_name + type(string_t), intent(in) :: dimensions(2) + real(kind=musica_dk), intent(in) :: variable_data(:,:) + character(len=*), intent(in) :: requestor_name + end subroutine write_2D_double + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Writes 3D double data + !! + !! If the provided dimensions do not exist, they will be created based on + !! the shape of the given data. If they do exist, they must be compatible + !! with the shape of the given data. + subroutine write_3D_double( this, variable_name, dimensions, variable_data, & + requestor_name ) + use musica_constants, only : musica_dk + use musica_string, only : string_t + import io_t + class(io_t), intent(inout) :: this + type(string_t), intent(in) :: variable_name + type(string_t), intent(in) :: dimensions(3) + real(kind=musica_dk), intent(in) :: variable_data(:,:,:) + character(len=*), intent(in) :: requestor_name + end subroutine write_3D_double + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Writes 4D double data + !! + !! If the provided dimensions do not exist, they will be created based on + !! the shape of the given data. If they do exist, they must be compatible + !! with the shape of the given data. + subroutine write_4D_double( this, variable_name, dimensions, variable_data, & + requestor_name ) + use musica_constants, only : musica_dk + use musica_string, only : string_t + import io_t + class(io_t), intent(inout) :: this + type(string_t), intent(in) :: variable_name + type(string_t), intent(in) :: dimensions(4) + real(kind=musica_dk), intent(in) :: variable_data(:,:,:,:) + character(len=*), intent(in) :: requestor_name + end subroutine write_4D_double + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Writes 0D int data + subroutine write_0D_int( this, variable_name, variable_data, & + requestor_name ) + use musica_string, only : string_t + import io_t + class(io_t), intent(inout) :: this + type(string_t), intent(in) :: variable_name + integer, intent(in) :: variable_data + character(len=*), intent(in) :: requestor_name + end subroutine write_0D_int + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Writes 1D int data + !! + !! If the provided dimensions do not exist, they will be created based on + !! the shape of the given data. If they do exist, they must be compatible + !! with the shape of the given data. + subroutine write_1D_int( this, variable_name, dimensions, variable_data, & + requestor_name ) + use musica_string, only : string_t + import io_t + class(io_t), intent(inout) :: this + type(string_t), intent(in) :: variable_name + type(string_t), intent(in) :: dimensions + integer, intent(in) :: variable_data(:) + character(len=*), intent(in) :: requestor_name + end subroutine write_1D_int + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Writes 0D double data to append 1D double data + !! + !! If the provided dimensions do not exist, they will be created based on + !! the shape of the given data. If they do exist, they must be compatible + !! with the shape of the given data. + subroutine append_0D_double( this, variable_name, variable_units, & + append_dimension, append_index, variable_data, requestor_name ) + use musica_constants, only : musica_dk + use musica_string, only : string_t + import io_t + class(io_t), intent(inout) :: this + type(string_t), intent(in) :: variable_name + type(string_t), intent(in) :: variable_units + type(string_t), intent(in) :: append_dimension + integer, intent(in) :: append_index + real(kind=musica_dk), intent(in) :: variable_data + character(len=*), intent(in) :: requestor_name + end subroutine append_0D_double + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Writes 1D double data to append 2D data + !! + !! If the provided dimensions do not exist, they will be created based on + !! the shape of the given data. If they do exist, they must be compatible + !! with the shape of the given data. + subroutine append_1D_double( this, variable_name, variable_units, & + append_dimension, append_index, dimensions, variable_data, & + requestor_name ) + use musica_constants, only : musica_dk + use musica_string, only : string_t + import io_t + class(io_t), intent(inout) :: this + type(string_t), intent(in) :: variable_name + type(string_t), intent(in) :: variable_units + type(string_t), intent(in) :: append_dimension + integer, intent(in) :: append_index + type(string_t), intent(in) :: dimensions + real(kind=musica_dk), intent(in) :: variable_data(:) + character(len=*), intent(in) :: requestor_name + end subroutine append_1D_double + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Writes 2D double data to append 3D double data + !! + !! If the provided dimensions do not exist, they will be created based on + !! the shape of the given data. If they do exist, they must be compatible + !! with the shape of the given data. + subroutine append_2D_double( this, variable_name, variable_units, & + append_dimension, append_index, dimensions, variable_data, & + requestor_name ) + use musica_constants, only : musica_dk + use musica_string, only : string_t + import io_t + class(io_t), intent(inout) :: this + type(string_t), intent(in) :: variable_name + type(string_t), intent(in) :: variable_units + type(string_t), intent(in) :: append_dimension + integer, intent(in) :: append_index + type(string_t), intent(in) :: dimensions(2) + real(kind=musica_dk), intent(in) :: variable_data(:,:) + character(len=*), intent(in) :: requestor_name + end subroutine append_2D_double + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Writes 3D double data to append 4D double data + !! + !! If the provided dimensions do not exist, they will be created based on + !! the shape of the given data. If they do exist, they must be compatible + !! with the shape of the given data. + subroutine append_3D_double( this, variable_name, variable_units, & + append_dimension, append_index, dimensions, variable_data, & + requestor_name ) + use musica_constants, only : musica_dk + use musica_string, only : string_t + import io_t + class(io_t), intent(inout) :: this + type(string_t), intent(in) :: variable_name + type(string_t), intent(in) :: variable_units + type(string_t), intent(in) :: append_dimension + integer, intent(in) :: append_index + type(string_t), intent(in) :: dimensions(3) + real(kind=musica_dk), intent(in) :: variable_data(:,:,:) + character(len=*), intent(in) :: requestor_name + end subroutine append_3D_double + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Writes 0D int data to append 1D int data + !! + !! If the provided dimensions do not exist, they will be created based on + !! the shape of the given data. If they do exist, they must be compatible + !! with the shape of the given data. + subroutine append_0D_int( this, variable_name, variable_units, & + append_dimension, append_index, variable_data, requestor_name ) + use musica_string, only : string_t + import io_t + class(io_t), intent(inout) :: this + type(string_t), intent(in) :: variable_name + type(string_t), intent(in) :: variable_units + type(string_t), intent(in) :: append_dimension + integer, intent(in) :: append_index + integer, intent(in) :: variable_data + character(len=*), intent(in) :: requestor_name + end subroutine append_0D_int + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Returns whether a variable exists in the file + logical function exists_char( this, variable_name, requestor_name ) & + result( exists ) + import io_t + class(io_t), intent(in) :: this + character(len=*), intent(in) :: variable_name + character(len=*), intent(in) :: requestor_name + end function exists_char + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Returns whether a variable exists in the file + logical function exists_string( this, variable_name, requestor_name ) & + result( exists ) + use musica_string, only : string_t + import io_t + class(io_t), intent(in) :: this + type(string_t), intent(in) :: variable_name + character(len=*), intent(in) :: requestor_name + end function exists_string + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Returns the dimension names for a given variable + function variable_dimensions( this, variable_name, requestor_name ) & + result( dimensions ) + use musica_string, only : string_t + import io_t + type(string_t), allocatable :: dimensions(:) + class(io_t), intent(in) :: this + class(string_t), intent(in) :: variable_name + character(len=*), intent(in) :: requestor_name + end function variable_dimensions + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Returns the units for a given variable + function variable_units( this, variable_name, requestor_name ) + use musica_string, only : string_t + import io_t + type(string_t) :: variable_units + class(io_t), intent(in) :: this + class(string_t), intent(in) :: variable_name + character(len=*), intent(in) :: requestor_name + end function variable_units + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Sets the units for a given variable + subroutine set_variable_units( this, variable_name, units, requestor_name ) + use musica_string, only : string_t + import io_t + class(io_t), intent(inout) :: this + class(string_t), intent(in) :: variable_name + class(string_t), intent(in) :: units + character(len=*), intent(in) :: requestor_name + end subroutine set_variable_units + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +end interface + +end module musica_io diff --git a/src/util/io/CMakeLists.txt b/src/util/io/CMakeLists.txt new file mode 100644 index 00000000..7bd76972 --- /dev/null +++ b/src/util/io/CMakeLists.txt @@ -0,0 +1,9 @@ +###################################################################### +# IO utilities source + +target_sources(tuvx_object + PRIVATE + netcdf.F90 +) + +###################################################################### diff --git a/src/util/io/netcdf.F90 b/src/util/io/netcdf.F90 new file mode 100644 index 00000000..b1a5780a --- /dev/null +++ b/src/util/io/netcdf.F90 @@ -0,0 +1,1299 @@ +! Copyright (C) 2021 National Center for Atmospheric Research +! SPDX-License-Identifier: Apache-2.0 +! +!> \file +!> The musica_io_netcdf module + +!> The io_netcdf_t type and related functions +module musica_io_netcdf + + use musica_io, only : io_t + use musica_string, only : string_t + + implicit none + private + + public :: io_netcdf_t + + integer, parameter :: kUnknownFileId = -9999 + + !> NetCDF file reader + type, extends(io_t) :: io_netcdf_t + integer :: file_id_ = kUnknownFileId + type(string_t) :: file_name_ + contains + !> @name Data read functions + !! @{ + procedure :: read_0D_double + procedure :: read_1D_double + procedure :: read_2D_double + procedure :: read_3D_double + procedure :: read_4D_double + procedure :: read_0D_int + procedure :: read_1D_int + !> @} + !> @name Data write functions + !! @{ + procedure :: write_0D_double + procedure :: write_1D_double + procedure :: write_2D_double + procedure :: write_3D_double + procedure :: write_4D_double + procedure :: write_0D_int + procedure :: write_1D_int + !> @} + !> @name Data append functions + !! @{ + procedure :: append_0D_double + procedure :: append_1D_double + procedure :: append_2D_double + procedure :: append_3D_double + procedure :: append_0D_int + !! @} + !> @name Returns whether a variable exists in the file + !! @{ + procedure :: exists_char + procedure :: exists_string + !> @} + !> Returns the dimension names for a given variable + procedure :: variable_dimensions + !> Returns the units for a given variable + procedure :: variable_units + !> Sets the units for a given variable + procedure :: set_variable_units + procedure, private :: is_open + procedure, private :: variable_id + procedure, private :: dimension_sizes + procedure, private :: check_add_dimension + procedure, private :: check_add_variable + final :: finalize + end type io_netcdf_t + + interface io_netcdf_t + procedure :: constructor + end interface + +contains + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Constructor for NetCDF file readers + function constructor( file_name, read_only ) result( new_io ) + + use musica_string, only : string_t + use netcdf, only : nf90_create, nf90_open, & + NF90_NETCDF4, NF90_WRITE, & + NF90_NOWRITE + + type(io_netcdf_t), pointer :: new_io + type(string_t), intent(in) :: file_name + logical, optional, intent(in) :: read_only + + logical :: file_exists + + allocate( new_io ) + new_io%file_name_ = file_name + if( present( read_only ) ) then + if( read_only ) then + call check_status( 233000996, & + nf90_open( file_name%to_char( ), NF90_NOWRITE, new_io%file_id_ ), & + "Error openning file '"//file_name%to_char( )//"'" ) + return + end if + end if + inquire( file = file_name%to_char( ), exist = file_exists ) + if( file_exists ) then + call check_status( 126279520, & + nf90_open( file_name%to_char( ), NF90_WRITE, new_io%file_id_ ), & + "Error openning file '"//file_name%to_char( )//"'" ) + else + call check_status( 427923808, & + nf90_create( file_name%to_char( ), NF90_NETCDF4, new_io%file_id_ ), & + "Error creating file '"//file_name%to_char( )//"'" ) + end if + + end function constructor + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Reads 0D double-precision floating-pointer data + subroutine read_0D_double( this, variable_name, container, requestor_name ) + + use musica_assert, only : assert_msg + use musica_constants, only : musica_dk + use musica_string, only : to_char + use netcdf, only : nf90_get_var + + class(io_netcdf_t), intent(inout) :: this + class(string_t), intent(in) :: variable_name + real(kind=musica_dk), intent(out) :: container + character(len=*), intent(in) :: requestor_name + + integer :: var_id + integer, allocatable :: dim_sizes(:) + type(string_t) :: id_str + + id_str = "variable '"//variable_name//"' in file '"//this%file_name_//"'" + call assert_msg( 879207328, this%is_open( ), & + "Trying to read from unopen file: "//id_str ) + var_id = this%variable_id( variable_name ) + dim_sizes = this%dimension_sizes( variable_name ) + call assert_msg( 712409197, size( dim_sizes ) .eq. 0, & + "Wrong number of dimensions for "// & + trim( id_str%to_char( ) )//": Expected 0 got "// & + trim( to_char( size( dim_sizes ) ) ) ) + call check_status( 190408927, & + nf90_get_var( this%file_id_, var_id, container ), & + "Error getting value for "//trim( id_str%to_char( ) ) ) + + end subroutine read_0D_double + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Reads 1D double-precision floating-pointer data + subroutine read_1D_double( this, variable_name, container, requestor_name ) + + use musica_assert, only : assert_msg + use musica_constants, only : musica_dk + use musica_string, only : to_char + use netcdf, only : nf90_get_var + + class(io_netcdf_t), intent(inout) :: this + class(string_t), intent(in) :: variable_name + real(kind=musica_dk), allocatable, intent(inout) :: container(:) + character(len=*), intent(in) :: requestor_name + + integer :: var_id + integer, allocatable :: dim_sizes(:) + type(string_t) :: id_str + + id_str = "variable '"//variable_name//"' in file '"//this%file_name_//"'" + call assert_msg( 163123652, this%is_open( ), & + "Trying to read from unopen file: "//id_str ) + var_id = this%variable_id( variable_name ) + dim_sizes = this%dimension_sizes( variable_name ) + call assert_msg( 275441997, size( dim_sizes ) .eq. 1, & + "Wrong number of dimensions for "// & + trim( id_str%to_char( ) )//": Expected 1 got "// & + trim( to_char( size( dim_sizes ) ) ) ) + if( allocated( container ) ) then + call assert_msg( 976961669, size( container ) .eq. dim_sizes(1), & + "Wrong size container for "//trim( id_str%to_char( ) ) & + //": Expected "//trim( to_char( dim_sizes(1) ) )// & + " got "//trim( to_char( size( container ) ) ) ) + else + allocate( container( dim_sizes(1) ) ) + end if + call check_status( 722809843, & + nf90_get_var( this%file_id_, var_id, container ), & + "Error getting value for "//trim( id_str%to_char( ) ) ) + + end subroutine read_1D_double + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Reads 2D double-precision floating-pointer data + subroutine read_2D_double( this, variable_name, container, requestor_name ) + + use musica_assert, only : assert_msg + use musica_constants, only : musica_dk + use musica_string, only : to_char + use netcdf, only : nf90_get_var + + class(io_netcdf_t), intent(inout) :: this + class(string_t), intent(in) :: variable_name + real(kind=musica_dk), allocatable, intent(inout) :: container(:,:) + character(len=*), intent(in) :: requestor_name + + integer :: var_id, i_dim + integer, allocatable :: dim_sizes(:) + type(string_t) :: id_str + + id_str = "variable '"//variable_name//"' in file '"//this%file_name_//"'" + call assert_msg( 675787021, this%is_open( ), & + "Trying to read from unopen file: "//id_str ) + var_id = this%variable_id( variable_name ) + dim_sizes = this%dimension_sizes( variable_name ) + call assert_msg( 400481613, size( dim_sizes ) .eq. 2, & + "Wrong number of dimensions for "// & + trim( id_str%to_char( ) )//": Expected 2 got "// & + trim( to_char( size( dim_sizes ) ) ) ) + if( allocated( container ) ) then + do i_dim = 1, 2 + call assert_msg( 230324709, size( container, i_dim ) .eq. & + dim_sizes( i_dim ), & + "Wrong size container for "// & + trim( id_str%to_char( ) )//": Expected "// & + trim( to_char( dim_sizes( i_dim ) ) )// & + " got "//trim( to_char( size( container, i_dim ) ) ) & + //" for dimension "//trim( to_char( i_dim ) ) ) + end do + else + allocate( container( dim_sizes(1), dim_sizes(2) ) ) + end if + call check_status( 960167804, & + nf90_get_var( this%file_id_, var_id, container ), & + "Error getting value for "//trim( id_str%to_char( ) ) ) + + end subroutine read_2D_double + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Reads 3D double-precision floating-pointer data + subroutine read_3D_double( this, variable_name, container, requestor_name ) + + use musica_assert, only : assert_msg + use musica_constants, only : musica_dk + use musica_string, only : to_char + use netcdf, only : nf90_get_var + + class(io_netcdf_t), intent(inout) :: this + class(string_t), intent(in) :: variable_name + real(kind=musica_dk), allocatable, intent(inout) :: container(:,:,:) + character(len=*), intent(in) :: requestor_name + + integer :: var_id, i_dim + integer, allocatable :: dim_sizes(:) + type(string_t) :: id_str + + id_str = "variable '"//variable_name//"' in file '"//this%file_name_//"'" + call assert_msg( 539957265, this%is_open( ), & + "Trying to read from unopen file: "//id_str ) + var_id = this%variable_id( variable_name ) + dim_sizes = this%dimension_sizes( variable_name ) + call assert_msg( 603060131, size( dim_sizes ) .eq. 3, & + "Wrong number of dimensions for "// & + trim( id_str%to_char( ) )//": Expected 3 got "// & + trim( to_char( size( dim_sizes ) ) ) ) + if( allocated( container ) ) then + do i_dim = 1, 3 + call assert_msg( 715378476, size( container, i_dim ) .eq. & + dim_sizes( i_dim ), & + "Wrong size container for "// & + trim( id_str%to_char( ) )//": Expected "// & + trim( to_char( dim_sizes( i_dim ) ) )// & + " got "//trim( to_char( size( container, i_dim ) ) ) & + //" for dimension "//trim( to_char( i_dim ) ) ) + end do + else + allocate( container( dim_sizes(1), dim_sizes(2), dim_sizes(3) ) ) + end if + call check_status( 210172071, & + nf90_get_var( this%file_id_, var_id, container ), & + "Error getting value for "//trim( id_str%to_char( ) ) ) + + end subroutine read_3D_double + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Reads 4D double-precision floating-pointer data + subroutine read_4D_double( this, variable_name, container, requestor_name ) + + use musica_assert, only : assert_msg + use musica_constants, only : musica_dk + use musica_string, only : to_char + use netcdf, only : nf90_get_var + + class(io_netcdf_t), intent(inout) :: this + class(string_t), intent(in) :: variable_name + real(kind=musica_dk), allocatable, intent(inout) :: container(:,:,:,:) + character(len=*), intent(in) :: requestor_name + + integer :: var_id, i_dim + integer, allocatable :: dim_sizes(:) + type(string_t) :: id_str + + id_str = "variable '"//variable_name//"' in file '"//this%file_name_//"'" + call assert_msg( 198190218, this%is_open( ), & + "Trying to read from unopen file: "//id_str ) + var_id = this%variable_id( variable_name ) + dim_sizes = this%dimension_sizes( variable_name ) + call assert_msg( 650822371, size( dim_sizes ) .eq. 4, & + "Wrong number of dimensions for "// & + trim( id_str%to_char( ) )//": Expected 4 got "// & + trim( to_char( size( dim_sizes ) ) ) ) + if( allocated( container ) ) then + do i_dim = 1, 4 + call assert_msg( 820979275, size( container, i_dim ) .eq. & + dim_sizes( i_dim ), & + "Wrong size container for "// & + trim( id_str%to_char( ) )//": Expected "// & + trim( to_char( dim_sizes( i_dim ) ) )// & + " got "//trim( to_char( size( container, i_dim ) ) ) & + //" for dimension "//trim( to_char( i_dim ) ) ) + end do + else + allocate( container( dim_sizes(1), dim_sizes(2), dim_sizes(3), & + dim_sizes(4) ) ) + end if + call check_status( 708660930, & + nf90_get_var( this%file_id_, var_id, container ), & + "Error getting value for "//trim( id_str%to_char( ) ) ) + + end subroutine read_4D_double + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Reads 0D integer data + subroutine read_0D_int( this, variable_name, container, requestor_name ) + + use musica_assert, only : assert_msg + use musica_string, only : to_char + use netcdf, only : nf90_get_var + + class(io_netcdf_t), intent(inout) :: this + class(string_t), intent(in) :: variable_name + integer, intent(out) :: container + character(len=*), intent(in) :: requestor_name + + integer :: var_id + integer, allocatable :: dim_sizes(:) + type(string_t) :: id_str + + id_str = "variable '"//variable_name//"' in file '"//this%file_name_//"'" + call assert_msg( 418014896, this%is_open( ), & + "Trying to read from unopen file: "//id_str ) + var_id = this%variable_id( variable_name ) + dim_sizes = this%dimension_sizes( variable_name ) + call assert_msg( 747800090, size( dim_sizes ) .eq. 0, & + "Wrong number of dimensions for "// & + trim( id_str%to_char( ) )//": Expected 0 got "// & + trim( to_char( size( dim_sizes ) ) ) ) + call check_status( 860118435, & + nf90_get_var( this%file_id_, var_id, container ), & + "Error getting value for "//trim( id_str%to_char( ) ) ) + + end subroutine read_0D_int + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Reads 1D integer data + subroutine read_1D_int( this, variable_name, container, requestor_name ) + + use musica_assert, only : assert_msg + use musica_string, only : to_char + use netcdf, only : nf90_get_var + + class(io_netcdf_t), intent(inout) :: this + class(string_t), intent(in) :: variable_name + integer, allocatable, intent(inout) :: container(:) + character(len=*), intent(in) :: requestor_name + + integer :: var_id + integer, allocatable :: dim_sizes(:) + type(string_t) :: id_str + + id_str = "variable '"//variable_name//"' in file '"//this%file_name_//"'" + call assert_msg( 121652260, this%is_open( ), & + "Trying to read from unopen file: "//id_str ) + var_id = this%variable_id( variable_name ) + dim_sizes = this%dimension_sizes( variable_name ) + call assert_msg( 798921103, size( dim_sizes ) .eq. 1, & + "Wrong number of dimensions for "// & + trim( id_str%to_char( ) )//": Expected 1 got "// & + trim( to_char( size( dim_sizes ) ) ) ) + if( allocated( container ) ) then + call assert_msg( 346288950, size( container ) .eq. dim_sizes(1), & + "Wrong size container for "//trim( id_str%to_char( ) ) & + //": Expected "//trim( to_char( dim_sizes(1) ) )// & + " got "//trim( to_char( size( container ) ) ) ) + else + allocate( container( dim_sizes(1) ) ) + end if + call check_status( 458607295, & + nf90_get_var( this%file_id_, var_id, container ), & + "Error getting value for "//trim( id_str%to_char( ) ) ) + + end subroutine read_1D_int + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Writes 0D double data + subroutine write_0D_double( this, variable_name, variable_data, & + requestor_name ) + + use musica_assert, only : assert_msg + use musica_constants, only : musica_dk + use musica_string, only : string_t + use netcdf, only : nf90_def_var, nf90_put_var, & + NF90_DOUBLE + + class(io_netcdf_t), intent(inout) :: this + type(string_t), intent(in) :: variable_name + real(kind=musica_dk), intent(in) :: variable_data + character(len=*), intent(in) :: requestor_name + + integer :: var_id + type(string_t) :: id_str + + id_str = "variable '"//variable_name//"' in file '"//this%file_name_//"'" + call assert_msg( 576950310, this%is_open( ), & + "Trying to write to an unopen file: "//id_str ) + call check_status( 550080126, nf90_def_var( this%file_id_, & + variable_name%to_char( ), & + NF90_DOUBLE, & + varid = var_id ), & + "Error creating "//trim( id_str%to_char( ) ) ) + call check_status( 540003807, & + nf90_put_var( this%file_id_, var_id, variable_data ), & + "Error writing to "//trim( id_str%to_char( ) ) ) + + end subroutine write_0D_double + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Writes 1D double data + !! + !! If the provided dimensions do not exist, they will be created based on + !! the shape of the given data. If they do exist, they must be compatible + !! with the shape of the given data. + subroutine write_1D_double( this, variable_name, dimensions, variable_data, & + requestor_name ) + + use musica_assert, only : assert_msg + use musica_constants, only : musica_dk + use musica_string, only : string_t + use netcdf, only : nf90_def_var, nf90_put_var, & + NF90_DOUBLE + + class(io_netcdf_t), intent(inout) :: this + type(string_t), intent(in) :: variable_name + type(string_t), intent(in) :: dimensions + real(kind=musica_dk), intent(in) :: variable_data(:) + character(len=*), intent(in) :: requestor_name + + integer :: var_id, dimids(1) + type(string_t) :: id_str + + id_str = "variable '"//variable_name//"' in file '"//this%file_name_//"'" + call assert_msg( 616828888, this%is_open( ), & + "Trying to write to an unopen file: "//id_str ) + dimids(1) = this%check_add_dimension( dimensions%to_char( ), & + size( variable_data ) ) + call check_status( 111622483, nf90_def_var( this%file_id_, & + variable_name%to_char( ), & + NF90_DOUBLE, dimids = dimids, & + varid = var_id ), & + "Error creating "//trim( id_str%to_char( ) ) ) + call check_status( 841465578, & + nf90_put_var( this%file_id_, var_id, variable_data ), & + "Error writing to "//trim( id_str%to_char( ) ) ) + + end subroutine write_1D_double + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Writes 2D double data + !! + !! If the provided dimensions do not exist, they will be created based on + !! the shape of the given data. If they do exist, they must be compatible + !! with the shape of the given data. + subroutine write_2D_double( this, variable_name, dimensions, variable_data, & + requestor_name ) + + use musica_assert, only : assert_msg + use musica_constants, only : musica_dk + use musica_string, only : string_t + use netcdf, only : nf90_def_var, nf90_put_var, & + NF90_DOUBLE + + class(io_netcdf_t), intent(inout) :: this + type(string_t), intent(in) :: variable_name + type(string_t), intent(in) :: dimensions(2) + real(kind=musica_dk), intent(in) :: variable_data(:,:) + character(len=*), intent(in) :: requestor_name + + integer :: var_id, dimids(2) + type(string_t) :: id_str + + id_str = "variable '"//variable_name//"' in file '"//this%file_name_//"'" + call assert_msg( 186994325, this%is_open( ), & + "Trying to write to an unopen file: "//id_str ) + dimids(1) = this%check_add_dimension( dimensions(1)%to_char( ), & + size( variable_data, 1 ) ) + dimids(2) = this%check_add_dimension( dimensions(2)%to_char( ), & + size( variable_data, 2 ) ) + call check_status( 916837420, nf90_def_var( this%file_id_, & + variable_name%to_char( ), & + NF90_DOUBLE, dimids = dimids, & + varid = var_id ), & + "Error creating "//trim( id_str%to_char( ) ) ) + call check_status( 464205267, & + nf90_put_var( this%file_id_, var_id, variable_data ), & + "Error writing to "//trim( id_str%to_char( ) ) ) + + end subroutine write_2D_double + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Writes 3D double data + !! + !! If the provided dimensions do not exist, they will be created based on + !! the shape of the given data. If they do exist, they must be compatible + !! with the shape of the given data. + subroutine write_3D_double( this, variable_name, dimensions, variable_data, & + requestor_name ) + + use musica_assert, only : assert_msg + use musica_constants, only : musica_dk + use musica_string, only : string_t + use netcdf, only : nf90_def_var, nf90_put_var, & + NF90_DOUBLE + + class(io_netcdf_t), intent(inout) :: this + type(string_t), intent(in) :: variable_name + type(string_t), intent(in) :: dimensions(3) + real(kind=musica_dk), intent(in) :: variable_data(:,:,:) + character(len=*), intent(in) :: requestor_name + + integer :: var_id, dimids(3) + type(string_t) :: id_str + + id_str = "variable '"//variable_name//"' in file '"//this%file_name_//"'" + call assert_msg( 232851031, this%is_open( ), & + "Trying to write to an unopen file: "//id_str ) + dimids(1) = this%check_add_dimension( dimensions(1)%to_char( ), & + size( variable_data, 1 ) ) + dimids(2) = this%check_add_dimension( dimensions(2)%to_char( ), & + size( variable_data, 2 ) ) + dimids(3) = this%check_add_dimension( dimensions(3)%to_char( ), & + size( variable_data, 3 ) ) + call check_status( 403007935, nf90_def_var( this%file_id_, & + variable_name%to_char( ), & + NF90_DOUBLE, dimids = dimids, & + varid = var_id ), & + "Error creating "//trim( id_str%to_char( ) ) ) + call check_status( 573164839, & + nf90_put_var( this%file_id_, var_id, variable_data ), & + "Error writing to "//trim( id_str%to_char( ) ) ) + + end subroutine write_3D_double + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Writes 4D double data + !! + !! If the provided dimensions do not exist, they will be created based on + !! the shape of the given data. If they do exist, they must be compatible + !! with the shape of the given data. + subroutine write_4D_double( this, variable_name, dimensions, variable_data, & + requestor_name ) + + use musica_assert, only : assert_msg + use musica_constants, only : musica_dk + use musica_string, only : string_t + use netcdf, only : nf90_def_var, nf90_put_var, & + NF90_DOUBLE + + class(io_netcdf_t), intent(inout) :: this + type(string_t), intent(in) :: variable_name + type(string_t), intent(in) :: dimensions(4) + real(kind=musica_dk), intent(in) :: variable_data(:,:,:,:) + character(len=*), intent(in) :: requestor_name + + integer :: var_id, dimids(4) + type(string_t) :: id_str + + id_str = "variable '"//variable_name//"' in file '"//this%file_name_//"'" + call assert_msg( 338451830, this%is_open( ), & + "Trying to write to an unopen file: "//id_str ) + dimids(1) = this%check_add_dimension( dimensions(1)%to_char( ), & + size( variable_data, 1 ) ) + dimids(2) = this%check_add_dimension( dimensions(2)%to_char( ), & + size( variable_data, 2 ) ) + dimids(3) = this%check_add_dimension( dimensions(3)%to_char( ), & + size( variable_data, 3 ) ) + dimids(4) = this%check_add_dimension( dimensions(4)%to_char( ), & + size( variable_data, 4 ) ) + call check_status( 233303326, nf90_def_var( this%file_id_, & + variable_name%to_char( ), & + NF90_DOUBLE, dimids = dimids, & + varid = var_id ), & + "Error creating "//trim( id_str%to_char( ) ) ) + call check_status( 680671172, & + nf90_put_var( this%file_id_, var_id, variable_data ), & + "Error writing to "//trim( id_str%to_char( ) ) ) + + end subroutine write_4D_double + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Writes 0D int data + subroutine write_0D_int( this, variable_name, variable_data, & + requestor_name ) + + use musica_assert, only : assert_msg + use musica_string, only : string_t + use netcdf, only : nf90_def_var, nf90_put_var, & + NF90_INT + + class(io_netcdf_t), intent(inout) :: this + type(string_t), intent(in) :: variable_name + integer, intent(in) :: variable_data + character(len=*), intent(in) :: requestor_name + + integer :: var_id + type(string_t) :: id_str + + id_str = "variable '"//variable_name//"' in file '"//this%file_name_//"'" + call assert_msg( 834034211, this%is_open( ), & + "Trying to write to an unopen file: "//id_str ) + call check_status( 998926808, nf90_def_var( this%file_id_, & + variable_name%to_char( ), & + NF90_INT, & + varid = var_id ), & + "Error creating "//trim( id_str%to_char( ) ) ) + call check_status( 546294655, & + nf90_put_var( this%file_id_, var_id, variable_data ), & + "Error writing to "//trim( id_str%to_char( ) ) ) + + end subroutine write_0D_int + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Writes 1D int data + !! + !! If the provided dimensions do not exist, they will be created based on + !! the shape of the given data. If they do exist, they must be compatible + !! with the shape of the given data. + subroutine write_1D_int( this, variable_name, dimensions, variable_data, & + requestor_name ) + + use musica_assert, only : assert_msg + use musica_string, only : string_t + use netcdf, only : nf90_def_var, nf90_put_var, & + NF90_INT + + class(io_netcdf_t), intent(inout) :: this + type(string_t), intent(in) :: variable_name + type(string_t), intent(in) :: dimensions + integer, intent(in) :: variable_data(:) + character(len=*), intent(in) :: requestor_name + + integer :: var_id, dimids(1) + type(string_t) :: id_str + + id_str = "variable '"//variable_name//"' in file '"//this%file_name_//"'" + call assert_msg( 769478106, this%is_open( ), & + "Trying to write to an unopen file: "//id_str ) + dimids(1) = this%check_add_dimension( dimensions%to_char( ), & + size( variable_data ) ) + call check_status( 257101860, nf90_def_var( this%file_id_, & + variable_name%to_char( ), & + NF90_INT, dimids = dimids, & + varid = var_id ), & + "Error creating "//trim( id_str%to_char( ) ) ) + call check_status( 427258764, & + nf90_put_var( this%file_id_, var_id, variable_data ), & + "Error writing to "//trim( id_str%to_char( ) ) ) + + end subroutine write_1D_int + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Writes 0D double data to append 1D double data + !! + !! If the provided dimensions do not exist, they will be created based on + !! the shape of the given data. If they do exist, they must be compatible + !! with the shape of the given data. + subroutine append_0D_double( this, variable_name, variable_units, & + append_dimension, append_index, variable_data, requestor_name ) + + use musica_assert, only : assert_msg + use musica_constants, only : musica_dk + use musica_string, only : string_t + use netcdf, only : nf90_def_var, nf90_put_var, & + NF90_DOUBLE, NF90_UNLIMITED + + class(io_netcdf_t), intent(inout) :: this + type(string_t), intent(in) :: variable_name + type(string_t), intent(in) :: variable_units + type(string_t), intent(in) :: append_dimension + integer, intent(in) :: append_index + real(kind=musica_dk), intent(in) :: variable_data + character(len=*), intent(in) :: requestor_name + + integer :: varid, dimids(1), start_ids(1), dim_sizes(0) + type(string_t) :: id_str, dimensions(0) + + id_str = "variable '"//variable_name//"' in file '"//this%file_name_//"'" + call assert_msg( 660803774, this%is_open( ), & + "Trying to write to an unopen file: "//id_str ) + call this%check_add_variable( variable_name, variable_units, NF90_DOUBLE, & + append_dimension, dimensions, & + dim_sizes, varid, dimids, start_ids ) + start_ids(1) = append_index + call check_status( 320489966, & + nf90_put_var( this%file_id_, varid, & + (/ variable_data /), start = start_ids, & + count = (/ 1 /) ), & + "Error writing to "//trim( id_str%to_char( ) ) ) + + end subroutine append_0D_double + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Writes 1D double data to append 2D double data + !! + !! If the provided dimensions do not exist, they will be created based on + !! the shape of the given data. If they do exist, they must be compatible + !! with the shape of the given data. + subroutine append_1D_double( this, variable_name, variable_units, & + append_dimension, append_index, dimensions, variable_data, & + requestor_name ) + + use musica_assert, only : assert_msg + use musica_constants, only : musica_dk + use musica_string, only : string_t + use netcdf, only : nf90_def_var, nf90_put_var, & + NF90_DOUBLE, NF90_UNLIMITED + + class(io_netcdf_t), intent(inout) :: this + type(string_t), intent(in) :: variable_name + type(string_t), intent(in) :: variable_units + type(string_t), intent(in) :: append_dimension + integer, intent(in) :: append_index + type(string_t), intent(in) :: dimensions + real(kind=musica_dk), intent(in) :: variable_data(:) + character(len=*), intent(in) :: requestor_name + + integer :: varid, dim_sizes(1), dimids(2), start_ids(2) + type(string_t) :: id_str + + id_str = "variable '"//variable_name//"' in file '"//this%file_name_//"'" + call assert_msg( 246721328, this%is_open( ), & + "Trying to write to an unopen file: "//id_str ) + dim_sizes(1) = size( variable_data ) + call this%check_add_variable( variable_name, variable_units, NF90_DOUBLE, & + append_dimension, (/ dimensions /), & + dim_sizes, varid, dimids, start_ids ) + start_ids(1) = append_index + call check_status( 641514922, & + nf90_put_var( this%file_id_, varid, & + (/ variable_data /), start = start_ids, & + count = (/ 1, size( variable_data ) /) ),& + "Error writing to "//trim( id_str%to_char( ) ) ) + + end subroutine append_1D_double + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Writes 2D double data to append 3D double data + !! + !! If the provided dimensions do not exist, they will be created based on + !! the shape of the given data. If they do exist, they must be compatible + !! with the shape of the given data. + subroutine append_2D_double( this, variable_name, variable_units, & + append_dimension, append_index, dimensions, variable_data, & + requestor_name ) + + use musica_assert, only : assert_msg + use musica_constants, only : musica_dk + use musica_string, only : string_t + use netcdf, only : nf90_def_var, nf90_put_var, & + NF90_DOUBLE, NF90_UNLIMITED + + class(io_netcdf_t), intent(inout) :: this + type(string_t), intent(in) :: variable_name + type(string_t), intent(in) :: variable_units + type(string_t), intent(in) :: append_dimension + integer, intent(in) :: append_index + type(string_t), intent(in) :: dimensions(2) + real(kind=musica_dk), intent(in) :: variable_data(:,:) + character(len=*), intent(in) :: requestor_name + + integer :: varid, dim_sizes(2), dimids(3), start_ids(3) + type(string_t) :: id_str + + id_str = "variable '"//variable_name//"' in file '"//this%file_name_//"'" + call assert_msg( 264592928, this%is_open( ), & + "Trying to write to an unopen file: "//id_str ) + dim_sizes(1) = size( variable_data, 1 ) + dim_sizes(2) = size( variable_data, 2 ) + call this%check_add_variable( variable_name, variable_units, NF90_DOUBLE, & + append_dimension, dimensions, & + dim_sizes, varid, dimids, start_ids ) + start_ids(1) = append_index + call check_status( 889287519, & + nf90_put_var( this%file_id_, varid, & + variable_data, start = start_ids, & + count = (/ 1, size( variable_data, 1 ), & + size( variable_data, 2 ) /) ),& + "Error writing to "//trim( id_str%to_char( ) ) ) + + end subroutine append_2D_double + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Writes 3D double data to append 4D double data + !! + !! If the provided dimensions do not exist, they will be created based on + !! the shape of the given data. If they do exist, they must be compatible + !! with the shape of the given data. + subroutine append_3D_double( this, variable_name, variable_units, & + append_dimension, append_index, dimensions, variable_data, & + requestor_name ) + + use musica_assert, only : assert_msg + use musica_constants, only : musica_dk + use musica_string, only : string_t + use netcdf, only : nf90_def_var, nf90_put_var, & + NF90_DOUBLE, NF90_UNLIMITED + + class(io_netcdf_t), intent(inout) :: this + type(string_t), intent(in) :: variable_name + type(string_t), intent(in) :: variable_units + type(string_t), intent(in) :: append_dimension + integer, intent(in) :: append_index + type(string_t), intent(in) :: dimensions(3) + real(kind=musica_dk), intent(in) :: variable_data(:,:,:) + character(len=*), intent(in) :: requestor_name + + integer :: varid, dim_sizes(3), dimids(4), start_ids(4) + type(string_t) :: id_str + + id_str = "variable '"//variable_name//"' in file '"//this%file_name_//"'" + call assert_msg( 351946623, this%is_open( ), & + "Trying to write to an unopen file: "//id_str ) + dim_sizes(1) = size( variable_data, 1 ) + dim_sizes(2) = size( variable_data, 2 ) + dim_sizes(3) = size( variable_data, 3 ) + call this%check_add_variable( variable_name, variable_units, NF90_DOUBLE, & + append_dimension, dimensions, & + dim_sizes, varid, dimids, start_ids ) + start_ids(1) = append_index + call check_status( 181789719, & + nf90_put_var( this%file_id_, varid, & + variable_data, start = start_ids, & + count = (/ 1, size( variable_data, 1 ), & + size( variable_data, 2 ), & + size( variable_data, 3 ) /) ),& + "Error writing to "//trim( id_str%to_char( ) ) ) + + end subroutine append_3D_double + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Writes 0D int data to append 1D int data + !! + !! If the provided dimensions do not exist, they will be created based on + !! the shape of the given data. If they do exist, they must be compatible + !! with the shape of the given data. + subroutine append_0D_int( this, variable_name, variable_units, & + append_dimension, append_index, variable_data, requestor_name ) + + use musica_assert, only : assert_msg + use musica_string, only : string_t + use netcdf, only : nf90_def_var, nf90_put_var, & + NF90_INT, NF90_UNLIMITED + + class(io_netcdf_t), intent(inout) :: this + type(string_t), intent(in) :: variable_name + type(string_t), intent(in) :: variable_units + type(string_t), intent(in) :: append_dimension + integer, intent(in) :: append_index + integer, intent(in) :: variable_data + character(len=*), intent(in) :: requestor_name + + integer :: varid, dimids(1), start_ids(1), dim_sizes(0) + type(string_t) :: id_str, dimensions(0) + + id_str = "variable '"//variable_name//"' in file '"//this%file_name_//"'" + call assert_msg( 896317785, this%is_open( ), & + "Trying to write to an unopen file: "//id_str ) + call this%check_add_variable( variable_name, variable_units, NF90_INT, & + append_dimension, dimensions, & + dim_sizes, varid, dimids, start_ids ) + start_ids(1) = append_index + call check_status( 108636131, & + nf90_put_var( this%file_id_, varid, & + (/ variable_data /), start = start_ids, & + count = (/ 1 /) ), & + "Error writing to "//trim( id_str%to_char( ) ) ) + + end subroutine append_0D_int + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Returns whether a variable exists in the file + logical function exists_char( this, variable_name, requestor_name ) & + result( exists ) + + use netcdf, only : nf90_inq_varid, & + NF90_ENOTVAR + + class(io_netcdf_t), intent(in) :: this + character(len=*), intent(in) :: variable_name + character(len=*), intent(in) :: requestor_name + + integer :: var_id, err_id + + err_id = nf90_inq_varid( this%file_id_, variable_name, var_id ) + + exists = .false. + if( err_id == NF90_ENOTVAR ) return + call check_status( 855364555, err_id, "Error trying to find variable '"// & + variable_name//"' in NetCDF file '"// & + trim( this%file_name_%to_char( ) )//"' for "// & + requestor_name ) + exists = .true. + + end function exists_char + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Returns whether a variable exists in the file + logical function exists_string( this, variable_name, requestor_name ) & + result( exists ) + + use musica_string, only : string_t + + class(io_netcdf_t), intent(in) :: this + type(string_t), intent(in) :: variable_name + character(len=*), intent(in) :: requestor_name + + exists = this%exists_char( variable_name%to_char( ), requestor_name ) + + end function exists_string + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Returns the dimension names for a given variable + function variable_dimensions( this, variable_name, requestor_name ) & + result( dimensions ) + + use musica_string, only : to_char + use netcdf, only : NF90_MAX_NAME, & + nf90_inquire_variable, & + nf90_inquire_dimension + + type(string_t), allocatable :: dimensions(:) + class(io_netcdf_t), intent(in) :: this + class(string_t), intent(in) :: variable_name + character(len=*), intent(in) :: requestor_name + + integer :: var_id, i_dim, n_dims + integer, allocatable :: dimids(:) + type(string_t) :: id_str + character(len=NF90_MAX_NAME) :: dim_name + + id_str = "variable '"//variable_name//"' in file '"//this%file_name_//"'" + var_id = this%variable_id( variable_name ) + call check_status( 744311319, & + nf90_inquire_variable( this%file_id_, var_id, ndims = n_dims ), & + "Error getting number of dimensions for "//id_str%to_char( ) ) + allocate( dimids( n_dims ) ) + call check_status( 104014576, & + nf90_inquire_variable( this%file_id_, var_id, dimids = dimids ), & + "Error getting dimesions for "//id_str%to_char( ) ) + allocate( dimensions( n_dims ) ) + do i_dim = 1, n_dims + call check_status( 788714786, & + nf90_inquire_dimension( this%file_id_, dimids( i_dim ), & + name = dim_name ),& + "Error getting dimesion size "//trim( to_char( i_dim ) )//" for "// & + id_str%to_char( ) ) + dimensions( i_dim ) = trim( dim_name ) + end do + + end function variable_dimensions + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Returns the units for a given variable + function variable_units( this, variable_name, requestor_name ) + + use netcdf, only : NF90_MAX_NAME, & + nf90_get_att + + type(string_t) :: variable_units + class(io_netcdf_t), intent(in) :: this + class(string_t), intent(in) :: variable_name + character(len=*), intent(in) :: requestor_name + + integer :: var_id + type(string_t) :: id_str + character(len=NF90_MAX_NAME) :: units + + id_str = "variable '"//variable_name//"' in file '"//this%file_name_//"'" + var_id = this%variable_id( variable_name ) + call check_status( 301987512, & + nf90_get_att( this%file_id_, var_id, "units", units ), & + "Error getting units for "//trim( id_str%to_char( ) ) ) + variable_units = trim( units ) + + end function variable_units + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Sets the units for a given variable + subroutine set_variable_units( this, variable_name, units, requestor_name ) + + use musica_string, only : string_t + use netcdf, only : nf90_put_att + + class(io_netcdf_t), intent(inout) :: this + class(string_t), intent(in) :: variable_name + class(string_t), intent(in) :: units + character(len=*), intent(in) :: requestor_name + + integer :: var_id + type(string_t) :: id_str + + id_str = "variable '"//variable_name//"' in file '"//this%file_name_//"'" + var_id = this%variable_id( variable_name ) + call check_status( 235495983, & + nf90_put_att( this%file_id_, var_id, "units", & + units%to_char( ) ), & + "Error setting units for "//trim( id_str%to_char( ) ) ) + + end subroutine set_variable_units + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Returns whether a file is open or not + logical function is_open( this ) + + class(io_netcdf_t), intent(in) :: this + + is_open = this%file_id_ .ne. kUnknownFileId + + end function is_open + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Returns a variable's id in the NetCDF file + integer function variable_id( this, variable_name ) + + use musica_assert, only : assert_msg + use netcdf, only : nf90_inq_varid + + class(io_netcdf_t), intent(in) :: this + class(string_t), intent(in) :: variable_name + + call assert_msg( 249726322, this%is_open( ), & + "Trying to read from unopen file: '"// & + this%file_name_//"'" ) + call check_status( 153462424, & + nf90_inq_varid( this%file_id_, & + variable_name%to_char( ), & + variable_id ), & + "Cannot find variable '"// & + trim( variable_name%to_char( ) )//"' in file '"// & + trim( this%file_name_%to_char( ) )//"'" ) + + end function variable_id + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Returns the dimensions for variable in the NetCDF file + function dimension_sizes( this, variable_name ) result( dim_sizes ) + + use musica_assert, only : assert_msg + use musica_string, only : to_char + use netcdf, only : nf90_inquire_variable, & + nf90_inquire_dimension + + integer, allocatable :: dim_sizes(:) + class(io_netcdf_t), intent(in) :: this + class(string_t), intent(in) :: variable_name + + integer :: var_id, n_dims, i_dim + integer, allocatable :: dimids(:) + type(string_t) :: id_str + + id_str = "variable '"//variable_name//"' in file '"//this%file_name_//"'" + call assert_msg( 191887763, this%is_open( ), & + "Trying to read from unopen file: "//id_str ) + var_id = this%variable_id( variable_name ) + call check_status( 516121527, & + nf90_inquire_variable( this%file_id_, var_id, ndims = n_dims ), & + "Error getting number of dimensions for "//trim( id_str%to_char( ) ) ) + allocate( dimids( n_dims ) ) + call check_status( 269878960, & + nf90_inquire_variable( this%file_id_, var_id, dimids = dimids ), & + "Error getting dimensions for "//trim( id_str%to_char( ) ) ) + allocate( dim_sizes( n_dims ) ) + do i_dim = 1, n_dims + call check_status( 770273353, & + nf90_inquire_dimension( this%file_id_, dimids( i_dim ), & + len = dim_sizes( i_dim ) ), & + "Error getting dimension size "//trim( to_char( i_dim ) )//" for "//& + trim( id_str%to_char( ) ) ) + end do + + end function dimension_sizes + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Checks if a dimension exists and verifies its size + !! + !! If the dimension does not exist, it is created. The dimension id is + !! returned. + function check_add_dimension( this, dim_name, dim_size ) result( dimid ) + + use musica_assert, only : assert_msg + use musica_string, only : string_t, to_char + use netcdf, only : nf90_inq_dimid, & + nf90_inquire_dimension, & + nf90_def_dim, & + NF90_NOERR, NF90_UNLIMITED + + integer :: dimid + class(io_netcdf_t), intent(inout) :: this + character(len=*), intent(in) :: dim_name + integer, intent(in) :: dim_size + + integer :: ierr, curr_size + type(string_t) :: id_str + + id_str = "dimension '"//dim_name//"' in file '"//this%file_name_//"'" + + ierr = nf90_inq_dimid( this%file_id_, dim_name, dimid ) + if( ierr == NF90_NOERR ) then + ! dimension exists, check its size, unless it's unlimited + if( dim_size .ne. NF90_UNLIMITED ) then + call check_status( 737744716, & + nf90_inquire_dimension( this%file_id_, dimid, & + len = curr_size ), & + "NetCDF file error for "// & + trim( id_str%to_char( ) ) ) + call assert_msg( 343403417, curr_size == dim_size, & + "Dimension mismatch for "//trim( id_str%to_char( ) ) & + //"; Expected "//trim( to_char( curr_size ) )// & + ", got "//trim( to_char( dim_size ) ) ) + end if + else + call check_status( 947493075, & + nf90_def_dim( this%file_id_, dim_name, dim_size, & + dimid ), & + "NetCDF file error for "//trim( id_str%to_char( ) ) ) + end if + + end function check_add_dimension + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Checks for an appendable variable in the file and adds it if it does not + !! exist yet + subroutine check_add_variable( this, variable_name, variable_units, & + variable_type, append_dimension, dimensions, dimension_sizes, varid, & + dimids, start_ids ) + + use musica_assert, only : assert_msg + use musica_string, only : string_t, to_char + use netcdf, only : nf90_inq_varid, & + nf90_inquire_dimension, & + nf90_inquire_variable, & + nf90_def_var, & + nf90_put_att, & + NF90_NOERR, NF90_UNLIMITED + + class(io_netcdf_t), intent(inout) :: this + type(string_t), intent(in) :: variable_name + type(string_t), intent(in) :: variable_units + integer, intent(in) :: variable_type + type(string_t), intent(in) :: append_dimension + type(string_t), intent(in) :: dimensions(:) + integer, intent(in) :: dimension_sizes(:) + integer, intent(out) :: varid + integer, intent(out) :: dimids(size(dimensions)+1) + integer, intent(out) :: start_ids(size(dimensions)+1) + + integer :: ierr, i_dim, ndims, ldimids(size(dimensions)+1) + type(string_t) :: id_str + + id_str = "variable '"//variable_name//"' in file '"//this%file_name_//"'" + + dimids = this%check_add_dimension( trim( append_dimension%to_char( ) ), & + NF90_UNLIMITED ) + do i_dim = 1, size( dimensions ) + dimids( i_dim + 1 ) = & + this%check_add_dimension( trim( dimensions( i_dim )%to_char( ) ), & + dimension_sizes( i_dim ) ) + end do + start_ids = 1 + ierr = nf90_inq_varid( this%file_id_, variable_name%to_char( ), varid ) + if( ierr == NF90_NOERR ) then + ! Check the dimension ids and units + call check_status( 372537549, & + nf90_inquire_variable( this%file_id_, varid, & + ndims = ndims, & + dimids = ldimids ), & + "NetCDF file error for "//trim( id_str%to_char( ) ) ) + call assert_msg( 192756621, ndims == size( dimensions ) + 1, & + "Dimension mismatch for "//trim( id_str%to_char( ) ) ) + do i_dim = 1, size( dimids ) + call assert_msg( 900541544, dimids( i_dim ) == ldimids( i_dim ), & + "Dimension "//trim( to_char( i_dim ) )// & + " mismatch for "//trim( id_str%to_char( ) ) ) + end do + call check_status( 302003316, & + nf90_inquire_dimension( this%file_id_, dimids(1), & + len = start_ids(1) ), & + "NetCDF file error for "//trim( id_str%to_char( ) ) ) + start_ids(1) = start_ids(1) + 1 + else + call check_status( 497577165, & + nf90_def_var( this%file_id_, & + variable_name%to_char( ), & + variable_type, dimids, varid ), & + "NetCDF file error for "//trim( id_str%to_char( ) ) ) + call check_status( 757618738, & + nf90_put_att( this%file_id_, varid, "units", & + variable_units%to_char( ) ), & + "Error setting units for "// & + trim( id_str%to_char( ) ) ) + end if + + end subroutine check_add_variable + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Finalizes a NetCDF file reader + subroutine finalize( this ) + + use netcdf, only : nf90_close + + type(io_netcdf_t), intent(inout) :: this + + if( this%file_id_ .ne. kUnknownFileId ) then + call check_status( 708311006, nf90_close( this%file_id_ ), & + "Error closing file" ) + end if + this%file_id_ = kUnknownFileId + this%file_name_ = "" + + end subroutine finalize + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! +!! @name Private NetCDF support functions +!! @{ +!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Checks a NetCDF status code and fail with a message if an error occurred + subroutine check_status( code, status, error_message ) + + use musica_assert, only : die_msg + use netcdf, only : NF90_NOERR, nf90_strerror + + !> Unique code to associate with any failure + integer, intent(in) :: code + !> NetCDF status code + integer, intent(in) :: status + !> Error message to display on failure + character(len=*), intent(in) :: error_message + + if( status .eq. NF90_NOERR ) return + call die_msg( 330311277, "NetCDF error: "//trim( error_message )//": "// & + trim( nf90_strerror( status ) ) ) + + end subroutine check_status + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +!> @} + +end module musica_io_netcdf diff --git a/src/util/iterator.F90 b/src/util/iterator.F90 new file mode 100644 index 00000000..b40411d2 --- /dev/null +++ b/src/util/iterator.F90 @@ -0,0 +1,81 @@ +! Copyright (C) 2020 National Center for Atmospheric Research +! SPDX-License-Identifier: Apache-2.0 +! +!> \file +!> The musica_iterator module + +!> The abstract iterator_t type and related functions +module musica_iterator + + implicit none + private + + public :: iterator_t + + !> An abstract iterator + !! + !! Extending types should provide a constructor that returns a pointer to a + !! iterator_t that references a newly allocated iterator of the extending + !! type. The iterator must be in the state it would be in after a call to + !! \c reset. + !! + !! Example usage: + !! \code{f90} + !! use musica_foo_iterator, only : foo_iterator_t + !! use musica_iterator, only : iterator_t + !! + !! class(iterator), pointer :: my_iterator + !! + !! my_iterator => foo_iterator_t( ) ! can accept arguments if necessary + !! do while( my_iterator%next( ) ) + !! some_function( my_iterator, ... ) ! use a function that uses a foo_iterator_t + !! end do + !! call my_iterator%reset( ) ! reset the iterator + !! do while( my_iterator%next( ) ) + !! some_other_function( my_iterator, ... ) + !! end do + !! deallocate( my_iterator ) + !! \endcode + !! + type, abstract :: iterator_t + contains + !> Advances the iterator + procedure(next), deferred :: next + !> Resets the iterator to the beginning of the collection + procedure(reset), deferred :: reset + end type iterator_t + +interface +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Advances the iterator + !! + !! Returns true if the iterator was advanced to the next record, returns + !! false if the end of the collection has been reached. + logical function next( this ) + import iterator_t + !> Iterator + class(iterator_t), intent(inout) :: this + end function next + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Resets the iterator to the beginning of the collection + !! + !! For iterators that target nested sets of elements (e.g., cells within a + !! column), the reset function can require a higher-level iterator whose + !! current target will be used to identify the nested set of elements to + !! iterate over. + !! + subroutine reset( this, parent ) + import iterator_t + !> Iterator + class(iterator_t), intent(inout) :: this + !> Iterator for parent model element + class(iterator_t), intent(in), optional :: parent + end subroutine reset + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +end interface + +end module musica_iterator diff --git a/src/util/map.F90 b/src/util/map.F90 new file mode 100644 index 00000000..db35c389 --- /dev/null +++ b/src/util/map.F90 @@ -0,0 +1,637 @@ +! Copyright (C) 2020 National Center for Atmospheric Research +! SPDX-License-Identifier: Apache-2.0 +! +!> \file +!> The musica_map module + +!> Utility for mapping among arrays +module musica_map + + use musica_constants, only : dk => musica_dk + + implicit none + private + + public :: map_t + + !> Matched pair + type :: pair_t + private + !> Index in source array + integer :: from_index_ + !> Index in destination array + integer :: to_index_ + !> Scaling factor applied to source data + real(kind=dk) :: scale_factor_ = 1.0 + contains + !> Returns the size of a binary buffer required to pack the pair + procedure :: pack_size => pair_pack_size + !> Packs the pair onto a characcter buffer + procedure :: mpi_pack => pair_mpi_pack + !> Unpacks a pair from a character buffer + procedure :: mpi_unpack => pair_mpi_unpack + end type pair_t + + !> Constructor of pair_t objects + interface pair_t + module procedure :: pair_constructor + end interface pair_t + + !> Map between arrays + !! + !! Maps can be used to transfer data from a source to a destination array + !! with optional scaling. + !! + !! The mapped elements are identified by name according to the passed + !! configuration. The configuration format for a map is: + !! \code{json} + !! { + !! "match full source": false, + !! "match full destination": false, + !! "sum multiple matches": true, + !! "default matching": "backup", + !! "pairs": [ + !! { + !! "from": "foo", + !! "to": "bar" + !! }, + !! { + !! "from": "baz", + !! "to": "quz", + !! "scale by": 1.2 + !! } + !! ] + !! } + !! \endcode + !! + !! The "match full source" and "match full destination" terms are optional + !! and default to \c true. + !! When these are \c true unmatched source/destination array elements will + !! trigger an error. + !! If unmatched destination elements are allowed, they will be set to + !! zero when the map is applied to transfer data. + !! The "sum multiple matches" term is optional and defaults to \c false. + !! When this is \c true, multiple matches to a single destination array + !! element will be summed when the map is applied to transfer data. + !! When this is \c false, the second match to a destination array + !! element will trigger an error. + !! The "default matching" term is optional and indicates how matching + !! names that appear in both source and destination label arrays + !! should be treated. + !! The three options for default matching are "always", "backup", + !! and "never"; the default option is "never". + !! Default matching "always" indicates that every time a name appears + !! in both the source and destination label arrays, a set of paired + !! elements should be created in the map with a scaling factor of 1.0. + !! Default matching "backup" indicates that such a pair is only + !! created when no explicit entries for the destination element + !! exist in the configuration. + !! Default mapping "never" means that no such pairs are created. + !! If the default mapping is set to "always" or "backup", the + !! "match full destination" term must be \c true. + !! + !! The "pairs" term is required and is an array that + !! describes each matched pair of elements. The matched pair terms + !! must include "from" and "to" terms. + !! The "scale by" term is optional and defaults to 1.0. + !! This scaling factor will be applied to the source array element + !! before additon to the destination array element. + !! + !! The \c map_t constructor accepts an array of source element labels + !! and an array of destination element labels that are used to + !! identify the mapped array indices. + !! + type :: map_t + private + !> Mapped pairs of array elements + type(pair_t), allocatable :: pairs_(:) + !> Source array size + integer :: from_size_ + !> Destination array size + integer :: to_size_ + contains + !> Transfers data from source to destination arrays + procedure :: apply + !> Returns the size of a character buffer required to pack the map + procedure :: pack_size + !> Packs the map onto a character buffer + procedure :: mpi_pack + !> Unpacks the map from a character buffer + procedure :: mpi_unpack + !> Prints the map + procedure :: print => print_map + !> Adds default matches by name to the map + procedure, private :: add_default_matches + !> Validates the matches based on user-selected options + procedure, private :: validate + end type map_t + + !> Constructor of map_t objects + interface map_t + module procedure :: constructor + end interface map_t + +contains + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Constructs a map_t object + type(map_t) function constructor( config, from_labels, to_labels ) & + result( this ) + + use musica_assert, only : assert_msg + use musica_config, only : config_t + use musica_iterator, only : iterator_t + use musica_string, only : string_t + + !> Map configuration + type(config_t), intent(inout) :: config + !> Source array element labels + type(string_t), intent(in) :: from_labels(:) + !> Destination array element labels + type(string_t), intent(in) :: to_labels(:) + + character(len=*), parameter :: my_name = "Map constructor" + type(config_t) :: pairs, pair + class(iterator_t), pointer :: iter + integer :: i_pair + integer, allocatable :: source_match(:), dest_match(:) + type(string_t) :: default_matching + type(string_t) :: required_keys(1), optional_keys(4) + + required_keys(1) = "pairs" + optional_keys(1) = "match full source" + optional_keys(2) = "match full destination" + optional_keys(3) = "sum multiple matches" + optional_keys(4) = "default matching" + + call assert_msg( 170733942, & + config%validate( required_keys, optional_keys ), & + "Bad configuration format for map." ) + call config%get( "default matching", default_matching, my_name, & + default = "never" ) + call config%get( "pairs", pairs, my_name ) + + this%from_size_ = size( from_labels ) + this%to_size_ = size( to_labels ) + + ! Get all matched pairs + allocate( this%pairs_( pairs%number_of_children( ) ) ) + iter => pairs%get_iterator( ) + i_pair = 0 + do while( iter%next( ) ) + call pairs%get( iter, pair, my_name ) + i_pair = i_pair + 1 + this%pairs_( i_pair ) = pair_t( pair, from_labels, to_labels ) + end do + deallocate( iter ) + + if( default_matching == "always" ) then + call this%add_default_matches( from_labels, to_labels, always = .true. ) + else if( default_matching == "backup" ) then + call this%add_default_matches( from_labels, to_labels, always = .false. ) + else + call assert_msg( 135980113, default_matching == "never", & + "Invalid default matching option for map creation: '"//& + default_matching//"'" ) + end if + + call this%validate( config, from_labels, to_labels ) + + end function constructor + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Transfers data from source to destination array based on map + subroutine apply( this, from, to ) + + use musica_assert, only : assert_msg + + !> Map + class(map_t), intent(in) :: this + !> Source array + real(kind=dk), intent(in) :: from(:) + !> Destination array + real(kind=dk), intent(out) :: to(:) + + integer :: i_elem + + call assert_msg( 764798475, size( from ) .eq. this%from_size_, & + "Wrong size for mapped source array." ) + call assert_msg( 133386338, size( to ) .eq. this%to_size_, & + "Wrong size for mapped destination array." ) + to(:) = 0.0_dk + do i_elem = 1, size( this%pairs_ ) + associate( pair => this%pairs_( i_elem ) ) + to( pair%to_index_ ) = to( pair%to_index_ ) + & + from( pair%from_index_ ) * & + pair%scale_factor_ + end associate + end do + + end subroutine apply + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Returns the size of a binary buffer required to pack the map + integer function pack_size( this, comm ) + + use musica_mpi + + !> Map to pack + class(map_t), intent(in) :: this + !> MPI communicator + integer, intent(in) :: comm + +#ifdef MUSICA_USE_MPI + integer :: i_pair + + pack_size = musica_mpi_pack_size( allocated( this%pairs_ ), comm ) + if( allocated( this%pairs_ ) ) then + pack_size = pack_size + & + musica_mpi_pack_size( size( this%pairs_ ), comm ) + do i_pair = 1, size( this%pairs_ ) + pack_size = pack_size + this%pairs_( i_pair )%pack_size( comm ) + end do + end if + pack_size = pack_size + musica_mpi_pack_size( this%from_size_, comm ) + & + musica_mpi_pack_size( this%to_size_, comm ) +#else + pack_size = 0 +#endif + + end function pack_size + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Packs the map onto a character buffer + subroutine mpi_pack( this, buffer, position, comm ) + + use musica_assert, only : assert + use musica_mpi + + !> Map to pack + class(map_t), intent(in) :: this + !> Memory buffer + character, intent(inout) :: buffer(:) + !> Current buffer position + integer, intent(inout) :: position + !> MPI communicator + integer, intent(in) :: comm + +#ifdef MUSICA_USE_MPI + integer :: i_pair, prev_position + + prev_position = position + call musica_mpi_pack( buffer, position, allocated( this%pairs_ ), comm ) + if( allocated( this%pairs_ ) ) then + call musica_mpi_pack( buffer, position, size( this%pairs_ ), comm ) + do i_pair = 1, size( this%pairs_ ) + call this%pairs_( i_pair )%mpi_pack( buffer, position, comm ) + end do + end if + call musica_mpi_pack( buffer, position, this%from_size_, comm ) + call musica_mpi_pack( buffer, position, this%to_size_, comm ) + call assert( 419959778, & + position - prev_position <= this%pack_size( comm ) ) +#endif + + end subroutine mpi_pack + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Unpacks a map from a character buffer + subroutine mpi_unpack( this, buffer, position, comm ) + + use musica_assert, only : assert + use musica_mpi + + !> Map to unpack + class(map_t), intent(out) :: this + !> Memory buffer + character, intent(inout) :: buffer(:) + !> Current buffer position + integer, intent(inout) :: position + !> MPI communicator + integer, intent(in) :: comm + +#ifdef MUSICA_USE_MPI + logical :: alloced + integer :: i_pair, n_pairs, prev_position + + prev_position = position + call musica_mpi_unpack( buffer, position, alloced, comm ) + if( alloced ) then + call musica_mpi_unpack( buffer, position, n_pairs, comm ) + allocate( this%pairs_( n_pairs ) ) + do i_pair = 1, size( this%pairs_ ) + call this%pairs_( i_pair )%mpi_unpack( buffer, position, comm ) + end do + end if + call musica_mpi_unpack( buffer, position, this%from_size_, comm ) + call musica_mpi_unpack( buffer, position, this%to_size_, comm ) + call assert( 576681590, & + position - prev_position <= this%pack_size( comm ) ) +#endif + + end subroutine mpi_unpack + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Prints the map details to a specified output unit + subroutine print_map( this, from_labels, to_labels, out_unit ) + + use musica_assert, only : assert_msg + use musica_string, only : string_t, output_table + + !> Map + class(map_t), intent(in) :: this + !> Source array element labels + type(string_t), intent(in) :: from_labels(:) + !> Destination array element labels + type(string_t), intent(in) :: to_labels(:) + !> Output unit + integer, intent(in) :: out_unit + + type(string_t) :: header(3) + type(string_t), allocatable :: table(:,:) + integer :: i_pair + + call assert_msg( 727878410, size( from_labels ) .eq. this%from_size_, & + "Wrong size for map source label array." ) + call assert_msg( 161474673, size( to_labels ) .eq. this%to_size_, & + "Wrong size for map destination label array." ) + if( .not. allocated( this%pairs_ ) ) then + write(out_unit,*) "Map not initialized" + return + end if + header(1) = "from" + header(2) = "to" + header(3) = "scaling factor" + allocate( table( 3, size( this%pairs_ ) ) ) + do i_pair = 1, size( this%pairs_ ) + associate( pair => this%pairs_( i_pair ) ) + table( 1, i_pair ) = from_labels( pair%from_index_ ) + table( 2, i_pair ) = to_labels( pair%to_index_ ) + table( 3, i_pair ) = pair%scale_factor_ + end associate + end do + call output_table( header, table, out_unit ) + + end subroutine print_map + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Adds default matches by name to the map + !! + !! If the \c always option is set to \c false, only unmatched source + !! elements are included in the default matching + subroutine add_default_matches( this, from_labels, to_labels, always ) + + use musica_array, only : find_string_in_array + use musica_string, only : string_t + + !> Map + class(map_t), intent(inout) :: this + !> Source array element labels + type(string_t), intent(in) :: from_labels(:) + !> Destination array element labels + type(string_t), intent(in) :: to_labels(:) + !> Flag indicating whether to always add default matches, or only do so + !! for unmatched source elements + logical, intent(in) :: always + + integer :: matches( size( to_labels ) ) + integer :: i_to, i_from, i_pair + type(pair_t) :: pair + + matches(:) = 0 + if( .not. always ) then + do i_pair = 1, size( this%pairs_ ) + i_to = this%pairs_( i_pair )%to_index_ + matches( i_to ) = matches( i_to ) + 1 + end do + end if + do i_to = 1, size( to_labels ) + if( matches( i_to ) > 0 ) cycle + if( find_string_in_array( from_labels, to_labels( i_to ), i_from, & + case_sensitive = .true. ) ) then + pair%to_index_ = i_to + pair%from_index_ = i_from + pair%scale_factor_ = 1.0_dk + this%pairs_ = [ this%pairs_, pair ] + end if + end do + + end subroutine add_default_matches + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Validates the map based on user-selected options + subroutine validate( this, config, from_labels, to_labels ) + + use musica_assert, only : assert_msg + use musica_config, only : config_t + use musica_string, only : string_t + + !> Map + class(map_t), intent(in) :: this + !> Map configuration + type(config_t), intent(inout) :: config + !> Source array element labels + type(string_t), intent(in) :: from_labels(:) + !> Destination array element labels + type(string_t), intent(in) :: to_labels(:) + + character(len=*), parameter :: my_name = "Map validation" + integer, allocatable :: match(:) + type(string_t) :: default_matching + integer :: i_pair, i_elem + logical :: match_source + logical :: match_dest + logical :: allow_sum + + call config%get( "match full source", match_source, my_name, & + default = .true. ) + call config%get( "match full destination", match_dest, my_name, & + default = .true. ) + call config%get( "sum multiple matches", allow_sum, my_name, & + default = .false. ) + call config%get( "default matching", default_matching, my_name, & + default = "never" ) + + call assert_msg( 548594113, match_dest .or. default_matching == "never", & + "Default matching is only possible when matching the "// & + "full destination array for maps." ) + + if( match_source ) then + allocate( match( this%from_size_ ) ) + match(:) = 0 + do i_pair = 1, size( this%pairs_ ) + associate( match_elem => match( this%pairs_( i_pair )%from_index_ ) ) + match_elem = match_elem + 1 + end associate + end do + do i_elem = 1, size( match ) + call assert_msg( 956987954, match( i_elem ) > 0, & + "Unmatched element '"//from_labels( i_elem )// & + "' in source array of map." ) + end do + deallocate( match ) + end if + + if( match_dest .or. .not. allow_sum ) then + allocate( match( this%to_size_ ) ) + match(:) = 0 + do i_pair = 1, size( this%pairs_ ) + associate( match_elem => match( this%pairs_( i_pair )%to_index_ ) ) + match_elem = match_elem + 1 + end associate + end do + do i_elem = 1, size( match ) + call assert_msg( 200274675, & + match( i_elem ) > 0 .or. .not. match_dest, & + "Unmatched element '"//to_labels( i_elem )// & + "' in destination array of map." ) + call assert_msg( 240867074, & + match( i_elem ) < 2 .or. allow_sum, & + "Multiple matches found for element '"// & + to_labels( i_elem )// & + "' in destination array of map." ) + end do + deallocate( match ) + end if + + end subroutine validate + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Constructor of pair_t objects + type(pair_t) function pair_constructor( config, from_labels, to_labels ) & + result( this ) + + use musica_array, only : find_string_in_array + use musica_assert, only : assert_msg + use musica_config, only : config_t + use musica_string, only : string_t + + !> Matched pair configuration + type(config_t), intent(inout) :: config + !> Source array element labels + type(string_t), intent(in) :: from_labels(:) + !> Destination array element labels + type(string_t), intent(in) :: to_labels(:) + + character(len=*), parameter :: my_name = "Map pair constructor" + type(string_t) :: label + type(string_t) :: required_keys(2), optional_keys(1) + + required_keys(1) = "from" + required_keys(2) = "to" + optional_keys(1) = "scale by" + + call assert_msg( 309595761, & + config%validate( required_keys, optional_keys ), & + "Bad configuration format for map pair." ) + + call config%get( "from", label, my_name ) + call assert_msg( 122570601, & + find_string_in_array( from_labels, label, & + this%from_index_, case_sensitive = .true. ), & + "Cannot find source label '"//label//"' building map." ) + call config%get( "to", label, my_name ) + call assert_msg( 740547646, & + find_string_in_array( to_labels, label, & + this%to_index_, case_sensitive = .true. ), & + "Cannot find destination label '"//label// & + "' building map." ) + call config%get( "scale by", this%scale_factor_, my_name, & + default = 1.0_dk ) + + end function pair_constructor + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Returns the size of a binary buffer required to pack the pair + integer function pair_pack_size( this, comm ) result( pack_size ) + + use musica_mpi + + !> Pair to pack + class(pair_t), intent(in) :: this + !> MPI communicator + integer, intent(in) :: comm + +#ifdef MUSICA_USE_MPI + pack_size = musica_mpi_pack_size( this%from_index_, comm ) + & + musica_mpi_pack_size( this%to_index_, comm ) + & + musica_mpi_pack_size( this%scale_factor_, comm ) +#else + pack_size = 0 +#endif + + end function pair_pack_size + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Packs the pair onto a character buffer + subroutine pair_mpi_pack( this, buffer, position, comm ) + + use musica_assert, only : assert + use musica_mpi + + !> Pair to pack + class(pair_t), intent(in) :: this + !> Memory buffer + character, intent(inout) :: buffer(:) + !> Current buffer position + integer, intent(inout) :: position + !> MPI communicator + integer, intent(in) :: comm + +#ifdef MUSICA_USE_MPI + integer :: prev_position + + prev_position = position + call musica_mpi_pack( buffer, position, this%from_index_, comm ) + call musica_mpi_pack( buffer, position, this%to_index_, comm ) + call musica_mpi_pack( buffer, position, this%scale_factor_, comm ) + call assert( 995726013, & + position - prev_position <= this%pack_size( comm ) ) +#endif + + end subroutine pair_mpi_pack + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Unpacks a pair from a character buffer + subroutine pair_mpi_unpack( this, buffer, position, comm ) + + use musica_assert, only : assert + use musica_mpi + + !> Pair to unpack + class(pair_t), intent(out) :: this + !> Memory buffer + character, intent(inout) :: buffer(:) + !> Current buffer position + integer, intent(inout) :: position + !> MPI communicator + integer, intent(in) :: comm + +#ifdef MUSICA_USE_MPI + integer :: prev_position + + prev_position = position + call musica_mpi_unpack( buffer, position, this%from_index_, comm ) + call musica_mpi_unpack( buffer, position, this%to_index_, comm ) + call musica_mpi_unpack( buffer, position, this%scale_factor_, comm ) + call assert( 143488254, & + position - prev_position <= this%pack_size( comm ) ) +#endif + + end subroutine pair_mpi_unpack + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +end module musica_map diff --git a/src/util/mpi.F90 b/src/util/mpi.F90 new file mode 100644 index 00000000..9a1aed77 --- /dev/null +++ b/src/util/mpi.F90 @@ -0,0 +1,1165 @@ +! Copyright (C) 2007-2021 Barcelona Supercomputing Center and University of +! Illinois at Urbana-Champaign +! SPDX-License-Identifier: MIT +module musica_mpi + ! Wrapper functions for MPI. + ! + ! This module was adapted from CAMP (https://github.com/open-atmos/camp). + ! + ! All of these functions can be called irrespective of whether MPI + ! support was compiled in or not. If MPI support is not enabled then + ! they do the obvious trivial thing (normally nothing). + +#ifdef MUSICA_USE_MPI + use mpi +#endif + + use musica_constants, only : dp => musica_dk + + implicit none + + private + public :: musica_mpi_support, musica_mpi_init, musica_mpi_abort, & + musica_mpi_finalize, musica_mpi_barrier, musica_mpi_rank, & + musica_mpi_size, musica_mpi_bcast, musica_mpi_pack_size, & + musica_mpi_pack, musica_mpi_unpack, MPI_COMM_WORLD + +#ifndef MUSICA_USE_MPI + ! Parameter to make a communicator available when MPI support is not + ! compiled in (to avoid a lot of preprocessor flags in tests) + integer, parameter :: MPI_COMM_WORLD = 0 +#endif + + integer, parameter :: dc = dp ! kind for double-precision complex numbers + + ! Broadcasts a variable from the primary process to all other processes + interface musica_mpi_bcast + procedure :: musica_mpi_bcast_integer + procedure :: musica_mpi_bcast_string + procedure :: musica_mpi_bcast_packed + end interface musica_mpi_bcast + + ! Returns the size of a character buffer needed to pack a given variable + interface musica_mpi_pack_size + procedure :: musica_mpi_pack_size_integer + procedure :: musica_mpi_pack_size_string + procedure :: musica_mpi_pack_size_real + procedure :: musica_mpi_pack_size_logical + procedure :: musica_mpi_pack_size_complex + procedure :: musica_mpi_pack_size_integer_array + procedure :: musica_mpi_pack_size_string_array + procedure :: musica_mpi_pack_size_real_array + procedure :: musica_mpi_pack_size_real_array_2d + procedure :: musica_mpi_pack_size_real_array_3d + end interface musica_mpi_pack_size + + ! Packs the given variable onto a character buffer + interface musica_mpi_pack + procedure :: musica_mpi_pack_integer + procedure :: musica_mpi_pack_string + procedure :: musica_mpi_pack_real + procedure :: musica_mpi_pack_logical + procedure :: musica_mpi_pack_complex + procedure :: musica_mpi_pack_integer_array + procedure :: musica_mpi_pack_string_array + procedure :: musica_mpi_pack_real_array + procedure :: musica_mpi_pack_real_array_2d + procedure :: musica_mpi_pack_real_array_3d + end interface musica_mpi_pack + + ! Unpacks a variable from a character buffer + interface musica_mpi_unpack + procedure :: musica_mpi_unpack_integer + procedure :: musica_mpi_unpack_string + procedure :: musica_mpi_unpack_real + procedure :: musica_mpi_unpack_logical + procedure :: musica_mpi_unpack_complex + procedure :: musica_mpi_unpack_integer_array + procedure :: musica_mpi_unpack_string_array + procedure :: musica_mpi_unpack_real_array + procedure :: musica_mpi_unpack_real_array_2d + procedure :: musica_mpi_unpack_real_array_3d + end interface musica_mpi_unpack + +contains + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + logical function musica_mpi_support( ) + ! Whether MPI support is compiled in. + +#ifdef MUSICA_USE_MPI + musica_mpi_support = .true. +#else + musica_mpi_support = .false. +#endif + + end function musica_mpi_support + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine musica_mpi_check_ierr( ierr ) + ! Dies if ``ierr`` is not ok. + + integer, intent(in) :: ierr ! MPI status code + +#ifdef MUSICA_USE_MPI + if( ierr /= MPI_SUCCESS )then + call musica_mpi_abort(1) + end if +#endif + + end subroutine musica_mpi_check_ierr + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine musica_mpi_init( ) + ! Initialize MPI. + +#ifdef MUSICA_USE_MPI + integer :: ierr + + call mpi_init( ierr ) + call musica_mpi_check_ierr( ierr ) +#endif + + end subroutine musica_mpi_init + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine musica_mpi_abort( status ) + ! Abort the program. + + integer, intent(in) :: status ! Status flag to abort with + +#ifdef MUSICA_USE_MPI + integer :: ierr + + call mpi_abort( MPI_COMM_WORLD, status, ierr ) +#else + call assert( status, .false. ) + +#endif + + end subroutine musica_mpi_abort + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + + subroutine musica_mpi_finalize( ) + + ! Shut down MPI. + +#ifdef MUSICA_USE_MPI + integer :: ierr + + call mpi_finalize( ierr ) + call musica_mpi_check_ierr( ierr ) +#endif + + end subroutine musica_mpi_finalize + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + ! Synchronize all processes. + subroutine musica_mpi_barrier( comm ) + + integer, intent(in) :: comm ! MPI communicator + +#ifdef MUSICA_USE_MPI + integer :: ierr + + call mpi_barrier( comm, ierr ) + call musica_mpi_check_ierr( ierr ) +#endif + + end subroutine musica_mpi_barrier + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + integer function musica_mpi_rank( comm ) + ! Returns the rank of the current process. + + integer, intent(in) :: comm ! MPI communicator + +#ifdef MUSICA_USE_MPI + integer :: rank, ierr + + call mpi_comm_rank( comm, rank, ierr ) + call musica_mpi_check_ierr( ierr ) + musica_mpi_rank = rank +#else + musica_mpi_rank = 0 +#endif + + end function musica_mpi_rank + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + integer function musica_mpi_size( comm ) + ! Returns the total number of processes. + + integer, intent(in) :: comm ! MPI communicator + +#ifdef MUSICA_USE_MPI + integer :: size, ierr + + call mpi_comm_size( comm, size, ierr ) + call musica_mpi_check_ierr( ierr ) + musica_mpi_size = size +#else + musica_mpi_size = 1 +#endif + + end function musica_mpi_size + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine musica_mpi_bcast_integer( val, comm ) + ! Broadcast the given value from process 0 to all other processes. + + integer, intent(inout) :: val ! value to broadcast + integer, intent(in) :: comm ! MPI communicator + +#ifdef MUSICA_USE_MPI + integer :: root, ierr + + root = 0 ! source of data to broadcast + call mpi_bcast( val, 1, MPI_INTEGER, root, comm, ierr ) + call musica_mpi_check_ierr( ierr ) +#endif + + end subroutine musica_mpi_bcast_integer + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine musica_mpi_bcast_string( val, comm ) + ! Broadcast the given value from process 0 to all other processes. + + character(len=*), intent(inout) :: val ! value to broadcast + integer, intent(in) :: comm ! MPI communicator + +#ifdef MUSICA_USE_MPI + integer :: root, ierr + + root = 0 ! source of data to broadcast + call mpi_bcast( val, len( val ), MPI_CHARACTER, root, comm, ierr ) + call musica_mpi_check_ierr( ierr ) +#endif + + end subroutine musica_mpi_bcast_string + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine musica_mpi_bcast_packed( val, comm ) + ! Broadcast the given value from process 0 to all other processes. + + character, intent(inout) :: val(:) ! value to be broadcast + integer, intent(in) :: comm ! MPI communicator + +#ifdef MUSICA_USE_MPI + integer :: root, ierr + + root = 0 ! source of data to broadcast + call mpi_bcast( val, size( val ), MPI_CHARACTER, root, comm, ierr ) + call musica_mpi_check_ierr( ierr ) +#endif + + end subroutine musica_mpi_bcast_packed + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + integer function musica_mpi_pack_size_integer( val, comm ) + ! Determines the number of bytes required to pack the given value. + + integer, intent(in) :: val ! value to be packed + integer, intent(in) :: comm ! MPI communicator + + integer :: ierr + +#ifdef MUSICA_USE_MPI + + call mpi_pack_size( 1, MPI_INTEGER, comm, & + musica_mpi_pack_size_integer, ierr ) + call musica_mpi_check_ierr( ierr ) +#else + musica_mpi_pack_size_integer = 0 +#endif + + end function musica_mpi_pack_size_integer + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + integer function musica_mpi_pack_size_real( val, comm ) + ! Determines the number of bytes required to pack the given value. + + real(kind=dp), intent(in) :: val ! value to pack + integer, intent(in) :: comm ! MPI communicator + + integer :: ierr + +#ifdef MUSICA_USE_MPI + + call mpi_pack_size( 1, MPI_DOUBLE_PRECISION, comm, & + musica_mpi_pack_size_real, ierr ) + call musica_mpi_check_ierr( ierr ) +#else + musica_mpi_pack_size_real = 0 +#endif + + end function musica_mpi_pack_size_real + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + integer function musica_mpi_pack_size_string( val, comm ) + ! Determines the number of bytes required to pack the given value. + + character(len=*), intent(in) :: val ! value to be packed + integer, intent(in) :: comm ! MPI communicator + + integer :: ierr + +#ifdef MUSICA_USE_MPI + + call mpi_pack_size( len_trim( val ), MPI_CHARACTER, comm, & + musica_mpi_pack_size_string, ierr ) + call musica_mpi_check_ierr( ierr ) + musica_mpi_pack_size_string = musica_mpi_pack_size_string & + + musica_mpi_pack_size_integer( len_trim( val ), comm ) +#else + musica_mpi_pack_size_string = 0 +#endif + + end function musica_mpi_pack_size_string + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + integer function musica_mpi_pack_size_logical( val, comm ) + ! Determines the number of bytes required to pack the given value. + + logical, intent(in) :: val ! value to pack + integer, intent(in) :: comm ! MPI communicator + + integer :: ierr + +#ifdef MUSICA_USE_MPI + + call mpi_pack_size( 1, MPI_LOGICAL, comm, & + musica_mpi_pack_size_logical, ierr ) + call musica_mpi_check_ierr( ierr ) +#else + musica_mpi_pack_size_logical = 0 +#endif + + end function musica_mpi_pack_size_logical + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + integer function musica_mpi_pack_size_complex( val, comm ) + ! Determines the number of bytes required to pack the given value. + + complex(kind=dc), intent(in) :: val ! value to pack + integer, intent(in) :: comm ! MPI communicator + + integer :: ierr + +#ifdef MUSICA_USE_MPI + + call mpi_pack_size( 1, MPI_DOUBLE_COMPLEX, comm, & + musica_mpi_pack_size_complex, ierr ) + call musica_mpi_check_ierr( ierr ) +#else + musica_mpi_pack_size_complex = 0 +#endif + + end function musica_mpi_pack_size_complex + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + integer function musica_mpi_pack_size_integer_array( val, comm ) + ! Determines the number of bytes required to pack the given value. + + integer, allocatable, intent(in) :: val(:) ! value to be packed + integer, intent(in) :: comm ! MPI communicator + + integer :: total_size, ierr + +#ifdef MUSICA_USE_MPI + logical :: is_allocated + + + total_size = 0 + is_allocated = allocated( val ) + if( is_allocated ) then + call mpi_pack_size( size( val ), MPI_INTEGER, comm, total_size, ierr ) + call musica_mpi_check_ierr( ierr ) + total_size = total_size + & + musica_mpi_pack_size_integer( size( val ), comm ) + end if + total_size = total_size + & + musica_mpi_pack_size_logical( is_allocated, comm ) +#else + total_size = 0 +#endif + + musica_mpi_pack_size_integer_array = total_size + + end function musica_mpi_pack_size_integer_array + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + integer function musica_mpi_pack_size_real_array( val, comm ) + ! Determines the number of bytes required to pack the given value. + + real(kind=dp), allocatable, intent(in) :: val(:) ! value to pack + integer, intent(in) :: comm ! MPI communicator + + integer :: total_size, ierr + +#ifdef MUSICA_USE_MPI + logical :: is_allocated + + + total_size = 0 + is_allocated = allocated( val ) + if( is_allocated ) then + call mpi_pack_size( size( val ), MPI_DOUBLE_PRECISION, comm, & + total_size, ierr ) + call musica_mpi_check_ierr( ierr ) + total_size = total_size + & + musica_mpi_pack_size_integer( size( val ), comm ) + end if + total_size = total_size + & + musica_mpi_pack_size_logical( is_allocated, comm ) +#else + total_size = 0 +#endif + + musica_mpi_pack_size_real_array = total_size + + end function musica_mpi_pack_size_real_array + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + integer function musica_mpi_pack_size_string_array( val, comm ) + ! Determines the number of bytes required to pack the given value. + + character(len=*), allocatable, intent(in) :: val(:) ! value to pack + integer, intent(in) :: comm ! MPI communicator + + integer :: i, total_size +#ifdef MUSICA_USE_MPI + logical :: is_allocated + + + is_allocated = allocated( val ) + if( is_allocated ) then + total_size = musica_mpi_pack_size_integer( size( val ), comm ) + do i = 1, size( val ) + total_size = total_size + & + musica_mpi_pack_size_string( val( i ), comm ) + end do + end if + total_size = total_size + & + musica_mpi_pack_size_logical( is_allocated, comm ) + musica_mpi_pack_size_string_array = total_size +#else + total_size = 0 +#endif + + end function musica_mpi_pack_size_string_array + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + integer function musica_mpi_pack_size_real_array_2d( val, comm ) + ! Determines the number of bytes required to pack the given value. + + real(kind=dp), allocatable, intent(in) :: val(:,:) ! value to pack + integer, intent(in) :: comm ! MPI Communicator + + integer :: total_size, ierr + +#ifdef MUSICA_USE_MPI + logical :: is_allocated + + + total_size = 0 + is_allocated = allocated( val ) + if( is_allocated ) then + call mpi_pack_size( size( val ), MPI_DOUBLE_PRECISION, comm, & + total_size, ierr ) + call musica_mpi_check_ierr( ierr ) + total_size = total_size & + + musica_mpi_pack_size_integer( size( val, 1 ), comm ) & + + musica_mpi_pack_size_integer( size( val, 2 ), comm ) + end if + total_size = total_size + & + musica_mpi_pack_size_logical( is_allocated, comm ) +#else + total_size = 0 +#endif + + musica_mpi_pack_size_real_array_2d = total_size + + end function musica_mpi_pack_size_real_array_2d + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + integer function musica_mpi_pack_size_real_array_3d( val, comm ) + ! Determines the number of bytes required to pack the given value. + + real(kind=dp), allocatable, intent(in) :: val(:,:,:) ! value to pack + integer, intent(in) :: comm ! MPI Communicator + + integer :: total_size, ierr + +#ifdef MUSICA_USE_MPI + logical :: is_allocated + + + total_size = 0 + is_allocated = allocated( val ) + if( is_allocated ) then + call mpi_pack_size( size( val ), MPI_DOUBLE_PRECISION, comm, & + total_size, ierr ) + call musica_mpi_check_ierr( ierr ) + total_size = total_size & + + musica_mpi_pack_size_integer( size( val, 1 ), comm ) & + + musica_mpi_pack_size_integer( size( val, 2 ), comm ) & + + musica_mpi_pack_size_integer( size( val, 3 ), comm ) + end if + total_size = total_size + & + musica_mpi_pack_size_logical( is_allocated, comm ) +#else + total_size = 0 +#endif + + musica_mpi_pack_size_real_array_3d = total_size + + end function musica_mpi_pack_size_real_array_3d + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine musica_mpi_pack_integer( buffer, position, val, comm ) + ! Packs the given value into the buffer, advancing position. + + character, intent(inout) :: buffer(:) ! memory buffer + integer, intent(inout) :: position ! current buffer position + integer, intent(in) :: val ! value to pack + integer, intent(in) :: comm ! MPI communicator + +#ifdef MUSICA_USE_MPI + integer :: prev_position, ierr + + + prev_position = position + call mpi_pack( val, 1, MPI_INTEGER, buffer, size( buffer ), & + position, comm, ierr ) + call musica_mpi_check_ierr( ierr ) + call assert( 913495993, & + position - prev_position <= & + musica_mpi_pack_size_integer( val, comm ) ) +#endif + + end subroutine musica_mpi_pack_integer + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine musica_mpi_pack_real( buffer, position, val, comm ) + ! Packs the given value into the buffer, advancing position. + + character, intent(inout) :: buffer(:) ! memory buffer + integer, intent(inout) :: position ! current buffer position + real(kind=dp), intent(in) :: val ! value to pack + integer, intent(in) :: comm ! MPI communicator + +#ifdef MUSICA_USE_MPI + integer :: prev_position, ierr + + + prev_position = position + call mpi_pack( val, 1, MPI_DOUBLE_PRECISION, buffer, size( buffer ), & + position, comm, ierr ) + call musica_mpi_check_ierr( ierr ) + call assert( 395354132, & + position - prev_position <= & + musica_mpi_pack_size_real( val, comm ) ) +#endif + + end subroutine musica_mpi_pack_real + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine musica_mpi_pack_string( buffer, position, val, comm ) + ! Packs the given value into the buffer, advancing position. + + character, intent(inout) :: buffer(:) ! memory buffer + integer, intent(inout) :: position ! curent buffer position + character(len=*), intent(in) :: val ! value to pack + integer, intent(in) :: comm ! MPI communicator + +#ifdef MUSICA_USE_MPI + integer :: prev_position, length, ierr + + + prev_position = position + length = len_trim( val ) + call musica_mpi_pack_integer( buffer, position, length, comm ) + call mpi_pack( val, length, MPI_CHARACTER, buffer, size( buffer ), & + position, comm, ierr ) + call musica_mpi_check_ierr( ierr ) + call assert( 607212018, & + position - prev_position <= & + musica_mpi_pack_size_string( val, comm ) ) +#endif + + end subroutine musica_mpi_pack_string + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine musica_mpi_pack_logical( buffer, position, val, comm ) + ! Packs the given value into the buffer, advancing position. + + character, intent(inout) :: buffer(:) ! memory buffer + integer, intent(inout) :: position ! curent buffer position + logical, intent(in) :: val ! value to pack + integer, intent(in) :: comm ! MPI communicator + +#ifdef MUSICA_USE_MPI + integer :: prev_position, ierr + + + prev_position = position + call mpi_pack( val, 1, MPI_LOGICAL, buffer, size( buffer ), & + position, comm, ierr ) + call musica_mpi_check_ierr( ierr ) + call assert( 104535200, & + position - prev_position <= & + musica_mpi_pack_size_logical( val, comm ) ) +#endif + + end subroutine musica_mpi_pack_logical + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine musica_mpi_pack_complex( buffer, position, val, comm ) + ! Packs the given value into the buffer, advancing position. + + character, intent(inout) :: buffer(:) ! memory buffer + integer, intent(inout) :: position ! curent buffer position + complex(kind=dc), intent(in) :: val ! value to pack + integer, intent(in) :: comm ! MPI communicator + +#ifdef MUSICA_USE_MPI + integer :: prev_position, ierr + + + prev_position = position + call mpi_pack( val, 1, MPI_DOUBLE_COMPLEX, buffer, size( buffer ), & + position, comm, ierr ) + call musica_mpi_check_ierr( ierr ) + call assert( 640416372, & + position - prev_position <= & + musica_mpi_pack_size_complex( val, comm ) ) +#endif + + end subroutine musica_mpi_pack_complex + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine musica_mpi_pack_integer_array( buffer, position, val, comm ) + ! Packs the given value into the buffer, advancing position. + + character, intent(inout) :: buffer(:) ! memory buffer + integer, intent(inout) :: position ! curent buffer position + integer, allocatable, intent(in) :: val(:) ! value to pack + integer, intent(in) :: comm ! MPI communicator + +#ifdef MUSICA_USE_MPI + integer :: prev_position, n, ierr + logical :: is_allocated + + + prev_position = position + is_allocated = allocated( val ) + call musica_mpi_pack_logical( buffer, position, is_allocated, comm ) + if( is_allocated ) then + n = size( val ) + call musica_mpi_pack_integer( buffer, position, n, comm ) + call mpi_pack( val, n, MPI_INTEGER, buffer, size( buffer ), & + position, comm, ierr ) + call musica_mpi_check_ierr( ierr ) + end if + call assert( 698601296, & + position - prev_position <= & + musica_mpi_pack_size_integer_array( val, comm ) ) +#endif + + end subroutine musica_mpi_pack_integer_array + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine musica_mpi_pack_real_array( buffer, position, val, comm ) + ! Packs the given value into the buffer, advancing position. + + character, intent(inout) :: buffer(:) ! memory buffer + integer, intent(inout) :: position ! curent buffer position + real(kind=dp), allocatable, intent(in) :: val(:) ! value to pack + integer, intent(in) :: comm ! MPI communicator + +#ifdef MUSICA_USE_MPI + integer :: prev_position, n, ierr + logical :: is_allocated + + + prev_position = position + is_allocated = allocated( val ) + call musica_mpi_pack_logical( buffer, position, is_allocated, comm ) + if( is_allocated ) then + n = size( val ) + call musica_mpi_pack_integer( buffer, position, n, comm ) + call mpi_pack( val, n, MPI_DOUBLE_PRECISION, buffer, size( buffer ), & + position, comm, ierr ) + call musica_mpi_check_ierr( ierr ) + end if + call assert( 825718791, & + position - prev_position <= & + musica_mpi_pack_size_real_array( val, comm ) ) +#endif + + end subroutine musica_mpi_pack_real_array + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine musica_mpi_pack_string_array( buffer, position, val, comm ) + ! Packs the given value into the buffer, advancing position. + + character, intent(inout) :: buffer(:) ! memory buffer + integer, intent(inout) :: position ! curent buffer position + character(len=*), allocatable, intent(in) :: val(:) ! value to pack + integer, intent(in) :: comm ! MPI communicator + +#ifdef MUSICA_USE_MPI + integer :: prev_position, i, n + logical :: is_allocated + + + prev_position = position + is_allocated = allocated( val ) + call musica_mpi_pack_logical( buffer, position, is_allocated, comm ) + if( is_allocated) then + n = size( val ) + call musica_mpi_pack_integer( buffer, position, n, comm ) + do i = 1, n + call musica_mpi_pack_string( buffer, position, val( i ), comm ) + end do + end if + call assert( 630900704, & + position - prev_position <= & + musica_mpi_pack_size_string_array( val, comm ) ) +#endif + + end subroutine musica_mpi_pack_string_array + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine musica_mpi_pack_real_array_2d( buffer, position, val, comm ) + ! Packs the given value into the buffer, advancing position. + + character, intent(inout) :: buffer(:) ! memory buffer + integer, intent(inout) :: position ! curent buffer position + real(kind=dp), allocatable, intent(in) :: val(:,:) ! value to pack + integer, intent(in) :: comm ! MPI communicator + +#ifdef MUSICA_USE_MPI + integer :: prev_position, n1, n2, ierr + logical :: is_allocated + + + prev_position = position + is_allocated = allocated( val ) + call musica_mpi_pack_logical( buffer, position, is_allocated, comm ) + if( is_allocated ) then + n1 = size( val, 1 ) + n2 = size( val, 2 ) + call musica_mpi_pack_integer( buffer, position, n1, comm ) + call musica_mpi_pack_integer( buffer, position, n2, comm ) + call mpi_pack( val, n1 * n2, MPI_DOUBLE_PRECISION, buffer, & + size( buffer ), position, comm, ierr ) + call musica_mpi_check_ierr( ierr ) + end if + call assert( 567349745, & + position - prev_position <= & + musica_mpi_pack_size_real_array_2d( val, comm ) ) +#endif + + end subroutine musica_mpi_pack_real_array_2d + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine musica_mpi_pack_real_array_3d( buffer, position, val, comm ) + ! Packs the given value into the buffer, advancing position. + + character, intent(inout) :: buffer(:) ! memory buffer + integer, intent(inout) :: position ! curent buffer position + real(kind=dp), allocatable, intent(in) :: val(:,:,:) ! value to pack + integer, intent(in) :: comm ! MPI communicator + +#ifdef MUSICA_USE_MPI + integer :: prev_position, n1, n2, n3, ierr + logical :: is_allocated + + + prev_position = position + is_allocated = allocated( val ) + call musica_mpi_pack_logical( buffer, position, is_allocated, comm ) + if( is_allocated ) then + n1 = size( val, 1 ) + n2 = size( val, 2 ) + n3 = size( val, 3 ) + call musica_mpi_pack_integer( buffer, position, n1, comm ) + call musica_mpi_pack_integer( buffer, position, n2, comm ) + call musica_mpi_pack_integer( buffer, position, n3, comm ) + call mpi_pack( val, n1 * n2 * n3, MPI_DOUBLE_PRECISION, buffer, & + size( buffer ), position, comm, ierr ) + call musica_mpi_check_ierr( ierr ) + end if + call assert( 851684870, & + position - prev_position <= & + musica_mpi_pack_size_real_array_3d( val, comm ) ) +#endif + + end subroutine musica_mpi_pack_real_array_3d + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine musica_mpi_unpack_integer( buffer, position, val, comm ) + ! Unpacks the given value from the buffer, advancing position. + + character, intent(inout) :: buffer(:) ! memory buffer + integer, intent(inout) :: position ! curent buffer position + integer, intent(out) :: val ! value to unpack + integer, intent(in) :: comm ! MPI communicator + +#ifdef MUSICA_USE_MPI + integer :: prev_position, ierr + + + prev_position = position + call mpi_unpack( buffer, size( buffer ), position, val, 1, MPI_INTEGER, & + comm, ierr ) + call musica_mpi_check_ierr( ierr ) + call assert( 890243339, & + position - prev_position <= & + musica_mpi_pack_size_integer( val, comm ) ) +#else + val = 0 +#endif + + end subroutine musica_mpi_unpack_integer + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine musica_mpi_unpack_real( buffer, position, val, comm ) + ! Unpacks the given value from the buffer, advancing position. + + character, intent(inout) :: buffer(:) ! memory buffer + integer, intent(inout) :: position ! curent buffer position + real(kind=dp), intent(out) :: val ! value to unpack + integer, intent(in) :: comm ! MPI communicator + +#ifdef MUSICA_USE_MPI + integer :: prev_position, ierr + + + prev_position = position + call mpi_unpack( buffer, size( buffer ), position, val, 1, & + MPI_DOUBLE_PRECISION, comm, ierr ) + call musica_mpi_check_ierr( ierr ) + call assert( 570771632, & + position - prev_position <= & + musica_mpi_pack_size_real( val, comm ) ) +#else + val = real( 0.0, kind = dp ) +#endif + + end subroutine musica_mpi_unpack_real + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine musica_mpi_unpack_string( buffer, position, val, comm ) + ! Unpacks the given value from the buffer, advancing position. + + character, intent(inout) :: buffer(:) ! memory buffer + integer, intent(inout) :: position ! curent buffer position + character(len=*), intent(out) :: val ! value to unpack + integer, intent(in) :: comm ! MPI communicator + +#ifdef MUSICA_USE_MPI + integer :: prev_position, length, ierr + + + prev_position = position + call musica_mpi_unpack_integer( buffer, position, length, comm ) + call assert(946399479, length <= len( val ) ) + val = '' + call mpi_unpack( buffer, size( buffer ), position, val, length, & + MPI_CHARACTER, comm, ierr ) + call musica_mpi_check_ierr( ierr ) + call assert( 503378058, & + position - prev_position <= & + musica_mpi_pack_size_string( val, comm ) ) +#else + val = '' +#endif + + end subroutine musica_mpi_unpack_string + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine musica_mpi_unpack_logical( buffer, position, val, comm ) + ! Unpacks the given value from the buffer, advancing position. + + character, intent(inout) :: buffer(:) ! memory buffer + integer, intent(inout) :: position ! curent buffer position + logical, intent(out) :: val ! value to unpack + integer, intent(in) :: comm ! MPI communicator + +#ifdef MUSICA_USE_MPI + integer :: prev_position, ierr + + + prev_position = position + call mpi_unpack( buffer, size( buffer ), position, val, 1, MPI_LOGICAL, & + comm, ierr ) + call musica_mpi_check_ierr( ierr ) + call assert( 694750528, & + position - prev_position <= & + musica_mpi_pack_size_logical( val, comm ) ) +#else + val = .false. +#endif + + end subroutine musica_mpi_unpack_logical + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine musica_mpi_unpack_complex( buffer, position, val, comm ) + ! Unpacks the given value from the buffer, advancing position. + + character, intent(inout) :: buffer(:) ! memory buffer + integer, intent(inout) :: position ! curent buffer position + complex(kind=dc), intent(out) :: val ! value to unpack + integer, intent(in) :: comm ! MPI communicator + +#ifdef MUSICA_USE_MPI + integer :: prev_position, ierr + + + prev_position = position + call mpi_unpack( buffer, size( buffer ), position, val, 1, & + MPI_DOUBLE_COMPLEX, comm, ierr ) + call musica_mpi_check_ierr( ierr ) + call assert( 969672634, & + position - prev_position <= & + musica_mpi_pack_size_complex( val, comm ) ) +#else + val = cmplx( 0 ) +#endif + + end subroutine musica_mpi_unpack_complex + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine musica_mpi_unpack_integer_array( buffer, position, val, comm ) + ! Unpacks the given value from the buffer, advancing position. + + character, intent(inout) :: buffer(:) ! memory buffer + integer, intent(inout) :: position ! curent buffer position + integer, allocatable, intent(inout) :: val(:) ! value to unpack + integer, intent(in) :: comm ! MPI communicator + +#ifdef MUSICA_USE_MPI + integer :: prev_position, n, ierr + logical :: is_allocated + + + prev_position = position + call musica_mpi_unpack_logical( buffer, position, is_allocated, comm ) + if( allocated( val ) ) deallocate( val ) + if( is_allocated ) then + call musica_mpi_unpack_integer( buffer, position, n, comm ) + allocate( val( n ) ) + call mpi_unpack( buffer, size( buffer ), position, val, n, MPI_INTEGER,& + comm, ierr ) + call musica_mpi_check_ierr( ierr ) + end if + call assert( 565840919, & + position - prev_position <= & + musica_mpi_pack_size_integer_array( val, comm ) ) +#endif + + end subroutine musica_mpi_unpack_integer_array + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine musica_mpi_unpack_real_array( buffer, position, val, comm ) + ! Unpacks the given value from the buffer, advancing position. + + character, intent(inout) :: buffer(:) ! memory buffer + integer, intent(inout) :: position ! curent buffer position + real(kind=dp), allocatable, intent(inout) :: val(:) ! value to unpack + integer, intent(in) :: comm ! MPI communicator + +#ifdef MUSICA_USE_MPI + integer :: prev_position, n, ierr + logical :: is_allocated + + + prev_position = position + call musica_mpi_unpack_logical( buffer, position, is_allocated, comm ) + if( allocated( val ) ) deallocate( val ) + if( is_allocated ) then + call musica_mpi_unpack_integer( buffer, position, n, comm ) + allocate( val( n ) ) + call mpi_unpack( buffer, size( buffer ), position, val, n, & + MPI_DOUBLE_PRECISION, comm, ierr ) + call musica_mpi_check_ierr( ierr ) + end if + call assert( 782875761, & + position - prev_position <= & + musica_mpi_pack_size_real_array( val, comm ) ) +#endif + + end subroutine musica_mpi_unpack_real_array + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine musica_mpi_unpack_string_array( buffer, position, val, comm ) + ! Unpacks the given value from the buffer, advancing position. + + character, intent(inout) :: buffer(:) ! memory buffer + integer, intent(inout) :: position ! curent buffer position + character(len=*), allocatable, intent(inout) :: val(:) ! value to unpack + integer, intent(in) :: comm ! MPI communicator + +#ifdef MUSICA_USE_MPI + integer :: prev_position, i, n + logical :: is_allocated + + + prev_position = position + call musica_mpi_unpack_logical( buffer, position, is_allocated, comm ) + if( allocated( val ) ) deallocate( val ) + if( is_allocated ) then + call musica_mpi_unpack_integer( buffer, position, n, comm ) + allocate( val( n ) ) + do i = 1, n + call musica_mpi_unpack_string( buffer, position, val( i ), comm ) + end do + end if + call assert( 320065648, & + position - prev_position <= & + musica_mpi_pack_size_string_array( val, comm ) ) +#endif + + end subroutine musica_mpi_unpack_string_array + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine musica_mpi_unpack_real_array_2d( buffer, position, val, comm ) + ! Unpacks the given value from the buffer, advancing position. + + character, intent(inout) :: buffer(:) ! memory buffer + integer, intent(inout) :: position ! curent buffer position + real(kind=dp), allocatable, intent(inout) :: val(:,:) ! value to unpack + integer, intent(in) :: comm ! MPI communicator + +#ifdef MUSICA_USE_MPI + integer :: prev_position, n1, n2, ierr + logical :: is_allocated + + + prev_position = position + call musica_mpi_unpack_logical( buffer, position, is_allocated, comm ) + if( allocated( val ) ) deallocate( val ) + if( is_allocated ) then + call musica_mpi_unpack_integer( buffer, position, n1, comm ) + call musica_mpi_unpack_integer( buffer, position, n2, comm ) + allocate( val( n1, n2 ) ) + call mpi_unpack( buffer, size( buffer ), position, val, n1 * n2, & + MPI_DOUBLE_PRECISION, comm, ierr ) + call musica_mpi_check_ierr( ierr ) + end if + call assert( 781681739, position - prev_position & + <= musica_mpi_pack_size_real_array_2d( val, comm ) ) +#endif + + end subroutine musica_mpi_unpack_real_array_2d + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine musica_mpi_unpack_real_array_3d( buffer, position, val, comm ) + ! Unpacks the given value from the buffer, advancing position. + + character, intent(inout) :: buffer(:) ! memory buffer + integer, intent(inout) :: position ! curent buffer position + real(kind=dp), allocatable, intent(inout) :: val(:,:,:) ! value to unpack + integer, intent(in) :: comm ! MPI communicator + +#ifdef MUSICA_USE_MPI + integer :: prev_position, n1, n2, n3, ierr + logical :: is_allocated + + + prev_position = position + call musica_mpi_unpack_logical( buffer, position, is_allocated, comm ) + if( allocated( val ) ) deallocate( val ) + if( is_allocated ) then + call musica_mpi_unpack_integer( buffer, position, n1, comm ) + call musica_mpi_unpack_integer( buffer, position, n2, comm ) + call musica_mpi_unpack_integer( buffer, position, n3, comm ) + allocate( val( n1, n2, n3 ) ) + call mpi_unpack( buffer, size( buffer ), position, val, n1 * n2 * n3, & + MPI_DOUBLE_PRECISION, comm, ierr ) + call musica_mpi_check_ierr( ierr ) + end if + call assert( 162434174, position - prev_position & + <= musica_mpi_pack_size_real_array_3d( val, comm ) ) +#endif + + end subroutine musica_mpi_unpack_real_array_3d + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + + !> Local assert + subroutine assert( code, condition ) + + !> Unique code for the assertion + integer, intent(in) :: code + !> Condition to evaluate + logical, intent(in) :: condition + + character(len=50) :: str_code + integer, parameter :: kErrorId = 0 + integer, parameter :: kErrorFileId = 10 + + if( .not. condition ) then + write(str_code,'(i30)') code + write(kErrorId,*) "ERROR (Musica-"//trim( adjustl( str_code ) )//"): " & + //"assertion failed" + open( unit = kErrorFileId, file = "error.json", action = "WRITE" ) + write(kErrorFileId,'(A)') '{' + write(kErrorFileId,'(A)') ' "code" : "'//trim( adjustl( str_code ) )//'",' + write(kErrorFileId,'(A)') ' "message" : "assertion failed"' + write(kErrorFileId,'(A)') '}' + close(kErrorFileId) + stop 3 + end if + + end subroutine assert + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +end module musica_mpi diff --git a/src/util/string.F90 b/src/util/string.F90 new file mode 100644 index 00000000..7564a51c --- /dev/null +++ b/src/util/string.F90 @@ -0,0 +1,1528 @@ +! Copyright (C) 2020 National Center for Atmospheric Research +! SPDX-License-Identifier: Apache-2.0 +! +!> \file +!> The musica_string module + +!> The string_t type and related functions +module musica_string + + use musica_constants, only : musica_ik, musica_rk, musica_dk + + implicit none + private + + public :: string_t, to_char, output_table + + !> Length of character array for to_char conversions + integer(kind=musica_ik), parameter :: kConvertCharLength = 100 + + !> Generic string type + type :: string_t + !> the string + character(len=:), allocatable :: val_ + contains + !> @name String assignment + !! @{ + procedure, private, pass(to) :: string_assign_char + procedure, private, pass(to) :: string_assign_int + procedure, private, pass(to) :: string_assign_real + procedure, private, pass(to) :: string_assign_double + procedure, private, pass(to) :: string_assign_logical + procedure, private, pass(from) :: string_assign_string + procedure, private, pass(from) :: char_assign_string + procedure, private, pass(from) :: real_assign_string + procedure, private, pass(from) :: double_assign_string + procedure, private, pass(from) :: int_assign_string + procedure, private, pass(from) :: logical_assign_string + generic :: assignment(=) => string_assign_char, string_assign_int, & + string_assign_real, string_assign_double, & + string_assign_logical, string_assign_string, & + char_assign_string, real_assign_string, & + double_assign_string, int_assign_string, & + logical_assign_string + !> @} + !> @name Joins to a string + !! @{ + procedure, private, pass(a) :: string_join_string + procedure, private, pass(a) :: string_join_char + procedure, private, pass(a) :: string_join_int + procedure, private, pass(a) :: string_join_real + procedure, private, pass(a) :: string_join_double + procedure, private, pass(a) :: string_join_logical + procedure, private, pass(b) :: char_join_string + procedure, private, pass(b) :: int_join_string + procedure, private, pass(b) :: real_join_string + procedure, private, pass(b) :: double_join_string + procedure, private, pass(b) :: logical_join_string + generic :: operator(//) => string_join_string, string_join_char, & + string_join_int, string_join_real, & + string_join_double, string_join_logical, & + char_join_string, int_join_string, & + real_join_string, double_join_string, & + logical_join_string + !> @} + !> @name String equality + !! @{ + procedure, private, pass(a) :: string_equals_string + procedure, private, pass(a) :: string_equals_char + procedure, private, pass(a) :: string_equals_int + procedure, private, pass(a) :: string_equals_real + procedure, private, pass(a) :: string_equals_double + procedure, private, pass(a) :: string_equals_logical + procedure, private, pass(b) :: char_equals_string + procedure, private, pass(b) :: int_equals_string + procedure, private, pass(b) :: real_equals_string + procedure, private, pass(b) :: double_equals_string + procedure, private, pass(b) :: logical_equals_string + generic :: operator(==) => string_equals_string, string_equals_char, & + string_equals_int, string_equals_real, & + string_equals_double, string_equals_logical, & + char_equals_string, int_equals_string, & + real_equals_string, double_equals_string, & + logical_equals_string + procedure, private, pass(a) :: string_not_equals_string + procedure, private, pass(a) :: string_not_equals_char + procedure, private, pass(a) :: string_not_equals_int + procedure, private, pass(a) :: string_not_equals_real + procedure, private, pass(a) :: string_not_equals_double + procedure, private, pass(a) :: string_not_equals_logical + procedure, private, pass(b) :: char_not_equals_string + procedure, private, pass(b) :: int_not_equals_string + procedure, private, pass(b) :: real_not_equals_string + procedure, private, pass(b) :: double_not_equals_string + procedure, private, pass(b) :: logical_not_equals_string + generic :: operator(/=) => string_not_equals_string, & + string_not_equals_char, & + string_not_equals_int, & + string_not_equals_real, & + string_not_equals_double, & + string_not_equals_logical, & + char_not_equals_string, & + int_not_equals_string, & + real_not_equals_string, & + double_not_equals_string, & + logical_not_equals_string + !> @} + !> Returns the string length + procedure :: length + !> Converts a string to upper case + procedure :: to_upper + !> Converts a string to lower case + procedure :: to_lower + !> Gets a substring + procedure :: substring + !> @name Splits a string on a sub-string + !! @{ + procedure, private :: split_char + procedure, private :: split_string + generic :: split => split_char, split_string + !> @} + + !> Replaces substrings within a string + procedure :: replace + !> Converts a string to a character array + procedure :: to_char => string_to_char + !> Returns the size of a binary buffer required to pack the string + procedure :: pack_size + !> Packs the string onto a character buffer + procedure :: mpi_pack + !> Unpacks the string from a character buffer + procedure :: mpi_unpack + end type string_t + + !> Converts values to character arrays + interface to_char + module procedure int_to_char + module procedure real_to_char + module procedure double_to_char + module procedure complex_real_to_char + module procedure complex_double_to_char + module procedure logical_to_char + end interface to_char + +contains + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Assigns a string from a character array + subroutine string_assign_char( to, from ) + + !> String to assign + class(string_t), intent(out) :: to + !> New string value + character(len=*), intent(in) :: from + + to%val_ = trim( from ) + + end subroutine string_assign_char + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Assigns a string from an integer + subroutine string_assign_int( to, from ) + + !> String to assign + class(string_t), intent(out) :: to + !> New string value + integer(kind=musica_ik), intent(in) :: from + + character(len=30) :: new_val + + write( new_val, '(i30)' ) from + to%val_ = trim( adjustl( new_val ) ) + + end subroutine string_assign_int + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Assigns a string from a real number + subroutine string_assign_real( to, from ) + + !> String to assign + class(string_t), intent(out) :: to + !> New string value + real(kind=musica_rk), intent(in) :: from + + character(len=60) :: new_val + + write( new_val, '(g30.20)' ) from + to%val_ = trim( adjustl( new_val ) ) + + end subroutine string_assign_real + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Assigns a string from a double precision real number + subroutine string_assign_double( to, from ) + + !> String to assign + class(string_t), intent(out) :: to + !> New string value + real(kind=musica_dk), intent(in) :: from + + character(len=60) :: new_val + + write( new_val, '(g30.20)' ) from + to%val_ = trim( adjustl( new_val ) ) + + end subroutine string_assign_double + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Assigns a string from a logical + subroutine string_assign_logical( to, from ) + + !> String to assign + class(string_t), intent(out) :: to + !> New string value + logical, intent(in) :: from + + if( from ) then + to%val_ = "true" + else + to%val_ = "false" + end if + + end subroutine string_assign_logical + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Assign a string from a string + subroutine string_assign_string( to, from ) + + !> String to assign + type(string_t), intent(inout) :: to + !> String to assign from + class(string_t), intent(in) :: from + + if( .not. allocated( from%val_ ) ) then + if( allocated( to%val_ ) ) deallocate( to%val_ ) + return + end if + to%val_ = from%val_ + + end subroutine string_assign_string + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Assign a character array from a string + subroutine char_assign_string( to, from ) + + !> Variable to assign + character(len=*), intent(inout) :: to + !> String to assign from + class(string_t), intent(in) :: from + + integer :: len_char, len_str + + if( .not. allocated( from%val_ ) ) then + to = "" + return + end if + len_char = len( to ) + len_str = len( from%val_ ) + if( len_char .lt. len_str ) then + to = from%val_(1:len_char) + else + to = from%val_ + end if + + end subroutine char_assign_string + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Assign a real from a string + subroutine real_assign_string( to, from ) + + !> Variable to assign + real(kind=musica_rk), intent(inout) :: to + !> String to assign from + class(string_t), intent(in) :: from + + integer :: ios + + call assert_msg( 584471137, allocated( from%val_ ), & + "Cannot assign real from unallocated string" ) + call assert_msg( 621504169, len( from%val_ ) .le. 40, & + "Error converting '"//from%val_//"' to real: "// & + "string too long" ) + read( from%val_, '(f40.0)', iostat=ios ) to + call assert_msg( 102862672, ios .eq. 0, & + "Error converting '"//from%val_//"' to real: "// & + "IOSTAT = "//trim( to_char( ios ) ) ) + + end subroutine real_assign_string + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Assign a double precision real from a string + subroutine double_assign_string( to, from ) + + !> Variable to assign + real(kind=musica_dk), intent(inout) :: to + !> String to assign from + class(string_t), intent(in) :: from + + integer :: ios + + call assert_msg( 860228840, allocated( from%val_ ), & + "Cannot assign double from unallocated string" ) + call assert_msg( 156176342, len( from%val_ ) .le. 40, & + "Error converting '"//from%val_//"' to double: "// & + "string too long" ) + read( from%val_, '(f40.0)', iostat=ios ) to + call assert_msg( 445821432, ios .eq. 0, & + "Error converting '"//from%val_//"' to double: "// & + "IOSTAT = "//trim( to_char( ios ) ) ) + + end subroutine double_assign_string + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Assign an integer from a string + subroutine int_assign_string( to, from ) + + !> Variable to assign + integer(kind=musica_ik), intent(inout) :: to + !> String to assign from + class(string_t), intent(in) :: from + + integer :: ios + + call assert_msg( 121762665, allocated( from%val_ ), & + "Cannot assign integer from unallocated string" ) + call assert_msg( 822629448, len( from%val_ ) .le. 20, & + "Error converting '"//from%val_//"' to integer: "// & + "string too long" ) + read( from%val_, '(i20)', iostat=ios ) to + call assert_msg( 484221174, ios .eq. 0, & + "Error converting '"//from%val_//"' to integer: "// & + "IOSTAT = "//trim( to_char( ios ) ) ) + + end subroutine int_assign_string + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Assigns a logical from a string + subroutine logical_assign_string( to, from ) + + !> Variable to assign + logical, intent(inout) :: to + !> String to assign from + class(string_t), intent(in) :: from + + call assert_msg( 285202023, allocated( from%val_ ), & + "Cannot assign logical from unallocated string" ) + if( from%val_ .eq. "true" ) then + to = .true. + else if( from%val_ .eq. "false" ) then + to = .false. + else + call assert_msg( 359920976, .false., & + "Cannot convert '"//from%val_//"' to logical" ) + end if + + end subroutine logical_assign_string + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Joins a string to a string + elemental function string_join_string( a, b ) result( c ) + + !> Joined string + type(string_t) :: c + !> String to join + class(string_t), intent(in) :: a + !> String to join + class(string_t), intent(in) :: b + + c%val_ = a%val_//b%val_ + + end function string_join_string + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Joins a string to a character array + elemental function string_join_char( a, b ) result( c ) + + !> Joined string + type(string_t) :: c + !> String to join + class(string_t), intent(in) :: a + !> Character array to join + character(len=*), intent(in) :: b + + c%val_ = a%val_//trim( b ) + + end function string_join_char + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Joins a string to an integer + elemental function string_join_int( a, b ) result( c ) + + !> Joined string + type(string_t) :: c + !> String to join + class(string_t), intent(in) :: a + !> Integer to join + integer(kind=musica_ik), intent(in) :: b + + character(len=30) :: new_val + + write( new_val, '(i30)' ) b + c%val_ = a%val_//adjustl( new_val ) + + end function string_join_int + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Joins a string to a real number + elemental function string_join_real( a, b ) result( c ) + + !> Joined string + type(string_t) :: c + !> String to join + class(string_t), intent(in) :: a + !> Real number to join + real(kind=musica_rk), intent(in) :: b + + character(len=60) :: new_val + + write( new_val, '(g30.20)' ) b + c%val_ = a%val_//adjustl( new_val ) + + end function string_join_real + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Joins a string to a double precision real number + elemental function string_join_double( a, b ) result( c ) + + !> Joined string + type(string_t) :: c + !> String to join + class(string_t), intent(in) :: a + !> Double precision real number to join + real(kind=musica_dk), intent(in) :: b + + character(len=60) :: new_val + + write( new_val, '(g30.20)' ) b + c%val_ = a%val_//adjustl( new_val ) + + end function string_join_double + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Joins a string to a logical + elemental function string_join_logical( a, b ) result( c ) + + !> Joined string + type(string_t) :: c + !> String to join + class(string_t), intent(in) :: a + !> Logical to join + logical, intent(in) :: b + + if( b ) then + c%val_ = a%val_//"true" + else + c%val_ = a%val_//"false" + end if + + end function string_join_logical + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Compares a string to a string for equality + logical elemental function string_equals_string( a, b ) result( equals ) + + !> String a + class(string_t), intent(in) :: a + !> String b + class(string_t), intent(in) :: b + + equals = trim( a%val_ ) .eq. trim( b%val_ ) + + end function string_equals_string + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Compares a string to a character array for equality + logical elemental function string_equals_char( a, b ) result( equals ) + + !> String a + class(string_t), intent(in) :: a + !> Character array b + character(len=*), intent(in) :: b + + equals = trim( a%val_ ) .eq. trim( b ) + + end function string_equals_char + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Compares a string to a integer for equality + logical elemental function string_equals_int( a, b ) result( equals ) + + !> String a + class(string_t), intent(in) :: a + !> Integer b + integer(kind=musica_ik), intent(in) :: b + + character(len=30) :: comp_val + + write( comp_val, '(i30)' ) b + equals = trim( a%val_ ) .eq. adjustl( comp_val ) + + end function string_equals_int + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Compares a string to a real number for equality + logical elemental function string_equals_real( a, b ) result( equals ) + + !> String a + class(string_t), intent(in) :: a + !> Real number b + real(kind=musica_rk), intent(in) :: b + + character(len=60) :: comp_val + + write( comp_val, '(g30.20)' ) b + equals = trim( a%val_ ) .eq. adjustl( comp_val ) + + end function string_equals_real + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Compares a string to a double-precision real number for equality + logical elemental function string_equals_double( a, b ) result( equals ) + + !> String a + class(string_t), intent(in) :: a + !> Double-precition real number b + real(kind=musica_dk), intent(in) :: b + + character(len=60) :: comp_val + + write( comp_val, '(g30.20)' ) b + equals = trim( a%val_ ) .eq. adjustl( comp_val ) + + end function string_equals_double + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Compares a string to a logical for equality + logical elemental function string_equals_logical( a, b ) result( equals ) + + !> String a + class(string_t), intent(in) :: a + !> Logical b + logical, intent(in) :: b + + equals = ( trim( a%val_ ) .eq. "true" .and. b ) .or. & + ( trim( a%val_ ) .eq. "false" .and. .not. b ) + + end function string_equals_logical + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Compares a string to a string for equality + logical elemental function string_not_equals_string( a, b ) & + result( not_equals ) + + !> String a + class(string_t), intent(in) :: a + !> String b + class(string_t), intent(in) :: b + + not_equals = .not. a .eq. b + + end function string_not_equals_string + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Compares a string to a character array for equality + logical elemental function string_not_equals_char( a, b ) & + result( not_equals ) + + !> String a + class(string_t), intent(in) :: a + !> Character array b + character(len=*), intent(in) :: b + + not_equals = .not. a .eq. b + + end function string_not_equals_char + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Compares a string to a integer for equality + logical elemental function string_not_equals_int( a, b ) & + result( not_equals ) + + !> String a + class(string_t), intent(in) :: a + !> Integer b + integer(kind=musica_ik), intent(in) :: b + + not_equals = .not. a .eq. b + + end function string_not_equals_int + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Compares a string to a real number for equality + logical elemental function string_not_equals_real( a, b ) & + result( not_equals ) + + !> String a + class(string_t), intent(in) :: a + !> Real number b + real(kind=musica_rk), intent(in) :: b + + not_equals = .not. a .eq. b + + end function string_not_equals_real + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Compares a string to a double-precision real number for equality + logical elemental function string_not_equals_double( a, b ) & + result( not_equals ) + + !> String a + class(string_t), intent(in) :: a + !> Double-precition real number b + real(kind=musica_dk), intent(in) :: b + + not_equals = .not. a .eq. b + + end function string_not_equals_double + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Compares a string to a logical for equality + logical elemental function string_not_equals_logical( a, b ) & + result( not_equals ) + + !> String a + class(string_t), intent(in) :: a + !> Logical b + logical, intent(in) :: b + + not_equals = .not. a .eq. b + + end function string_not_equals_logical + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Returns the length of the string + elemental integer function length( this ) + + !> String + class(string_t), intent(in) :: this + + length = len( this%val_ ) + + end function length + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Converts a string to upper case + !! + !! Adapted from http://www.star.le.ac.uk/~cgp/fortran.html (25 May 2012) + !! Original author: Clive Page + function to_upper( this ) result( cap_string ) + + !> Converted string + type(string_t) :: cap_string + !> String to convert + class(string_t), intent(in) :: this + + character(26), parameter :: cap = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' + character(26), parameter :: low = 'abcdefghijklmnopqrstuvwxyz' + integer :: i_str, i_char + + cap_string%val_ = this%val_ + do i_str = 1, len( cap_string%val_ ) + i_char = index( low, cap_string%val_(i_str:i_str) ) + if( i_char .gt. 0 ) cap_string%val_(i_str:i_str) = cap(i_char:i_char) + end do + + end function to_upper + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Converts a string to lower case + !! + !! Adapted from http://www.star.le.ac.uk/~cgp/fortran.html (25 May 2012) + !! Original author: Clive Page + function to_lower( this ) result( low_string ) + + !> Converted string + type(string_t) :: low_string + !> String to convert + class(string_t), intent(in) :: this + + character(26), parameter :: cap = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' + character(26), parameter :: low = 'abcdefghijklmnopqrstuvwxyz' + integer :: i_str, i_char + + low_string%val_ = this%val_ + do i_str = 1, len( low_string%val_ ) + i_char = index( cap, low_string%val_(i_str:i_str) ) + if( i_char .gt. 0 ) low_string%val_(i_str:i_str) = low(i_char:i_char) + end do + + end function to_lower + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Returns a substring + !! + !! Example: + !! \code{f90} + !! type(string_t) :: my_string, sub_string + !! my_string = "Hi there!" + !! sub_string = my_string%substring( 4, 5 ) + !! write(*,*) sub_string + !! sub_string = my_string%substring( 9, 50 ) + !! write(*,*) sub_string + !! \endcode + !! + !! Output: + !! \code{bash} + !! there + !! ! + !! \endcode + !! + function substring( this, start_index, length ) + + !> Substring + type(string_t) :: substring + !> Full string + class(string_t), intent(in) :: this + !> Starting character index + integer(kind=musica_ik), intent(in) :: start_index + !> Length of the substring to return + integer(kind=musica_ik), intent(in) :: length + + integer :: l + + if( start_index + length - 1 .gt. len( this%val_ ) ) then + l = len( this%val_ ) - start_index + 1 + else + l = length + end if + substring%val_ = this%val_(start_index:l+start_index-1) + + end function substring + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Splits a string on a substring + !! + !! Example: + !! \code{f90} + !! type(string_t) :: my_string + !! type(string_t), allocatable :: sub_strings(:) + !! integer :: i + !! my_string = "my original string" + !! sub_strings = my_string%split( ' ' ) + !! do i = 1, size( sub_strings ) + !! write(*,*) i, sub_strings( i ) + !! end do + !! sub_strings = my_string%split( ' ', .true. ) + !! do i = 1, size( sub_strings ) + !! write(*,*) i, sub_strings( i ) + !! end do + !! \endcode + !! + !! Output: + !! \code{bash} + !! 1 my + !! 2 original + !! 3 + !! 4 + !! 5 + !! 6 string + !! 1 my + !! 2 original + !! 3 string + !! \endcode + !! + function split_char( this, splitter, compress ) result( sub_strings ) + + !> Split string + type(string_t), allocatable :: sub_strings(:) + !> Full string + class(string_t), intent(in) :: this + !> String to split on + character(len=*), intent(in) :: splitter + !> Compress (default = false) + !! + !! No 0-length substrings will be returned (adjacent tokens will be + !! merged; tokens at the beginning and end of the original string will be + !! ignored) + logical, intent(in), optional :: compress + + integer :: i, start_str, i_substr, sl, count + logical :: l_comp, is_string + + if( .not. allocated( this%val_ ) ) then + allocate( sub_strings( 0 ) ) + return + end if + if( present( compress ) ) then + l_comp = compress + else + l_comp = .false. + end if + + sl = len( splitter ) + if( sl .eq. 0 ) then + allocate( sub_strings( 1 ) ) + sub_strings(1)%val_ = this%val_ + return + end if + + count = 0 + i = 1 + start_str = 1 + is_string = .not. l_comp + do while( i .le. len( this%val_ ) - sl + 1 ) + if( this%val_(i:i+sl-1) .eq. splitter ) then + if( is_string ) then + count = count + 1 + end if + i = i + sl + is_string = .not. l_comp + else + i = i + 1 + is_string = .true. + end if + end do + if( is_string ) count = count + 1 + + allocate( sub_strings( count ) ) + + i = 1 + start_str = 1 + i_substr = 1 + is_string = .not. l_comp + do while( i .le. len( this%val_ ) - sl + 1 ) + if( this%val_(i:i+sl-1) .eq. splitter ) then + if( is_string ) then + if( i .eq. start_str ) then + sub_strings( i_substr ) = "" + else + sub_strings( i_substr ) = this%val_(start_str:i-1) + end if + i_substr = i_substr + 1 + end if + i = i + sl + start_str = i + is_string = .not. l_comp + else + i = i + 1 + is_string = .true. + end if + end do + + if( is_string ) then + if( i .eq. start_str ) then + sub_strings( i_substr ) = "" + else + sub_strings( i_substr ) = this%val_( start_str:len( this%val_ ) ) + end if + end if + + end function split_char + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Splits a string on a substring + !! + !! See \c string_split_char for description and example + !! + function split_string( this, splitter, compress ) result( sub_strings ) + + !> Split string + type(string_t), allocatable :: sub_strings(:) + !> Full string + class(string_t), intent(in) :: this + !> String to split on + type(string_t), intent(in) :: splitter + !> Compress (default = false) + !! + !! No 0-length substrings will be returned (adjacent tokens will be + !! merged; tokens at the beginning and end of the original string will be + !! ignored) + logical, intent(in), optional :: compress + + sub_strings = this%split_char( splitter%to_char( ), compress ) + + end function split_string + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +!> Replaces substrings within a string + !! + !! Example: + !! \code{f90} + !! type(string_t) :: my_string + !! my_string = "foo bar foobar" + !! my_string = my_string%replace( 'foo', 'bar' ) + !! write(*,*) my_string + !! \endcode + !! + !! Output: + !! \code{bash} + !! bar bar barbar + !! \endcode + !! + function replace( this, from, to ) + + !> String with replacements + type(string_t) :: replace + !> Original string + class(string_t) :: this + !> Sub-string to replace + character(len=*), intent(in) :: from + !> Replacement string + character(len=*), intent(in) :: to + + integer :: i_char, start_str, s + logical :: is_string + + start_str = 1 + s = len( from ) + is_string = .false. + replace = "" + i_char = 1 + do while( i_char .le. len( this%val_ ) - s + 1 ) + if( this%val_( i_char:i_char+s-1 ) .eq. from ) then + if( is_string .and. i_char .gt. start_str ) then + replace%val_ = replace%val_//this%val_( start_str:i_char-1 ) + end if + replace = replace//to + i_char = i_char + s + start_str = i_char + is_string = .false. + else + i_char = i_char + 1 + is_string = .true. + end if + end do + + if( start_str .le. len( this%val_ ) ) then + replace%val_ = replace%val_//this%val_( start_str:len( this%val_ ) ) + end if + + end function replace + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Converts a string to a character array + function string_to_char( this ) result( char_array ) + + !> Converted string + character(len=:), allocatable :: char_array + !> String to convert + class(string_t), intent(in) :: this + + char_array = this%val_ + + end function string_to_char + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Joins a character array to a string + elemental function char_join_string( a, b ) result( c ) + + !> Joined string + type(string_t) :: c + !> Character array to join + character(len=*), intent(in) :: a + !> String to join + class(string_t), intent(in) :: b + + c%val_ = a//b%val_ + + end function char_join_string + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Joins an integer to a string + elemental function int_join_string( a, b ) result( c ) + + !> Joined string + type(string_t) :: c + !> Integer to join + integer(kind=musica_ik), intent(in) :: a + !> String to join + class(string_t), intent(in) :: b + + character(len=30) :: new_val + + write( new_val, '(i30)' ) a + c%val_ = trim( adjustl( new_val ) )//b%val_ + + end function int_join_string + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Joins a real number to a string + elemental function real_join_string( a, b ) result( c ) + + !> Joined string + type(string_t) :: c + !> Real number to join + real(kind=musica_rk), intent(in) :: a + !> String to join + class(string_t), intent(in) :: b + + character(len=60) :: new_val + + write( new_val, '(g30.20)' ) a + c%val_ = trim( adjustl( new_val ) )//b%val_ + + end function real_join_string + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Joins a double precision real number to a string + elemental function double_join_string( a, b ) result( c ) + + !> Joined string + type(string_t) :: c + !> Double precision real number to join + real(kind=musica_dk), intent(in) :: a + !> String to join + class(string_t), intent(in) :: b + + character(len=60) :: new_val + + write( new_val, '(g30.20)' ) a + c%val_ = trim( adjustl( new_val ) )//b%val_ + + end function double_join_string + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Joins a logical to a string + elemental function logical_join_string( a, b ) result( c ) + + !> Joined string + type(string_t) :: c + !> Logical to join + logical, intent(in) :: a + !> String to join + class(string_t), intent(in) :: b + + if( a ) then + c%val_ = "true"//b%val_ + else + c%val_ = "false"//b%val_ + end if + + end function logical_join_string + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Compares a character array to a string for equality + logical elemental function char_equals_string( a, b ) result( equals ) + + !> Character array a + character(len=*), intent(in) :: a + !> String b + class(string_t), intent(in) :: b + + equals = b .eq. a + + end function char_equals_string + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Compares an integer to a string for equality + logical elemental function int_equals_string( a, b ) result( equals ) + + !> Integer a + integer(kind=musica_ik), intent(in) :: a + !> String b + class(string_t), intent(in) :: b + + equals = b .eq. a + + end function int_equals_string + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Compares a real number to a string for equality + logical elemental function real_equals_string( a, b ) result( equals ) + + !> Real number a + real(kind=musica_rk), intent(in) :: a + !> String b + class(string_t), intent(in) :: b + + equals = b .eq. a + + end function real_equals_string + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Compares a double-precision real number to a string for equality + logical elemental function double_equals_string( a, b ) result( equals ) + + !> Double-precision real number a + real(kind=musica_dk), intent(in) :: a + !> String b + class(string_t), intent(in) :: b + + equals = b .eq. a + + end function double_equals_string + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Compares a logical to a string for equality + logical elemental function logical_equals_string( a, b ) result( equals ) + + !> Logical a + logical, intent(in) :: a + !> String b + class(string_t), intent(in) :: b + + equals = b .eq. a + + end function logical_equals_string + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Compares a character array to a string for equality + logical elemental function char_not_equals_string( a, b ) & + result( not_equals ) + + !> Character array a + character(len=*), intent(in) :: a + !> String b + class(string_t), intent(in) :: b + + not_equals = .not. b .eq. a + + end function char_not_equals_string + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Compares an integer to a string for equality + logical elemental function int_not_equals_string( a, b ) & + result( not_equals ) + + !> Integer a + integer(kind=musica_ik), intent(in) :: a + !> String b + class(string_t), intent(in) :: b + + not_equals = .not. b .eq. a + + end function int_not_equals_string + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Compares a real number to a string for equality + logical elemental function real_not_equals_string( a, b ) & + result( not_equals ) + + !> Real number a + real(kind=musica_rk), intent(in) :: a + !> String b + class(string_t), intent(in) :: b + + not_equals = .not. b .eq. a + + end function real_not_equals_string + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Compares a double-precision real number to a string for equality + logical elemental function double_not_equals_string( a, b ) & + result( not_equals ) + + !> Double-precition real number a + real(kind=musica_dk), intent(in) :: a + !> String b + class(string_t), intent(in) :: b + + not_equals = .not. b .eq. a + + end function double_not_equals_string + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Compares a logical to a string for equality + logical elemental function logical_not_equals_string( a, b ) & + result( not_equals ) + + !> Logical a + logical, intent(in) :: a + !> String b + class(string_t), intent(in) :: b + + not_equals = .not. b .eq. a + + end function logical_not_equals_string + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Returns the size of a binary buffer required to pack the string + integer function pack_size( this, comm ) + + use musica_mpi + + class(string_t), intent(in) :: this ! string to pack + integer, intent(in) :: comm ! MPI communicator + +#ifdef MUSICA_USE_MPI + pack_size = musica_mpi_pack_size( allocated( this%val_ ), comm ) + if( allocated( this%val_ ) ) then + pack_size = pack_size + & + musica_mpi_pack_size( len( this%val_ ), comm ) + & + musica_mpi_pack_size( this%val_, comm ) + end if +#else + pack_size = 0 +#endif + + end function pack_size + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Packs the string onto a character buffer + subroutine mpi_pack( this, buffer, position, comm ) + + use musica_mpi + + !> String to pack + class(string_t), intent(in) :: this + !> Memory buffer + character, intent(inout) :: buffer(:) + !> Current buffer position + integer, intent(inout) :: position + !> MPI communicator + integer, intent(in) :: comm + +#ifdef MUSICA_USE_MPI + integer :: prev_position + + prev_position = position + call musica_mpi_pack( buffer, position, allocated( this%val_ ), comm ) + if( allocated( this%val_ ) ) then + call musica_mpi_pack( buffer, position, len( this%val_ ), comm ) + call musica_mpi_pack( buffer, position, this%val_, comm ) + end if + call assert_msg( 408845490, & + position - prev_position <= this%pack_size( comm ), & + "assertion failed" ) +#endif + + end subroutine mpi_pack + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Unpacks a string from a character buffer + subroutine mpi_unpack( this, buffer, position, comm ) + + use musica_mpi + + !> String to be unpacked + class(string_t), intent(out) :: this + !> Memory buffer + character, intent(inout) :: buffer(:) + !> Current buffer position + integer, intent(inout) :: position + !> MPI communicator + integer, intent(in) :: comm + +#ifdef MUSICA_USE_MPI + integer :: prev_position, str_size + logical :: is_allocated + + prev_position = position + call musica_mpi_unpack( buffer, position, is_allocated, comm ) + if( is_allocated ) then + call musica_mpi_unpack( buffer, position, str_size, comm ) + allocate( character( len = str_size ) :: this%val_ ) + call musica_mpi_unpack( buffer, position, this%val_, comm ) + end if + call assert_msg( 838278952, & + position - prev_position <= this%pack_size( comm ), & + "assertion failed" ) +#endif + + end subroutine mpi_unpack + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Converts an integer to a char array + character(len=kConvertCharLength) function int_to_char( val ) & + result( ret_val ) + + !> Value to convert + integer(kind=musica_ik), intent(in) :: val + + write( ret_val, '(i30)' ) val + ret_val = adjustl( ret_val ) + + end function int_to_char + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Converts a real number to a char array + character(len=kConvertCharLength) function real_to_char( val ) & + result( ret_val ) + + !> Value to convert + real(kind=musica_rk), intent(in) :: val + + write( ret_val, '(g30.20)' ) val + ret_val = adjustl( ret_val ) + + end function real_to_char + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Converts a double-precision real number to a char array + character(len=kConvertCharLength) function double_to_char( val ) & + result( ret_val ) + + !> Value to convert + real(kind=musica_dk), intent(in) :: val + + write( ret_val, '(g30.20)' ) val + ret_val = adjustl( ret_val ) + + end function double_to_char + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Converts a real complex number to a char array + character(len=kConvertCharLength) function complex_real_to_char( val ) & + result( ret_val ) + + !> Value to convert + complex(kind=musica_rk), intent(in) :: val + + ret_val = "(" // trim( to_char( real( val ) ) ) & + // ", " // trim( to_char( aimag( val ) ) ) // ")" + ret_val = adjustl( ret_val ) + + end function complex_real_to_char + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +!> Converts a double-precision real complex number to a char array + character(len=kConvertCharLength) function complex_double_to_char( val ) & + result( ret_val ) + + !> Value to convert + complex(kind=musica_dk), intent(in) :: val + + ret_val = "(" // trim( to_char( real( val ) ) ) & + // ", " // trim( to_char( aimag( val ) ) ) // ")" + ret_val = adjustl( ret_val ) + + end function complex_double_to_char + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Converts a logical to a char array + character(len=kConvertCharLength) function logical_to_char( val ) & + result( ret_val ) + + !> Value to convert + logical, intent(in) :: val + + if( val ) then + write( ret_val, '(a4)' ) "true" + else + write( ret_val, '(a5)' ) "false" + end if + + end function logical_to_char + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Output tabular data to a given file unit + subroutine output_table( header, table, file_unit ) + + !> Table header + type(string_t), intent(in) :: header(:) + !> Table data (column, row) + type(string_t), intent(in) :: table(:,:) + !> File unit + integer(kind=musica_ik), intent(in) :: file_unit + + integer(kind=musica_ik), parameter :: kMaxWidth = 120 + type(string_t) :: temp_str + character(len=256) :: fmt_row, fmt_div + integer(kind=musica_ik) :: i_col, i_row, table_width, str_len + integer(kind=musica_ik), allocatable :: max_len(:) + real(kind=musica_dk) :: frac + + call assert_msg( 239541866, size( header ) .eq. size( table, dim = 1 ), & + "Mismatched table header/data. Number of header "// & + "columns: "//trim( to_char( size( header ) ) )// & + ". Number of data columns: "// & + trim( to_char( size( table, dim = 1 ) ) ) ) + allocate( max_len( size( header ) ) ) + do i_col = 1, size( header ) + max_len( i_col ) = header( i_col )%length( ) + do i_row = 1, size( table, dim = 2 ) + if( max_len( i_col ) .lt. table( i_col, i_row )%length( ) ) then + max_len( i_col ) = table( i_col, i_row )%length( ) + end if + end do + end do + table_width = 1 + do i_col = 1, size( max_len ) + table_width = table_width + 3 + max_len( i_col ) + end do + if( table_width .gt. kMaxWidth ) then + frac = real( kMaxWidth, kind=musica_dk ) / & + real( ( table_width - 1 - 3*size( max_len ) ), kind=musica_dk ) + table_width = 0 + do i_col = 1, size( max_len ) + max_len( i_col ) = floor( max_len( i_col ) * frac ) + table_width = table_width + 3 + max_len( i_col ) + end do + end if + + if( table_width .ge. 10 .and. table_width .le. 99 ) then + write(fmt_div, '(a,i2,a)') '(', table_width, "('-'))" + else if( table_width .ge. 100 .and. table_width .le. 1000 ) then + write(fmt_div, '(a,i3,a)') '(', table_width, "('-'))" + else + call assert_msg( 289029811, .false., "Invalid table width" ) + end if + write(file_unit, fmt_div) + + temp_str = '("|"' + do i_col = 1, size( max_len ) + temp_str = temp_str//',1x,"' + str_len = header( i_col )%length( ) + if( str_len .ge. max_len( i_col ) ) then + temp_str = temp_str//header( i_col )%val_( 1 : max_len( i_col ) ) + else + temp_str = temp_str//header( i_col )//'",'// & + trim( to_char( max_len( i_col ) - str_len ) )//'x,"' + end if + temp_str = temp_str//' |"' + end do + temp_str = temp_str//')' + write(fmt_row, '(a)') temp_str%val_ + write(file_unit, fmt_row) + + write(file_unit, fmt_div) + + do i_row = 1, size( table, dim = 2 ) + temp_str = '("|"' + do i_col = 1, size( max_len ) + temp_str = temp_str//',1x,"' + str_len = table( i_col, i_row )%length( ) + if( str_len .ge. max_len( i_col ) ) then + temp_str = temp_str// & + table( i_col, i_row )%val_( 1 : max_len( i_col ) ) + else + temp_str = temp_str//table( i_col, i_row )//'",'// & + trim( to_char( max_len( i_col ) - str_len ) )//'x,"' + end if + temp_str = temp_str//' |"' + end do + temp_str = temp_str//')' + write(fmt_row, '(a)') temp_str%val_ + write(file_unit, fmt_row) + end do + + write(file_unit, fmt_div) + + end subroutine output_table + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Local assert function + subroutine assert_msg( code, condition, error_message ) + + !> Unique code for the assertion + integer, intent(in) :: code + !> Condition to evaluate + logical, intent(in) :: condition + !> Message to display on failure + character(len=*), intent(in) :: error_message + + integer, parameter :: kErrorFileId = 10 + integer, parameter :: kErrorId = 0 + character(len=50) :: str_code + + if( .not. condition ) then + write(str_code,'(i30)') code + write(kErrorId,*) "ERROR (Musica-"//trim( adjustl( str_code ) )//"): " & + //error_message + open( unit = kErrorFileId, file = "error.json", action = "WRITE" ) + write(kErrorFileId,'(A)') '{' + write(kErrorFileId,'(A)') ' "code" : "'//trim( adjustl( str_code ) )//'",' + write(kErrorFileId,'(A)') ' "message" : "'//error_message//'"' + write(kErrorFileId,'(A)') '}' + close(kErrorFileId) + stop 3 + end if + + end subroutine assert_msg + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +end module musica_string diff --git a/src/util/yaml_util.F90 b/src/util/yaml_util.F90 new file mode 100644 index 00000000..2955fcf6 --- /dev/null +++ b/src/util/yaml_util.F90 @@ -0,0 +1,452 @@ +! Copyright (C) 2020 National Center for Atmospheric Research +! SPDX-License-Identifier: Apache-2.0 +! +!> \file +!> Utility module for YAML parser + +!> Utility module for YAML parser +module musica_yaml_util + + use iso_c_binding + use musica_constants, only : musica_ik, musica_rk, musica_dk + + implicit none + public + + !> Interoperable string type + type, bind(c) :: string_t_c + type(c_ptr) :: ptr_ + integer(c_int) :: size_ + end type string_t_c + + !> Interoperable array type for strings + type, bind(c) :: string_array_t_c + type(c_ptr) :: ptr_ + integer(c_int) :: size_ + end type string_array_t_c + + !> Interoperable array type for doubles + type, bind(c) :: double_array_t_c + type(c_ptr) :: ptr_ + integer(c_int) :: size_ + end type double_array_t_c + + !> Interoperable array type for nodes + type, bind(c) :: node_array_t_c + type(c_ptr) :: ptr_ + integer(c_int) :: size_ + end type node_array_t_c + + !> C wrapper functions for YAML parser + interface + + !> Constructor from a YAML string + function yaml_create_from_string_c(yaml_string) & + bind(c, name="yaml_create_from_string") + use iso_c_binding + implicit none + type(c_ptr) :: yaml_create_from_string_c + character(len=1, kind=c_char), intent(in) :: yaml_string(*) + end function yaml_create_from_string_c + + !> Constructor from a YAML file + function yaml_create_from_file_c(file_path) & + bind(c, name="yaml_create_from_file") + use iso_c_binding + implicit none + type(c_ptr) :: yaml_create_from_file_c + character(len=1, kind=c_char), intent(in) :: file_path(*) + end function yaml_create_from_file_c + + !> Outputs YAML configuration to a file + subroutine yaml_to_file_c(node, file_path) bind(c, name="yaml_to_file") + use iso_c_binding + implicit none + type(c_ptr), value :: node + character(len=1, kind=c_char), intent(in) :: file_path(*) + end subroutine yaml_to_file_c + + !> Gets the number of elements + function yaml_size_c(node) bind(c, name="yaml_size") + use iso_c_binding + implicit none + integer(kind=c_int) :: yaml_size_c + type(c_ptr), value :: node + end function yaml_size_c + + !> Gets an beginning iterator for a node + function yaml_begin_c(node) bind(c, name="yaml_begin") + use iso_c_binding + implicit none + type(c_ptr) :: yaml_begin_c + type(c_ptr), value :: node + end function yaml_begin_c + + !> Gets an ending iterator for a node + function yaml_end_c(node) bind(c, name="yaml_end") + use iso_c_binding + implicit none + type(c_ptr) :: yaml_end_c + type(c_ptr), value :: node + end function yaml_end_c + + !> Increments an iterator + !! + !! Returns true if incremented iterator is < end, false otherwise + function yaml_increment_c(iter, end) bind(c, name="yaml_increment") + use iso_c_binding + implicit none + logical(kind=c_bool) :: yaml_increment_c + type(c_ptr), value :: iter + type(c_ptr), value :: end + end function yaml_increment_c + + !> Returns whether an iterator is == end + function yaml_at_end_c(iter, end) bind(c, name="yaml_at_end") + use iso_c_binding + implicit none + logical(kind=c_bool) :: yaml_at_end_c + type(c_ptr), value :: iter + type(c_ptr), value :: end + end function yaml_at_end_c + + !> Gets the key associated with an iterator + function yaml_key_c(iter) bind(c, name="yaml_key") + use iso_c_binding + import :: string_t_c + implicit none + type(string_t_c) :: yaml_key_c + type(c_ptr), value :: iter + end function yaml_key_c + + !> Gets a sub-node by key + function yaml_get_node_c(node, key, found) bind(c, name="yaml_get_node") + use iso_c_binding + implicit none + type(c_ptr) :: yaml_get_node_c + type(c_ptr), value :: node + character(len=1, kind=c_char), intent(in) :: key(*) + logical(kind=c_bool), intent(out) :: found + end function yaml_get_node_c + + !> Gets a string by key + function yaml_get_string_c(node, key, found) bind(c, name="yaml_get_string") + use iso_c_binding + import :: string_t_c + implicit none + type(string_t_c) :: yaml_get_string_c + type(c_ptr), value :: node + character(len=1, kind=c_char), intent(in) :: key(*) + logical(kind=c_bool), intent(out) :: found + end function yaml_get_string_c + + !> Gets an integer by key + function yaml_get_int_c(node, key, found) bind(c, name="yaml_get_int") + use iso_c_binding + implicit none + integer(kind=c_int) :: yaml_get_int_c + type(c_ptr), value :: node + character(len=1, kind=c_char), intent(in) :: key(*) + logical(kind=c_bool), intent(out) :: found + end function yaml_get_int_c + + !> Gets a float by key + function yaml_get_float_c(node, key, found) bind(c, name="yaml_get_float") + use iso_c_binding + implicit none + real(kind=c_float) :: yaml_get_float_c + type(c_ptr), value :: node + character(len=1, kind=c_char), intent(in) :: key(*) + logical(kind=c_bool), intent(out) :: found + end function yaml_get_float_c + + !> Gets a double by key + function yaml_get_double_c(node, key, found) bind(c, name="yaml_get_double") + use iso_c_binding + implicit none + real(kind=c_double) :: yaml_get_double_c + type(c_ptr), value :: node + character(len=1, kind=c_char), intent(in) :: key(*) + logical(kind=c_bool), intent(out) :: found + end function yaml_get_double_c + + !> Gets a boolean by key + function yaml_get_bool_c(node, key, found) bind(c, name="yaml_get_bool") + use iso_c_binding + implicit none + logical(kind=c_bool) :: yaml_get_bool_c + type(c_ptr), value :: node + character(len=1, kind=c_char), intent(in) :: key(*) + logical(kind=c_bool), intent(out) :: found + end function yaml_get_bool_c + + !> Gets a string array by key + function yaml_get_string_array_c(node, key, found) & + bind(c, name="yaml_get_string_array") + use iso_c_binding + import :: string_array_t_c + implicit none + type(string_array_t_c) :: yaml_get_string_array_c + type(c_ptr), value :: node + character(len=1, kind=c_char), intent(in) :: key(*) + logical(kind=c_bool), intent(out) :: found + end function yaml_get_string_array_c + + !> Gets a double array by key + function yaml_get_double_array_c(node, key, found) & + bind(c, name="yaml_get_double_array") + use iso_c_binding + import :: double_array_t_c + implicit none + type(double_array_t_c) :: yaml_get_double_array_c + type(c_ptr), value :: node + character(len=1, kind=c_char), intent(in) :: key(*) + logical(kind=c_bool), intent(out) :: found + end function yaml_get_double_array_c + + !> Gets a node array by key + function yaml_get_node_array_c(node, key, found) & + bind(c, name="yaml_get_node_array") + use iso_c_binding + import :: node_array_t_c + implicit none + type(node_array_t_c) :: yaml_get_node_array_c + type(c_ptr), value :: node + character(len=1, kind=c_char), intent(in) :: key(*) + logical(kind=c_bool), intent(out) :: found + end function yaml_get_node_array_c + + !> Gets a node using an iterator + function yaml_get_node_from_iterator_c(iter) & + bind(c, name="yaml_get_node_from_iterator") + use iso_c_binding + implicit none + type(c_ptr) :: yaml_get_node_from_iterator_c + type(c_ptr), value :: iter + end function yaml_get_node_from_iterator_c + + !> Gets a string using an iterator + function yaml_get_string_from_iterator_c(iter) & + bind(c, name="yaml_get_string_from_iterator") + use iso_c_binding + import :: string_t_c + implicit none + type(string_t_c) :: yaml_get_string_from_iterator_c + type(c_ptr), value :: iter + end function yaml_get_string_from_iterator_c + + !> Gets an integer using an iterator + function yaml_get_int_from_iterator_c(iter) & + bind(c, name="yaml_get_int_from_iterator") + use iso_c_binding + implicit none + integer(kind=c_int) :: yaml_get_int_from_iterator_c + type(c_ptr), value :: iter + end function yaml_get_int_from_iterator_c + + !> Gets a float using an iterator + function yaml_get_float_from_iterator_c(iter) & + bind(c, name="yaml_get_float_from_iterator") + use iso_c_binding + implicit none + real(kind=c_float) :: yaml_get_float_from_iterator_c + type(c_ptr), value :: iter + end function yaml_get_float_from_iterator_c + + !> Gets a double using an iterator + function yaml_get_double_from_iterator_c(iter) & + bind(c, name="yaml_get_double_from_iterator") + use iso_c_binding + implicit none + real(kind=c_double) :: yaml_get_double_from_iterator_c + type(c_ptr), value :: iter + end function yaml_get_double_from_iterator_c + + !> Gets a boolean using an iterator + function yaml_get_bool_from_iterator_c(iter) & + bind(c, name="yaml_get_bool_from_iterator") + use iso_c_binding + implicit none + logical(kind=c_bool) :: yaml_get_bool_from_iterator_c + type(c_ptr), value :: iter + end function yaml_get_bool_from_iterator_c + + !> Gets a string array using an iterator + function yaml_get_string_array_from_iterator_c(iter) & + bind(c, name="yaml_get_string_array_from_iterator") + use iso_c_binding + import :: string_array_t_c + implicit none + type(string_array_t_c) :: yaml_get_string_array_from_iterator_c + type(c_ptr), value :: iter + end function yaml_get_string_array_from_iterator_c + + !> Adds a YAML node to a YAML node + subroutine yaml_add_node_c(node, key, value) bind(c, name="yaml_add_node") + use iso_c_binding + implicit none + type(c_ptr), value :: node + character(len=1, kind=c_char), intent(in) :: key(*) + type(c_ptr), value :: value + end subroutine yaml_add_node_c + + !> Adds a string to a YAML node + subroutine yaml_add_string_c(node, key, value) & + bind(c, name="yaml_add_string") + use iso_c_binding + implicit none + type(c_ptr), value :: node + character(len=1, kind=c_char), intent(in) :: key(*) + character(len=1, kind=c_char), intent(in) :: value(*) + end subroutine yaml_add_string_c + + !> Adds an int to a YAML node + subroutine yaml_add_int_c(node, key, value) bind(c, name="yaml_add_int") + use iso_c_binding + implicit none + type(c_ptr), value :: node + character(len=1, kind=c_char), intent(in) :: key(*) + integer(kind=c_int), value :: value + end subroutine yaml_add_int_c + + !> Adds a float to a YAML node + subroutine yaml_add_float_c(node, key, value) & + bind(c, name="yaml_add_float") + use iso_c_binding + implicit none + type(c_ptr), value :: node + character(len=1, kind=c_char), intent(in) :: key(*) + real(kind=c_float), value :: value + end subroutine yaml_add_float_c + + !> Adds a double to a YAML node + subroutine yaml_add_double_c(node, key, value) & + bind(c, name="yaml_add_double") + use iso_c_binding + implicit none + type(c_ptr), value :: node + character(len=1, kind=c_char), intent(in) :: key(*) + real(kind=c_double), value :: value + end subroutine yaml_add_double_c + + !> Adds a boolean to a YAML node + subroutine yaml_add_bool_c(node, key, value) bind(c, name="yaml_add_bool") + use iso_c_binding + implicit none + type(c_ptr), value :: node + character(len=1, kind=c_char), intent(in) :: key(*) + logical(kind=c_bool), value :: value + end subroutine yaml_add_bool_c + + !> Adds a string array to a YAML node + subroutine yaml_add_string_array_c(node, key, value) & + bind(c, name="yaml_add_string_array") + use iso_c_binding + import :: string_array_t_c + implicit none + type(c_ptr), value :: node + character(len=1, kind=c_char), intent(in) :: key(*) + type(string_array_t_c), value :: value + end subroutine yaml_add_string_array_c + + !> Adds a double array to a YAML node + subroutine yaml_add_double_array_c(node, key, value) & + bind(c, name="yaml_add_double_array") + use iso_c_binding + import :: double_array_t_c + implicit none + type(c_ptr), value :: node + character(len=1, kind=c_char), intent(in) :: key(*) + type(double_array_t_c), value :: value + end subroutine yaml_add_double_array_c + + !> Adds a node array to a YAML node + subroutine yaml_add_node_array_c(node, key, value) & + bind(c, name="yaml_add_node_array") + use iso_c_binding + import :: node_array_t_c + implicit none + type(c_ptr), value :: node + character(len=1, kind=c_char), intent(in) :: key(*) + type(node_array_t_c), value :: value + end subroutine yaml_add_node_array_c + + !> Copy node + function yaml_copy_node_c(node) bind(c, name="yaml_copy_node") + use iso_c_binding + implicit none + type(c_ptr) :: yaml_copy_node_c + type(c_ptr), value :: node + end function yaml_copy_node_c + + !> Copy node to string + function yaml_to_string_c(node) bind(c, name="yaml_to_string") + use iso_c_binding + import :: string_t_c + implicit none + type(string_t_c) :: yaml_to_string_c + type(c_ptr), value :: node + end function yaml_to_string_c + + !> Merges one node into another + function yaml_merge_node_c(dest, src) bind(c, name="yaml_merge_node") + use iso_c_binding + implicit none + logical(kind=c_bool) :: yaml_merge_node_c + type(c_ptr), value :: dest + type(c_ptr), value, intent(in) :: src + end function yaml_merge_node_c + + !> Node destructor + subroutine yaml_delete_node_c(node) bind(c, name="yaml_delete_node") + use iso_c_binding + implicit none + type(c_ptr), value :: node + end subroutine yaml_delete_node_c + + !> String destructor + subroutine yaml_delete_string_c(string) bind(c, name="yaml_delete_string") + use iso_c_binding + import :: string_t_c + implicit none + type(string_t_c), value :: string + end subroutine yaml_delete_string_c + + !> String array destructor + subroutine yaml_delete_string_array_c(array) & + bind(c, name="yaml_delete_string_array") + use iso_c_binding + import :: string_array_t_c + implicit none + type(string_array_t_c), value :: array + end subroutine yaml_delete_string_array_c + + !> Double array destructor + subroutine yaml_delete_double_array_c(array) & + bind(c, name="yaml_delete_double_array") + use iso_c_binding + import :: double_array_t_c + implicit none + type(double_array_t_c), value :: array + end subroutine yaml_delete_double_array_c + + !> Node array destructor + subroutine yaml_delete_node_array_c(array) & + bind(c, name="yaml_delete_node_array") + use iso_c_binding + import :: node_array_t_c + implicit none + type(node_array_t_c), value :: array + end subroutine yaml_delete_node_array_c + + !> Iterator destructor + subroutine yaml_delete_iterator_c(iter) & + bind(c, name="yaml_delete_iterator") + use iso_c_binding + implicit none + type(c_ptr), value :: iter + end subroutine yaml_delete_iterator_c + + end interface + +end module musica_yaml_util \ No newline at end of file diff --git a/test/CMakeLists.txt b/test/CMakeLists.txt index ef24ac8f..103518eb 100644 --- a/test/CMakeLists.txt +++ b/test/CMakeLists.txt @@ -2,7 +2,7 @@ # Test utilities add_library(tuvx_test_utils unit/test_utils.F90) -target_link_libraries(tuvx_test_utils musica::musicacore) +target_link_libraries(tuvx_test_utils musica::tuvx) set_target_properties(tuvx_test_utils PROPERTIES Fortran_MODULE_DIRECTORY ${PROJECT_BINARY_DIR}/test_include @@ -24,8 +24,10 @@ add_custom_target(copy_test_data ALL ${CMAKE_COMMAND} -E copy_directory ################################################################################ # Add subdirectories +string(REGEX MATCH "^[0-9]+" CMAKE_Fortran_COMPILER_MAJOR_VERSION ${CMAKE_Fortran_COMPILER_VERSION}) + add_subdirectory(unit) -if(NOT ${CMAKE_Fortran_COMPILER_ID} MATCHES "NAG") +if(NOT ${CMAKE_Fortran_COMPILER_ID} MATCHES "NAG" AND NOT (${CMAKE_Fortran_COMPILER_ID} STREQUAL "GNU" AND ${CMAKE_Fortran_COMPILER_MAJOR_VERSION} VERSION_EQUAL 13)) # oldtuv doesn't build with NAG, so bypass the regression tests add_subdirectory(oldtuv) add_subdirectory(regression) @@ -34,7 +36,33 @@ endif() ################################################################################ # Run examples as tests -add_test(NAME full_example COMMAND tuv-x examples/full_config.json - WORKING_DIRECTORY ${CMAKE_BINARY_DIR}) +add_custom_target(make-tuv54-example-dir ALL COMMAND ${CMAKE_COMMAND} + -E make_directory ${CMAKE_BINARY_DIR}/example_tuv_5_4) +add_custom_target(link-tuv54-example-data ALL COMMAND ${CMAKE_COMMAND} + -E copy_directory ${CMAKE_CURRENT_SOURCE_DIR}/../data ${CMAKE_BINARY_DIR}/example_tuv_5_4/data) +add_test(NAME TUV_5_4 COMMAND tuv-x ../examples/tuv_5_4.json + WORKING_DIRECTORY ${CMAKE_BINARY_DIR}/example_tuv_5_4) +add_custom_target(make-ts1-tsmlt-example-dir ALL COMMAND ${CMAKE_COMMAND} + -E make_directory ${CMAKE_BINARY_DIR}/example_ts1_tsmlt) +add_custom_target(link-ts1-tsmlt-example-data ALL COMMAND ${CMAKE_COMMAND} + -E copy_directory ${CMAKE_CURRENT_SOURCE_DIR}/../data ${CMAKE_BINARY_DIR}/example_ts1_tsmlt/data) +add_test(NAME TS1_TSMLT COMMAND tuv-x ../examples/ts1_tsmlt.json + WORKING_DIRECTORY ${CMAKE_BINARY_DIR}/example_ts1_tsmlt) +add_custom_target(make-tuv54-yaml-example-dir ALL COMMAND ${CMAKE_COMMAND} + -E make_directory ${CMAKE_BINARY_DIR}/example_tuv_5_4_yaml) +add_custom_target(link-tuv54-yaml-example-data ALL COMMAND ${CMAKE_COMMAND} + -E copy_directory ${CMAKE_CURRENT_SOURCE_DIR}/../data ${CMAKE_BINARY_DIR}/example_tuv_5_4_yaml/data) +add_test(NAME TUV_5_4_YAML COMMAND tuv-x ../examples/tuv_5_4.yml + WORKING_DIRECTORY ${CMAKE_BINARY_DIR}/example_tuv_5_4_yaml) +add_test(NAME TUV_5_4_COMPARE COMMAND python3 test/json_yaml_compare.py example_tuv_5_4 example_tuv_5_4_yaml + WORKING_DIRECTORY ${CMAKE_BINARY_DIR}) +add_custom_target(make-ts1-tsmlt-yaml-example-dir ALL COMMAND ${CMAKE_COMMAND} + -E make_directory ${CMAKE_BINARY_DIR}/example_ts1_tsmlt_yaml) +add_custom_target(link-ts1-tsmlt-yaml-example-data ALL COMMAND ${CMAKE_COMMAND} + -E copy_directory ${CMAKE_CURRENT_SOURCE_DIR}/../data ${CMAKE_BINARY_DIR}/example_ts1_tsmlt_yaml/data) +add_test(NAME TS1_TSMLT_YAML COMMAND tuv-x ../examples/ts1_tsmlt.yml + WORKING_DIRECTORY ${CMAKE_BINARY_DIR}/example_ts1_tsmlt_yaml) +add_test(NAME TS1_TSMLT_COMPARE COMMAND python3 test/json_yaml_compare.py example_ts1_tsmlt example_ts1_tsmlt_yaml + WORKING_DIRECTORY ${CMAKE_BINARY_DIR}) ################################################################################ diff --git a/test/data/config_example.json b/test/data/config_example.json new file mode 100644 index 00000000..801f221f --- /dev/null +++ b/test/data/config_example.json @@ -0,0 +1,12 @@ +{ + "my int" : 12, + "other props" : { + "an int" : 45 + }, + "real props" : { + "foo" : 14.2, + "bar" : 64.2, + "foobar" : 920.4 + }, + "a string" : "foo" +} diff --git a/test/data/config_example.yml b/test/data/config_example.yml new file mode 100644 index 00000000..d330a3e8 --- /dev/null +++ b/test/data/config_example.yml @@ -0,0 +1,8 @@ +my int: 12 +other props: + an int: 45 +real props: + foo: 14.2 + bar: 64.2 + foobar: 920.4 +a string: foo \ No newline at end of file diff --git a/test/data/cross_sections/cross_section.base.config.json b/test/data/cross_sections/cross_section.base.config.json index 02512e28..25fd74d9 100644 --- a/test/data/cross_sections/cross_section.base.config.json +++ b/test/data/cross_sections/cross_section.base.config.json @@ -48,6 +48,18 @@ "upper extrapolation": { "type": "constant", "value": 32.3 } } ] + }, + { + "name": "from config", + "type": "base", + "data": { + "default value": 12.3, + "point values": [ + { "wavelength": 102.5, "value": 92.3 }, + { "wavelength": 103.75, "value": 53.2 } + ] + } + } ] } diff --git a/test/data/cross_sections/util/burkholder.config.json b/test/data/cross_sections/util/burkholder.config.json new file mode 100644 index 00000000..36a3efcf --- /dev/null +++ b/test/data/cross_sections/util/burkholder.config.json @@ -0,0 +1,22 @@ +{ + "type": "BURKHOLDER", + "netcdf file": { + "file path": "test/data/cross_sections/util/burkholder.nc" + }, + "A": 12.5, + "B": 202.3, + "temperature ranges": [ + { + "maximum": 209.999999999999, + "fixed value": 210.0 + }, + { + "minimum": 210.0, + "maximum": 300.0 + }, + { + "minimum": 300.00000000001, + "fixed value": 300.0 + } + ] +} \ No newline at end of file diff --git a/test/data/cross_sections/util/burkholder.nc b/test/data/cross_sections/util/burkholder.nc new file mode 100644 index 0000000000000000000000000000000000000000..1b73b9d55dd3af29bd7265d5c2ce86b40e39e180 GIT binary patch literal 436 zcmZ>EabskF04^ZK48%MosksHIMTsS)MXAM5IhLf%JP?}|h`9<9ixP8FOHzvIt23QJY2MF^3F<3s{Ei)%4EHS4v6)evNlCS>(W`hXU(!9(P zsO2E_OnJFrIgmOHpi&VaEr#UIcr-VG^#Ikt>;%zV1ndNvT>;c$<52Vf$Yfw}fI7gT zSOLm+fYJ#NT5Bc<%yQ5<0|I9q^ufXm4hB$h!_CGZ;9!~t1`cLE5OwBYVPgjiNr-++ Ts6GiOEd!+$ptKT{R)Np}mrP8* literal 0 HcmV?d00001 diff --git a/test/data/cross_sections/util/taylor.config.json b/test/data/cross_sections/util/taylor.config.json new file mode 100644 index 00000000..54b0c7d3 --- /dev/null +++ b/test/data/cross_sections/util/taylor.config.json @@ -0,0 +1,23 @@ +{ + "type": "TAYLOR_SERIES", + "netcdf file": { + "file path": "test/data/cross_sections/util/taylor.nc" + }, + "base temperature": 295.2, + "minimum wavelength": 280.5, + "maximum wavelength": 540.2, + "temperature ranges": [ + { + "maximum": 209.999999999999, + "fixed value": 210.0 + }, + { + "minimum": 210.0, + "maximum": 300.0 + }, + { + "minimum": 300.00000000001, + "fixed value": 300.0 + } + ] +} \ No newline at end of file diff --git a/test/data/cross_sections/util/taylor.nc b/test/data/cross_sections/util/taylor.nc new file mode 100644 index 0000000000000000000000000000000000000000..1b73b9d55dd3af29bd7265d5c2ce86b40e39e180 GIT binary patch literal 436 zcmZ>EabskF04^ZK48%MosksHIMTsS)MXAM5IhLf%JP?}|h`9<9ixP8FOHzvIt23QJY2MF^3F<3s{Ei)%4EHS4v6)evNlCS>(W`hXU(!9(P zsO2E_OnJFrIgmOHpi&VaEr#UIcr-VG^#Ikt>;%zV1ndNvT>;c$<52Vf$Yfw}fI7gT zSOLm+fYJ#NT5Bc<%yQ5<0|I9q^ufXm4hB$h!_CGZ;9!~t1`cLE5OwBYVPgjiNr-++ Ts6GiOEd!+$ptKT{R)Np}mrP8* literal 0 HcmV?d00001 diff --git a/test/data/heating_rates.json b/test/data/heating_rates.json new file mode 100644 index 00000000..7ff2a056 --- /dev/null +++ b/test/data/heating_rates.json @@ -0,0 +1,100 @@ +{ + "grids" : [ + { + "name": "height", + "type": "equal interval", + "units": "km", + "begins at": 1.0, + "ends at": 5.0, + "cell delta": 1.0 + }, + { + "name": "wavelength", + "type": "equal interval", + "units": "nm", + "begins at": 400.0, + "ends at": 700.0, + "cell delta": 50.0 + } + ], + "profiles": [ + { + "name": "temperature", + "type": "from config file", + "units": "K", + "grid": { + "name": "height", + "units": "km" + }, + "values": [ 200.0, 250.0, 300.0, 350.0, 400.0 ] + }, + { + "name": "extraterrestrial flux", + "type": "from config file", + "units": "photon cm-2 s-1", + "grid": { + "name": "wavelength", + "units": "nm" + }, + "values": [ 1.0e+4, 1.0e+5, 1.0e+6, 1.0e+7, 1.0e+8, 1.0e+9, 1.0e+10 ] + }, + { + "name": "air", + "type": "from config file", + "units": "molecule cm-3", + "grid": { + "name": "height", + "units": "km" + }, + "values": [ 2.5e+19, 2.0e+19, 1.5e+19, 1.0e+19, 5.0e+18 ] + } + ], + "reactions": [ + { + "name": "jfoo", + "cross section": { + "type": "base", + "data": { + "default value": 12.3 + } + }, + "quantum yield": { + "type": "base", + "constant value": 0.75 + }, + "heating": { + "energy term": 2.0 + } + }, + { + "name": "jbar", + "cross section": { + "type": "base", + "data": { + "default value": 45.6 + } + }, + "quantum yield": { + "type": "base", + "constant value": 0.25 + } + }, + { + "name": "jbaz", + "cross section": { + "type": "base", + "data": { + "default value": 78.9 + } + }, + "quantum yield": { + "type": "base", + "constant value": 0.5 + }, + "scaling factor": 1.1, + "heating": { + "energy term": 3000.0 + } + } + ] +} \ No newline at end of file diff --git a/test/data/io_netcdf_test_data.nc b/test/data/io_netcdf_test_data.nc new file mode 100644 index 0000000000000000000000000000000000000000..d67beaa5288e9cc325c1abd718aca1dfc3218205 GIT binary patch literal 888 zcmZ>EabskF04^ZK0>q4I5I&fl4q-Ec#4{jlkb1^U2%8B)fk|#4$pOU7g{2ip!eAyF zM2>L@kY*_?#ZUmU3y2xlK;^4|G|XK?0U*tslvo6$!1`fkfcPLa5MfXqz*3Pk{E*5v%6^i&`N2ta-U0hoH2evlYQ&jFyG9S-5* z>qM#^dI0(CK+FlmAa!6rJLoOG&ShJ$#DP<8N8syLc?YYlhx%hQzBw3&1BDk~cktW} zq2msK6c#!-_yLV_U*}+N39#_q_PJRc=Sn0l%AI@q>~V6M$}GaA;WY`*}{ci|YyNTgTSTKIGu) z01{?!a9#kRHyi~!*x@kG+=&@Q8*IdX3r{%Gt>dKHXS5NdZchSO-f@cE?*kyd7TB3- z4hM{Y-urqOX1+u70Tg>&uNXe~_3XML+&(V{pl&34Jr+RtF#ETxMRAA2?36d%&Qlv< z?y-@NVSTd6{yNNEPFiMOl_2w=?sGVx0t&FhFn2mmTNru(BoA}1IXIY%;qE@926jIH Dp0m&i literal 0 HcmV?d00001 diff --git a/test/data/la_srb_bands.config.json b/test/data/la_srb_bands.config.json index 51bd6d98..a00baaa2 100644 --- a/test/data/la_srb_bands.config.json +++ b/test/data/la_srb_bands.config.json @@ -1,18 +1,24 @@ { "grids" : [ { - "name": "height", - "type": "equal interval", - "units": "km", - "begins at" : 0.0, - "ends at" : 120.0, - "cell delta" : 1.0 + "name": "height", + "type": "equal interval", + "units": "km", + "begins at" : 0.5, + "ends at" : 150.5, + "cell delta" : 1.0 }, { - "name": "wavelength", - "type": "from csv file", - "units": "nm", - "file path": "data/grids/wavelength/combined.grid" + "name": "wavelength", + "type": "from csv file", + "units": "nm", + "file path": "test/data/waccm2_ref_101_mod.grid" + }, + { + "name": "LUT wavelength", + "type": "from csv file", + "units": "nm", + "file path": "test/data/waccm2_ref_101.grid" } ], "cross section parameters file": "data/cross_sections/O2_parameters.txt", @@ -26,9 +32,28 @@ "name": "height", "units": "km" } + }, + { + "name": "air", + "type": "air", + "units": "molecule cm-3", + "file path": "data/profiles/atmosphere/ussa.dens" + }, + { + "name": "O2", + "type": "O2", + "units": "molecule cm-3", + "file path": "data/profiles/atmosphere/ussa.dens" } ], - "O2 estimate" :{ - "scale factor": 0.2095 + "O2 cross section": { + "netcdf files": [ + { + "file path": "data/cross_sections/O2_1.nc", + "lower extrapolation": { "type": "boundary" }, + "interpolator": { "type": "fractional target" } + } + ], + "type": "base" } } diff --git a/test/data/quantum_yields/base.config.json b/test/data/quantum_yields/base.config.json index e5a5d883..c1b52b82 100644 --- a/test/data/quantum_yields/base.config.json +++ b/test/data/quantum_yields/base.config.json @@ -25,6 +25,12 @@ { "band": "schumann-runge continuum", "value": 0.932 + }, + { + "band": "range", + "minimum wavelength": 207.0, + "maximum wavelength": 250.0, + "value": 0.243 } ] }, diff --git a/test/data/quantum_yields/h2so4_mills.config.json b/test/data/quantum_yields/h2so4_mills.config.json new file mode 100644 index 00000000..ea6511cf --- /dev/null +++ b/test/data/quantum_yields/h2so4_mills.config.json @@ -0,0 +1,143 @@ +{ + "grids": [ + { + "type": "from config file", + "name": "wavelength", + "units": "nm", + "values": [ + 120.0000, + 121.0000, + 122.0000, + 123.5000, + 124.3000, + 125.5000, + 126.3000, + 127.1000, + 130.1000, + 131.1000, + 135.0000, + 140.0000, + 145.0000, + 150.0000, + 155.0000, + 160.0000, + 165.0000, + 168.0000, + 171.0000, + 173.0000, + 174.4000, + 177.0000, + 178.6000, + 180.2000, + 181.8000, + 183.5000, + 185.2000, + 186.9000, + 188.7000, + 190.5000, + 192.3000, + 194.2000, + 196.1000, + 198.0000, + 200.0000, + 202.0000, + 204.1000, + 205.8000, + 208.0000, + 211.0000, + 214.0000, + 217.0000, + 220.0000, + 223.0000, + 226.0000, + 229.0000, + 232.0000, + 235.0000, + 238.0000, + 241.0000, + 244.0000, + 247.0000, + 250.0000, + 253.0000, + 256.0000, + 259.0000, + 263.0000, + 267.0000, + 271.0000, + 275.0000, + 279.0000, + 283.0000, + 287.0000, + 291.0000, + 295.0000, + 298.5000, + 302.5000, + 305.5000, + 308.5000, + 311.5000, + 314.5000, + 317.5000, + 322.5000, + 327.5000, + 332.5000, + 337.5000, + 342.5000, + 347.5000, + 350.0000, + 355.0000, + 360.0000, + 365.0000, + 370.0000, + 375.0000, + 380.0000, + 385.0000, + 390.0000, + 395.0000, + 400.0000, + 405.0000, + 410.0000, + 415.0000, + 420.0000, + 430.0000, + 440.0000, + 450.0000, + 500.0000, + 550.0000, + 600.0000, + 650.0000, + 700.0000, + 750.0000 + ] + } + ], + "quantum yield": { + "type": "H2SO4 Mills", + "netcdf files": [ + "data/quantum_yields/H2SO4_mills.nc" + ], + "parameterized wavelengths": [ + 525, + 625, + 725 + ], + "collision interval s": [ + 1.1e-9, + 8.9e-9, + 1.7e-7 + ], + "molecular diameter m": 4.18e-10, + "molecular weight kg mol-1": 98.078479e-3 + }, + "cross section": { + "type": "base", + "data": { + "default value": 0.0, + "point values": [ + { "wavelength": 121.5, "value": 6.3e-17 }, + { "wavelength": 525.0, "value": 1.43e-26 }, + { "wavelength": 625.0, "value": 1.8564e-25 }, + { "wavelength": 725.0, "value": 3.086999e-24 } + ] + } + } +} \ No newline at end of file diff --git a/test/data/quantum_yields/jh2so4.nc b/test/data/quantum_yields/jh2so4.nc new file mode 100644 index 0000000000000000000000000000000000000000..db0126a1b1d221dbf80f34b69449dee631996df3 GIT binary patch literal 863648 zcmeF4gKz&+2pu64e9^FulFarWM`W@c^d+IKWG;89qYy!y=VFn9X=Y5X-iT?**u zj`q`Ms;`{Tr;&a>bM_o{YEWFC#`?^o&;0!-J5ICL5A>nVs|;*Zw}C|+i}o|-PPFJY z*}-A*oEZ*Q7UQQ*cCej0Zp`eu_T%TO?=_k;WA5y6{0G&aE7RV7_T+i?<1Hr4o-y5` zU;hCEtt`6s?%trj{#g-y=F?~4`D5nUPqTNJ=r~C~Gcd@tA@~2K(6kv26Gu6Wnf|x` zAJakq`ZE@tW=|e(VQ25)Xg?c&KL1>Y$&PFi{@?RBOy{rbf3^O1=26BMQ4s8Bk8zwk z8-J_%nQH!TKhwDX|Nk@Uum9)IG3=&)QGH!UUsaz=^y7jvXWP%2!#_m*{ff!|_A?6g z{_Fey`v3pu&&WHe_Za=JP(Q=KR>vK!tI?E6)^lbw(vSGxT>T97v()(Cepczu*8O@l zvZ!q_X`V%^))t-n^=hb}^y;ks+&_PA{yFyJ>NHTFsGnW5dZzwkv+cSV7}#|)K4aJY zLqofsk0;pmaWb&$ug^jH9IDR|`W&s#ar&H~&&m3nrq3DroUPBf`dpyT#rj;PPp3=+ zJ7-;2>T|U|UG?d%PY->1>C;D_e)k(bEbUmT#DP7O%dS2JdP6l>2 z^m$jGubd3p=e0FxZ<1-y-dxw3x;C~ouroCg(J}c_e zLZ6lNSy`V|^r?G_T{V4H*JllV*3@S$eOl_Xwmz-&Sx29B^;u7!`jum+|3lbW>$9Og z^?!G}#`a(pr+v!ukBiOaqX9s$8VGd+M{7K6~r4k3ReAv!6cu>vMoU2kLW>J_qY_h(3qvbC^Dd z>vM!YN9uEwK1b_wj6TQebDTcM>(gGJ6ZAPzpOf@CS)Wt%IaQz2^f_Ih4*Hy-&zbt1 zrBD4@x6>~YJ4b!$w;sEB`kb%N1^Qg5&qexNtj{I-T&mAy`dqG0CpDc6>{jTyLRV*9 zopp85)kW8px~|l9m9DFFU9IbCUDxQkMpsu|U3GQS)lFA-UEOtEtLs`_J#_WZ)l*kb zUA=Vm($!m6Z(V(K_0iQ=S6^NIboJBKUsr!!19T10HBi?;U4wKD(luDuU|mCW4be4J z*HB%HB#3|UDxTlPS+@1qjZhdHCopgU1M~O)iqYv^}4RtHBQ$! zT{q~uLD!ACZqzki*LYnw>AFeR&AM*ZH9^+|T@!Up)HO-hBwdqrP1ZF<*A!h-4Gh}r z|0eCn=(Dpv>*>=}|LnUykLy#}seiqle%ww!Zl@o&)sNd+=r=n3|GABmf!IMtKDzf9 z7|_h$y4UMEzUG&wfevOQnUq&tqzt&)| zxX32x$ZGnESmvN2?`wg<;xp#Zk(czWfXqS0eYS(a63=hYQ7bHElF;uD#%YhhU};ap zn>4zv+_hOz6RgE(S<(AoGWsUs42ix$MID-e!Lrl*JQ=gvSt188D0+Gjbop8b=-39& z#j+@7SqTiBs^a-UV{c!T%VLdQDbVksPA+|*wqiiOZlEtBuDi4;%AlF_h zF_CLUE)IyjY0~irxt~c>Dshk*xSZ6x6?FfY?C?n%gIs&5WI2wtR#w+LQFInlG`(|0 z=Ae>uS1QYCr8DO*rtCueDUk-1JXeHS+=+lr9ceF-18k?7cFRB zT9IcngW$}CsSh$y6 z26a4tQY?!yZMeSfKI<1)%yrl%mqkDcFmOM?`S5wh&E&FpihKpFwde#U^ERVbULp@N zYv~FGYv-Fn=XWeBkppZu^WlAFYtQIA8};~N{)2IHS>(J21COel175IfpjZ}Vn{wZ; z$0E*qE;M^0mxX&@_KWisp$oU+z9EqZmAz9Q3_Pn{fiCLxSRx15UalV35Iq<7V;0Yc z%4MO$2i7Md{la`c z-zU7zS%byW-V-HqfbHhT*F(Ll#50R$hGJQiH%ns{^LZc1vK4Y`MdhcsFpE>%=egVr zxnPODLFM-lSol;t3|*d4-OJMgA0t9KfJrSH55P9{6j&KyQD!EJAtTh+oM7uvrm~ zy1PUkRPibIUHI7-Viu3&_JdnA?EnUTJ9*HLcUs$X<0tWttc>jp=BE+FGSzOM? zEQWCo*!hUuduOG}99Q@!y#o`MVhbhu1Z=M~<0<>aU+-yj87#M+T4~=3un6dN2YS44JEUq447B2ieSru(B zmPOUdTw4yhgdSH~^>n*j77oMU7r|8)L08w$mdj!n-zS3Spk79+7vzX#Q7wN>_(Sj^ z_K($>h{YxHplZE&tsYXs9Zc2~lpA+e3%3A+kkOvZqBnAV>R8&KYL6}{n<*rf>m+M} z=SpLcYcEx=&wYF$zl(#(n!7u5Ka-|ZebG8F2<`3*b**+y8iQPWsrnJ@k)Y5p&TqL+ zLtQoZb4f}yiv8sm&(Pyau3Hd?N@9>}E7cg>PaRWO)6!7a??ZAwlcrQ7hU3n#mFT-5 zH(RXHq;Y^B)Ob-F8g`Md6}L6WXNY7`vr$j52)C#LbvxrNkppb6xzvtXOkW0dr!=`N zvbcsAzIzL^7=ryp5_wRqVnJXKQD6_Vh*~X?18lD~@Efz}AIU5pwUo;usxGsL83bKx zd0sAyCykiJD~`d}&TJ)?g=Ib7e;C<<*Q;x{t(D7S9zQ=KR|mpB)_%uYO(GAn++PO_ zA}^v3oIKj>lgI%KYUf`HT~{Fv>alXYTo&DV9kOo9Y-Vv{l3W)4oX=Xf-3%-|ixrj2 z;^qJ_h%yXi7JbqCDv<|SS)i^?QQbc4)LN#p?A>on(hGkU=zW)WXqE{o;-9Em=>l36@|D3`?% z?oEm*`U5Py>mt`Dkq6Z++!YLB2KQkWv%o|qi(anGBG#E%Y?J#gkh%e!+lzULS^#-} zMgCK!U)*qkKg2d!0QIp!K0_pndKGM$g;NV=u`EL(2iRV3>~&^w;tsPoh;^$(9#k*B z9T=>q!BF3P{UmaL?e$*p^JD#RTpQ%u@uOH4_3Lq7YyAeU3HZ9rmCIrdY5=tU^>6rz z@2Q(|S?uT!260Wf7saobgL_*0k$`Zn*&XV;XHV74xTGASv=&mS;7;3?^;OZ z;}SW*ADULhJ7FlX&RCp>jFnp-X*zxz7$nXq$Sh*e@2QTZ4Qd+arfjCfoqo`e>|fFt zd0t}kP za(yJ}%o_HKJ976-G`sH#2FWECK*P$R#;lH|4Qg)Tp=_q)K|P^iLpModkZUhBA2ksS zk|T_mMW}7=XVR3Kud4zE$=O(+QrNY9(ir60OU-X*f<;O-&Uc2Jf=%w{l9XDMYsM@l zuYiX4pCQTqzuQVJhVWk9l;kXC;U_nj(;}D|q`X5dfWpu3{W~j3$JF8q*8)--e}i8{ z6q9@Jw4sY&kh<_Gv*?b#ElK{6Yb)9G*~~2VagHy-eO~To(v)nxhl53$A#%PHaokE8 zgIs&b<}}ww(mEJ}No4+$xt~c>YFQZX%%?P0yz7A??d0}Ax9r6E&a_i+*e{$irTIgy zz0`8$3ouAG;rARw?nmt?_j5@~Ef3{k7Jd0ziTp88lKp?Tm0JG(#4G~wETwhLmj3;7 zNypU6<^;32J`K8VuBRmX|86U_S^z(wjB*{BMF#dI{{4HT98;@pTxZW1$#t`JZ*bp` zV*lUmq*m`ZuE>Z^QeUSiE4guJ>pJ{Q&B$rWEGFIkJ1a@Y)Orf%JGWGeXBHb4O0xg& zwo>bjwqUSj;vZ<#eeBu&`}asWrq&NyFpC7vdq!87B*pfB+DUCHlw}q#hd`r;9{A_? zNI9oALvDh>*1BVuMbJ+vw*S*kY7@AGSp#Cw!a3P~g&)wiZwJ97wnb|RcKdJJe)+yt^@B&wKj4UQUC5EM0}zOD2mi zSbvare_od?Yb&?Ev-~h0_=EReUZ*bmRaBx+fI;~K#!#Osh%0FMPPzBa3YGc!;j^|J zm^d{bDb_D4to*`$@t*gQI0a3V%i_ssu<#ws`7Ngpa<7q!U1l+h{ajaF(F=JDiM~M< z6KjEmUsbLNtVnz$kpmc57`rhG_ZX;ifo!D`2U$$_PH z0sL%rJ|MT}pi*6bF!A4A2NVt_N}F>VzF0(+=ihCK_U;TS!N*oAw16#_KS=Ri5y^i&DrSZr0}st zaPD3RYj}w~sOIS&U=V%~&r)(9wL>BYFsM}xdn72rg7>q#Z+kA6#d7X-jac3mY}OWe zBA3PWzgXP4$t=bo&n1xuS=L89L6I#RGm9Oz5;?$jOSg8=$guuU594)mS=`6Elp?=! z{OK{~lvozEn`2)9ts8Kc{bKt8xh#BMgTcBj9A|hIahA*CDe{{XReU*^c#bBqEUema zk89NQh0J2>Ot~zA_*oitvI$st6%3Qh;w5Uy6kUA}vlx!|9!TUtb?k6|plBDaEqkR6 zlgI&nP$!gQ@aTKyIQP!`PA-er{QGEPT6|{~g9eFZQMWyw8x#{1$t)5)<+2Ff3I;Ln z`F`R3%U3Ro*O_1u+oKKCr}qT0Eb7_0GK)>EnZ^3Ta#@6w0E6{;3owgMh{YxHpn5Nd zGm8-sP~T2+`}peHPG%N6_?hY(inY5)zo;M35G>+KR%E|;A-AWo{*%MZVj9QdeyvtY z^a(I%U{i`&9K8hf^DZfug;!lL*idm4v&fz;m&N^p%whp*hveU2gIE^U4f(w&8!n*N zfc%}4zSOI_7 z)Uprz#WutnGFfDDZF!SF_6JZOp+ z$jJe6S=@&0l=zA77olawi)GQw@&x=Lsq0s0=!7nESuD)QETV@ni>;`uO5{P!jumGX zpVmUd4A)8I0Na~uygp6t>dh>A6_d+iEP9?PIcgfSh>+W_)jahT7$koz%`BeHm+Ke5 zYJovYXZ$`I3U4B}hS;Jj*GEz!UVursODC~@(IVK0{o)d9p>>IwVBW7GmDGE^!G18SLQ4;Jao(St&f4>wDNK`lRXJ}cd01emO=Z!MNZ ztG3*Kk$$fbvsmmemxaf6Fvw`Y`HOW~7v-|JHiKEXJcLG-z`9i;4{BZMH?z3PF?iH) zFpxp8NkJ4?V|>w!1Wm~!XE`h{)v6JW5d1jn5*_Lti~`A_hCrnL2bKYzX)yb$Mum| z4_}EK;0JB}VximPIKGIz0wxl9P}`gLnZ-x$`(0nLx&W2~eB(5FupAvbHU0aSX zcDnF$ByQ~}i5%bucCL4zJ1=rCO57#Hp%QtJ-8o*L?y7VIOg5O;m&gIOw>M?K*fsM4 zvluTo$Jc&D3>fS>z&XARN!UXn(Ko1lTobU^T@33}+VF9KL=Irk{&_sJ7-0(C*s_;c z79HxpW)_K9pVG#a=t+^tgF4JFz%0ITzt+Z68zgc7gARK+x3{OW8P4OWl2{fU^JIa+ zo*+wRF?5Ao7M*#0y60hOW)X8hE(_0RV6e9VuifLHX3J%92|bLocRBZ>Y^nz)5_wRk zGE>ZJKvnA_p+&G-4)nU)ed(P5Zp%vWV@@EGA-4KW)y3m|P+c>hvTZv)GEB zHQL$KUoo?I5VT^P{*o=IS``I_8VtMk^5>=)t4;ZQ>PEpq+h z>lkM7Mx4t@*ev(`7hRmJn1$0>_KP>DHOusi!?&2l8Gg1V zHXbdJ0~mBI0NW|kjQ8LrE(Q~cJg95eOfbo`=k-WpCe~;&S$O_p7HJQmN%=oXLW z#k!OZ7b$}Clse<&vUrHv5FH+Hgjvjz+oRN@I>%Utqen1{?G42GMUP3Hz~Jz6_yeVU z$Gub{59+b`GFTjG%=gaJ)^cO59xv>e#d59{r8BBzAW$})C4YJNu1(Wosnqpb> zw&r~2G1EcJ;sN&5NaR7iXV(UUW22@+Gpcoy$N{$Z&ZxpHHjQN#lbXt9@$M_Lc-M+q zBo-3OqE7>k!H+lRzVM7!a{IOV%<2q(IPQ$Ng0|EjFV`>9_A`r96`@;ZKb6bkttl9s zAk>Ix%eJ9nS@f;flUWSA3f=N0O)d)uewLny%MTV?o4=6DBAMgO6EC?hXX}!Za#_6O zUW1d3O0Zw-Hy6vI%FxeX5M;O$y2^5`TozcS8c@)(C(I)Jo>&%DJG+8G(2scNYUA^A zS?u=*gW&n!n8i}Lac8wgxK~o}hr7(;Rft%>sJ5B=aYAMc1B*2yW{G7{z5G@%2zfr4 zS)6_;mxb>!FbK8h_`oGZ&LjtqdhkDVfxMJ-$2dl%6%f?1qf zD3?Wg6EKL_x*WQ;CD!l~d5~o##M~5Vm6us;@{z~^wp;r0IyG`V*OomrJWnL@pxTB7 zz+{~n=Px{*(3>KY#mw@|!lxV5;|1y^GFjY3&5)vu`hbP!K-30Avass@6%3*lb1uj8 zV3U|_ZT5VLsK9_nR<-V}*EsLo%%rzm;?`Yy;TNNyiroj`&=MBh9O^)`^(e^J*k z1`J|)fdP3>_L6vgfI;2q{64;zL&)us_r>FKS=``UPHd9}VB=%6MJ$VY?QeiV?B)b! z5!YWXi&Va6t~bZN5%M+OES5$6vfOj9-rE>{;p-^37p4A6CoqUJY{M*W&rm9HQ2p0` z{T_iioa^(mdnA#AvY8qTN`b~b#QT%TFVRFUi%e#*VZb#o@h|aFEDP&eyjI_kwVhck z@RZBKHy8{yHtobL?qai08a#K>Jr>Su`B|2Q1=C&w~aepjTcZ4{CV42D4bh zYxlt74JC2_gGP0~FpJOJ{~I`Wrd$?*sGrg%d-SYP;LVA0S^QWAzu0t{-@g{rri@q? zjmMz(gf_S1=Sk3dx$ik>oD~JX*qr7E4K5%zm(!$nA{Zo8;GUG=spvhBc%4uapP|fR zE${6QK8HGqOco!vF^g{;UxZl8&1*FsybCN6?RigTNZ=WXJ^=pC5l z$N~P)YC8AEXB5lC`MUVha#@@@2?iPS3qqre8i{4m+Oit6xQ8ATin2GA%fht*SZwKd z1sZi&ZvLY6BhGVfNf`zf(Ut3q^@}!k+-tD46!&XIJ0brmkq5PjMh$?rF4@F>ad)aj z4zRt=FRmSK&2hkaOiQ`X5!<27!C+e#?!$-)#WPl-Z;j z(Cwx@pt1eY<0z2_wRPb8#P%he--=CdCy@jEpzVpz(CznAq3erDMPWegsx<|J9i5Dr z#T0j`FsPkVLuQdwky&J+4?`jkYIpMq80;+m9U52pmqZS*-LCNnW-)givsm_2E(>qm zA86;z0?gtj)+G{oklnL6V6dw-uiZB^sV7oCj}ThYF|@0rD{u44V7^SF9ou-~>LvpCsT zE{k13%p%4fnovbERtV=!I9>8eo$&Vx%H8r23wd# zFz;ti4apJf7d`vgGK)`~15SN?RxXPT{$O#mA3@XFd&p(+g|CsLX)~BbSS7J6dUfGG zt*oMv%;JrwTo&Pdz#wZ1Gf8hR_kPjq<#}dt4EshXJrwb$MBkv^t@&LK$Ep?ull0ff zXUJsXZ3PC$oR&i~?9hWClSOu6W^wy4vj}M`kppb+Q=gxy$D3iTP8lzE%4M;l7ML6l z;PvX3wnlPUT;S)&@wbb?WJ_Qju`K#lS_lRwy2Br6%QL|&X7yth@spriTNRY+7ny&+ z;A9^3KGRkox%bX~#b+^#5z)}C4{eo79Mo?V_Z*zu$@k7}P2(hTP&QM)6t1tIBIJB& zoBKn#EPnAmfm73yz-HSW>^qalgZg(L1O}&$=Y?*sFSl;iKaAgpa=J3&3fk_nL!wW> z5BfjjeW|CH)Mmf9I!r8!0Znbd;Ph3#Mt0Pc+s8LxRb{X^Q!fR&V{sF?esM9IS-A22 zV#k^3Vp$Bd;C1Sm2hL!!v*J>@EdKgkvS)4h8reB(vRoFsKfoW(2BfoJ9BwF<#h?Q3 zn8hnM=q~N5To(QJfWf(rcz)2X3H{}=h#Ac+*6oGv+L0=k#j7*S;!7Fm?t*wXh(sPV zxJ7X=INz%Wvl#MCA_v$$cs1uO&c_d776~upvbbmh2Iv3qx@7kcx$D#+ zXixWXV*O&sxp%VL>@FW@ErW%QjxCg7kA{wokO#cub@j~&A?(`9S?~<0o#Yw&I7%) zllw3BE$t+i#oR$)aoMCDbl+*Yx!++2_}wsMelffd?hkZ%5AQqMKQ&P< zi+-cw4_8Xuhwk4EmB@pJNAlY2%0#ZWA1H+QQznbYKI|9!JfQ~$KbFV=wvVWXJQiIg zD`pYDTP}-*+z)xLmY2j-S-(RGTY1TMHyN6BN$wxD$K%vs#w1m*$?pq zU7J*wS=`?zmqmm%7+l*&(1Z0}%VqJ9pQ+bNTw)eW(fcZq2aU2i2?p0EaL?<(Q>d@X zWZ`&|S?os6mkya_N#paoM-nFWzuoE9)`#XiB_JXnb|< z|(=<&pCi5y_N{Sl5YvaNXx0&W|DZFom~JkY#R%?cd{B~m*G}%hGgcxGni#zW{_tQd=fh7K z{*=f83?@Eo#w@m!ho0)r3s!+ZsL4y-)1UCR7FdK>dJDt=ld0*9%3zSVY&^3_lKXDL zrtd7lAj#MQ8d|4>Qi+3_&F1&6C54Vv_ETswYKbygeBhcua`hTu5mx7cL=LdM`J89a zZq@(V`+n0PT8SsrnL7Hppom*dmxPiY;XCb zKQw(YYKOGW;-o|lV9;vZTxdqVve0#rqm@b=)aoARaxy%+DEleO%wHl0*xq_5$KG2s z#8?y+i2H^_9@P5sAu!nzJ{%fd9Q_y~S+wc-7!0;nZpSRv%H40)<~V8qv~|-Su!u2Q zFVQDpyKURe&~0_`ETtGHxpgz!-F=zGR_-~7`Hr=kMBkvc)+@ncd-Hf`tYe@=4zRs# z0`IxozJDRJc!k~+i9D!XB_}Z0(JlwNegdAcGFgOlXBJt!zi9oveiAu=fnBj^=+3Tu z--sK8T(CqQWVe#{A?`f07fj;LO_Im~w%dJs2i?`%7rLP%&L#4o_72aO#U(>#vA?oJ z4zRs_4nIqG58xi?jg7FsNFopFFo>^>-B-DvZ)2jfL=Nza4yRf{_Y5u!jjx0nfkYnE zvGo#Was3Ok2$q}I>X_aG4E7FL4c$~!?!M(tRWg{x4es08ioOsvM<;#exNoWlf{8oV2~BS_4f3ss11l@(c7{fSR5-l8k&An?mHiP2cQN( z$5vMZi;T_}lu8`b`&YWMn~wbsgJ$f&wIY&5p9#;w;P^a#kJ6TEs13+uaqbwicpVPi z;y+I!2iV@X8OIkVCRE4yRzs*n9@ICQdz4PxnZPU@{3LRK?fnW4fu8I?m|5J~FPFuP zd(7hGALzEu8|AXNW()?W+74qD+YpmWNS5B5pbuoUYT5S$JNR z$N{zwC>+5oV!0<}`!~7k)B!V>g2kEAe68%TAFa+M4jOP3Yjir}fi)TJIG-hvgR+?h z+H`=PHCzDQY4b*@#6bh2k?W~VP{)=6Y<<<}f*WU{k=iBq1-QB(A<~s)mm@$hT%b>e=9Z@QA z(BLn1l-+c}vKe$w6+6?0aQ49^eK>GJk9@QeKu&dFtAKN}3LRDa1V&f3alaWs%w1Q&xIXpHBH zL>@Gv8v4KKsuA*8bRa@*ZF$5hetuk?=L^5c%xf#rCt&-Chkc+|A8~JE=49mhB=Vq< zc7wp;+5paPWuCW`$N>yS#&Z7R8mBGjV3S^AS&T9W0h8<28=(gyTFPZH@&vPpF@YX3 z{3w^jUe0&kFtK446X%L$F}f_jhwsMHdd%Xq+0KF2vic1W>lfp;UI&9adyX=T?a^Xcj5kRGgS$2ALywv5mdj!a>Zf$qZw#|o z5-XR*k!Ucu`-}5i$L=A{kjR7VD`39}-J8TYzT<6CSCz?P0q3>uU5tT$9FIefyi67s zn}I=g%MZ{KMslx_3AK6uVRk&%%}z{`+lw+`CGuEwzxZE%aT0k?k=MwCI|;Zp?k|dh zo~#`wkppa>*o5n5_aByG7M_LVvhd>A`$3N(%;I%Bxhx)k2ZIOOCqPg2l6&u*)cPG5 z~!(-5;-WFY0_(cXHd>tUZb6!CAYRbxx*qbc{rH& zOq{+DA=WP@M|d)eOzz`5)8LR?79Tio@u=otFgfG9LoACaUGsp!BX6!Ho_V)iE{o`K z%;F3C$JsvU(~-!7rhN7Qi^n5_pl8$EC31l6Q@gKV7Dw^?pmQc?<+6z7c=L%B>g#mQ zAxAEYFPZR*C;r^8b?%JZ{?2JVutujR-|+mP^HzRh{bE{dMfkz=cj{Byxa1OpiuvMbCV@;rzme2Xa|_>=&2Jy~VPa zVaGjdFWirV$)$zoT|g)o^k%-WxsSVx!h20AK%QDb;01}j$6#a z2QimK-=LX))ev8mtH*9isTA6G{r{*=grX4m8x>rGL_-gI@>ABh~`2eTJ7fWDb& z482w=MJ|g|{C=%B7tb<_S&hZAm}5Qz4Bj>#%`8rb%4IRV9kU4LT+a0xm*uk9_n29H z;~emHXPisqL5{^Zuk~(tVKBLV=aNJYu-$RwI_SH7FQGS@$-Q4Vrl9wP-dBue7XEnO zfjX8p$niJ##=l>|YqT4$L}GULp@#FlIEfh;PU&jv==rlSL}`D19+H1QvHKur86w;^%rW_%eax&$|mw zN#pzAXP_q=@09xXYZJ4$ z-(4aH*uHq|L+JNm7ohi>$*qqpPI<~KcHurj_kEhHbBTi%f9E>tkJ9PNe!Bl;sYDL2 zeMv`-D}KzKg!2cjqvW#i{R##@E`DGZfst}q+~Hc$&-$a7#mi-4SuCx&8Vr7V@*b-k zyJm7(%;9%F{Cs`@Omafy#+^&|^IH8^r|rz*ZC|l|v8+%HF!&Y6dGLoF6Xde^Yp=v_ zLn|)#WAWZ3I@Y5WSY&9(XGr8h zz2EVD;@CT`r)DI|y+-=1V1GCsa1eg6rLB=fpMdRs|N6Z&Cz^77WXo0LKPB>@zL8;I za^hwg=+>$35;?&3ewJKMJ-PT5&bJwqkjr9+2N;|xk2)%C3#cHLMSr_cX0h)ZbbF1h za#@_?y_ly*BKD^3yDy4mF<=PaFHZl;hF|RHA-5lVz(d?0=uBi0W^oT|cZt411E*(! z!C9LW=+0S_C31l613zD97B|j7cjb|L?;Nze9~hjQ&%G$S{N=`4gA23;i}M=iFLqav zTPqsu#WDE#^zvY`dkb>F>R8&KA*Dtuo9RN2X3#x$a`(~<2@hu$Pp>kIi*nbgLo0Ow zgNrU7p?k;3&HWDDI1LOgRS04hZ)Pc#IA~byJj!mmw3G8%`z7r6ONJm-}+x z*8alim6ynahFhbaN|#^o9=!d*f>~?}gnwLFX%9V6wUb1jfbAoip$0%#&C$O{2htYE zWwD#@omaOm0-Ma1h{+}LppiCnz~EXp^rTScu?-SAfWgSUBbdbl?twnoH&!f*Q7un_ z#r1_vpa<`?mdj%AUNE>}!uyvGO~l?Bi9Bd@%i7E$?mYC+JFHJ+ve?79-OU(w-3 z`y_IJAB<_vap%pmn{j?5?>V_FcA)o!ZjF7zEIhDxLLv_u+t>sQZhhwG$x-dHL=Ipu zHbaBnc5eYa8UZE}dC<7Jh^^>O`IcajRdtL+4zPV(!Y=5Y)Jx1F5qWWmJZOCN!C-K= z9n7a=)^gXW<72o+boUa!%kWu`=Xejz!(ZH^bY?PY0}^@Aln!;_7mwWe z9(v}bl|&9;Fl9H_1Rk5Be~->O$jyUKt(OBPkJtBro_&jb?Gk;1rp85r!IOH-;@m7Z zi5$RSTA7c`V)rZPx%a7ZS$Oa>^=U_IusA;lxgCi-Xu81^FnD^woLPJoCpTbXY7GqoRcY+#YxWPJpabEqKhAj zie)jQC9g+bINQT7F3lFqBH0lPUKZiLoJ()_i}j0{6?!rY|LxGrGf*dy$b)8j9R-6| z!#Vm(#FnL|OCiKeFV7V;rd}kIJ9CKZ@N6kng z51QTmCs@2`&N;rT53r9}CW}4M%;La0=(SM}5;?&3IkjFu-*(`A?bmLdlglFbCbKvd z1HC>7Y$Wm^$NZeXc-M!YBiApXe@iBd*~##ScUMP2Z}jRYkppaZyypddKMV}$#z{}H zEarAMWfu2%U(wADu5wxI>;@Je##e&g%(N5BVqR6`^ytG=_K#aFw#jATodkdQI5iV` zYwKgVEWY1i7H_zx@pfJ8FOtZE=G$}5_tR{SFK%yIB#{IBVg7ma?a`-?PjP;y(p|AE z7POcF2A}5-Wfoz7!U0@-xr}o#pnr zF4@L=C4T%V!z}j4i}j18=6S*3=d!ZUoJOd-OXNXIov|O4e*VNglX4O^OXL7QSo-7x z^w(m%Z;c*WpvEkb2QA}wqtmZ%^TFg{;8uwoVEeL+9njzN$3Pzy&Q>aM(DKr_KhW<_ z`IPGmSQ>*| zd&#MP2WH{8P$@m>(6TsqWv$aYk4sv>i z{yojGuAj1>o+jRt$N{#mC_783W;ksS&Yx9~`|h9>-LQW|Gu-@}S@Ww(}h zAm@Nzraq9!LD@{s=X)vD^7{8gp=N+k|*F+god%X^M{4qo{p7c7%S{i@1tEnksv zrSv*al2VC-Tt=ZkOUu{kk+Pp&Dk18jHko~u;Lx3W0SU*{}VDshm@{@2QGEnlXE zQhL)bP^rX0F0WB9)AIc^QTEfD!wV#GfbA>GFITGNZ;H5r-Zrc$mqmA66I%W`0buhs z7WoW`JZR-&4`sKOKNV{-dRO9wL=MVkTA46Tsh0nF9M0c4A-|=Lr43qn!%W$%8C8er z^zMz^e(+TVGML4f)=KI9NL(`jBkVu4s)?mCSu=_lrIg;EDWFv1pjG2nDZ4eJYh#tt z2b&&BB@SBUw_n+<6)1`IDt*`tCNf!M-eML#N-Cv~rNKldi`Ung#hOFRVx`==*=lq2 zYiR`z^=B6Es5+K5X!Qb)wF)*xev3Yxek_eauD!H+LzFt! z3eFm@ls-4d{X-o~8?^e8k+NAUn25Rvecp)msx%JDURq<&Td7v?ktfc-5Uv$yhxVFLD@`e)^Lumkl!Die;tJ0SBX4m z%~r%%TA|aS%;GSv8JR5Z7g2U=g^kL9#kYERPq;`Hu0^rGOe@@GDYFRklE?wJySAvI zR4csT7|y@vzo=B=AlC_NmEBt5^e;;3`%JkpxT_!baBGEMpl^%53w}?d>wdh;R4Y;y zc~1J#5wW=P5ov>5*&nnb!@0lnN4h4BL9V^zX8KDVYefQif6>o!b8?+=(!LLJiDME0s9N{R8L0 zi~iZB?AHwX6q3k6*-UFI@cxlvO}S2Du&RMv7M=OtSSsdox_~Ik6|4_^0-bOBqSAF0Q#RCqqU+h~UmW8M36=reDmRY>rBA10Na(h|{ z!;N5(x5^p0EG7qmL5ZfHn8mY?pH)mG4)PimsqEHD zE@uD8w+7dWOct))nMFG1xAN_}Es=w=nY_{-FpDQ$p!r^64X=)+4f47%PT8!H`FUvm z3Q^J+Z}>^>=aQ7XEh~Znt%+b3E+onRzuQXQeTOoOz4w^KHauJZ z{ykET$$JskQ|Ue4m!su>Vk5=&f7(gjv0Nk4YFMhzG$XUd|NI^)=j45IB^YSKxlUr# zt*jK=|7j^kK-9|?+xlvheJ=O6kdRyte{e5O}8Tn6XJ^|b3u7vIMp(@s7baT}h zi5$RUUd5Zx4-ar{(5=Q7@H1KY9%4(}+g!kK2I-Byxc5 z^IyYu`fN5I=XdN-Gm^-I7OciKL7%UfGK=@d5;?&3g%$QdzxW{ENq3_T$Yrq|brJg7 z75Q+w*Zq}P7K^$cf?s^g$Ip>_-~8mVcyNMQ>{|=X-mpb1i^U6gt^R$U6I_ z)K^9Ng_F@}Ww&NPt(4N^h^k5@4sz<*UD>S}Ovkg7p4j!0$U)gmPJz#rY6e-$asC9S z>QLMur#o$w(VAh!T}tVxPgA852d${e*NEW)#1-_cG4>hBWHGgfvRgB}fLZ`OyVYJI z2W2y@NOw`H<*9WJ=g*zYlu8`5;>&hrx0YuGYRdGY>H>)zl+EPaiuV=exq*H@dU1S$ zTox{EmF-&I20lvZ<PK79r+BI zEc&iec5C^Xa{cUeKe@SIm*C>e!ZS@Nz5X;ysl-7pw}vUZwR{h;SAyOI$*r5MtT+lR z^0(-ql-@R7r&QvgmE)=?yS4m24VBW{>m`*+9JF%d24%OF{}JK}dba>IW|=IWJpcb9J`C8W&Ls|7m4W+%R-i>k zWj}rRhN*$a6{LL94$b#?lJj4S`>LF{&t$18iSo!?mJ94Sq0-Sh+RCHA{9V z23nz2wZP(Qt7A$f4qCGhafMdsI8@oFaNlObM-Z8gWPPcD4Vq+M|&uxpN{BxRmai>xh*=aY}SlT4=bf#MdkK` zyY2E}7L$ya#fEUD5(l|`Eu-w#jCYYz`rS%y4bi>HWUwe&2>XfX_m%SMT;d>i#}&$M zt>{qfC!#;o`b*@XY$o>%d!<^@#Jo@g!%(FX2f4p3q3qU*{%8j^=zd!w2W2y@t%G}| zR;(NPeKmvNcXC-wLH=7S7LNRdX7J#yTo&;hcNTk&cLr&Ob>zkuYaga4KhR9L=Rh;$ zeTfo%gFGrB=GIKyP*2qi4+Tr)pll|O5r>p&CfB*2FOTtMbuMv`$N&8vtK5Hg^0%Gz# zcko~^(8{2Os2LSOtyw0E z^N*Ot_;{#MKh%swvhXR~nOUTvFGn*9J1&ufvYCAB7Bh>VH=srj1}T*|$Y%-H%}RAn zQ}$~GY8{ZsLD@_`+pvd5D-|$YoofYVgR+@?t1nfm znbzjDdx1Zt)Vah#z9W&Z&`jrzQ1)vDJ3N)hLD@{cLGP7nrU(CG;o+~&B@XgEiyjoM zv~fdazgF;4d5Ij9&E#i%y`SamFIkYDQ|%4V%}%s6PFQJG354)U9e z+K^WI#eQYKR%ipBtuk38bH1}oh1`0o-@`UwP-gizXyFD}uZr{w|8k9(#fclt zV!qt9nSWo7!Oh5J(fPICKl z{69H>f!Q0b85Qx^Ezu{G%@j}@>kqALvut&)6}hlasl-76WBy{X;-a!&-$xQ5k%O|C z0)i(g)ykgaeeK4>@ZJOUHEDwa&hY+`a>R92feLAI-v&06^)A<$w=pwc)fdnw3~ z{h@q6-gj0kv#vxA%wlslrCRy0u~3t|F-j#43c7>XN-KXKz0aCS$4?SDD4Qv`#6qQ7 zg_>bd6L(9c5(fo$7^3XfD$H04H93P^uuK*U`JP!}I~Zuii_7if3r^yEXN8|P;TOgG z6_)4|%4Q1AM!$tt(T-#A;(-UnvIwEk%66@yTOzdh^}$Ld4hreW`R|J7?kW4V5@jz* zzcSt18zGlksaeIphz3F=%caUa)= zI+ivlv;^uQn#B{|*Iu#;)~(VwD0?ZiJ?Ho;SzS}-T1k6cGwN8{pwM|P%4V(7Y|d+y zjF)@w4BfPaS?q9vmVAo(nL3s>DD>t5WwTc4XEc;7hbxshD9m`XvRkX%HVR5pvDZo_ zi`I_JV)Zg+ku0|#JZz>ZvpCg^S-kF~RN|npm~dscR>kBBRI4{kA_rwNgUz@mC9&Ucn>xLquZNV8~W;l%GnDLn^qs6-wV*@a{9>W9&rq?OLV-d&k2 z7VtW?M*i3EkJ9hat0a@fCd8Rqjm|z`QKo_1y)=>6?tnp!wZtrDqCZ@uU#u%oky)JK zzO6E8IG4$yNe8f~X~NIeGH)y;a!@wYI(zQ#tl8%Un3&ZqE0;xpH5k?4n(U@5bnF1|a6TJsAS@eu!7U8_d zzwAW0b+f1?e7~r5dolaP2IO>P`b8qI$t=rXWfnO%ByvzTQ`C))U|>1Q3|g*|+a zPM#FXLQB&(_i*e@=&mdm1J zQ82Kw=Xz>+lPI|?=2T}E8<79j%6CV9jzk_56J3Q_Jo12+cSqe_CW|u#!JtmH5N2_# zrbG_PW{UZC77XgxyF)AFtD#ilpxEk*l-*jL4WpnH+7^?@LD@{P{fxn&&LeYZg{8NZ zN*olse5JBmt6OzHw8C!mZ^>klm<bC7VGnM zVZX@X+;7F1^(AspHq-k0{lTJMDa;C&!j2E$b3`}>zdaa;~-1Ug>6I>HoX)E3{QSjX>fi3})_1_u#7mFBs_(!2p*lQ(`2l)lO z1A{W9Rxpb*a_<*@FUm6uwWH@;{EK# zgRpj2Uz0W{;7PW!Su59c4b=FM+}`*=n_kRfQzW!#9o#q6v9v*fUZa)Gnz`9PXwhJ~ z_lv;$C76ZV7HBcUlS(BH3Tik}*{zv>+W{>$HC-YHWith>8VUyGCv%Rk*cJ3FN#sF6 zS2=%C{(3T)n6&ni$U)gm!8PlGL4{7yP?LB(Th+0&LBap`d#rN*%_;Z<_Zn2J%CT1Q z1#+LMA!gWjs8#es9aSryosi2(no`K*aAmV*VPFC+(Rq$E2D$c9$S%%nSxo1?-x8@G zb3c=&6k3pTITkm$7rJC=x%stA91+dUe<-Qjs z>^ACTT9q-pms?x1M4CV3+DqZJ%EBM2oWlFoH0}QW+|Q&bh0omt7FC_vvWU_rW8^1ELc=4YymYjK_7-R4$5AN_`lz+ko)gW5pny}u~zLi z`-kcEJh`7qQ;K+#schD&cSwVlwn?O0yiPTWqW0- zbBTkZR;^cdYqg$Yt*(_#N1P#(#hJrkVc8QsC|bFa^CfanHdAz|NM^Cs2U>0pdgRry zv_a7$xaXjDS?+Z$ce#u-2D$c9blhTftkquL6KdW_?moomf4%RwBeMuV%%zT{4T`bu zq-@r#I)8(je>^6QL9V?NvjDbhR>@PqqI`e%+|Q&b#T>{726ak=FpI6IHA~~5?4{Uz zyk@U6*99yp&{&Bam_=9a_pNgS>r<`5Y`L*ktWQn&L*17C>=zdX$n}dW*lVZNjoJei z73+Nw%VK@m-e6EKPc*ae8Y7p*sQk>rzB99U86cO%`gzRa825u)boG?W;t6U)TK!s= z!Ng({_8Cd!L2e9yh{RXZZy_#fXSj4n7MlyhcCG1pjz4Rh$2-R)@}SLK*dLl1T!nwstR;7Cw%M%)7&II4iCMT*mgp18 zX4-t5*JRCh-(eQFyNhL!VDu6UnwLh6NUPNty-E^!P(la3XEt{%3?{X_OeAtpHdBJj zJuql~z7Mq4W7HDWv9v)6hu9xlSdCS-YnE-~_ID;4!y0TE3Z_`hVme#6d|jxEG~mVjX3_X0<`?Gc_p*JqB8<{L#$f zC+a2YSlXbZr@XJI)u;OB_#EsnM73%*8D9g*wR+BQOsNNbQ+ZmgA> zl8tMlt%n7)!JzL-B@Rk``as#OwavkOLTiwOeov7s(ki1TNo!~04<^=zjU;kVHdEU0 z@nF!-pL>+72L#Av5%`c} z@}Ts#{h7rZ^tfsbH>{M%LD@{{i>iY~`wqzMX$`;0jkVG=vK1g$if7weJ!*;?iI;`V-oshm? z|9}o);`(gl|6f#gU~NuX3Jm<`#X-wg)Vs%Ovxnqz{9nHp78Apj4Tt}?Yi;h67!0Zf zh?c*L@$vs(P;_8zUWxZzP_?+T+H3>=iDMJ zhJuZQl_s@zq(gp_YWI{LCGWFXpJ-y>@M`Vw*~Z6IJ7FiZVs7*}I<9L{Yez^J7}Uv} zSXlJXo8#NDB8RXD&L=GPV9ymFYYS_~wQ1~`>TJmgt&|RV3~e0PueHze>VlnU}D5x1CjESUXpgX5Uoz_vKI@KfE7BCyQ(H zEUo7+xjvuCe`w^uo~>Q!v0sGhO;63|OF#es$42wBM0_u?dpTP zH`OnHozJQAAmlyySX)@TmON$8R6iybTKNRtd8>^B`?YpmLJffGU(5>@zFDz8QORO= zY661>1!XSo+u@`}4(!?5?eV9u2*LW4d^ac6%c2{e8`R*yCorj!D7#)3^Mb&jp(Xo@ zs?_Zg{+Gz_{g<6ejU3pswP(a- zFldrj)+7Ga@od$|!`ibWm$2yB2I@Z9X7ip_4ev7 zI%{L#@N30)ko!dQ{44o03aF6HaZQ_A@l)^&rRF_92#aCJ^=ae4ey#We@+@s0C%tO{ zr*doLAS`|>%StU$m4VjCg1t3-tSzjBJioDLYS9q)391paR~rL|Un`-`3}G=J4H#5o z^=-#BZE7V9#{Gd>JevR}HQqkf#=zm%T0eUT7*y_Y7Fxy=`vn}=HL0~B$s927P4h%p zocGn_|7)+-hAt(A#j@_uvYk;I`1(6qj;#&K{D_3TaJ7dxz;JKm&GAj zoB3C|f$`ybx0zZNn~TWW%>UA4uqfXzm0lL3$Adw&9+Km8OX;JR#q+LUQ9XHEsM}1f zC=&he9duv*>#Z&8(6>hcWzu6@RM=hk%T--R*47M?2M;)00xaAE$LS*Q#jUlq2lil6 zjpp&f;#$;~tGbS?t*50=tHv+az`~I`;< zR=lJ)-?@_(fkEB$QXi=lyo%2?hPAWjB=${p=gNJf(#vETIk0DI=W*GqTd%nMZ7-j& z4{BNLDj;*Ldb`lqNtKhu=w&fTYRdJi%N)G&c+`$G^7!B0{xARQ*6vad`HUI_OFy6Q zLag1td_&KXwR>bEVewLOI#r6^*5m%)om#tZw*ZTV5k;U?HV^yvZ|FI*;@tiMgGQ+m zL#uio(BuB!omz1dur8%WlRF5D1Iz#Y8+y*HxQCg+pm8pF_k&*`^5J?2d~s^+@xt7S z8n1W@CVuBpYyR>LJxA7_Seb7&DQCdKzZv$m>ml&PskP^S`w$&8ti9gTFdmxvOa7u- zhgptm+SJ+`i#i!KJ(CGcsy(Z#je*0jwfB()2F;qxgI4dg#&J!XTJfIMgvG6c!s6{t zZ44ZKt@sJ@K9uI2hJr;vcpJwxZED5eodO2Uf00^Zz^Con7&!b|39g&KqD8-R&>F)w zJFaO{D`8|GVezN*9t5Vq8eSU*_G=|vy$TjBhe?hvaMWCl9Kd2<@yB4%Dpgx(&2*T1 z@v*kB_6=UZo~hNipP@A;RA$u}*1j_z**CS$d>2|PQ>;b~?Ah9%SMph{r^|Y^)?_?m zHS)0b_ujz1sZI9V(Avg}RbyED_h(?=)Mow-Xzgiw@0|xSX9k0|`DLC_CkuWn{F%0} z4g?)y&(wAq)?`#?MgwgO9Dc0>8}oxjkhARNuA6n6Qz83k{O1C#pGQai3`Q|nNS>?>+tZUk5~pqbhjIQ&|Ne!_Eu+HZa*EMoQcq8!e% z3=BHBWP>)$c*em=n_7pvmlYP9?+A@I;Y!zX#dMmU^cz4G&ZE78jNC1N_&Mwdjy0Dx*^l$jgGsYaz4VTY#j;PJYYyaasM(#* zdRaXG3*({djFiykEi0*IaoqJ37<98_z1sX@O}#7z%bKj)c*$S1sGC+Vi^B^rF1n}w z2yJmJLM@9EP78%a)E;O{-<^6{G!7CLp9=_!-I$AOyp${+l27o z4aa&_CyTR~Pf(vqa=&Q%>lTe1*t2!o;9g06wj;MkL7fWgWziga`KfQoUCe-jZs=XJ zpPugu27Q;tLEAMz{fv*bg?0MgYW7SaIR-)79etsVfy1wLrm*xHgv8zhi{Of_9M`m| zb*8J-4*R8+XKL`~G1?e7{90$$&*Wq3H$>KG?Tf@Xu4z;2%xlyPso$G9VA6iB-aPo( z^0+@xXcyE)s6(bh+Qx&!uXQ%8BgRAMtvt{U(SJFvX;bTLoXju!H;@{0hmXi}Y2(0t zt+SudlSKWGj^K0Z*!?D}#<0#+mOSSGuPf}II^OB7kpp|S&JC}^N&_}Lfp%)Rn^j|2 z=MKsH*1`&)Mns*CVE(C+#rYIc9|@Zg!2YST2i9mhSyY!AQFz+v!eVU?jU3psb$--H zFbE&K1llF{ZB~t8oj*R7eN*@=^d?c4SiDb3C5xZZO8>>cVAKNW$7DZfYS z4E{`8SU(^3Vb2tqTk@Sfu07Spz~R@rm`vWo7un<}nDh*6?YO2*t&6^Ez#wwMKw+^9 z@4D5-f&E$+Bk@iciabJK(aTxy-)_3NS8{uipT-G`8R$*nV{Ktw{NpTprlGD_hfwd7 z==apdf&E&S-1D>2(C%fRz5AihlaIB9bt%-BJ=4%7((~H;9`++@+4hRDxYf%>(a|t?3;#Vt_tlFk9Dg`7MF_;6&3;VOzm5urA7|y*}B~MHY*JqauC{g z7UrLPtSzj|OVR&L!?v|$?-Y^>=h`^1U+eOnbgVS&`9)|*Kjbs`SX)?Ea^Sf^!}Ghb zcM7?qw@2wpQ(2P@Zx#j?{c7XAIoieq`?ao2mb%&S2@Cj~`t5dR)fm>5Gcwm2en|4+ zp@mU9Qpw_K8mXfW|6?}$r_jj@G;(0i)>Xd}tQ1uy1RDBz1gpldt`2#`zA37cFzMeF z<3uNmU44bcoRiT07k|>ofjwJS-(ZbSQSx^XX@GA9wJffcO3L0TI^`bdfVJqA*T}=V z)*M_;!sP*t2zg-y~Lw2|ofII1Rnf ze5@_3>mOymSXm;n%uRE)y8U+`A8r_%W5^nl`m=bd~$Xh^#e*#ZMR~ z+BmRZ>&D_IU@)TQEa)JwRjeArx^Z3lI!8oaVE;5|sowo&Hz^AkjM(xEbg&cl7xA&S zux`*8aQL-u4qpHUBXit_4!)(g&VF-u5n)kx6Ld&*?CIuXZDHN~ zZ3KI!kx{aDV#tPm+88+eTDP1fpEYtvMlgv?SJ`n*n_9Qp9s`4s&!j#Q>4SW@HV*99 zx;1?RSd7Xo_4de+6dE}Qi_<-XMg1<&$mQqNvbdc*xv+>{D=e-J(#ygV&kY*2LwZq$ zX2`CWMen^bE}lJy4)tB2m&Nj%U@$t@U11T5e1=9I*6kZtghjm*!eS-vr7Bt6vE-RL zI%=k{xV}Rp2li~;31|TZqqob&_nCUrF{4S6meBih2c+h81frZJnNpu?T^ zYh&Q>Yuz0wy#`|*Y!nui^{z+m?vWm)v007_ix9o<(7*d?Bp8ehketr&Wjh^XMw?pq z3O*7R1GhkjU-8h!z~R@r*SvtRSQ`V4O1s=~O`BTx#=8lNTQcX0s)+ZbXyd?st$X{W z_jz1KtV1ZOm)<=1y|;g1T#WPm`!})(J@P8Y#eL^x!XiYTtx*@ykD-%AtJ1<^X-8;u ziuoEjuxIQ3MD!TYxQlVZqQVTlEDl@)gYhXp2#X)}&cW~h{!v)CBX2>`a~i1~7Z04@ z3yUA+z7c)e(#xXdPr_n$acK1CgL+v^7$YoB5;Uev3%xA%=MffvJ{A`39_VH9M(QFH zN~{zXQ}phccv$Ee7))qgS6Cd1S352qHp?X}#@`nf?=t9RF-F#@6XM&0#fT#H)v~ys z;Sv~(Yw>sfVmIm~8hKdvhaV6Y$FXmOqKoI&$bmguU*_QXz(n;Nyo=;;#xL&*7BT6H zvT6+L!L?xaO%sglrHL81L?Z|GY(1=rJQhtDhIs|WJl&(0#U9)%X~N61%z#ET8>p7W zBTO$6(ZrU>`O=6Z=w;K$!+JEw8{=W((QVL?t`9YGV9(a$G}7Zb$z__bSgbb>{&>I{ zFqpIe>kt~15k0T`nYOSVKP=3iDK>2$=%_(hxAL*Ju%6Vv&7LW?pNx-DPseLx;P7ib zk#q&c-Yx(pqZ{9FT+^o3)1t$`U~-L&!eT$xt=c%SU+d}AUSKeJ^CIY&l6q@JPd}q? zkEZ01+Q68ZxNk5QZDBp@63L!vO0Jv+ZjSp1R`I<}|Y{i)AAeZgRA zt9`n!4vLbX*m^&yg2t62M?uLFB(_+}eqJt}(0^z1OgBnl`o_ zbi9r6p_9esl)~b*%(ccxrq#%SJzKwcUj~cm&1B#5_{VzRfAP!WJi;QrGju||Mywjc zdYSSL`=%KMGealr9Hx;2d$wM7`vDAQjFx-n#Jm_E8hKbR&zuq#FQv9TapY%>9N4q< zYuQg=F|%PB=)_+GST%(sUEn`Z8i`q`u=ff_lmXY1E@@=TqTBZ$vw(q0yoVZCZL zoQ>10NO@mlY=OQiLHx_K^=j7!VR29DX0fBu%chZs^;`BfU@_YtbySM|wZBFV?AiKl zV63oM=?R_O*ojqRSifDX$-Ze$T6vyK-rZUw2li~e_K^LlbGo14bDEL|dusStTUf7W z)?m*x=gbu7lxWlxwQ*p-*6VlJM?`bW*uvt;a*Z6o;!UI8U@$kf9&~Cgz5N$&Hc3r+ z?rS$;u~BdC_iYB*b2qPnFqvk?F%ykpz3nD-k$GG4uz#91;CGE2*t7NaXhl|GqSJ4Mf zvrp^IYkgdTVL(gVyJ8ezgY5% zKpsOQ59^O5KJ1&82E2yOt%f~KT8kv zywnRE*R-ki=R#SBENd<`=6RhyX=C8wQPe=L=F7S$U~BSS(75-d9cI!Qqt>Wk&s!R+W<4 z@}f?g9M`ldC32T~>Z%cc*9Hy@(Z;~xml6dn;A2{Ka}soMZZP3vZ9$1foEc#%cNo&1+29u?;)b6pO#50}1 zU~MdVpK0lvS$fAsyq~amEcKCPwbkyWp~Mdwg2g)T7SLrYQm7plNz!@=i`ZV!<%xUi zWl{R0uy`bU@Rm1Ush34#Zt4^N(`nslLN_se2SPUr%U0nb*W=#wnUMcC*k;38}@)opuU{=R9 zZA!_UaDSl9`SIJJ)#uQ|ri}x}L$b0`Pu<*4_6e*hqIaE|tdZouHy_yoHfx3y(>Nw% zT!fW_Zpqd}Sp1B8sYV`@Y>wPJxBPetEY=p=p^*c;CyU<&-4geAK71&8l{E68WOt8( z#n$xspldJb&E+Idj^6}rZJiV>)|K$oI40mdc@dd+Ze6!cSjgXe)5wF82bKYYt)E?l z#bvD3bh79!^NVeD#)8HA5|uP^fcNAR3qiNdmm2f>Vd#C;$b*t^>M1N3;$b*vqj{Yp#J|P9zY>2FFNKHH z&32Sn2NoNPpjU~HwFRYUnV3D(j)?uxjS(-kF>v^$6oX`5vE#%FVR07gRmXKrN-5^O z2ZNnIG>2{~fcu9g1`e;3BEer+bbcT#24r_!)25W-PCsF>y^63n5v7fR!!M;w5(5Ui zlJ|vf&ZYN$kuranuxKEC7@K=Pad6V6l(K4VVX?42bn`*f2DEX2_mmxy3k#W6(3ULd z&(X;udOld}_HyLI^{z)!F3Tw_M%{&Oi94rpOu&1}!x6&b65e}3TQii_%i`f4u!t)l z^^vVX?bNbJl|p_SalKxE$=1!7XK3U>sR})paj|CxbX#)NRdurPzYGR@(&Q5sP4uou zQgxKI`kuxz|J=4>uf{QfagZverHqS3>t$SgL=S>S9+Yb7@5162c^Am`K+L&xvN$B` z)4d+pe@NTspsuQu#r+Ey7kguBLASq9`+hA-o$Lo;aqbRuM@7ABv()+hz#u-SyenqM zgx-9vF(|cfBlb=4oku`-+{T_Ooh*U^g~euByYDQGy%RcFL>3ShpGHG>M&iDqlf^u# z1tbK>Z)NAX%o;gh9HicZ+7Km7{($pcdC?QCkq4!|o)rudZc3eGS8q!r2QWzeQO3o- zB8PCkD*^cojXWq#R>|e;>+>2cc4v&%$N}EdxaEQFi~9q*yKQ<_jX`M|$-HxaitFs3 zcCYWDkpsM^>5F;@?XNpcSbWmEPE9kZDj4ja(kJ@EwB1&6u zJQy5IDZi0Dmj>{;#-OymQa3wTcRKs0y#>!`YixAv5H1eRdgF1l0 z!86>72 z9S1#dbGAkf@Sc94)DVx|*@p9jMR70H$b-^PI}ZlO3(H*mU?^&eI$3P0BrLjDgC5-X zOd|()Pk%~k0mnBz#QCB0VR~6Smc2B`-!~B!O&_Rb;gl>n7@Y9lA}p5Z&0jd>mY#zX z!*HLVLocyb(>ONB$pihIbmC}YjEln_gEVr0cc(_E4bjPT?}SA(`aCuAAg7+cfWgUn zc<%)rKHESe2QY9NE%(fm(}v>wNcN0+SuE`c1}CrO5EdQ4Mk5b$N=O0*r*cme78~3& za)5WIt7C;l@Ka&&aiLxoZ<7j(6$PM2tNyB%MTQJ=zc}^WTUboUt(S%KRxmhSy1cNs zf_jNY9+aU9eiL*$#DK-I{3SJVfcFfovp`R8|4CSMPpy~50I40G{sVh->DacjdRfF4 z$9OnXQRd>u6ZO)|Vof$-F-&s6#{>RU%Oc;*1?=4Ed8$ zvKdu0a$wJt-wAu}OtK^=z#@4{)ZI1mp!@-8z#v%=@)ss~XmgDm*fZrHwozClU=NK+ ze*coqCLqh4lG&i2yCfjv`!xye{fipdk9sZ##Nsxhd*g+}b#qDPIMjlis>u4}Yoe4ckCe6E+8ac3MDpX5;8>zdl1e3HuZS=Aj zdK?T=A3`67NqYjSkp~sp`UEV}v2MNq-S}PmMgN@K*Gqn6ww$f{9bb z`5HN}XDa*%dnHV|5~v*-r)BxovM7=*mc5&FQK+k$4C$NcWf7P|SX`Y3%@BfohDIJ# zBm(2Wq%XZjSX{lQkpp|CB5SLILHd|}(2SMKvuX?~a^pGsHtDa4W?YUMfl3z6PBPbW zDuaG4lPMkM89G^1tcP*o6#W94sZXdz4(yqndk`2nT@8n3y0nN@W03RQ@$B1VD7hV) z*(*jP2lh(CQ9PT} zQLWWd8_2TcuwE8^?J*v#KZHfr@#T2Y47#2xH(@~Tz(`h-k@Hhkq4DZA$@$=3P^1^ zSG{Z+Ik0CcRpJ(_$=0hFG}l@@WBFKHP^m^`*|W*EyEim0` zy=o@MW6ZHkzTdNGtjvW#VKGzg zodq*g&^RX8GnIK?MOfU9hZgMY#Hulss7+vG0%6k0F=&lR04Dyqm=f=4>)~$T3EvVcqsTJjOKF{8b z^YDJ!7&!b=xww^JkgvybsPmPFj%(VK%H5Q{oP3+5_n>I$LfRNO{8G8kvL?&-?g)Qo zipID*u4z+p$t!cM{9dx3z3BCP+88+el8f&UJ~sIyi$aT)(fb^636^<9{)3oTm|`P3 zIXG!ka*2w zOD+$kH>tq6SHj}jOUE^BO0FqRgF!)(e!dc=7i(kS@Jp_RlM9O`!lXnro~@4Snv`6t zWfK;&20%+(8Li3x*IvoBQ%YfR{R6aQiG;7OYdR*^m9zn`rpIf?HEl}e_p}3pB5P|1 zi+$)#(Z+%OQu%8;z@W&BW6-kJCRU9>fUa-VSD;Lo%LxviPbo=wp;@=SH9gK?sb1N$YnW0+@}qR%Do>9Syf zMh?Q_Q3+O4tQh+DjLWNuYFSiBCi9A7Kc)f`S6}ovYUDu`@&IIv%;a8h!*ddJ0`JHldUIbku{UoVTl5(|qxQNrS~-W;DtR^+iv zsSg{$!n4pWwd2C0>@Q$Y+7%3pXGnrx7PaDpMQ>S;cj z;qo4((oa%@iC1gA`-(i~%G|q5fziTZ^>~eAf<2SR_IF@Vrp+U$*L&Pc`B+IJXn|bD$i}6sl zrsRGrmOxEW+n8X#uY`tq?U*GuLZl~(KhTP&Wt{vH>rnu1BC zcgXcQSZPx7ypRzL%H6L9^{Ik)KWJj$@JgO9>VbhvF6ra*nXtfdO`DQeib(csT$-Rp zWPGmS@6%}Gz<$Xq_heS%GO01Nvb+O=kF^DPRgnCJ%kg9E-Bj)~QX2z@U-GIq01RA{ z$$Ky=@6p?r%Cuio8iLZcqM36y2Yw7$h*Ws_HEpfghQ*gsi2VqdnRwc)nMS}F%?>MWp7rE zLEf#9$1-kxrn7%j^)=QfI$89K00XyG{h@x|Q#5j5&*VMM4-DMydP4n1V6Dc-+Jd~7 zyl2m*Lbf|lzjJt=Xyd?s$vbWa7*wbyeZT%cJlDuUSX{_2EJj|0`nM0$%i`JJ<01j; z5aYjAZ!V`|5_vC5g?G{y?*Fc;+Hq0w2dS62mz4WOHJ?bmEXoXK@5a4@>?^7^YPMb$ z)fWkiIbP6e=jZEX(Pp!-IR7WKdiEH-EJCFx-Xk@}gQ?yg_fU;IsNy(zrh51kka3~* z)yIjb;u6X2d4!G=7H{>w*VXl7MKCCwDK)gzmPxD{gUXkYKJdcPGQTKYeS}61?3v1U z?#XHje~=nt>1%)RxyJb4dtJZ$uT%L8fAN_qaw`;CHt~;NuIf4>w=~Paz`5QDVKG^6 zeZ;NOufpPh^o5rz@I=>W_~Mq_Le7CjQ5WPbOu4PEzFgIHL~bkV35%r(P#6DUx(Ix6 zOKvy%fI%@^dZ1k{&iZmy*AZ37R9aX>{|3U!$gM+<&t4 zvN(SbEK0SJI*CW?9co#4B$a;fQpX>GiN}-Q^s@Nh`*Ixr_vFzo3ge;lf_zZV) zu4_{Am~;#b%B0Bw^%|8&lmD;1l1D;37?kO|8tR>SlX>FSYYAT*EJoJXW)J?D7*HYuvqg+lmD;1l4n>17?d;8hf&Gp?bp{e z9h2v>zw_UNWG-GQZj>hfUwi%6-hL-OH~-t)|F35DJxAodDLWWcs37wUzmHg#=ppdMDS2O$ zzKaU8rN7fZ;@y|4x{jz~@`>!&RQOAJ8vQ?a(na8lTdG*{?|NAqsU=n$ihV|3zMW!I*9Qg=P>|J^B7jJ(aC7>~TSpw*)mvuX^gxN;EtHXg&4LIaX-(#U~5 zQ^j-Fz`)~PI%q&lcUFx-6+cLCyl0jC?BCQ#aaJP-_Dq%X-eWbMi|#^e#6bC2TTrC{ z*=OdJM4qXEDHdpB;P6Y8dSM@t@d`pOqX~>j;kc$vsnQI22c1{K5A5C4l)oXWjRX6o zO7TTmjd!k*(3-;)-!C3WeZ)IL_R`c!(ukR84Dw0WhkYCGt8JjQBJn;Yoh-`k1A~fg zk_WH#shUO(?3sL;UJ({kUO{UQJkF{y$Y(J6IZee^lGm#JUhiIApC!RO227>eKF~V- zuwLb3Z9zWAF0p4*X_f5duJc=nHUsk4!N4czy0Cb< zO&bG;U#eU|YKK01@_|LYj(YdrRc$kk2je)~2 zRbJ)|29;0c5*C-%I<9F`s(c)CZsS`R`wvZn`q+1-jRX6o%D?1bHNKHjOKfnmGoNb= z^35b`GvBMSUTx^Fcg^nWTAs&%sZwq+v|&8nVX1RmG#wx;#-jJxG;(jQkpp`s-+__` zukxTcm^9j?w^rmkuNN3p^^Sx#F6POqG01mcLH2E`PL)24#)}VYmyZ?e+C1;s?xjGWJ+Q_*BDf#h}1{?=4597rfFKeYxXKN3W0&&>tw=WIL`T4 zTTqp*Z`iZ(50L$4O+VJx#=zm1s*IZ^EEeR1HtX%-xTa01%6jR?@&CQ5uy}Mw8v}=5 zs&cjo7*wk%_l@SQeH_=cDOGvZPgpEG2yK3$jWz}jzf?7IM`7_!@>(rwxI3t1{ z@>$hux`9cH_@A^faQLOF4NikW^@Z|osg|x-uR5-4QmPtKMOeI@4{f;$=b9Keyi(OE zvOWz6keX4e-00hKT-T&jb<0NfYXat_g0`BxL6iTly;9W+vStr>bp@zcSej#GMQhvMrs`2Lnh^1mSr>a;@s+jN+t_?h}qayWI? zcEGskm_F;bm}&Tos%4o326g`2DJ&GfFQ=M|)B@@TUKAG3XKNS(-||S+>P-fNy0aw5 z*Qq7y?%(?E_x>4G>(M}1Jn0JUbi((0_xzvyQMJ(@z@VPnZD?l??4kHi-~XOJr)tZi z!JuA@^yPG3nf!b9``^4#wF6Iu#Rcg_>5^sIfBXLTe2uEzmK;v~yi!l?68-Xf_WR$w zQMEs7@pV(br#w%(yvg+6zW+U6qv~0uU#ouHJ23e%=+E!j?|<_~)m^YJz%)oBwZtFK zZ2oWG|DLZ=^*S;h8Z?pTNLTN2-?QKU=8dX%oyFHpgT;5DT~`hHZ{Po(uTk|8`M{vT zud?^9TNdOqzGu(>$s1K)ggTjN=ye86xTd)u;`f{Yxr+{_j~`00$TqC290Z> z$JO*4fb;L&_qY5}Kp5WfU>eWp4JJMB>&@{6Og=2*;$AXnuR5qPe~a7q{uu?VmETB{ z677Y>uJYfz=l|r70*+!|fN9cSo+G^rJo!)G{oX&PfV;9*Z?aG7XT2xjx$?dH{+2%q z_)~fgnx<{d*G=yaJHPck4WCgBa}f-hHv9wHC-{N}-{0~`HA)Q@7V~}-7N-t=>w6kL zqZ$FIpPHtRR)R%ew@3}XzvYo?w3EKhW~H|Xi-k_#`ksc*sK&s@V9+dV3N$1QdQ&ub z|EEW)F%@|%(`0DCqq6U)0F`ft-a z*9z<_b<~#Cn}f-KoKif}HYon(mjcJi+N|XSA7K$)Pay_arobg7!Jy^O=uI*Mo=53r z5hv@ARyoFiNmzpsdRbgRPm*cX4!w*fY?t0WR)NnA#zU)>GXD(En?~)psG0Pvuy`rs zBYebYy)3dzzO%Kf4JP3)Zs=uEE;AUk4wqh~felmWWl>|Sut;bO9k^5P-n*JX&%vNg z^6k)w+^1MI2GtDnVc(`rjbES<(IKoFgKAC;W8bFDgip|jr|93($zu5oVR7L$bWmMy zjU3oB)!aK54BBQBCWE%>&HdK=d6ckd?F=3KLn~H|K{cOuV&A6iqKVMKL$GdD$)Z-$ zV#4B~%*6-a`&lCg_Dr?1T?C7uq7R`%syAZQ7*wltU-oT+dYp$2S+iUt2lh<0{GWh9 z&?fAmF_Edz@2Qao)oRs1Sp4n^jr35=qVIYzXy?8{Saic0jgPej)f)91dp7MN-a;ei zDSoCd$Sy1rL?h3<;&Y8bwYJH8GdO8B_HTwJUZ9Z!d!||^Wv&(Mhw)&Bmh;rh;;zNs zP4Gy0Z_d#6`}MMTC;QEUPsnd&=rlZAHS(a^>DOUgv`;U2&!I=AYUIG4sdj$kD@^-3 zk_R99{;pmY6{L39eiG^;W?0cIdRf#S$lgu+pQI0CSPQ*5zS_a~8(yY^nF%Jt#@5n1 zF2bsTL5C(74`$e&ntEA`j}aC#5}?C=ans9U@eW~eRp#Ksb7#=YVuw6GI%W?9li_uc z-_po~YM*)x1|3_r6c&+s`?YG{m7H(Kxiy5vM!oMouKn(~jEkF2!s5xYo2Wjwv@vk_r8+g1 zfxPjd2iD>x6~4&eyXF5fx|D=={uK?P3JZTpwUUYIId|^sxtz8 zd#3aJal)cpA8iaAeyPr!>R{0MR(W9&+|6-Kn^NtW#lfJ%&fd`BDVAwt;P6YekFE!U zjx}=#i;!lHYuc2)%)v7Wi#y1RYvaIvsZJs63oxB}%GxZdHvWc_P8JRCv2WAqv-E34 z?RMA5fjv{5VNy5iJYgQ6o9M#mS>j`DL3K6^XV0cfu6Stl3r3v{HFQyT+^U#k01)@I$_E)o_Idh?z2 zGGzvX?nAl@iwDU0Iap~@s^_^140@!R1|3yfZ(gfj2bov&n1uU;8MW=Irm^s~SE@Hb za=tyYCBwKFoeTHUufL<^nCk894+cFK)Djjks10cG|Fuu5clS6L^eQCp*Bbqc-oD@Z zX(eybYi(LE8Pf>!&#!rDIi~t9Bfy|{Sy{V}iSy9n{hvOme#=+FV!NzI#^&4q&+lkC zr~1)9fJGlqhAm2%_2&pEuqVc&dXc-6p^hpf@q#q~bsPxE>A3o-v-_deT z4SLCYJNpH+V$Wv$qjy@o|I;Tmm?rtGe#bU|#e|x8#{Tnr8qTRfTs|-e4HzIS*1y)^ z`&%BV!5w*ygdW`j785PZ#lQ94@BK4sm=fy`)4y6LVG)XT>-X;aTmGnF@eW|n|Ih?s zapl;zzNg_cYFN(~3F}{un6<|6&jlu zeOr92EvVsM$>oIYOv&C&Y&-OOYU99uso`CjdxyKs{dLO7&2U z9N058id`furl*EZS#g+EV^E{5McKC*ltJq4Q&Z{9@in?MSXhiW3!U0|F000%Mjxc# zchKi>_HU*h)w?INarQxAFgSEAbXwtFtQvzFdrQCX;1`m=m==TlmQEI}Wv(?Ocmw-4 z(;igO$bmgm<01E0&5$c{znEU-44-QZYP{e#_H7~ycZE)0lwBhS_DqfUp(n{i2HgUS z8Hq68(8z-t-|Y+rk#n*Mi&lSXLvZY!<`ynT+C@aSucwg>A_&Q-)CX5aj9MwVeZ0WknE|M zn=V2xi|O9NV#{9W+)jF*sZF;!35#c_iyfb=h%gu_)ZzJk(L9m$boPt$jP_t_IO_-=Z zE3tnwe^_gc9N058YmfIDnCP;F`P|IErnd*W+0b%e5Z&oEbb(6mN%BnG_*~RMY+r*@lUg(7t(`e+to~hYyvR04rLS4ix zoQ4{KMjq7MN%jZC^p9STI5&B73EIOcZOt5EazNr})j99f3 zy7+_MdTR4i#f8PqYS1Nh6+crS;oTo*WTsWZVwv7tPKzY)ZbnwUEiC?A&Z;q}MUFe{ z+l=gwUIVkVzG4<`lG_`(>J*qPUD03Tm|)M;;_rRSBX7w2a+ZF|s+UDqKlW}$Wt6(= zvIfYDYve&KqVow0-=5HAE6~HHlf^uFrj80(DlGoGr;!7DrWQMffWfF`lD}A9|F~Wj z=OlkI>hd%&S-xCvO`yfI+F&p`O+8`pX9l(7qGht7!om~x3A3VZH@z%!&K4Hk1EDLH z%+brD{5WATPil!P-eVuLMjq6%j^r;!pOI(k%9>#sIk0DH*%|o?GbWKdM^-M#ua`w6 zeiLR)nYPTptbDy#FN>LZz+gP1ey zEbhb!i{GRsu)5Mqy(~URf9Kfz=vgzXWAQxE$b(vClDXE{`j0U_RzJwBkpp|CR?dyU zVC*nFOU)X$j(S=6JP{U~r2lu#sPTGPG{t*R%-B0?z+}xe#VmTtUd(YB-+{&25i*Kzv+Yst7cDg77g z`s$s7x4I|yiE)3_m2q*fklu0e;T{-_cRm1JZ&Ipd(K=(KuxOe|SajI0mqp=Z!Xl=k zu-H~#FAMMP!eWcm+c%`Z8eSt0YTaOuu((?ix}gc4tvXqB`3(#vWIztbY*?O6BM0_O zts^n#HWR!t-!vQE>79eOo|aU`MOW06%|`$0ddJ0T%(=~k89l&czmM8U&i=l(SU{YgQn{8RGcb(d1T0>zm?5>Q94;l52i`A0b zo3u{m;#>Vc=w%U)_g$DtS7k1~bxOQm78fMX8Jj|S*S6jb*306ttV3eUgfj!PtrYGX z8hKEgzjA;F=DJ>M!u z=@)_VFu8RQbVm)W)ilDOwxg;Di;)k6#kAiwa$wKYc8;u1CvUDPEbe*hWw8OzP&4_) zRIu1tO79%J?Lh+uQ&R2|76Xy<(>OM$?WIUzQRa-WI8s9+2lh;DpWXt4DJ>2_cUkFK zH3qf)RDgY(DbX{ayIQZ)$bmgmP^Q{oFlD{u`gW}$x6f&f9N04j)#wBUQ;VI4?jG}mRbx<4E182&ZS({CH@h!l-8{BM0_O?Uv*OgBe9-ow_gOMZGMx%6(!+J@mwzeRZ)$)5wF`9f55#W561Wk9{-q zXym}2somu!tY(J%je4{14&HgopJ@wf_hb=!HZu;Nh3C(R_DnsV_W^_LCvvdbiO!+_myfjt^-NcqJ)0dx zeq*&0dp2g(7}T@aTJ~*r#CWmViI;q4)fm*X#&z~>cHI4))lTB%&#Ez~XBU}w?yOXh z{o6_UyJ+OVo~h^Gd5fL1z{E~+D?u-dWtZ5y+4=SntDUsk8&-`$JrCkOVRqHU-)^## zuGhO}?|JtEj{&o5)p%ArSr*L6`B+;}uSA2`v)P?Y=32=HV_l++1N)_3Ic1%?yA}4} z*~uR0trhk1z`fG!-nxO=*vSJ|v1$zJ)#MucHgV~9vD(Qu9%j`T)GK5t`!;bMaL=?; zWErKA1AC@k6CbjgxH#l3>=Y5`-{Q}-1@&4hz0Z3xqgG_6xU08r*6Ua*{{J_7x}e@} zr}V$7Z9F*qQm^|vgvH(^tai%Pbsg8VDfLcNjy;>b)=5@7Rfc}78iRUg$2!F9?L3(M z+o}2nXym}2sdss-L(JYddzhcTw_r01=8P{klLI5+i8MUYvjP5srRl;tR|ra-u+;w zIk14wH3s#*fLgLiSaXB@+i45d)X0H7Q}177&qTr}tV`^)F{m|bMzL?Rul6xk zJMAOnG5A+Sj6PJc9xRbx<}IX3$?2a0ZH zwVjG&Wz`teXNx=gHU|dGXSJP16l2vG)aPVj_H7OvF2ZU%JlbVG%f%)wX=kvuX_L`=%lLHbM#AI89=;?PGtjY77cFe1?6SPv_HB;ecV)G+Txh|nF{ocs`5P=Jir}|m zXDyC;yG|BaJlMB6(ftQjJ8RTYR*gaZipt)*6B|)qx3gYfsgVPFrhXOWok1tw;GSt` zbHSWkBM<6VU*?@BE6Ca`+n8e-Imo!^5X)*#4wQX}+3smY@vq;=0PG7eC--8WVgKO% zNh=KMH#RZG#i>MdSnVGsp3uu;esW>qds$dKYO9yUM(N8r6@~F&XZP0I$Jg&*yo`&( z{V^`GPky9#TwDqPi_E;VvTN2SI7L*&QS^ZEsZ>=-=70yT#P!&YUh}m zLn8g(og>VoXw&J~+RBM0_O zq2ZFtIa@s!pWC?}BA>y>+JZvIN}c^|%mwyt=k`FIL>mY8OQCa7Gc;!pNiHY%ILtS6 zvRLoTzRkI$(i@-qP9u#R*fWJDbYwN>D$6r9kIOnf*BBIfPI{ov4av*??K~qcY2?73 zDfI3xR&y?H3ag#x>SScD`5>qvDV9(S)*-Tb*zC8As*?A*TC*jYu z1@$-W*t0p`7i)Dp?|Jm3Xyd?ssed7P7s&bbn2X!_3LMtRL0FWR_vM^_E;Yn_p?c?9 z{i{jO!B0j0W^r`A-f_`n1$#F?1*1-4=l`L(UKXAH5Ek>LK9avH)@T}eQ2zn0!s064 z6=Ub$gSER(79-`EdcokHX%}#+q>%%Arv5Yfv6>5YCHGsPO$9#J7}S475B6;?jKLln zyTJPQ8ac3M>c2yJ8ZR8e9$mX&qUm~B9L1h~bK&#P%)l;KS8rcV|4YZ2f%)0}kg!;& zcdu^$M{@7{x$j_M@k(z`WB=bj$hcU8--cbNaz#GZ7&IV7FZOMIekghHLK8n~L0R?lhZ*#FJ=HhnYQm-^}V9zwbr6H@iIPog0U3f?_R*gXe zs>uD~;xV~j6h7^(kpp|C0riKlnoEg?vf4#*>a8sg2$J_eUviHU7G3rBcMj;)iW!(o zy>Z{Li|j&9hd=&%`P_DXU6fU0(14xTBVjH_V|{8D^+9bwCyS%` z*|)j8`zfnkbo^LWjX?u0j$+^D@^AH7?V{INR0a*Wk3E>?N)fqV6mt$#3F2R-X~64L z?A=^xjqza@3q@XBBM%BoTvAv}K^@gDcA&RL4(yr2GGKjbt{g+I&n}+PS1*g4e(c>` z`P`M&F5dDDtHz+PVs7l)Ty#9d#12KEm_UAUg*cMOZG+{gFn+26gFD!o!6GQuy?!U9_;DX#)17(*bFaL zbM2DUmP@5-%jX({!j{VWa;~Sv^TaOIV2VZ#?3uzgNp1OhrR02Wmzp=9RbxQ>8Het0(yEJ0e7!-E3GW#~yFUvEv^x$_IIk0C6dnC`1 z8)-i9xn260;#|%fH)ddNc#i~&G8X#!_*h#|c;c+=+1%(UHGwj%lW1e$@Jr$8p9_mc z`B?2TD>6H-X;TXSVKaL+H!k2EAaZ@c8RX5kpp|C@afXKb}N1jpW7~{@LS*cSk zwyWKNRbx>2`Zny_+|J{~YP+`H&Z;ped^hG+=62m=?B8}>_E;ka_DtbN(3@m#55bzu zcKrqUEsZ=V{3qnU&F%FA*uP!A{BIgLuxARtg&dB#eG~iG?ec>a&$XUn9b)b{VP0XE zKdd+R8~*z?9v|k8_b^u54UZE(R2MWbNq07F?sS{TYP&V+$*M7Epi>t1ZSKqtVYS`n z=v}7{%qF?tJIBili+i|#@Uga_fd#9uXLINM8CJUj%By^+E@)tB{3guZ!kA~+6?(r_ z2jOqSG|)?WIy)Lv9I+&Y{AhjoJwY4IKSZSWK0Br^nI)e6BHQ;Ivfi+uYlaIhO75RBvs0;6hti z{3&(f$J=^Php(tySN9M~&idxo~w$bmi6z-_3DnEL@6`P}y0eUnvV(7=6|Pni3m z4cNc!l^AO@oh(i+Vc+KdqVue_m;YE+jX?u1A=hi}pDDxsZLcxN?dW827Yxk(KY9p@ zvwCX+1E1e#2IfIwtjTO|vtHwvV9zx0-Dp{nIQ&vXx;SC6IxVa1eeY+-HEl`}S!CbxgNqB;yIrwJJ#7peekmd^dR)!JB$lw~ zw$^b?n^Hva;_TTxED_9VSKNR(IUj2aiYPycJ)4J3r6y4EEyjm74(yjAe6T(>4~H-3 zbGwqe-glWs1Y#e%dAM$duo#q)Rbx;@qdx50JiLNlXuDFvU5y;rGexx7z-k^P`+?Q= zNj95RV^BmFj05wir1bszRL5^dCyS62?AttQmW$Q)8MBpDV^GB4ob1~?8s3-H_Bn%d zKGqf#F;bo*kJidFwQ}YT+88+eQbereavohmEzz#rXo};SHl^VgH?n6t!>p^&nSQIa zF>v^$;WuSok>Ti4VX-IPaZQ`j@P`Bj8Gc7^qdm*DnKlLvzcl>CO0dY7zXEjD8ub4< zu4_^n{ucL6J7b;CU@<$tt0wza-!Dp_*&YiC@6b%;GD zLlsT_zxGN|X&VTO3+Rcr=R__1`nslLipo4$SbRorqdn(CtS0|od!?vs31E?_SOMtV z9_H)onvN+d&uuWs)L8BtbMNZyU5hIGTv$ZTh0bgA6RXCcsFKgvx1DJfYRvY$W0^H_ zV9ylgioP5>(*=3I)_l)qRL1x$Xp}|bU~i_dRf%)7Z&y8 znYv)oOT8@Wz84l@pP&nq>aCkaHJKwU7EKTqec!NZ42o)9f_>YWkE6%cUU)x9BM0_O zQSBw)nfbQ|d~Ppl*qK#hP*m3=Q0n%Ek;BqRFz_*h#|RMc?xY+Kv2LYEA_qm6;XFGY>s z1P0cPNy6g!3dc2VN>LN9fdM5w4qe(@@tS>_%)!YS`vdHyM{;W$4-UT+H8-VGbyHM6G)S1{5!OjOG1t z-}suBmSc+AvR_!-m*2|rd$@mS@&C0?irO_DEKDk?r>>}l=gQaL(Q-^t2{QLK#b1EQ ziX9WRc>kwQiaMMP3`{+#o2|^JxK?!Hh_DEeT+Yg|itnB0kjJvk4B0=j@^`)cT2Ysz zE@I-6VtlM>GvlAXBQ56?bzSOZ=9Z7JIEwwMTKs?QlcMfs0RuaUA9Qt@!e3w4bWBl? zByV9C%p@#k_SEG6Yp)dbT-IcEwWVOOCUJ+auWLG{sNdRyf&F6!VbKMuiGjl_MZMc2 zEXHCVyS?Tt^5Kr_nv|mc!oI`*Ywyhebu70(eheX*Th?W>w>{YAZP@d?pKaD4%AroB zPAQ>69ZHB)&+WONL!ppD8b~_kd6s$JhLFrr(j++vq3>(0wV!kCS3i9Jfpx84KI?w& z{mbWV-NSXQ>$)M%O<^W;GN01qzob_PmhQp~aId^y%$cTl{vufZO<{3S`e$>?dL>zD z${|=u<}XZ*tIT9>-)Wlsm-Gt3>OV6Blh#sL?B%^RCI3cC4nb2{Sag$h81vG3J)ai; zC4E9Ln)@MW23=z&^WLjd^1P-Tg7L}Bz)XCfb^hP@d7_Cy#47|F$bG^r#BK^udJUkJ90qa4leGQYJT=~CpJHicmNZOo#Uxr24V*hShH zMEpW9`@FEol)1hI|E(W6r%fSPAZrb3b^kXrS$Ka}Z44rQA=pO7A+-kmAS_mpG3xH+ ztV?<=)5w85L$J5(OO5KgN?2?ipqIt7+ylU z?lJ3RG3pZ6L+z}QtjnL&yJsRex}&h@)Qy= zgvA?Av#xlBdjmRIOh#cbd%dtY5zxqiJVS8meaxWt7XH2guFU;LFN+W4`BD1}BfyoD znTkeRFUoeB{MqdjH&GX;~=L(B9vd(i|YrT7Ef=7H|(W3|Jx+!BxH3kHa3xntvA1D8~ z?s8Bg2l5QT(@jV*dfYv%>$|ig)ff;wdy#x&^k)gI>p$J5kpp>#;CHg_B6`yvX7PC$ z)XU;Wp1Z;56aNqv4=3qm@eB7uF#7k6!eU8fy(}(Cebh4-%FD%xT78V0v(a3>3gI8@1DaIV`!@6lF z*9Ya=0z4>wre2VK>gI$l+89Lqf@h>I>XtuFzv1S=JpUOvuSvnH!~fq1){T|Dcbkh8 z*F|0a<{Z||JViBtTk3~2)j~{yyrvwyqUk=LN$)?s}$`7h}eycQFL#oThNTlalf^1P-T zyp*4X#b%lB+}42KH#9Mbcm*$`P*@z3G1|7FJkJ$5uSvnn9xp5|&1K!TH(8Val3u~f zljlfm#re!)d*bYp=QZWv71m=0vGMX8**^GpP5w)I1+UHH!XiudOl;p>rQ~@{Ie6_q z5Eh+zy)W*FQ~a)V#}Q%in`|&jx`2& z5AP-482f|F>Fj!{lSU5Y8N5ejoEle(`|G%C1+Pib$OF8dGH(%QhIRKNipQya8VifoGEUt+pZlxyo3;S&8UE%R#yueKoqI~1*Tx{?7rg#ilw;hp zJ6QL0eLZqcn}YYe%!9|h)?8S8{Hrzw5x?LK%3%g^@4PB3E~iD#X;bh97hfZD_&a=9 z)IssOoS`kGE;gKIEqW(iTRlYlf;YUOusAIH&WgTMJg+sfmazEo9P8ff(GgDC6uj3< zGlTe2+l7U%cplu7Ya<@z|B~JNRkpTzi1-E1moa;M({5ZB`gvA3g zE;+bunBKZrD)SZzPoHHbhp@6<7R&#Xx){+)SoC~JFN;;PgvIzbgvESb+o+KTcx&$y z7BhATiyKEZav;y(t(SE<3Cm@U@9>@b^s?AEj=W>SE?M(>c+w|&S!|L1dcw&n%;fOd zE_zvPllw%%#cRys%a#ZAve@}gW>BxJ>}UV-WnP1zkq3CYe-Rc&o~>VQAEc23c?NH< zCoG!uWIa+-ac}uRRbi1Y_s%1a4W(m^0p7uB`+=}nvs_p_m#E2qNw46YlRkUBBEC=H(N&6{Bj@=& z6YHIpdGKT9crLgkFD*HEKm0*nvEHTAtjF$cp~d@OeS-IMUuKYa3(sfavG?Bj>)&WO z2JaWSPb3<7wjTS2$L?DEm-GqVrPg$eiH!%a9&f?#TqXZTOAg*|@(!Mu%l8R9{*q!A zS1NHmB;I{U>SE(DEp_l$pWt2VCoCS}`7At9dD371M$0jH*X8+<*#9~+IdQ+@ckn-x zq%KAd5f;<+_D4pQ8YwKspAr`5xjrb@7BH#|zfWM|#|7jaPo^eoV-WERqspZ)gTy7T zv7Q{p?;DZxniNJ=D85Fvd@d|DXK3fji^1P-TMpdrM3=+>v zpZ!#K-e;tVLBuPJs``wuxF&luPrctJa!#8LM$K~jwYp#`!(HTlAR@^7j?&;53tESAW34pOSgGqw6bzK7~$ zv4YpCVM+^L4{mB?=^dwr*5pwQU`prtq^8EZ9Y{3>gx2#|3{(2Yk$+R;y598{p-oeW z0j9ihKeM>K$9tq2147&6T`OfyC-QG@U%Nmf2l5P|oiY!eva1Xo8;E^^RAWG>Nc!t3 z-;W^w21YE=$bmdVXg~LcFtx%)IyP`}2C2q?(4p7JH>Nh<YLT^!5ZoM~dsB?KojE ztq-ZjfY5PSbC4=)<4w&Q`5HNpX9%4-N{Xo?_*yaekly}C=xm{|m?HBRxMDXQYYYgT zn@+wlbp?Nm&KUECMh@f|Lf>B@#neL`NsSq(cwX!0w!-4q&B9{eO;U{kp^Ib5H>Ops zL27C>S3Dm1Z;`NQ+CW(Ro990%*A@`EQkgtsT8E0Hrq(&dEdG%1D5X8VhFL_lUO}oc zAawIN@{MW3xyNjxrs=HuZ7EdStrgqoW8aa?>@XK?L z2-Au}bZlzRQpeK8Uy^w(i2E8yNCRnI*;wp$bmeAU+pR> zrpIz$#MD`(cb|ZNJNFJTJ^Nl_Vxl3BRAYdTzmacD@7kTzL_c$bRAYc2^%MEV^k)-D zP4wnxNHqrd(TB-5rh9VljENbokpp=KKUVe!q)#uTV-qvzQBsWoeggM~Fnz^aks*MBr1;5QIQp`BU-%m2} zdwEWWe$y7HPaOHi%q)JkntCyZG;$!%;CJD1DQ0%&b)BZ(fH8VmbWI`enEB+dq^90R z9=B4iEx_+4&(zFe{~+%su_n)FXyZVB!G9o=6f?(9CN+sqMU!d_@E=@6zAn43 zmQ5Q6@(cbGJpYZEfBsCzrvCMBNi_!ey-t#E%&OUw)HLYSiBw~N-=`J%#;hjmNKJ#O zFOq5u@SpyOd}CIC_Xn5;Kk>I8bh3E%im>R$_fXR?UvUp{0N)=ltM9GE#55eO_!@bh z_f}!n@H4{VD6c`FTw8!Y@FID}thc6;nnq3DA=Mb*znD$FF>6)^scH05XHty;{!1gt zH)gG#M`{{vRoqV4+Vs?Bl@^6~l&Br=fcqhm=W~ZlcU({u#)ODNYC;J-PH zJY)82T}e&Tojg9FTw8!YZW?*U?1?-kGf9T$J+*Nlzu>>MoD{P^T}^6|dM+i^7~oGh zK)x}1^)^zIG_MV*#sGg3uR+1=qT;%^Hbo-`@(ljuKS(kA>q(@hS-bV58Uy?(JkN>Q zzuiavO|!9|Y2-kj!JlSGF{eDQVKdE+K1RnH1N`Z{rwVgw4=4YodHvHGIgn@YKdeuR zIZ0PYP4fZGNHqrdAM-bZFeh*a`8Um1Dt@NUY)A|+=U!gtXc$TRq>9wo(G zs6}d0>a8Qy7~rpwbve29c^|t;dAhwu4&)j9by1|4n<4XBDGL?Pcdq|QSai6D)TCV9 zM5-~s->`*zW9|c~q$agcaSw45k3%rG_f26j>NQf00sfY!$T#M`#P6FXbq|l>b+XvT z*9PW>d2NzO15YCd@(jK#!@=BlzoTQ5_TYL_jRF47;(O<3J;}dGo4!XQ2l5R5ZXSnV z?kZ+r(!QOemqk%0@{YN?NgQOf{;o?&5kdnO(Dq$QDa+7$d#eaSQC^_BUH%%h)ZV-WER{@2oH&l~bG{bsUa{}nl> zO~F62nml8k&wW*s)w6~+1`)sDfAhGon4C*$vSx-N=d>yK=PHnA%$xNRsmVIOpHyRj z{~g~eF>l#?@^7+}E@|XIp27c~`(&86Wj7t0?EXKJY7FpyI7z-S@8D5Vlf97FAW*I? z!2fA5dB(i6dr3|9Z;y~_4Dc@$zk^>|Oa4tx<`In?$TRrA%qGSB(mW0^IYaoHbo86H z0RLBBtA_d2Wz3$lx~nz@5x?MH;_)fw#{vCja&C5yoYSV@|Hkv1nBSbAA11f3nKlLy zzu;f~iE_-(znj$Lj^t-7<=O)LEBx+_`NeZNxf}avV-WER{x$wS4(31DhJG`7Wu@61 z`2$4?{vTnoi}}50lA65sir2c{;O{44{tH)y#i&}O8Uy^B+%LoYAomVU-Zs5;5&j#$ zS782IyjIENSJG$fca~t z3X2_j*Bpe)6+cII^4=;_P*LxigK&AC_s0Aq1Gp{tzT#@@^nE%^t_ zY77Wh*-pN(Am#?C34|Ud)ff=2#_tnY&@@Q?O<=3uJrm*T?-K(o$dbA!ET?y$K=^ik zeqcd+Ubkfm+w~$g8Uw=c0{O;*uJRlyd_7Sk2l5Qzn%qalg2yV+u_@fJid17j*c6g) zEa-O^scBWJC8@@MaIG2S8w-XGAvLW6uaasE2-mJizOf+m0jX*A@*Gl)0pU74kA(#j zmXUwcY8CHC)X5@xEBVHP4`t0ktE*feI$6|hAS~uBCN-@yc@LgW7O}4ji`6^_Y+4U0 zuaN_JhH%_5VX^%cQqy{&-u0c~gyON;A^FZh>kB-eL0q&2gzJqa&scCq=C#^1i`B*; z;upe+XNARu^`xdv-)vHi0pSK2*3zV=%~{3Ikw(0p z69Y9TF^jfwJa(sCTR^x;6Y`9K1RynSdvqq%7!Ynchwy`q0P&!p(V46$UzVB>$#e4ellCWYMAr`Nlxkw@FRAd%BTo3<$U6F**hw z{gV8fcHu&e9LO_-lfNa!z%%j=-fj!;p`hQi1%y+JpQ(d0$-8M^YP~iF5x)>l>rXib zUcZmjw9n`9D&^V&!s(01GX};=->m&$p6k=bf&4-^;|eJTrt~H??H5-e)ff=Yl5uKa z)`R5Vw7-zAkpp>#aP~k_3@mO(YC1IG{u$-k0>U{9$ukDlHzYM3o>W{Hx#xw&PT42W zVY=e?i+rvJ3>@Alb@9~(QjG!O0^W;>fio|Yf77uhuVvH8A~2DBW8gvyQq!^XZc>c_ z;le%S8w1y5Y}PRxuaN_JhH$GtNwKip^Q5NZriVy1287%2m<$VRlp+77<4u0wP|0G< zv?B72PZrH4t<~?#dr370I2Ql=XLl_AhvILJg=1j}*v!?1V_^x{%+-ZsVF}pG)rDhW z3E0flg=1j}*v!?1V_^x{%+-ZsVF}pG)rDhW3E0flg=1j}*v!?1V_^x{%+-ZsVF}pG z)rDhW3E0flg=1j}*v!?1V_^x{%+-ZsVF}pG)rDhW3E0flg=1j}*v!?1V_^x{%+-Zs zVF}pG)rDhW3E0flg=1j}*v!?1V_^x{%+-ZsVF}pG)rDhW3E0flg=1j}*v!?1V_^x{ z%+-ZsVF}pG)rDhW3E0flg=1j}*v!?1V_^x{%+-ZsVF}pG)rDhW3E0flg=1j}*v!?1 zV_^x{%+-ZsVF}pG)rDhW3E0flg=1j}*v!?1V_^x{%+-ZsVF}pG)rDhW3E0flg=1j} z*v!?1V_^x{%+-ZsVF}pG)rDhW3E0flg=1j}*v!?1V_^x{%+-ZsVF}pG)rDhW3E0fl zg=1j}*v!?1V_^x{%+-ZsVF}pG)rDhW3E0flg=1j}*v!?1V_^x{%+-ZsVF}pG)rDhW z3E0flg=1j}*v!?1V_^x{%+-ZsVF}pG)rDhW3E0flg=1j}*v!?1V_^x{%+-ZsVF}pG z)rDhW3E0flg=1j}*v!?1V_^x{%+-ZsVF}pG)rDhW3E0flg=1j}*v!?1V_^x{%+-Zs zVF}pG)rDhW3E0flg=1j}*v!?1V_^x{%+-ZsVF}pG)rDhW3E0flg=1j}*v!?1V_^x{ z%+-ZsVF}pG)rDhW3E0flg=1j}*v!?1V_^x{%+-ZsVF}pG)rDhW3E0flg=1j}*v!?1 zV_^x{%+-ZsVF}pG)rDhW3E0flg=1j}*v!?1V_^x{%+-ZsVF}pG)rDhW3E0flg=1j} v*v!?1V_^x{%+-ZsVF}pG)rDhW3E0flg=1j}*v!?1V_^x{%+ 2Br", "tolerance": 1.0e-3 + }, + { + "cross section": { + "type": "base", + "netcdf files": [ + { "file path": "data/cross_sections/BRO_JPL06.nc" } + ] + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + }, + "label": "BRO + hv -> Br + O", + "__note": "first test: excluding edges of interpolation because of double vs float algorithms", + "mask" : [ { "index": 62 }, { "index": 86 }] + }, + { + "cross section": { + "type": "base", + "netcdf files": [ + { "file path": "data/cross_sections/BRO_JPL06.nc" } + ] + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + }, + "label": "BRO + hv -> Br + O", + "__note": "second test: including edges of interpolation with relaxed tolerance", + "tolerance": 5.0e-3 + }, + { + "cross section": { + "type": "base", + "netcdf files": [ + { "file path": "data/cross_sections/CL2O2_JPL10.nc" } + ] + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + }, + "label": "Cl2O2 + hv -> Cl + ClOO", + "__note": "first test: excluding edges of interpolation because of double vs float algorithms", + "mask" : [ { "index": 34 }, { "index": 97 } ] + }, + { + "cross section": { + "type": "base", + "netcdf files": [ + { "file path": "data/cross_sections/CL2O2_JPL10.nc" } + ] + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + }, + "label": "Cl2O2 + hv -> Cl + ClOO", + "__note": "second test: including edges of interpolation with relaxed tolerance", + "tolerance": 1.0e-3 + }, + { + "cross section": { + "type": "base", + "netcdf files": [ + { "file path": "data/cross_sections/CLO_JPL06.nc" } + ] + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + }, + "label": "ClO + hv -> Cl + O", + "__note": "first test: excluding edges of interpolation because of double vs float algorithms", + "mask": [ { "index": 51 }, { "index": 71 }] + }, + { + "cross section": { + "type": "base", + "netcdf files": [ + { "file path": "data/cross_sections/CLO_JPL06.nc" } + ] + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + }, + "label": "ClO + hv -> Cl + O", + "__note": "second test: including edges of interpolation with relaxed tolerance", + "tolerance": 1.0e-3 + }, + { + "cross section": { + "type": "HNO3+hv->OH+NO2", + "netcdf files": [ + { "file path": "data/cross_sections/HNO3_JPL06.nc" } + ] + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + }, + "label": "HNO3 + hv -> OH + NO2", + "__note": "first test: excluding edges of interpolation because of double vs float algorithms", + "mask": [ { "index": 30 }, { "index": 79 } ] + }, + { + "cross section": { + "type": "HNO3+hv->OH+NO2", + "netcdf files": [ + { "file path": "data/cross_sections/HNO3_JPL06.nc" } + ] + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + }, + "label": "HNO3 + hv -> OH + NO2", + "__note": "second test: including lower edge of interpolation with relaxed tolerance (upper edge is a very small value with large relative difference)", + "tolerance": 1.0e-3, + "mask": [ { "index": 79 } ] + }, + { + "cross section": { + "type": "temperature based", + "netcdf file": "data/cross_sections/CF2CL2_JPL06.nc", + "parameterization": { + "AA": [ -43.8954569, -2.403597e-1, -4.2619e-4, 9.8743e-6, 0.0 ], + "BB": [ 4.8438e-3, 4.96145e-4, -5.6953e-6, 0.0, 0.0 ], + "lp": [ 0.0, 1.0, 2.0, 3.0, 4.0 ], + "minimum wavelength": 200.0, + "maximum wavelength": 231.0, + "base temperature": 296.0, + "base wavelength": 200.0, + "logarithm": "natural", + "temperature ranges": [ + { + "maximum": 219.999999999999, + "fixed value": 220.0 + }, + { + "minimum": 220, + "maximum": 296 + }, + { + "minimum": 296.00000000001, + "fixed value": 296.0 + } + ] + } + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + }, + "label": "CF2Cl2 + hv -> 2Cl", + "tolerance": 1.0e-3 + }, + { + "cross section": { + "type": "temperature based", + "netcdf file": "data/cross_sections/CFC113_JPL06.nc", + "parameterization": { + "AA": [ -1087.9, 20.004, -1.3920e-1, 4.2828e-4, -4.9384e-7 ], + "BB": [ 12.493, -2.3937e-1, 1.7142e-3, -5.4393e-6, 6.4548e-9 ], + "lp": [ 0.0, 1.0, 2.0, 3.0, 4.0 ], + "minimum wavelength": 182.0, + "maximum wavelength": 230.0, + "base temperature": 273.0, + "base wavelength": 0.0, + "logarithm": "base 10", + "temperature ranges": [ + { + "maximum": 209.999999999999, + "fixed value": 210.0 + }, + { + "minimum": 210, + "maximum": 300 + }, + { + "minimum": 300.00000000001, + "fixed value": 300.0 + } + ] + } + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + }, + "label": "CFC113 + hv -> 3Cl", + "tolerance": 5.0e-3 + }, + { + "cross section": { + "type": "temperature based", + "netcdf file": "data/cross_sections/CFC114_JPL10.nc", + "parameterization": { + "AA": [ -160.50, 2.4807, -1.5202e-2, 3.8412e-5, -3.4373e-8 ], + "BB": [ -1.5296, 3.5248e-2, -2.9951e-4, 1.1129e-6, -1.5259e-9 ], + "lp": [ 0.0, 1.0, 2.0, 3.0, 4.0 ], + "minimum wavelength": 172.0, + "maximum wavelength": 220.0, + "base temperature": 273.0, + "base wavelength": 0.0, + "logarithm": "base 10", + "temperature ranges": [ + { + "maximum": 209.999999999999, + "fixed value": 210.0 + }, + { + "minimum": 210, + "maximum": 300 + }, + { + "minimum": 300.00000000001, + "fixed value": 300.0 + } + ] + } + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + }, + "label": "CFC114 + hv -> 2Cl", + "tolerance": 1.0e-3 + }, + { + "cross section": { + "type": "base", + "netcdf files": [ + { "file path": "data/cross_sections/CFC115_JPL10.nc" } + ] + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + }, + "label": "CFC115 + hv -> Cl", + "__note": "first test: excluding edges of interpolation because of double vs float algorithms", + "mask": [ { "index": 19 }, { "index": 46 } ] + }, + { + "cross section": { + "type": "base", + "netcdf files": [ + { "file path": "data/cross_sections/CFC115_JPL10.nc" } + ] + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + }, + "label": "CFC115 + hv -> Cl", + "__note": "second test: including edges of interpolation with relaxed tolerance", + "tolerance": 1.0e-4 + }, + { + "cross section": { + "type": "temperature based", + "netcdf file": "data/cross_sections/CFCL3_JPL06.nc", + "parameterization": { + "AA": [ -84.611, 7.9551e-1, -2.0550e-3, -4.4812e-6, 1.5838e-8 ], + "BB": [ -5.7912, 1.1689e-1, -8.8069e-4, 2.9335e-6, -3.6421e-9 ], + "lp": [ 0.0, 1.0, 2.0, 3.0, 4.0 ], + "minimum wavelength": 174.1, + "maximum wavelength": 230.0, + "base temperature": 273.0, + "base wavelength": 0.0, + "logarithm": "base 10", + "temperature ranges": [ + { + "maximum": 209.999999999999, + "fixed value": 210.0 + }, + { + "minimum": 210, + "maximum": 300 + }, + { + "minimum": 300.00000000001, + "fixed value": 300.0 + } + ] + } + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + }, + "label": "CFCl3 + hv -> 3Cl", + "tolerance": 1.0e-3 + }, + { + "cross section": { + "type": "temperature based", + "netcdf file": "data/cross_sections/CH3BR_JPL06.nc", + "parameterization": { + "AA": [ 46.520, -1.4580, 1.1469e-2, -3.7627e-5, 4.3264e-8 ], + "BB": [ 9.3408e-1, -1.6887e-2, 1.1487e-4, -3.4881e-7, 3.9945e-10 ], + "lp": [ 0.0, 1.0, 2.0, 3.0, 4.0 ], + "minimum wavelength": 200.0, + "maximum wavelength": 280.0, + "base temperature": 273.0, + "base wavelength": 0.0, + "logarithm": "base 10", + "temperature ranges": [ + { + "maximum": 209.999999999999, + "fixed value": 210.0 + }, + { + "minimum": 210, + "maximum": 300 + }, + { + "minimum": 300.00000000001, + "fixed value": 300.0 + } + ] + } + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + }, + "label": "CH3Br + hv -> Br", + "tolerance": 1.0e-3 + }, + { + "cross section": { + "type": "temperature based", + "netcdf file": "data/cross_sections/CHBR3_JPL10.nc", + "parameterization": { + "AA": [ -32.6067, 0.10308, 6.39e-5, -7.7392e-7, -2.2513e-9, 6.1376e-12 ], + "BB": [ 0.1582, -0.0014758, 3.8058e-6, 9.187e-10, -1.0772e-11, 0.0 ], + "lp": [ 0.0, 1.0, 2.0, 3.0, 4.0, 5.0 ], + "minimum wavelength": 260.0, + "maximum wavelength": 362.0, + "base temperature": 296.0, + "base wavelength": 0.0, + "logarithm": "base 10", + "invert temperature offset": true, + "temperature ranges": [ + { + "maximum": 259.999999999999, + "fixed value": 260.0 + }, + { + "minimum": 260.0 + } + ] + } + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + }, + "label": "CHBr3 + hv -> 3Br", + "tolerance": 1.0e-3 + }, + { + "cross section": { + "type": "temperature based", + "netcdf file": "data/cross_sections/H1301_JPL06.nc", + "parameterization": { + "AA": [ 62.563, -2.0068, 1.6592e-2, -5.6465e-5, 6.7459e-8 ], + "BB": [ -9.1755e-1, 1.8575e-2, -1.3857e-4, 4.5066e-7, -5.3803e-10 ], + "lp": [ 0.0, 1.0, 2.0, 3.0, 4.0 ], + "minimum wavelength": 178.0, + "maximum wavelength": 280.0, + "base temperature": 273.0, + "base wavelength": 0.0, + "logarithm": "base 10", + "temperature ranges": [ + { + "maximum": 209.999999999999, + "fixed value": 210.0 + }, + { + "minimum": 210.0, + "maximum": 300.0 + }, + { + "minimum": 300.00000000001, + "fixed value": 300.0 + } + ] + } + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + }, + "label": "H1301 + hv -> Br", + "tolerance": 1.0e-3 + }, + { + "cross section": { + "type": "temperature based", + "netcdf file": "data/cross_sections/H2402_JPL06.nc", + "parameterization": { + "AA": [ 34.026, -1.152616, 8.959798e-3, -2.9089e-5, 3.307212e-8 ], + "BB": [ 4.010664e-1, -8.358968e-3, 6.415741e-5, -2.157554e-7, 2.691871e-10 ], + "lp": [ 0.0, 1.0, 2.0, 3.0, 4.0 ], + "minimum wavelength": 190.0, + "maximum wavelength": 290.0, + "base temperature": 273.0, + "base wavelength": 0.0, + "logarithm": "base 10", + "temperature ranges": [ + { + "maximum": 209.999999999999, + "fixed value": 210.0 + }, + { + "minimum": 210.0, + "maximum": 300.0 + }, + { + "minimum": 300.00000000001, + "fixed value": 300.0 + } + ] + } + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + }, + "label": "H2402 + hv -> 2Br", + "tolerance": 1.0e-3 + }, + { + "cross section": { + "type": "temperature based", + "netcdf file": "data/cross_sections/HCFC22_JPL06.nc", + "parameterization wavelength grid": { + "name": "custom wavelengths", + "type": "from config file", + "units": "nm", + "values": [ + 169.0, 171.0, 173.0, 175.0, 177.0, 179.0, 181.0, 183.0, 185.0, + 187.0, 189.0, 191.0, 193.0, 195.0, 197.0, 199.0, 201.0, 203.0, + 205.0, 207.0, 209.0, 211.0, 213.0, 215.0, 217.0, 219.0, 221.0 + ] + }, + "parameterization": { + "AA": [ -106.029, 1.5038, -8.2476e-3, 1.4206e-5 ], + "BB": [ -1.3399e-1, 2.7405e-3, -1.8028e-5, 3.8504e-8 ], + "lp": [ 0.0, 1.0, 2.0, 3.0 ], + "minimum wavelength": 174.0, + "maximum wavelength": 204.0, + "base temperature": 273.0, + "base wavelength": 0.0, + "logarithm": "base 10", + "temperature ranges": [ + { + "maximum": 209.999999999999, + "fixed value": 210.0 + }, + { + "minimum": 210.0, + "maximum": 300.0 + }, + { + "minimum": 300.00000000001, + "fixed value": 300.0 + } + ] + } + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + }, + "label": "HCFC22 + hv -> Cl", + "tolerance": 1.0e-3, + "__note": "excluding upper edge of interpolation, which has a small value", + "mask": [ { "index": 43 } ] + }, + { + "cross section": { + "type": "temperature based", + "netcdf file": "data/cross_sections/HCFC141b_JPL10.nc", + "parameterization": { + "AA": [ -682.913042, 12.122290, -8.187699e-2, 2.437244e-4, -2.719103e-7 ], + "BB": [ 4.074747, -8.053899e-2, 5.946552e-4, -1.945048e-6, 2.380143e-9 ], + "lp": [ 0.0, 1.0, 2.0, 3.0, 4.0 ], + "minimum wavelength": 172.0, + "maximum wavelength": 240.0, + "base temperature": 273.0, + "base wavelength": 0.0, + "logarithm": "base 10", + "temperature ranges": [ + { + "maximum": 209.999999999999, + "fixed value": 210.0 + }, + { + "minimum": 210.0, + "maximum": 300.0 + }, + { + "minimum": 300.00000000001, + "fixed value": 300.0 + } + ] + } + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + }, + "label": "HCFC141b + hv -> 2Cl", + "tolerance": 5.0e-3 + }, + { + "cross section": { + "type": "temperature based", + "netcdf file": "data/cross_sections/HCFC142b_JPL10.nc", + "parameterization": { + "AA": [ -328.092008, 6.342799, -4.810362e-2, 1.611991e-4, -2.042613e-7 ], + "BB": [ 4.289533e-1, -9.042817e-3, 7.018009e-5, -2.389064e-7, 3.039799e-10 ], + "lp": [ 0.0, 1.0, 2.0, 3.0, 4.0 ], + "minimum wavelength": 172.0, + "maximum wavelength": 230.0, + "base temperature": 273.0, + "base wavelength": 0.0, + "logarithm": "base 10", + "temperature ranges": [ + { + "maximum": 209.999999999999, + "fixed value": 210.0 + }, + { + "minimum": 210.0, + "maximum": 300.0 + }, + { + "minimum": 300.00000000001, + "fixed value": 300.0 + } + ] + } + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + }, + "label": "HCFC142b + hv -> Cl", + "tolerance": 1.0e-3 + }, + { + "cross section": { + "type": "temperature based", + "parameterization": { + "type": "TAYLOR_SERIES", + "netcdf file": { + "file path": "data/cross_sections/BRONO2_JPL06.nc" + }, + "base temperature": 296.0, + "temperature ranges": [ + { + "maximum": 199.999999999999, + "fixed value": 200.0 + }, + { + "minimum": 200.0, + "maximum": 296.0 + }, + { + "minimum": 296.00000000001, + "fixed value": 296.0 + } + ] + } + }, + "quantum yield": { + "type": "base", + "constant value": 0.85 + }, + "label": "BrONO2 + hv -> Br + NO3", + "__note": "first test: excluding edges of interpolation because of double vs float algorithms", + "mask": [{ "index": 97 }, { "index": 34 }] + }, + { + "cross section": { + "type": "temperature based", + "parameterization": { + "type": "TAYLOR_SERIES", + "netcdf file": { + "file path": "data/cross_sections/BRONO2_JPL06.nc" + }, + "base temperature": 296.0, + "temperature ranges": [ + { + "maximum": 199.999999999999, + "fixed value": 200.0 + }, + { + "minimum": 200.0, + "maximum": 296.0 + }, + { + "minimum": 296.00000000001, + "fixed value": 296.0 + } + ] + } + }, + "quantum yield": { + "type": "base", + "constant value": 0.85 + }, + "label": "BrONO2 + hv -> Br + NO3", + "__note": "second test: including edges of interpolation with relaxed tolerance", + "tolerance": 1.0e-3 + }, + { + "cross section": { + "type": "temperature based", + "parameterization": { + "type": "TAYLOR_SERIES", + "netcdf file": { + "file path": "data/cross_sections/BRONO2_JPL06.nc" + }, + "base temperature": 296.0, + "temperature ranges": [ + { + "maximum": 199.999999999999, + "fixed value": 200.0 + }, + { + "minimum": 200.0, + "maximum": 296.0 + }, + { + "minimum": 296.00000000001, + "fixed value": 296.0 + } + ] + } + }, + "quantum yield": { + "type": "base", + "constant value": 0.15 + }, + "label": "BrONO2 + hv -> BrO + NO2", + "__note": "first test: excluding edges of interpolation because of double vs float algorithms", + "mask": [{ "index": 97 }, { "index": 34 }] + }, + { + "cross section": { + "type": "temperature based", + "parameterization": { + "type": "TAYLOR_SERIES", + "netcdf file": { + "file path": "data/cross_sections/BRONO2_JPL06.nc" + }, + "base temperature": 296.0, + "temperature ranges": [ + { + "maximum": 199.999999999999, + "fixed value": 200.0 + }, + { + "minimum": 200.0, + "maximum": 296.0 + }, + { + "minimum": 296.00000000001, + "fixed value": 296.0 + } + ] + } + }, + "quantum yield": { + "type": "base", + "constant value": 0.15 + }, + "label": "BrONO2 + hv -> BrO + NO2", + "__note": "second test: including edges of interpolation with relaxed tolerance", + "tolerance": 1.0e-3 + }, + { + "cross section": { + "type": "temperature based", + "netcdf file": "data/cross_sections/HO2NO2_JPL06.nc", + "parameterization": { + "type": "BURKHOLDER", + "netcdf file": { + "file path": "data/cross_sections/HO2NO2_temp_JPL06.nc" + }, + "A": -988.0, + "B": 0.69, + "temperature ranges": [ + { + "maximum": 279.999999999999, + "fixed value": 280.0 + }, + { + "minimum": 280.0, + "maximum": 350.0 + }, + { + "minimum": 350.00000000001, + "fixed value": 350.0 + } + ] + } + }, + "quantum yield": { + "type": "base", + "constant value": 0.30, + "override bands": [ + { + "band": "range", + "minimum wavelength": 200.0, + "value": 0.20 + } + ] + }, + "label": "HO2NO2 + hv -> OH + NO3", + "__note": "first test: excluding edges of interpolation because of double vs float algorithms", + "tolerance": 1.0e-5, + "mask": [ { "index": 29 }, { "index": 78 }, { "index": 79 } ] + }, + { + "cross section": { + "type": "temperature based", + "netcdf file": "data/cross_sections/HO2NO2_JPL06.nc", + "parameterization": { + "type": "BURKHOLDER", + "netcdf file": { + "file path": "data/cross_sections/HO2NO2_temp_JPL06.nc" + }, + "A": -988.0, + "B": 0.69, + "temperature ranges": [ + { + "maximum": 279.999999999999, + "fixed value": 280.0 + }, + { + "minimum": 280.0, + "maximum": 350.0 + }, + { + "minimum": 350.00000000001, + "fixed value": 350.0 + } + ] + } + }, + "quantum yield": { + "type": "base", + "constant value": 0.30, + "override bands": [ + { + "band": "range", + "minimum wavelength": 200.0, + "value": 0.20 + } + ] + }, + "label": "HO2NO2 + hv -> OH + NO3", + "__note": "second test: including edges of interpolation with relaxed tolerance", + "tolerance": 1.0e-3, + "mask": [ { "index": 79 } ] + }, + { + "cross section": { + "type": "temperature based", + "netcdf file": "data/cross_sections/HO2NO2_JPL06.nc", + "parameterization": { + "type": "BURKHOLDER", + "netcdf file": { + "file path": "data/cross_sections/HO2NO2_temp_JPL06.nc" + }, + "A": -988.0, + "B": 0.69, + "temperature ranges": [ + { + "maximum": 279.999999999999, + "fixed value": 280.0 + }, + { + "minimum": 280.0, + "maximum": 350.0 + }, + { + "minimum": 350.00000000001, + "fixed value": 350.0 + } + ] + } + }, + "quantum yield": { + "type": "base", + "constant value": 0.70, + "override bands": [ + { + "band": "range", + "minimum wavelength": 200.0, + "value": 0.80 + } + ] + }, + "label": "HO2NO2 + hv -> HO2 + NO2", + "__note": "first test: excluding edges of interpolation because of double vs float algorithms", + "tolerance": 1.0e-5, + "mask": [ { "index": 29 }, { "index": 78 }, { "index": 79 } ] + }, + { + "cross section": { + "type": "temperature based", + "netcdf file": "data/cross_sections/HO2NO2_JPL06.nc", + "parameterization": { + "type": "BURKHOLDER", + "netcdf file": { + "file path": "data/cross_sections/HO2NO2_temp_JPL06.nc" + }, + "A": -988.0, + "B": 0.69, + "temperature ranges": [ + { + "maximum": 279.999999999999, + "fixed value": 280.0 + }, + { + "minimum": 280.0, + "maximum": 350.0 + }, + { + "minimum": 350.00000000001, + "fixed value": 350.0 + } + ] + } + }, + "quantum yield": { + "type": "base", + "constant value": 0.70, + "override bands": [ + { + "band": "range", + "minimum wavelength": 200.0, + "value": 0.80 + } + ] + }, + "label": "HO2NO2 + hv -> HO2 + NO2", + "__note": "second test: including edges of interpolation with relaxed tolerance", + "tolerance": 1.0e-3, + "mask": [ { "index": 79 } ] + }, + { + "cross section": { + "type": "temperature based", + "netcdf file": "data/cross_sections/CH3CL_JPL06.nc", + "parameterization": { + "AA": [ -299.80, 5.1047, -3.3630e-2, 9.5805e-5, -1.0135e-7 ], + "BB": [ -7.1727, 1.4837e-1, -1.1463e-3, 3.9188e-6, -4.9994e-9 ], + "lp": [ 0.0, 1.0, 2.0, 3.0, 4.0 ], + "minimum wavelength": 174.1, + "maximum wavelength": 216.0, + "base temperature": 273.0, + "base wavelength": 0.0, + "logarithm": "base 10", + "temperature ranges": [ + { + "maximum": 209.999999999999, + "fixed value": 210.0 + }, + { + "minimum": 210, + "maximum": 300 + }, + { + "minimum": 300.00000000001, + "fixed value": 300.0 + } + ] + } + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + }, + "label": "CH3Cl + hv -> Cl", + "tolerance": 5.0e-3 + }, + { + "cross section": { + "type": "base", + "netcdf files": [ + { "file path": "data/cross_sections/SO2_Mills.nc" } + ] + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + }, + "label": "SO2 + hv -> SO + O", + "tolerance": 1.0e-4 + }, + { + "cross section": { + "type":"temperature based", + "netcdf file": "data/cross_sections/N2O5_JPL06.nc", + "parameterization": { + "type": "HARWOOD", + "aa": [ -18.27, -18.42, -18.59, -18.72, -18.84, + -18.90, -18.93, -18.87, -18.77, -18.71, + -18.31, -18.14, -18.01, -18.42, -18.59, + -18.13 ], + "bb": [ -91.0, -104.0, -112.0, -135.0, -170.0, + -226.0, -294.0, -388.0, -492.0, -583.0, + -770.0, -885.0, -992.0, -949.0, -966.0, + -1160.0 ], + "base temperature": 0.0, + "base wavelength": 0.0, + "logarithm": "base 10", + "minimum wavelength": 260.0, + "maximum wavelength": 410.0, + "temperature ranges": [ + { + "maximum": 199.999999999999, + "fixed value": 200 + }, + { + "minimum": 200, + "maximum": 295 + }, + { + "minimum": 295.00000000001, + "fixed value": 295.0 + } + ] + }, + "parameterization wavelength grid": { + "name": "custom wavelengths", + "type": "from config file", + "units": "nm", + "values": [ + 255.0, 265.0, 275.0, 285.0, 295.0, 305.0, + 315.0, 325.0, 335.0, 345.0, 355.0, 365.0, + 375.0, 385.0, 395.0, 405.0, 415.0 + ] + } + }, + "quantum yield": { + "type": "Taylor series", + "constant value": 0.0, + "coefficients": [ -2.832441, 0.012809638 ], + "override bands": [ + { + "band": "range", + "minimum wavelength": 300.0, + "value": 1.0 + } + ] + }, + "label": "N2O5 + hv -> NO3 + NO2", + "tolerance": 1.0e-3, + "mask": [ { "index": 93 } ] + }, + { + "cross section": { + "type":"temperature based", + "netcdf file": "data/cross_sections/N2O5_JPL06.nc", + "parameterization": { + "type": "HARWOOD", + "aa": [ -18.27, -18.42, -18.59, -18.72, -18.84, + -18.90, -18.93, -18.87, -18.77, -18.71, + -18.31, -18.14, -18.01, -18.42, -18.59, + -18.13 ], + "bb": [ -91.0, -104.0, -112.0, -135.0, -170.0, + -226.0, -294.0, -388.0, -492.0, -583.0, + -770.0, -885.0, -992.0, -949.0, -966.0, + -1160.0 ], + "base temperature": 0.0, + "base wavelength": 0.0, + "logarithm": "base 10", + "minimum wavelength": 260.0, + "maximum wavelength": 410.0, + "temperature ranges": [ + { + "maximum": 199.999999999999, + "fixed value": 200 + }, + { + "minimum": 200, + "maximum": 295 + }, + { + "minimum": 295.00000000001, + "fixed value": 295.0 + } + ] + }, + "parameterization wavelength grid": { + "name": "custom wavelengths", + "type": "from config file", + "units": "nm", + "values": [ + 255.0, 265.0, 275.0, 285.0, 295.0, 305.0, + 315.0, 325.0, 335.0, 345.0, 355.0, 365.0, + 375.0, 385.0, 395.0, 405.0, 415.0 + ] + } + }, + "quantum yield": { + "type": "Taylor series", + "constant value": 0.0, + "coefficients": [ -2.832441, 0.012809638 ], + "override bands": [ + { + "band": "range", + "minimum wavelength": 300.0, + "value": 1.0 + } + ] + }, + "label": "N2O5 + hv -> NO3 + NO2", + "tolerance": 1.0e-2 + }, + { + "cross section": { + "type":"temperature based", + "netcdf file": "data/cross_sections/N2O5_JPL06.nc", + "parameterization": { + "type": "HARWOOD", + "aa": [ -18.27, -18.42, -18.59, -18.72, -18.84, + -18.90, -18.93, -18.87, -18.77, -18.71, + -18.31, -18.14, -18.01, -18.42, -18.59, + -18.13 ], + "bb": [ -91.0, -104.0, -112.0, -135.0, -170.0, + -226.0, -294.0, -388.0, -492.0, -583.0, + -770.0, -885.0, -992.0, -949.0, -966.0, + -1160.0 ], + "base temperature": 0.0, + "base wavelength": 0.0, + "logarithm": "base 10", + "minimum wavelength": 260.0, + "maximum wavelength": 410.0, + "temperature ranges": [ + { + "maximum": 199.999999999999, + "fixed value": 200 + }, + { + "minimum": 200, + "maximum": 295 + }, + { + "minimum": 295.00000000001, + "fixed value": 295.0 + } + ] + }, + "parameterization wavelength grid": { + "name": "custom wavelengths", + "type": "from config file", + "units": "nm", + "values": [ + 255.0, 265.0, 275.0, 285.0, 295.0, 305.0, + 315.0, 325.0, 335.0, 345.0, 355.0, 365.0, + 375.0, 385.0, 395.0, 405.0, 415.0 + ] + } + }, + "quantum yield": { + "type": "Taylor series", + "constant value": 0.0, + "coefficients": [ 3.832441, -0.012809638 ], + "override bands": [ + { + "band": "range", + "minimum wavelength": 300.0, + "value": 0.0 + } + ] + }, + "label": "N2O5 + hv -> NO3 + NO + O", + "tolerance": 1.0e-3, + "mask": [ { "index": 93 } ] + }, + { + "cross section": { + "type":"temperature based", + "netcdf file": "data/cross_sections/N2O5_JPL06.nc", + "parameterization": { + "type": "HARWOOD", + "aa": [ -18.27, -18.42, -18.59, -18.72, -18.84, + -18.90, -18.93, -18.87, -18.77, -18.71, + -18.31, -18.14, -18.01, -18.42, -18.59, + -18.13 ], + "bb": [ -91.0, -104.0, -112.0, -135.0, -170.0, + -226.0, -294.0, -388.0, -492.0, -583.0, + -770.0, -885.0, -992.0, -949.0, -966.0, + -1160.0 ], + "base temperature": 0.0, + "base wavelength": 0.0, + "logarithm": "base 10", + "minimum wavelength": 260.0, + "maximum wavelength": 410.0, + "temperature ranges": [ + { + "maximum": 199.999999999999, + "fixed value": 200 + }, + { + "minimum": 200, + "maximum": 295 + }, + { + "minimum": 295.00000000001, + "fixed value": 295.0 + } + ] + }, + "parameterization wavelength grid": { + "name": "custom wavelengths", + "type": "from config file", + "units": "nm", + "values": [ + 255.0, 265.0, 275.0, 285.0, 295.0, 305.0, + 315.0, 325.0, 335.0, 345.0, 355.0, 365.0, + 375.0, 385.0, 395.0, 405.0, 415.0 + ] + } + }, + "quantum yield": { + "type": "Taylor series", + "constant value": 0.0, + "coefficients": [ 3.832441, -0.012809638 ], + "override bands": [ + { + "band": "range", + "minimum wavelength": 300.0, + "value": 0.0 + } + ] + }, + "label": "N2O5 + hv -> NO3 + NO + O", + "tolerance": 1.0e-2 + }, + { + "cross section": { + "type": "temperature based", + "parameterization": { + "type": "TAYLOR_SERIES", + "netcdf file": { + "file path": "data/cross_sections/ACETONE_JPL06.nc" + }, + "base temperature": 0.0, + "temperature ranges": [ + { + "maximum": 234.999999999999, + "fixed value": 235.0 + }, + { + "minimum": 235.0, + "maximum": 298.0 + }, + { + "minimum": 298.00000000001, + "fixed value": 298.0 + } + ] + } + }, + "quantum yield": { + "type": "CH3COCH3+hv->CH3CO+CH3", + "low wavelength value": 1, + "minimum temperature": 218, + "maximum temperature": 295 + }, + "label": "CH3COCH3 + hv -> CH3CO3 + CH3O2", + "__note": "quantum yield parameterization includes multiple chained exponentials and single vs double precision seems to be quite different", + "tolerance": 2 + }, + { + "cross section": { + "type": "temperature based", + "parameterization": { + "type": "TAYLOR_SERIES", + "netcdf file": { + "file path": "data/cross_sections/ACETONE_JPL06.nc" + }, + "base temperature": 0.0, + "temperature ranges": [ + { + "maximum": 234.999999999999, + "fixed value": 235.0 + }, + { + "minimum": 235.0, + "maximum": 298.0 + }, + { + "minimum": 298.00000000001, + "fixed value": 298.0 + } + ] + } + }, + "quantum yield": { + "type": "CH3COCH3+hv->CH3CO+CH3", + "branch": "CO+CH3CO", + "low wavelength value": 1, + "minimum temperature": 218, + "maximum temperature": 295 + }, + "label": "CH3COCH3 + hv -> CH3CO3 + CH3O2", + "__note": "quantum yield parameterization includes multiple chained exponentials and single vs double precision seems to be quite different", + "tolerance": 1.0e-3 } ] diff --git a/test/json_yaml_compare.py b/test/json_yaml_compare.py new file mode 100644 index 00000000..b22dddcb --- /dev/null +++ b/test/json_yaml_compare.py @@ -0,0 +1,26 @@ +import os +import filecmp +import sys + +def compare_files(file_name, folder_path1, folder_path2): + file1 = os.path.join(folder_path1, file_name) + file2 = os.path.join(folder_path2, file_name) + + if os.path.isfile(file1) and os.path.isfile(file2): + if filecmp.cmp(file1, file2): + print("The files are equal.") + else: + print("The files are not equal.") + return 1 # Return a failure code + else: + print("One or both files do not exist.") + return 1 # Return a failure code + +if __name__ == "__main__": + if len(sys.argv) != 3: + print("Usage: python script.py ") + else: + folder_path1 = sys.argv[1] + folder_path2 = sys.argv[2] + compare_files("photolysis_rate_constants.nc", folder_path1, folder_path2) + compare_files("dose_rates.nc", folder_path1, folder_path2) diff --git a/test/oldtuv/CMakeLists.txt b/test/oldtuv/CMakeLists.txt index 2be3bff6..e0a9f406 100644 --- a/test/oldtuv/CMakeLists.txt +++ b/test/oldtuv/CMakeLists.txt @@ -97,7 +97,7 @@ add_subdirectory(util) add_subdirectory(Profile) add_library(oldphotolib ${PHOTO_SRC} ${GRID_SRC} ${PROFILE_SRC} ${CROSS_SRC} ${QY_SRC} ${RADIATOR_SRC} ${RAD_SRC} ${SW_SRC} ${UTIL_SRC}) -target_link_libraries(oldphotolib musica::musicacore ${NETCDF_LIBS} ${JSON_LIB}) +target_link_libraries(oldphotolib musica::tuvx ${NETCDF_LIBS}) set_target_properties(oldphotolib PROPERTIES OUTPUT_NAME oldphoto) add_executable(oldtuv tuv.f) diff --git a/test/oldtuv/Profile/Profile_factory.F90 b/test/oldtuv/Profile/Profile_factory.F90 index a617332e..3d448806 100644 --- a/test/oldtuv/Profile/Profile_factory.F90 +++ b/test/oldtuv/Profile/Profile_factory.F90 @@ -45,8 +45,6 @@ function Profile_builder( config, gridWareHouse ) result( new_Profile_t ) character(len=*), parameter :: Iam = 'Profile builder: ' type(string_t) :: Profile_type - write(*,*) Iam,'entering' - new_Profile_t => null() call config%get( 'Profile type', Profile_type, Iam ) @@ -73,8 +71,6 @@ function Profile_builder( config, gridWareHouse ) result( new_Profile_t ) call new_Profile_t%initialize( config, gridWareHouse ) - write(*,*) Iam,'exiting' - end function Profile_builder !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/test/oldtuv/Profile/Profile_warehouse.F90 b/test/oldtuv/Profile/Profile_warehouse.F90 index 8f0d7500..2ce6f39a 100644 --- a/test/oldtuv/Profile/Profile_warehouse.F90 +++ b/test/oldtuv/Profile/Profile_warehouse.F90 @@ -62,8 +62,6 @@ function constructor( config, gridwarehouse ) result( Profile_warehouse_obj ) character(len=32) :: keychar type(string_t) :: aswkey - write(*,*) Iam // 'entering' - allocate( Profile_warehouse_obj ) associate(new_obj=>Profile_warehouse_obj) @@ -78,8 +76,6 @@ function constructor( config, gridwarehouse ) result( Profile_warehouse_obj ) do while( iter%next() ) keychar = Profile_set%key(iter) aswkey = keychar - write(*,*) ' ' - write(*,*) Iam,'key = ',trim(keychar) call Profile_set%get( iter, Profile_config, Iam ) call Profile_config%add( 'Handle', aswkey, Iam ) !----------------------------------------------------------------------------- @@ -91,13 +87,8 @@ function constructor( config, gridwarehouse ) result( Profile_warehouse_obj ) deallocate( iter ) - write(*,*) ' ' - write(*,'(a,''There are '',i3,'' Profile objects'')') Iam,size(new_obj%Profile_objs_) - end associate - write(*,*) Iam // 'exiting' - end function constructor !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -121,9 +112,6 @@ function get_Profile( this, Profile_handle ) result( Profile_ptr ) integer(ik) :: ndx logical(lk) :: found - write(*,*) ' ' - write(*,*) Iam,'entering' - found = .false._lk do ndx = 1,size(this%Profile_objs_) if( Profile_handle .eq. this%Profile_objs_(ndx)%ptr_%handle_ ) then @@ -138,8 +126,6 @@ function get_Profile( this, Profile_handle ) result( Profile_ptr ) call die_msg( 460768214, "Invalid Profile handle: '"// Profile_handle%to_char()//"'" ) endif - write(*,*) Iam,'exiting' - end function get_Profile !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -156,14 +142,10 @@ subroutine finalize( this ) integer(kind=ik) :: ndx character(len=*), parameter :: Iam = 'Profile warehouse finalize: ' - write(*,*) Iam,'entering' - if( allocated( this%Profile_objs_ ) ) then deallocate( this%Profile_objs_ ) endif - write(*,*) Iam,'exiting' - end subroutine finalize !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/test/oldtuv/Profile/air.from_csv_file.type.F90 b/test/oldtuv/Profile/air.from_csv_file.type.F90 index e8285cf3..d6e0c0f7 100644 --- a/test/oldtuv/Profile/air.from_csv_file.type.F90 +++ b/test/oldtuv/Profile/air.from_csv_file.type.F90 @@ -54,8 +54,6 @@ subroutine initialize( this, profile_config, gridWareHouse ) class(abs_interpolator_t), pointer :: theInterpolator class(base_grid_t), pointer :: zGrid - write(*,*) Iam // 'entering' - !> Get the configuration settings call profile_config%get( 'Filespec', Filespec, Iam ) call profile_config%get( 'Handle', this%handle_, Iam, default = 'None' ) @@ -128,16 +126,6 @@ subroutine initialize( this, profile_config, gridWareHouse ) this%edge_val_ = theInterpolator%interpolate( zGrid%edge_, zdata,airlog ) this%edge_val_ = exp( this%edge_val_ ) - write(*,*) ' ' - write(*,*) Iam // 'data z grid' - write(*,'(1p10g15.7)') zdata - write(*,*) ' ' - write(*,*) Iam // this%handle_%to_char() // ' on data z grid' - write(*,'(1p10g15.7)') Profile - write(*,*) ' ' - write(*,*) Iam // this%handle_%to_char() // ' @ mdl z grid edges' - write(*,'(1p10g15.7)') this%edge_val_ - this%mid_val_ = .5_dk & *(this%edge_val_(1_ik:this%ncells_) + this%edge_val_(2_ik:this%ncells_+1_ik)) this%delta_val_ = (this%edge_val_(2_ik:this%ncells_+1_ik) - this%edge_val_(1_ik:this%ncells_)) @@ -154,8 +142,6 @@ subroutine initialize( this, profile_config, gridWareHouse ) this%burden_dens_(k) = accum enddo - write(*,*) Iam // 'exiting' - end subroutine initialize subroutine finalize( this ) diff --git a/test/oldtuv/Profile/from_csv_file.type.F90 b/test/oldtuv/Profile/from_csv_file.type.F90 index a3cefea9..a16d0a27 100644 --- a/test/oldtuv/Profile/from_csv_file.type.F90 +++ b/test/oldtuv/Profile/from_csv_file.type.F90 @@ -52,8 +52,6 @@ subroutine initialize( this, profile_config, gridWareHouse ) type(string_t) :: Handle class(abs_interpolator_t), pointer :: theInterpolator - write(*,*) Iam // 'entering' - !> Get the configuration settings call profile_config%get( 'Filespec', Filespec, Iam ) call profile_config%get( 'Handle', this%handle_, Iam, default = 'None' ) @@ -122,24 +120,12 @@ subroutine initialize( this, profile_config, gridWareHouse ) this%edge_val_ = theInterpolator%interpolate( zGrid%edge_, zdata,Profile ) - write(*,*) ' ' - write(*,*) Iam // 'data z grid' - write(*,'(1p10g15.7)') zdata - write(*,*) ' ' - write(*,*) Iam // this%handle_%to_char() // ' on data z grid' - write(*,'(1p10g15.7)') Profile - write(*,*) ' ' - write(*,*) Iam // this%handle_%to_char() // ' @ mdl z grid edges' - write(*,'(1p10g15.7)') this%edge_val_ - this%mid_val_ = .5_dk & *(this%edge_val_(1_ik:this%ncells_) + this%edge_val_(2_ik:this%ncells_+1_ik)) this%delta_val_ = (this%edge_val_(2_ik:this%ncells_+1_ik) - this%edge_val_(1_ik:this%ncells_)) this%layer_dens_ = this%mid_val_ * zGrid%delta_ * km2cm this%layer_dens_(this%ncells_) = this%layer_dens_(this%ncells_) + this%edge_val_(this%ncells_+1_ik) * this%hscale_ * km2cm - write(*,*) Iam // 'exiting' - end subroutine initialize subroutine finalize( this ) diff --git a/test/oldtuv/Profile/holdingtank/from_csv_file.type.F90 b/test/oldtuv/Profile/holdingtank/from_csv_file.type.F90 index 9cf15a9b..4948119c 100644 --- a/test/oldtuv/Profile/holdingtank/from_csv_file.type.F90 +++ b/test/oldtuv/Profile/holdingtank/from_csv_file.type.F90 @@ -44,8 +44,6 @@ subroutine initialize( this, profile_config, zGrid ) character(len=132) :: InputLine type(string_t) :: Filespec - write(*,*) Iam // 'entering' - !> Get the configuration settings call profile_config%get( 'Filespec', Filespec, Iam ) call profile_config%get( 'Handle', this%handle_, Iam, default = 'None' ) @@ -94,16 +92,6 @@ subroutine initialize( this, profile_config, zGrid ) allocate( this%edge_val_(this%ncells_+1_ik) ) this%edge_val_ = this%inter1( zGrid, zdata,Profile ) - write(*,*) ' ' - write(*,*) Iam // 'data z grid' - write(*,'(1p10g15.7)') zdata - write(*,*) ' ' - write(*,*) Iam // this%handle_%to_char() // ' on data z grid' - write(*,'(1p10g15.7)') Profile - write(*,*) ' ' - write(*,*) Iam // this%handle_%to_char() // ' @ mdl z grid edges' - write(*,'(1p10g15.7)') this%edge_val_ - allocate( this%mid_val_(this%ncells_) ) allocate( this%delta_val_(this%ncells_) ) this%mid_val_(:) = .5_dk & @@ -112,8 +100,6 @@ subroutine initialize( this, profile_config, zGrid ) close(unit=inUnit) - write(*,*) Iam // 'exiting' - end subroutine initialize end module micm_from_csv_file_vert_Profile diff --git a/test/oldtuv/Profile/o2.from_csv_file.type.F90 b/test/oldtuv/Profile/o2.from_csv_file.type.F90 index a4333e15..3c83c418 100644 --- a/test/oldtuv/Profile/o2.from_csv_file.type.F90 +++ b/test/oldtuv/Profile/o2.from_csv_file.type.F90 @@ -55,8 +55,6 @@ subroutine initialize( this, profile_config, gridWareHouse ) class(abs_interpolator_t), pointer :: theInterpolator class(base_grid_t), pointer :: zGrid - write(*,*) Iam // 'entering' - !> Get the configuration settings call profile_config%get( 'Filespec', Filespec, Iam ) call profile_config%get( 'Handle', this%handle_, Iam, default = 'None' ) @@ -130,16 +128,6 @@ subroutine initialize( this, profile_config, gridWareHouse ) this%edge_val_ = exp( this%edge_val_ ) this%edge_val_ = o2Vmr * this%edge_val_ - write(*,*) ' ' - write(*,*) Iam // 'data z grid' - write(*,'(1p10g15.7)') zdata - write(*,*) ' ' - write(*,*) Iam // this%handle_%to_char() // ' on data z grid' - write(*,'(1p10g15.7)') Profile - write(*,*) ' ' - write(*,*) Iam // this%handle_%to_char() // ' @ mdl z grid edges' - write(*,'(1p10g15.7)') this%edge_val_ - this%mid_val_ = .5_dk & *(this%edge_val_(1_ik:this%ncells_) + this%edge_val_(2_ik:this%ncells_+1_ik)) this%delta_val_ = (this%edge_val_(2_ik:this%ncells_+1_ik) - this%edge_val_(1_ik:this%ncells_)) @@ -149,8 +137,6 @@ subroutine initialize( this, profile_config, gridWareHouse ) this%exo_layer_dens_ = [this%layer_dens_,exo_layer_dens] this%layer_dens_(this%ncells_) = this%layer_dens_(this%ncells_) + exo_layer_dens - write(*,*) Iam // 'exiting' - end subroutine initialize subroutine finalize( this ) diff --git a/test/oldtuv/Profile/o3.from_csv_file.type.F90 b/test/oldtuv/Profile/o3.from_csv_file.type.F90 index f8f7ec45..3bc8b293 100644 --- a/test/oldtuv/Profile/o3.from_csv_file.type.F90 +++ b/test/oldtuv/Profile/o3.from_csv_file.type.F90 @@ -57,8 +57,6 @@ subroutine initialize( this, profile_config, gridWareHouse ) class(abs_interpolator_t), pointer :: theInterpolator class(base_grid_t), pointer :: zGrid - write(*,*) Iam // 'entering' - !> Get the configuration settings call profile_config%get( 'Filespec', Filespec, Iam ) call profile_config%get( 'Handle', this%handle_, Iam, default = 'None' ) @@ -145,13 +143,6 @@ subroutine initialize( this, profile_config, gridWareHouse ) this%edge_val_ = theInterpolator%interpolate( zGrid%edge_, zdata,Profile ) - write(*,*) ' ' - write(*,*) Iam // 'data z grid' - write(*,'(1p10g15.7)') zdata - write(*,*) ' ' - write(*,*) Iam // this%handle_%to_char() // ' on data z grid' - write(*,'(1p10g15.7)') Profile - this%mid_val_ = ONEHALF & *(this%edge_val_(iONE:this%ncells_) + this%edge_val_(iTWO:this%ncells_+iONE)) this%delta_val_ = (this%edge_val_(iTWO:this%ncells_+iONE) - this%edge_val_(iONE:this%ncells_)) @@ -171,12 +162,6 @@ subroutine initialize( this, profile_config, gridWareHouse ) endif endif - write(*,*) ' ' - write(*,*) Iam // this%handle_%to_char() // ' @ mdl z grid edges' - write(*,'(1p10g15.7)') this%edge_val_ - - write(*,*) Iam // 'exiting' - end subroutine initialize subroutine finalize( this ) diff --git a/test/oldtuv/Profile/sza_from_time.type.F90 b/test/oldtuv/Profile/sza_from_time.type.F90 index 07943e5e..cf93fe11 100644 --- a/test/oldtuv/Profile/sza_from_time.type.F90 +++ b/test/oldtuv/Profile/sza_from_time.type.F90 @@ -319,7 +319,6 @@ function szaFromTime( YEAR, DAY, HOUR, LAT, LONG ) result( solarElevation ) DELTA = YEAR - 1949_ik LEAP = DELTA / 4_ik JD = 32916.5_dk + real(DELTA*365_ik + LEAP + DAY,dk) + HOUR / Day2Hrs - write(*,*) 'szaFromTime: delta, leap, day, hour = ',delta, leap, day, hour ! ** last yr of century not leap yr unless divisible ! ** by 400 (not executed for the allowed YEAR range, @@ -338,8 +337,6 @@ function szaFromTime( YEAR, DAY, HOUR, LAT, LONG ) result( solarElevation ) MNLONG = MOD( MNLONG, THREE60 ) IF( MNLONG < rZERO ) MNLONG = MNLONG + THREE60 - write(*,*) 'szaFromTime: jd,time = ',jd,time - ! ** mean anomaly in radians between 0 and 2*pi MNANOM = 357.528_dk + 0.9856003_dk*TIME MNANOM = MOD( MNANOM, THREE60 ) @@ -358,8 +355,6 @@ function szaFromTime( YEAR, DAY, HOUR, LAT, LONG ) result( solarElevation ) ECLONG = ECLONG*d2r OBLQEC = OBLQEC*d2r - write(*,*) 'szaFromTime: mnlong,mnanom,eclong = ',mnlong,mnanom,eclong - ! ** right ascension NUM = COS( OBLQEC )*SIN( ECLONG ) DEN = COS( ECLONG ) @@ -374,7 +369,6 @@ function szaFromTime( YEAR, DAY, HOUR, LAT, LONG ) result( solarElevation ) ! ** declination DEC = ASIN( SIN( OBLQEC )*SIN( ECLONG ) ) - write(*,*) 'szaFromTime: oblqec, eclong = ',oblqec, eclong ! ** Greenwich mean sidereal time in hours GMST = 6.697375_dk + 0.0657098242_dk*TIME + HOUR @@ -402,7 +396,6 @@ function szaFromTime( YEAR, DAY, HOUR, LAT, LONG ) result( solarElevation ) ! ** solar elevation ! noon when HA = 0 - write(*,*) 'szaFromTime: dec,lat,ha = ',dec,lat,ha solarElevation = ASIN( SIN( DEC )*SIN( LAT*d2r ) + COS( DEC )*COS( LAT*d2r )*COS( HA ) ) ! ** Convert elevation to degrees diff --git a/test/oldtuv/cross_section/abstract.cross_section.type.F90 b/test/oldtuv/cross_section/abstract.cross_section.type.F90 index d7c04bba..0d8bb9d4 100644 --- a/test/oldtuv/cross_section/abstract.cross_section.type.F90 +++ b/test/oldtuv/cross_section/abstract.cross_section.type.F90 @@ -91,8 +91,6 @@ subroutine addpnts( this, config, data_lambda, data_parameter ) logical :: found character(len=:), allocatable :: number - write(*,*) Iam,'entering' - !> add endpoints to data arrays; first the lower bound nRows = size(data_lambda) lowerLambda = data_lambda(1) ; upperLambda = data_lambda(nRows) @@ -122,8 +120,6 @@ subroutine addpnts( this, config, data_lambda, data_parameter ) call addpnt(x=data_lambda,y=data_parameter,xnew=(rONE+deltax)*upperLambda,ynew=addpnt_val_upper) call addpnt(x=data_lambda,y=data_parameter,xnew=1.e38_musica_dk,ynew=addpnt_val_upper) - write(*,*) Iam,'exiting' - end subroutine addpnts end module micm_abs_cross_section_type diff --git a/test/oldtuv/cross_section/acetone-ch3co_ch3.cross_section.type.F90 b/test/oldtuv/cross_section/acetone-ch3co_ch3.cross_section.type.F90 index 87395df5..5c3f2636 100644 --- a/test/oldtuv/cross_section/acetone-ch3co_ch3.cross_section.type.F90 +++ b/test/oldtuv/cross_section/acetone-ch3co_ch3.cross_section.type.F90 @@ -61,8 +61,6 @@ function run( this, environment ) result( cross_section ) call die_msg( 500000001, msg ) endif - write(*,*) Iam,'exiting' - end function run end module micm_ch3coch3_ch3co_ch3_cross_section_type diff --git a/test/oldtuv/cross_section/base.cross_section.type.F90 b/test/oldtuv/cross_section/base.cross_section.type.F90 index 0fe33fcc..4b1e14b9 100644 --- a/test/oldtuv/cross_section/base.cross_section.type.F90 +++ b/test/oldtuv/cross_section/base.cross_section.type.F90 @@ -69,7 +69,6 @@ subroutine initialize( this, config, mdlLambdaEdge ) type(netcdf_t), allocatable :: netcdf_obj type(string_t), allocatable :: netcdfFiles(:) - write(*,*) Iam,'entering' !> set model wavelength array this%mdl_lambda_edge = mdlLambdaEdge nmdlLambda = size( this%mdl_lambda_edge ) @@ -115,8 +114,6 @@ subroutine initialize( this, config, mdlLambdaEdge ) enddo file_loop endif has_netcdf_file - write(*,*) Iam,'exiting' - end subroutine initialize !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -135,12 +132,8 @@ function run( this, environment ) result( cross_section ) character(len=*), parameter :: Iam = 'base cross section calculate: ' - write(*,*) Iam,'entering' - cross_section = this%cross_section(1)%array(:,1) - write(*,*) Iam,'exiting' - end function run !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -153,7 +146,6 @@ subroutine finalize( this ) character(len=*), parameter :: Iam = 'base cross section finalize: ' integer(musica_ik) :: ndx - write(*,*) Iam,'entering' if( allocated(this%cross_section) ) then do ndx = 1,size(this%cross_section) if( allocated(this%cross_section(ndx)%array ) ) then @@ -171,7 +163,6 @@ subroutine finalize( this ) if( allocated(this%mdl_lambda_center) ) then deallocate(this%mdl_lambda_center) endif - write(*,*) Iam,'exiting' end subroutine finalize diff --git a/test/oldtuv/cross_section/bro-br_o.cross_section.type.F90 b/test/oldtuv/cross_section/bro-br_o.cross_section.type.F90 index ef4f6e31..299b6dbe 100644 --- a/test/oldtuv/cross_section/bro-br_o.cross_section.type.F90 +++ b/test/oldtuv/cross_section/bro-br_o.cross_section.type.F90 @@ -57,7 +57,6 @@ subroutine initialize( this, config, mdlLambdaEdge ) type(netcdf_t), allocatable :: netcdf_obj type(string_t), allocatable :: netcdfFiles(:) - write(*,*) Iam,'entering' !> set model wavelength array this%mdl_lambda_edge = mdlLambdaEdge nmdlLambda = size( this%mdl_lambda_edge ) @@ -102,8 +101,6 @@ subroutine initialize( this, config, mdlLambdaEdge ) enddo file_loop endif has_netcdf_file - write(*,*) Iam,'exiting' - end subroutine initialize end module micm_bro_br_o_cross_section_type diff --git a/test/oldtuv/cross_section/ccl4.cross_section.type.F90 b/test/oldtuv/cross_section/ccl4.cross_section.type.F90 index aa49172f..7e63d8e5 100644 --- a/test/oldtuv/cross_section/ccl4.cross_section.type.F90 +++ b/test/oldtuv/cross_section/ccl4.cross_section.type.F90 @@ -50,8 +50,6 @@ function run( this, environment ) result( cross_section ) real(musica_dk) :: Temp, lambda, Wpoly real(musica_dk) :: w1, w2, w3, w4 - write(*,*) Iam,'entering' - Temp = max( min( 300._musica_dk,environment%temperature ),210._musica_dk ) Temp = Temp - 295._musica_dk do wNdx = 1,size(this%mdl_lambda_center) @@ -67,8 +65,6 @@ function run( this, environment ) result( cross_section ) endif enddo - write(*,*) Iam,'exiting' - end function run end module micm_ccl4_cross_section_type diff --git a/test/oldtuv/cross_section/cfc-11.cross_section.type.F90 b/test/oldtuv/cross_section/cfc-11.cross_section.type.F90 index 832b6670..3341568d 100644 --- a/test/oldtuv/cross_section/cfc-11.cross_section.type.F90 +++ b/test/oldtuv/cross_section/cfc-11.cross_section.type.F90 @@ -42,13 +42,9 @@ function run( this, environment ) result( cross_section ) character(len=*), parameter :: Iam = 'cfc-11->Products cross section run: ' real(musica_dk) :: Temp - write(*,*) Iam,'entering' - Temp = 1.e-4_musica_dk*(environment%temperature - 298._musica_dk) cross_section = this%cross_section(1)%array(:,1)*exp( (this%mdl_lambda_center(:) - 184.9_musica_dk)*Temp ) - write(*,*) Iam,'exiting' - end function run end module micm_cfc11_cross_section_type diff --git a/test/oldtuv/cross_section/ch2o.cross_section.type.F90 b/test/oldtuv/cross_section/ch2o.cross_section.type.F90 index db7cd8a3..cacbe059 100644 --- a/test/oldtuv/cross_section/ch2o.cross_section.type.F90 +++ b/test/oldtuv/cross_section/ch2o.cross_section.type.F90 @@ -44,8 +44,6 @@ function run( this, environment ) result( cross_section ) Tadj = environment%temperature - 298._musica_dk cross_section = this%cross_section(1)%array(:,1) + this%cross_section(1)%array(:,2) * Tadj - write(*,*) Iam,'exiting' - end function run end module micm_ch2o_cross_section_type diff --git a/test/oldtuv/cross_section/ch3ono2-ch3o_no2.cross_section.type.F90 b/test/oldtuv/cross_section/ch3ono2-ch3o_no2.cross_section.type.F90 index 37aefd0a..2cc77020 100644 --- a/test/oldtuv/cross_section/ch3ono2-ch3o_no2.cross_section.type.F90 +++ b/test/oldtuv/cross_section/ch3ono2-ch3o_no2.cross_section.type.F90 @@ -42,13 +42,9 @@ function run( this, environment ) result( cross_section ) character(len=*), parameter :: Iam = 'ch3ono2->ch3o+no2 cross section run: ' real(musica_dk) :: Temp - write(*,*) Iam,'entering' - Temp = environment%temperature - 298._musica_dk cross_section = this%cross_section(1)%array(:,1)*exp( this%cross_section(1)%array(:,2)*Temp ) - write(*,*) Iam,'exiting' - end function run end module micm_ch3ono2_ch3o_no2_cross_section_type diff --git a/test/oldtuv/cross_section/chbr3.cross_section.type.F90 b/test/oldtuv/cross_section/chbr3.cross_section.type.F90 index aa0d2851..7e8d7120 100644 --- a/test/oldtuv/cross_section/chbr3.cross_section.type.F90 +++ b/test/oldtuv/cross_section/chbr3.cross_section.type.F90 @@ -48,8 +48,6 @@ function run( this, environment ) result( cross_section ) integer(musica_ik) :: wNdx real(musica_dk) :: wc, Temp, lambda - write(*,*) Iam,'entering' - do wNdx = 1,size(this%mdl_lambda_center) Temp = environment%temperature lambda = this%mdl_lambda_center(wNdx) @@ -62,8 +60,6 @@ function run( this, environment ) result( cross_section ) endif enddo - write(*,*) Iam,'exiting' - end function run end module micm_chbr3_cross_section_type diff --git a/test/oldtuv/cross_section/chcl3.cross_section.type.F90 b/test/oldtuv/cross_section/chcl3.cross_section.type.F90 index 969c8428..44bd7e67 100644 --- a/test/oldtuv/cross_section/chcl3.cross_section.type.F90 +++ b/test/oldtuv/cross_section/chcl3.cross_section.type.F90 @@ -51,8 +51,6 @@ function run( this, environment ) result( cross_section ) integer(musica_ik) :: wndx real(musica_dk) :: w1, w2, w3, w4, tcoeff, Tadj - write(*,*) Iam,'entering' - associate( wc => this%mdl_lambda_center, Temp => environment%temperature ) Tadj = min(max(Temp,210._musica_dk),300._musica_dk) - 295._musica_dk do wNdx = 1,size(wc) @@ -69,8 +67,6 @@ function run( this, environment ) result( cross_section ) enddo end associate - write(*,*) Iam,'exiting' - end function run end module micm_chcl3_cross_section_type diff --git a/test/oldtuv/cross_section/cl2-cl_cl.cross_section.type.F90 b/test/oldtuv/cross_section/cl2-cl_cl.cross_section.type.F90 index d87529cc..5b3bbdc4 100644 --- a/test/oldtuv/cross_section/cl2-cl_cl.cross_section.type.F90 +++ b/test/oldtuv/cross_section/cl2-cl_cl.cross_section.type.F90 @@ -43,8 +43,6 @@ function run( this, environment ) result( cross_section ) integer(musica_ik) :: wNdx real(musica_dk) :: aa, bb, bbsq, alpha, ex1, ex2 - write(*,*) Iam,'entering' - aa = 402.7_musica_dk/environment%temperature bb = exp( aa ) bbsq = bb * bb @@ -58,8 +56,6 @@ function run( this, environment ) result( cross_section ) enddo end associate - write(*,*) Iam,'exiting' - end function run end module micm_cl2_cl_cl_cross_section_type diff --git a/test/oldtuv/cross_section/clono2.cross_section.type.F90 b/test/oldtuv/cross_section/clono2.cross_section.type.F90 index d7a9f932..c467e8f3 100644 --- a/test/oldtuv/cross_section/clono2.cross_section.type.F90 +++ b/test/oldtuv/cross_section/clono2.cross_section.type.F90 @@ -45,16 +45,12 @@ function run( this, environment ) result( cross_section ) integer(musica_ik) :: wNdx real(musica_dk) :: Tadj - write(*,*) Iam,'entering' - Tadj = environment%temperature - 296._musica_dk associate( polyCoeff => this%cross_section(1)%array ) cross_section = polyCoeff(:,1)*(rONE + Tadj*(polyCoeff(:,2) + Tadj*polyCoeff(:,3))) end associate - write(*,*) Iam,'exiting' - end function run end module micm_clono2_cross_section_type diff --git a/test/oldtuv/cross_section/cross_section_factory.F90 b/test/oldtuv/cross_section/cross_section_factory.F90 index 7247f2c0..e74b40ef 100644 --- a/test/oldtuv/cross_section/cross_section_factory.F90 +++ b/test/oldtuv/cross_section/cross_section_factory.F90 @@ -59,7 +59,6 @@ function cross_section_builder( config, mdlLambdaEdge ) result( new_cross_sectio type(string_t) :: cross_section_type character(len=*), parameter :: Iam = 'cross section builder: ' - write(*,*) Iam,'entering' new_cross_section_t => null( ) call config%get( 'cross section type', cross_section_type, Iam ) @@ -79,7 +78,6 @@ function cross_section_builder( config, mdlLambdaEdge ) result( new_cross_sectio cross_section_type%to_char( )//"'" ) end select call new_cross_section_t%initialize( config, mdlLambdaEdge ) - write(*,*) Iam,'exiting' end function cross_section_builder diff --git a/test/oldtuv/cross_section/h2o2-oh_oh.cross_section.type.F90 b/test/oldtuv/cross_section/h2o2-oh_oh.cross_section.type.F90 index 440bc608..654dd4e2 100644 --- a/test/oldtuv/cross_section/h2o2-oh_oh.cross_section.type.F90 +++ b/test/oldtuv/cross_section/h2o2-oh_oh.cross_section.type.F90 @@ -58,8 +58,6 @@ function run( this, environment ) result( cross_section ) integer(musica_ik) :: wNdx real(musica_dk) :: lambda, sumA, sumB, t, chi, xs - write(*,*) Iam,'entering' - associate( wl => this%mdl_lambda_edge, wc => this%mdl_lambda_center ) do wNdx = 1,size(this%mdl_lambda_center) ! Parameterization (JPL94) @@ -77,8 +75,6 @@ function run( this, environment ) result( cross_section ) enddo end associate - write(*,*) Iam,'exiting' - end function run end module micm_h2o2_oh_oh_cross_section_type diff --git a/test/oldtuv/cross_section/hcfc.cross_section.type.F90 b/test/oldtuv/cross_section/hcfc.cross_section.type.F90 index 3190731b..72b87563 100644 --- a/test/oldtuv/cross_section/hcfc.cross_section.type.F90 +++ b/test/oldtuv/cross_section/hcfc.cross_section.type.F90 @@ -71,8 +71,6 @@ function run( this, environment ) result( cross_section ) cross_section(wNdx) = sigma enddo - write(*,*) Iam,'exiting' - end function run end module micm_hcfc_cross_section_type diff --git a/test/oldtuv/cross_section/hno3-oh_no2.cross_section.type.F90 b/test/oldtuv/cross_section/hno3-oh_no2.cross_section.type.F90 index b715d706..366a2b16 100644 --- a/test/oldtuv/cross_section/hno3-oh_no2.cross_section.type.F90 +++ b/test/oldtuv/cross_section/hno3-oh_no2.cross_section.type.F90 @@ -62,7 +62,6 @@ subroutine initialize( this, config, mdlLambdaEdge ) type(config_t) :: tmp_config type(string_t) :: addpntVal - write(*,*) Iam,'entering' !> set model wavelength array this%mdl_lambda_edge = mdlLambdaEdge nmdlLambda = size( this%mdl_lambda_edge ) @@ -119,8 +118,6 @@ subroutine initialize( this, config, mdlLambdaEdge ) enddo file_loop endif has_netcdf_file - write(*,*) Iam,'exiting' - end subroutine initialize !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -141,13 +138,9 @@ function run( this, environment ) result( cross_section ) character(len=*), parameter :: Iam = 'hno3->oh+no2 cross section calculate: ' real(musica_dk) :: Temp - write(*,*) Iam,'entering' - Temp = environment%temperature - 298._musica_dk cross_section = this%cross_section(1)%array(:,1)*exp( this%cross_section(1)%array(:,2)*Temp ) - write(*,*) Iam,'exiting' - end function run end module micm_hno3_oh_no2_cross_section_type diff --git a/test/oldtuv/cross_section/hobr-oh_br.cross_section.type.F90 b/test/oldtuv/cross_section/hobr-oh_br.cross_section.type.F90 index 12986b8c..60048d6b 100644 --- a/test/oldtuv/cross_section/hobr-oh_br.cross_section.type.F90 +++ b/test/oldtuv/cross_section/hobr-oh_br.cross_section.type.F90 @@ -46,8 +46,6 @@ function run( this, environment ) result( cross_section ) character(len=*), parameter :: Iam = 'hobr_oh_br cross section calculate: ' - write(*,*) Iam,'entering' - associate( wc => this%mdl_lambda_center ) where( wc >= 250._musica_dk .and. wc <= 550._musica_dk ) cross_section = & @@ -60,8 +58,6 @@ function run( this, environment ) result( cross_section ) endwhere end associate - write(*,*) Iam,'exiting' - end function run end module micm_hobr_oh_br_cross_section_type diff --git a/test/oldtuv/cross_section/n2o-n2_o1d.cross_section.type.F90 b/test/oldtuv/cross_section/n2o-n2_o1d.cross_section.type.F90 index 6d7cdaf0..0930f8c0 100644 --- a/test/oldtuv/cross_section/n2o-n2_o1d.cross_section.type.F90 +++ b/test/oldtuv/cross_section/n2o-n2_o1d.cross_section.type.F90 @@ -71,8 +71,6 @@ function run( this, environment ) result( cross_section ) endif enddo - write(*,*) Iam,'exiting' - end function run end module micm_n2o_n2_o1d_cross_section_type diff --git a/test/oldtuv/cross_section/n2o5-no2_no3.cross_section.type.F90 b/test/oldtuv/cross_section/n2o5-no2_no3.cross_section.type.F90 index d56d23c4..898a1923 100644 --- a/test/oldtuv/cross_section/n2o5-no2_no3.cross_section.type.F90 +++ b/test/oldtuv/cross_section/n2o5-no2_no3.cross_section.type.F90 @@ -44,8 +44,6 @@ function run( this, environment ) result( cross_section ) integer(musica_ik) :: wNdx real(musica_dk) :: AdjTemp, Tfac - write(*,*) Iam,'entering' - associate( Temp => environment%temperature ) AdjTemp = max( Tlower,min(Temp,Tupper) ) do wNdx = 1,size(this%mdl_lambda_center) @@ -54,8 +52,6 @@ function run( this, environment ) result( cross_section ) enddo end associate - write(*,*) Iam,'exiting' - end function run end module micm_n2o5_no2_no3_cross_section_type diff --git a/test/oldtuv/cross_section/nitroxy_acetone.cross_section.type.F90 b/test/oldtuv/cross_section/nitroxy_acetone.cross_section.type.F90 index 7c667be2..f1c7a36f 100644 --- a/test/oldtuv/cross_section/nitroxy_acetone.cross_section.type.F90 +++ b/test/oldtuv/cross_section/nitroxy_acetone.cross_section.type.F90 @@ -46,16 +46,12 @@ function run( this, environment ) result( cross_section ) character(len=*), parameter :: Iam = 'nitroxy_acetone cross section calculate: ' - write(*,*) Iam,'entering' - where( this%mdl_lambda_center >= 284._musica_dk .and. this%mdl_lambda_center <= 335._musica_dk ) cross_section = exp( c + this%mdl_lambda_center*(b + a*this%mdl_lambda_center) ) elsewhere cross_section = rZERO endwhere - write(*,*) Iam,'exiting' - end function run end module micm_nitroxy_acetone_cross_section_type diff --git a/test/oldtuv/cross_section/nitroxy_ethanol.cross_section.type.F90 b/test/oldtuv/cross_section/nitroxy_ethanol.cross_section.type.F90 index 5fcba685..947a2504 100644 --- a/test/oldtuv/cross_section/nitroxy_ethanol.cross_section.type.F90 +++ b/test/oldtuv/cross_section/nitroxy_ethanol.cross_section.type.F90 @@ -46,16 +46,12 @@ function run( this, environment ) result( cross_section ) character(len=*), parameter :: Iam = 'nitroxy_ethanol cross section calculate: ' - write(*,*) Iam,'entering' - where( this%mdl_lambda_center >= 270._musica_dk .and. this%mdl_lambda_center <= 306._musica_dk ) cross_section = exp( c + this%mdl_lambda_center*(b + a*this%mdl_lambda_center) ) elsewhere cross_section = rZERO endwhere - write(*,*) Iam,'exiting' - end function run end module micm_nitroxy_ethanol_cross_section_type diff --git a/test/oldtuv/cross_section/no2.tint.cross_section.type.F90 b/test/oldtuv/cross_section/no2.tint.cross_section.type.F90 index 56c7cc94..6dbf4047 100644 --- a/test/oldtuv/cross_section/no2.tint.cross_section.type.F90 +++ b/test/oldtuv/cross_section/no2.tint.cross_section.type.F90 @@ -71,7 +71,6 @@ subroutine initialize( this, config, mdlLambdaEdge ) type(netcdf_t), allocatable :: netcdf_obj type(string_t), allocatable :: netcdfFiles(:) - write(*,*) Iam,'entering' !> set model wavelength array this%mdl_lambda_edge = mdlLambdaEdge nmdlLambda = size( this%mdl_lambda_edge ) @@ -154,8 +153,6 @@ subroutine initialize( this, config, mdlLambdaEdge ) call die_msg( 400000008, msg ) endif has_netcdf_file - write(*,*) Iam,'exiting' - end subroutine initialize !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -177,8 +174,6 @@ function run( this, environment ) result( cross_section ) integer(musica_ik) :: fileNdx, tNdx real(musica_dk) :: Tadj, Tstar - write(*,*) Iam,'entering' - cross_section = 0.0_musica_dk do fileNdx = 1,size(this%cross_section) associate( Temp => this%cross_section(fileNdx)%temperature, wrkXsect => this%cross_section(fileNdx) ) @@ -198,8 +193,6 @@ function run( this, environment ) result( cross_section ) end associate enddo - write(*,*) Iam,'exiting' - end function run !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -212,8 +205,6 @@ subroutine finalize( this ) character(len=*), parameter :: Iam = 'no2 tint cross section finalize: ' integer(musica_ik) :: ndx - write(*,*) Iam,'entering' - if( allocated(this%cross_section) ) then do ndx = 1,size(this%cross_section) associate( Xsection => this%cross_section(ndx) ) @@ -237,8 +228,6 @@ subroutine finalize( this ) deallocate(this%mdl_lambda_center) endif - write(*,*) Iam,'exiting' - - end subroutine finalize + end subroutine finalize end module micm_no2_tint_cross_section_type diff --git a/test/oldtuv/cross_section/o3.tint.cross_section.type.F90 b/test/oldtuv/cross_section/o3.tint.cross_section.type.F90 index 7ab3672e..b0bf8f9f 100644 --- a/test/oldtuv/cross_section/o3.tint.cross_section.type.F90 +++ b/test/oldtuv/cross_section/o3.tint.cross_section.type.F90 @@ -72,7 +72,6 @@ subroutine initialize( this, config, mdlLambdaEdge ) type(netcdf_t), allocatable :: netcdf_obj type(string_t), allocatable :: netcdfFiles(:) - write(*,*) Iam,'entering' !> set model wavelength array this%mdl_lambda_edge = mdlLambdaEdge nmdlLambda = size( this%mdl_lambda_edge ) @@ -157,8 +156,6 @@ subroutine initialize( this, config, mdlLambdaEdge ) call die_msg( 400000008, msg ) endif has_netcdf_file - write(*,*) Iam,'exiting' - end subroutine initialize !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -181,8 +178,6 @@ function run( this, environment ) result( cross_section ) integer(musica_ik) :: fileNdx, tNdx, wNdx real(musica_dk) :: Tadj, Tstar - write(*,*) Iam,'entering' - cross_section = rZERO lambda_loop: & @@ -215,8 +210,6 @@ function run( this, environment ) result( cross_section ) end associate enddo lambda_loop - write(*,*) Iam,'exiting' - end function run !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/test/oldtuv/cross_section/oclo.cross_section.type.F90 b/test/oldtuv/cross_section/oclo.cross_section.type.F90 index 21a9b16e..cce5f177 100644 --- a/test/oldtuv/cross_section/oclo.cross_section.type.F90 +++ b/test/oldtuv/cross_section/oclo.cross_section.type.F90 @@ -43,8 +43,6 @@ function run( this, environment ) result( cross_section ) integer(musica_ik) :: ndx, nParms real(musica_dk) :: Tfac - write(*,*) Iam,'entering' - associate( Temp => environment%temperature, Xsection => this%cross_section ) nParms = size(Xsection) if( Temp <= Xsection(1)%temperature(1) ) then @@ -65,8 +63,6 @@ function run( this, environment ) result( cross_section ) endif end associate - write(*,*) Iam,'exiting' - end function run end module micm_oclo_cross_section_type diff --git a/test/oldtuv/cross_section/rono2.cross_section.type.F90 b/test/oldtuv/cross_section/rono2.cross_section.type.F90 index c587909b..2fcdcf41 100644 --- a/test/oldtuv/cross_section/rono2.cross_section.type.F90 +++ b/test/oldtuv/cross_section/rono2.cross_section.type.F90 @@ -62,7 +62,6 @@ subroutine initialize( this, config, mdlLambdaEdge ) type(config_t) :: tmp_config type(string_t) :: addpntVal - write(*,*) Iam,'entering' !> set model wavelength array this%mdl_lambda_edge = mdlLambdaEdge nmdlLambda = size( this%mdl_lambda_edge ) @@ -119,8 +118,6 @@ subroutine initialize( this, config, mdlLambdaEdge ) enddo file_loop endif has_netcdf_file - write(*,*) Iam,'exiting' - end subroutine initialize !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -141,13 +138,9 @@ function run( this, environment ) result( cross_section ) character(len=*), parameter :: Iam = 'rono2 cross section calculate: ' real(musica_dk) :: Temp - write(*,*) Iam,'entering' - Temp = environment%temperature - 298._musica_dk cross_section = this%cross_section(1)%array(:,1)*exp( this%cross_section(1)%array(:,2)*Temp ) - write(*,*) Iam,'exiting' - end function run end module micm_rono2_cross_section_type diff --git a/test/oldtuv/cross_section/t_butyl_nitrate.cross_section.type.F90 b/test/oldtuv/cross_section/t_butyl_nitrate.cross_section.type.F90 index d0223f89..3be6ad4f 100644 --- a/test/oldtuv/cross_section/t_butyl_nitrate.cross_section.type.F90 +++ b/test/oldtuv/cross_section/t_butyl_nitrate.cross_section.type.F90 @@ -46,16 +46,12 @@ function run( this, environment ) result( cross_section ) character(len=*), parameter :: Iam = 't_butyl_nitrate cross section calculate: ' - write(*,*) Iam,'entering' - where( this%mdl_lambda_center >= 270._musica_dk .and. this%mdl_lambda_center <= 330._musica_dk ) cross_section = exp( c + this%mdl_lambda_center*(b + a*this%mdl_lambda_center) ) elsewhere cross_section = rZERO endwhere - write(*,*) Iam,'exiting' - end function run end module micm_t_butyl_nitrate_cross_section_type diff --git a/test/oldtuv/cross_section/tint.cross_section.type.F90 b/test/oldtuv/cross_section/tint.cross_section.type.F90 index 8544ad37..2f262178 100644 --- a/test/oldtuv/cross_section/tint.cross_section.type.F90 +++ b/test/oldtuv/cross_section/tint.cross_section.type.F90 @@ -71,7 +71,6 @@ subroutine initialize( this, config, mdlLambdaEdge ) type(netcdf_t), allocatable :: netcdf_obj type(string_t), allocatable :: netcdfFiles(:) - write(*,*) Iam,'entering' !> set model wavelength array this%mdl_lambda_edge = mdlLambdaEdge nmdlLambda = size( this%mdl_lambda_edge ) @@ -154,8 +153,6 @@ subroutine initialize( this, config, mdlLambdaEdge ) call die_msg( 400000008, msg ) endif has_netcdf_file - write(*,*) Iam,'exiting' - end subroutine initialize !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -177,8 +174,6 @@ function run( this, environment ) result( cross_section ) integer(musica_ik) :: fileNdx, tNdx real(musica_dk) :: Tadj, Tstar - write(*,*) Iam,'entering' - cross_section = 0.0_musica_dk do fileNdx = 1,size(this%cross_section) associate( Temp => this%cross_section(fileNdx)%temperature, wrkXsect => this%cross_section(fileNdx) ) @@ -196,8 +191,6 @@ function run( this, environment ) result( cross_section ) end associate enddo - write(*,*) Iam,'exiting' - end function run !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -210,8 +203,6 @@ subroutine finalize( this ) character(len=*), parameter :: Iam = 'tint cross section finalize: ' integer(musica_ik) :: ndx - write(*,*) Iam,'entering' - if( allocated(this%cross_section) ) then do ndx = 1,size(this%cross_section) associate( Xsection => this%cross_section(ndx) ) @@ -235,8 +226,6 @@ subroutine finalize( this ) deallocate(this%mdl_lambda_center) endif - write(*,*) Iam,'exiting' - end subroutine finalize end module micm_tint_cross_section_type diff --git a/test/oldtuv/delta_eddington.f90 b/test/oldtuv/delta_eddington.f90 index 38c4bbe6..13237eca 100644 --- a/test/oldtuv/delta_eddington.f90 +++ b/test/oldtuv/delta_eddington.f90 @@ -244,10 +244,6 @@ subroutine calculate( this, nlyr, nstr, albedo, & mu2(i) = SIGN( MAX(ABS(mu2(i)),rONE/SQRT(largest)),mu2(i) ) END IF - if( initialized .and. i == 2 ) then - write(*,*)'TUV: dsdh diagnostic' - write(*,*) dsdh(i,1:i) - endif END IF !** the following gamma equations are from pg 16,289, Table 1 @@ -301,13 +297,6 @@ subroutine calculate( this, nlyr, nstr, albedo, & cuptn(i) = up*expon1 cdntn(i) = dn*expon1 - if( initialized .and. i == 3 ) then - write(*,*) 'TUV: cup diagnostic' - write(*,*) expon, expon0, expon1, divisr, temp, up, dn - write(*,*) lam(i), mu2(i), gam1, gam2, gam3, gam4 - write(*,*) tauc(i-1:i), tausla(i-1:i) - endif - ENDDO layer_loop if( initialized ) then @@ -377,8 +366,6 @@ subroutine calculate( this, nlyr, nstr, albedo, & call diagout( 'b.old',b ) call diagout( 'd.old',d ) call diagout( 'e.old',e ) - write(*,*) 'e diagnostic' - write(*,*) e(5), e1(2), e3(2), cup(3), cdn(3), cuptn(2), cdntn(2) initialized = .false. endif ! solve tri-diagonal system: diff --git a/test/oldtuv/diagout.f90 b/test/oldtuv/diagout.f90 index c73781d9..8e52f265 100644 --- a/test/oldtuv/diagout.f90 +++ b/test/oldtuv/diagout.f90 @@ -20,8 +20,6 @@ subroutine diagnostic_1d( filename, variable ) integer :: ios - write(*,*) 'diagnostic_1d: entering' - open(unit=44,file='odat/OUTPUTS/'//filename,form='unformatted',iostat=ios) if( ios /= 0 ) then write(*,*) 'diagnostic_1d: failed to open ',filename,'; error = ',ios @@ -33,8 +31,6 @@ subroutine diagnostic_1d( filename, variable ) stop 'OpnErr' endif - write(*,*) 'diagnostic_1d: exiting' - end subroutine diagnostic_1d subroutine diagnostic_1d_dk( filename, variable ) @@ -44,8 +40,6 @@ subroutine diagnostic_1d_dk( filename, variable ) integer :: ios - write(*,*) 'diagnostic_1d_dk: entering' - open(unit=44,file='odat/OUTPUTS/'//filename,form='unformatted',iostat=ios) if( ios /= 0 ) then write(*,*) 'diagnostic_1d: failed to open ',filename,'; error = ',ios @@ -57,8 +51,6 @@ subroutine diagnostic_1d_dk( filename, variable ) stop 'OpnErr' endif - write(*,*) 'diagnostic_1d_dk: exiting' - end subroutine diagnostic_1d_dk subroutine diagnostic_2d( filename, variable ) diff --git a/test/oldtuv/disord_subs.f b/test/oldtuv/disord_subs.f index ecee9843..d5cdfaca 100644 --- a/test/oldtuv/disord_subs.f +++ b/test/oldtuv/disord_subs.f @@ -1416,7 +1416,6 @@ SUBROUTINE FLUXES( tausla, tauslau, REAL :: ANG1, ANG2, DIRINT, FACT, FDNTOT, FNET, PLSORC, ZINT c .. - IF( PRNT( 2 ) ) WRITE( *, 9000 ) c ** Zero DISORT output arrays U0C = 0. FLDIR = 0. @@ -1547,26 +1546,17 @@ SUBROUTINE FLUXES( tausla, tauslau, & ( UAVG( LU ) - PLSORC ) 70 CONTINUE - IF( PRNT( 2 ) ) WRITE( *, FMT = 9010 ) UTAU( LU ), LYU, - & RFLDIR( LU ), RFLDN( LU ), FDNTOT, FLUP( LU ), FNET, - & UAVG( LU ), PLSORC, DFDT( LU ) ENDDO LEVEL_LOOP IF( PRNT( 3 ) ) THEN - WRITE( *, FMT = 9020 ) - DO LU = 1, NTAU - WRITE( *, FMT = 9030 ) UTAU( LU ) - DO IQ = 1, NN ANG1 = 180./ PI* ACOS( CMU( 2*NN - IQ + 1 ) ) ANG2 = 180./ PI* ACOS( CMU( IQ ) ) - WRITE( *, 9040 ) ANG1, CMU(2*NN-IQ+1), U0C(IQ,LU), - $ ANG2, CMU(IQ), U0C(IQ+NN,LU) ENDDO ENDDO @@ -1742,26 +1732,13 @@ SUBROUTINE PRAVIN( UMU, NUMU, UTAU, NTAU, U0U ) IF( NUMU.LT.1 ) RETURN - WRITE( *, '(//,A)' ) - & ' ******* AZIMUTHALLY AVERAGED INTENSITIES ' // - & '(at user polar angles) ********' - LENFMT = 8 NPASS = 1 + (NUMU-1) / LENFMT - WRITE( *,'(/,A,/,A)') ' Optical Polar Angle Cosines', - & ' Depth' - DO 20 NP = 1, NPASS IUMIN = 1 + LENFMT * ( NP - 1 ) IUMAX = MIN( LENFMT*NP, NUMU ) - WRITE( *,'(/,10X,8F14.5)') ( UMU(IU), IU = IUMIN, IUMAX ) - - DO 10 LU = 1, NTAU - WRITE( *, '(0P,F10.4,1P,8E14.4)' ) UTAU( LU ), - & ( U0U( IU,LU ), IU = IUMIN, IUMAX ) - 10 CONTINUE 20 CONTINUE @@ -1798,110 +1775,13 @@ SUBROUTINE PRTINP( NLYR, DTAUC, DTAUCP, SSALB, PMOM, c .. - WRITE( *, '(/,A,I4,A,I4)' ) ' No. streams =', NSTR, - & ' No. computational layers =', NLYR - - IF( IBCND /= 1 ) WRITE( *, '(I4,A,10F10.4,/,(26X,10F10.4))' ) - & NTAU,' User optical depths :', ( UTAU(LU), LU = 1, NTAU ) - - IF( .NOT. ONLYFL ) WRITE( *, '(I4,A,10F9.5,/,(31X,10F9.5))' ) - & NUMU,' User polar angle cosines :',( UMU(IU), IU = 1, NUMU ) - - IF( .NOT. ONLYFL .AND. IBCND /= 1 ) - & WRITE( *, '(I4,A,10F9.2,/,(28X,10F9.2))' ) - & NPHI,' User azimuthal angles :',( PHI(J), J = 1, NPHI ) - - IF( .NOT. PLANK .OR. IBCND == 1 ) - & WRITE( *, '(A)' ) ' No thermal emission' - - - WRITE( *, '(A,I2)' ) ' Boundary condition flag: IBCND =', IBCND - - IF( IBCND == 0 ) THEN - - WRITE( *, '(A,1P,E11.3,A,0P,F8.5,A,F7.2,/,A,1P,E11.3)' ) - & ' Incident beam with intensity =', FBEAM, - & ' and polar angle cosine = ', UMU0, - & ' and azimuth angle =', PHI0, - & ' plus isotropic incident intensity =', FISOT - - IF( LAMBER ) WRITE( *, '(A,0P,F8.4)' ) - & ' Bottom albedo (Lambertian) =', ALBEDO - - IF( .NOT. LAMBER ) WRITE( *, '(A,/,(10X,10F9.5))' ) - & ' Legendre coeffs of bottom bidirectional reflectivity :', - & ( HL( K ), K = 0, NSTR ) - - ELSE IF( IBCND == 1 ) THEN - - WRITE(*,'(A)') ' Isotropic illumination from top and bottom' - WRITE( *, '(A,0P,F8.4)' ) - & ' Bottom albedo (Lambertian) =', ALBEDO - END IF - - - IF( DELTAM ) WRITE( *, '(A)' ) ' Uses delta-M method' - IF( .NOT.DELTAM ) WRITE( *, '(A)' ) ' Does not use delta-M method' - - - IF( IBCND == 1 ) THEN - - WRITE( *, '(A)' ) ' Calculate albedo and transmissivity of'// - & ' medium vs. incident beam angle' - - ELSE IF( ONLYFL ) THEN - - WRITE( *, '(A)' ) - & ' Calculate fluxes and azim-averaged intensities only' - - ELSE - - WRITE( *, '(A)' ) ' Calculate fluxes and intensities' - - END IF - - - WRITE( *, '(A,1P,E11.2)' ) - & ' Relative convergence criterion for azimuth series =', - & ACCUR - - IF( LYRCUT ) WRITE( *, '(A)' ) - & ' Sets radiation = 0 below absorption optical depth 10' - - -c ** Print layer variables - IF( PLANK ) WRITE( *, FMT = 9180 ) - IF( .NOT. PLANK ) WRITE( *, FMT = 9190 ) - YESSCT = rZERO DO LC = 1, NLYR YESSCT = YESSCT + SSALB( LC ) - - IF( PLANK ) - & WRITE(*,'(I4,2F10.4,F10.5,F12.5,2F10.4,F10.5,F9.4,F14.3)') - & LC, DTAUC( LC ), TAUC( LC ), SSALB( LC ), FLYR( LC ), - & DTAUCP( LC ), TAUCPR( LC ), OPRIM( LC ), PMOM(1,LC) - - IF( .NOT.PLANK ) - & WRITE(*,'(I4,2F10.4,F10.5,F12.5,2F10.4,F10.5,F9.4)') - & LC, DTAUC( LC ), TAUC( LC ), SSALB( LC ), FLYR( LC ), - & DTAUCP( LC ), TAUCPR( LC ), OPRIM( LC ), PMOM( 1,LC ) ENDDO - IF( PRTMOM .AND. YESSCT > rZERO ) THEN - - WRITE( *, '(/,A)' ) ' Layer Phase Function Moments' - - DO LC = 1, NLYR - IF( SSALB( LC ).GT.rZERO ) - & WRITE( *, '(I6,10F11.6,/,(6X,10F11.6))' ) - & LC, ( PMOM( K, LC ), K = 0, NSTR ) - ENDDO - - END IF - c ** (Read every other line in these formats) 9180 FORMAT( /, 37X, '<------------- Delta-M --------------->', /, @@ -1954,17 +1834,9 @@ SUBROUTINE PRTINT( UU, UTAU, NTAU, UMU, NUMU, PHI ) IF( NPHI.LT.1 ) RETURN - WRITE( *, '(//,A)' ) - & ' ********* I N T E N S I T I E S *********' - LENFMT = 10 NPASS = 1 + (NPHI-1) / LENFMT - WRITE( *, '(/,A,/,A,/,A)' ) - & ' Polar Azimuth angles (degrees)', - & ' Optical Angle', - & ' Depth Cosine' - DO 30 LU = 1, NTAU DO 20 NP = 1, NPASS @@ -1972,18 +1844,6 @@ SUBROUTINE PRTINT( UU, UTAU, NTAU, UMU, NUMU, PHI ) JMIN = 1 + LENFMT * ( NP - 1 ) JMAX = MIN( LENFMT*NP, NPHI ) - WRITE( *, '(/,18X,10F11.2)' ) ( PHI(J), J = JMIN, JMAX ) - - IF( NP.EQ.1 ) WRITE( *, '(F10.4,F8.4,1P,10E11.3)' ) - & UTAU(LU), UMU(1), (UU(1, LU, J), J = JMIN, JMAX) - IF( NP.GT.1 ) WRITE( *, '(10X,F8.4,1P,10E11.3)' ) - & UMU(1), (UU(1, LU, J), J = JMIN, JMAX) - - DO 10 IU = 2, NUMU - WRITE( *, '(10X,F8.4,1P,10E11.3)' ) - & UMU( IU ), ( UU( IU, LU, J ), J = JMIN, JMAX ) - 10 CONTINUE - 20 CONTINUE 30 CONTINUE @@ -2764,9 +2624,6 @@ SUBROUTINE SOLEIG( AMB, APB, ARRAY, CMU, CWT, GL, MAZIM, IF( IER.GT.0 ) THEN - WRITE( *, FMT = '(//,A,I4,A)' ) ' ASYMTX--eigenvalue no. ', - & IER, ' didnt converge. Lower-numbered eigenvalues wrong.' - CALL ERRMSG( 'ASYMTX--convergence problems',.True.) END IF @@ -3518,11 +3375,6 @@ SUBROUTINE SOLVEC( AMB, APB, ARRAY, CMU, CWT, GL, SSA = OPRIM - IF (DEBUG) THEN - write (*,*) '! *** Neither upward nor downward iteration' - write (*,*) '! *** converged; using original result.' - ENDIF - DONE = .TRUE. GOTO 777 ENDIF @@ -3536,15 +3388,6 @@ SUBROUTINE SOLVEC( AMB, APB, ARRAY, CMU, CWT, GL, SSA = DSSA - IF (DEBUG) THEN - write (*,*) '! *** The upward iteration did not converge.' - write (*,*) '! *** Had to iterate ', DAGAIN, - $ ' times in layer LC =', LC,';' - write (*,*) '! *** changed SSA from ', - $ OPRIM, ' to ', SSA,',' - write (*,*) '! *** by a factor of ', SSA/OPRIM - ENDIF - DONE = .TRUE. GOTO 777 ENDIF @@ -3552,15 +3395,6 @@ SUBROUTINE SOLVEC( AMB, APB, ARRAY, CMU, CWT, GL, *bm if downward iteration did not converge, we are done *bm (the result of the upward iteration will be used) IF (NODN) THEN - IF (DEBUG) THEN - write (*,*) '! *** The downward iteration did not converge.' - write (*,*) '! *** Had to iterate ', UAGAIN, - $ ' times in layer LC =', LC,';' - write (*,*) '! *** changed SSA from ', - $ OPRIM, ' to ', SSA,',' - write (*,*) '! *** by a factor of ', SSA/OPRIM - ENDIF - DONE = .TRUE. GOTO 998 ENDIF @@ -3578,30 +3412,10 @@ SUBROUTINE SOLVEC( AMB, APB, ARRAY, CMU, CWT, GL, SSA = DSSA - IF (DEBUG) THEN - write (*,*) '! *** Both iterations converged;', - $ ' using downward.' - write (*,*) '! *** Had to iterate ', DAGAIN, - $ ' times in layer LC =', LC,';' - write (*,*) '! *** changed SSA from ', - $ OPRIM, ' to ', SSA,',' - write (*,*) '! *** by a factor of ', SSA/OPRIM - ENDIF - DONE = .TRUE. GOTO 777 ELSE - IF (DEBUG) THEN - write (*,*) '! *** Both iterations converged;', - $ ' using upward.' - write (*,*) '! *** Had to iterate ', UAGAIN, - $ ' times in layer LC =', LC,';' - write (*,*) '! *** changed SSA from ', - $ OPRIM, ' to ', SSA,',' - write (*,*) '! *** by a factor of ', SSA/OPRIM - ENDIF - DONE = .TRUE. goto 998 ENDIF diff --git a/test/oldtuv/grid/grid_factory.F90 b/test/oldtuv/grid/grid_factory.F90 index b0924d81..a052a7f2 100644 --- a/test/oldtuv/grid/grid_factory.F90 +++ b/test/oldtuv/grid/grid_factory.F90 @@ -39,7 +39,6 @@ function grid_builder( config ) result( new_grid_t ) type(string_t) :: grid_type character(len=*), parameter :: Iam = 'Grid builder: ' - write(*,*) Iam,'entering' new_grid_t => null() call config%get( 'Grid type', grid_type, Iam ) @@ -55,7 +54,6 @@ function grid_builder( config ) result( new_grid_t ) end select call new_grid_t%initialize( config ) - write(*,*) Iam,'exiting' end function grid_builder diff --git a/test/oldtuv/grid/grid_warehouse.F90 b/test/oldtuv/grid/grid_warehouse.F90 index 13c9fa4c..aee7d9b1 100644 --- a/test/oldtuv/grid/grid_warehouse.F90 +++ b/test/oldtuv/grid/grid_warehouse.F90 @@ -62,8 +62,6 @@ function constructor( config ) result( grid_warehouse_obj ) character(len=32) :: keychar type(string_t) :: aswkey - write(*,*) Iam // 'entering' - allocate( grid_warehouse_obj ) associate(new_obj=>grid_warehouse_obj) @@ -78,8 +76,6 @@ function constructor( config ) result( grid_warehouse_obj ) do while( iter%next() ) keychar = grid_set%key(iter) aswkey = keychar - write(*,*) ' ' - write(*,*) Iam,'key = ',trim(keychar) call grid_set%get( iter, grid_config, Iam ) call grid_config%add( 'Handle', aswkey, Iam ) !----------------------------------------------------------------------------- @@ -91,13 +87,8 @@ function constructor( config ) result( grid_warehouse_obj ) deallocate( iter ) - write(*,*) ' ' - write(*,'(a,''There are '',i3,'' grid objects'')') Iam,size(new_obj%grid_objs_) - end associate - write(*,*) Iam // 'exiting' - end function constructor !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -121,9 +112,6 @@ function get_grid( this, grid_handle ) result( grid_ptr ) integer(ik) :: ndx logical(lk) :: found - write(*,*) ' ' - write(*,*) Iam,'entering' - found = .false._lk do ndx = 1,size(this%grid_objs_) if( grid_handle .eq. this%grid_objs_(ndx)%ptr_%handle_ ) then @@ -138,8 +126,6 @@ function get_grid( this, grid_handle ) result( grid_ptr ) call die_msg( 460768214, "Invalid grid handle: '"// grid_handle%to_char()//"'" ) endif - write(*,*) Iam,'exiting' - end function get_grid !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -156,14 +142,10 @@ subroutine finalize( this ) integer(kind=ik) :: ndx character(len=*), parameter :: Iam = 'grid warehouse finalize: ' - write(*,*) Iam,'entering' - if( allocated( this%grid_objs_ ) ) then deallocate( this%grid_objs_ ) endif - write(*,*) Iam,'exiting' - end subroutine finalize !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/test/oldtuv/grids.f b/test/oldtuv/grids.f index b5b65288..247519fd 100644 --- a/test/oldtuv/grids.f +++ b/test/oldtuv/grids.f @@ -393,7 +393,6 @@ SUBROUTINE gridz(zstart, zstop, nz, z, zout, izout) CASE( 1 ) *-----grid option 1: manual ----------------- * entire grid (nz levels) in increments zincr - WRITE(*,*) 'equally spaced z-grid' zincr = (zstop - zstart) / REAL(nz - 1) allocate( z(nz) ) z(1) = zstart @@ -405,7 +404,6 @@ SUBROUTINE gridz(zstart, zstop, nz, z, zout, izout) *-----grid option 2: automatic ----------------- * entire grid (nz levels) in increments zincr - WRITE(*,*) 'equally spaced z-grid' zincr = (zstop - zstart) / real(nz - 1) nlev = nz-1 n = 1 @@ -416,7 +414,6 @@ SUBROUTINE gridz(zstart, zstop, nz, z, zout, izout) *-----copy & edit this section for non-uniform grid---- * the example provided below is high vertical resolution in * snow, with atmosphere above it. - WRITE(*,*) 'snow-atmosphere grid' * 0.-10. cm from ground, in 1 cm increments ( 1 cm = 1e-5 km): zincr = 1.e-5 nlev = 10 @@ -477,8 +474,6 @@ SUBROUTINE gridz(zstart, zstop, nz, z, zout, izout) CASE( 4 ) *-----grid option 4: grid for Mexico City - WRITE(*,*) 'mirage z-grid' - * grid for mirage km: incr(range)i * 0.1(0-4) 2-41 * 0.2(4-8) 42-61 @@ -512,7 +507,6 @@ SUBROUTINE gridz(zstart, zstop, nz, z, zout, izout) * nz = total number of altitudes * Table: z(iz), where iz goes from 1 to nz * trivial example of 2-layer (3-altitudes) shown below, user should modify - WRITE(*,*) 'user-defined grid, named...' nz = 3 z(1) = 0. z(2) = 10. @@ -527,8 +521,6 @@ SUBROUTINE gridz(zstart, zstop, nz, z, zout, izout) * nz = total number of altitudes * Table: z(iz), where iz goes from 1 to nz - WRITE(*,*) 'user-defined grid, named...' - END SELECT * Insert additional altitude for selected outputs. diff --git a/test/oldtuv/photo_kinetics.F90 b/test/oldtuv/photo_kinetics.F90 index 87d280b1..75f30773 100644 --- a/test/oldtuv/photo_kinetics.F90 +++ b/test/oldtuv/photo_kinetics.F90 @@ -98,8 +98,6 @@ function constructor( config,mdlLambdaEdge ) result( new_photo_kinetics_obj ) do while( iter%next( ) ) keychar = reaction_set%key(iter) areaction_key = keychar - write(*,*) ' ' - write(*,*) Iam,'key = ',trim(keychar) new_obj%reaction_key = [new_obj%reaction_key,areaction_key] call reaction_set%get( iter, reaction_config, Iam ) !----------------------------------------------------------------------------- @@ -127,11 +125,7 @@ function constructor( config,mdlLambdaEdge ) result( new_photo_kinetics_obj ) deallocate( iter ) nSize = size(new_obj%cross_section_objs_) - write(*,*) ' ' - write(*,'(a,''There are '',i3,'' cross sections'')') Iam,nSize nSize = size(new_obj%quantum_yield_objs_) - write(*,*) ' ' - write(*,'(a,''There are '',i3,'' quantum yields'')') Iam,nSize !----------------------------------------------------------------------------- !> setup cross section, quantum yield arrays @@ -164,9 +158,6 @@ subroutine update_for_new_environmental_state( this, environment, nwave ) real(musica_dk), allocatable :: a_quantum_yield(:) real(musica_dk), allocatable :: quantum_yield_tray(:) - write(*,*) ' ' - write(*,*) Iam,'entering' - allocate(cross_section_tray(0)) do ndx = 1, size(this%cross_section_objs_) associate( calc_ftn => this%cross_section_objs_(ndx)%val_ ) @@ -178,9 +169,6 @@ subroutine update_for_new_environmental_state( this, environment, nwave ) this%cross_section_values_ = reshape( cross_section_tray, & (/nwave,size(this%cross_section_objs_) /) ) - write(*,*) Iam,'size of cross section values = ',& - size(this%cross_section_values_,dim=1), size(this%cross_section_values_,dim=2) - allocate(quantum_yield_tray(0)) do ndx = 1, size(this%quantum_yield_objs_) associate( calc_ftn => this%quantum_yield_objs_(ndx) ) @@ -195,11 +183,6 @@ subroutine update_for_new_environmental_state( this, environment, nwave ) this%quantum_yield_values_ = reshape( quantum_yield_tray, & (/nwave,size(this%quantum_yield_objs_) /) ) - write(*,*) Iam,'size of quantum_yield values = ',& - size(this%quantum_yield_values_,dim=1), size(this%quantum_yield_values_,dim=2) - - write(*,*) Iam,'exiting' - end subroutine update_for_new_environmental_state !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -213,8 +196,6 @@ subroutine finalize( this ) integer(kind=musica_ik) :: ndx character(len=*), parameter :: Iam = 'photo_kinetics finalize: ' - write(*,*) Iam,'entering' - if( allocated( this%cross_section_values_ ) ) then deallocate( this%cross_section_values_ ) endif @@ -245,8 +226,6 @@ subroutine finalize( this ) deallocate( this%reaction_key ) end if - write(*,*) Iam,'exiting' - end subroutine finalize !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/test/oldtuv/quantum_yield/abstract.quantum_yield.type.F90 b/test/oldtuv/quantum_yield/abstract.quantum_yield.type.F90 index d5eb0495..46a39e38 100644 --- a/test/oldtuv/quantum_yield/abstract.quantum_yield.type.F90 +++ b/test/oldtuv/quantum_yield/abstract.quantum_yield.type.F90 @@ -92,8 +92,6 @@ subroutine addpnts( this, config, data_lambda, data_parameter ) logical :: found character(len=:), allocatable :: number - write(*,*) Iam,'entering' - !> add endpoints to data arrays; first the lower bound nRows = size(data_lambda) lowerLambda = data_lambda(1) ; upperLambda = data_lambda(nRows) @@ -123,8 +121,6 @@ subroutine addpnts( this, config, data_lambda, data_parameter ) call addpnt(x=data_lambda,y=data_parameter,xnew=(rONE+deltax)*upperLambda,ynew=addpnt_val_) call addpnt(x=data_lambda,y=data_parameter,xnew=1.e38_musica_dk,ynew=addpnt_val_) - write(*,*) Iam,'exiting' - end subroutine addpnts end module micm_abs_quantum_yield_type diff --git a/test/oldtuv/quantum_yield/acetone-ch3co_ch3.quantum_yield.type.F90 b/test/oldtuv/quantum_yield/acetone-ch3co_ch3.quantum_yield.type.F90 index 58ce3968..bf1d52f1 100644 --- a/test/oldtuv/quantum_yield/acetone-ch3co_ch3.quantum_yield.type.F90 +++ b/test/oldtuv/quantum_yield/acetone-ch3co_ch3.quantum_yield.type.F90 @@ -59,8 +59,6 @@ function run( this, environment ) result( quantum_yield ) real(musica_dk) :: dumexp real(musica_dk) :: fco, fac - write(*,*) Iam,'entering' - Tadj = environment%temperature/295._musica_dk M = environment%number_density_air lambda_loop: & @@ -112,8 +110,6 @@ function run( this, environment ) result( quantum_yield ) quantum_yield(wNdx) = fac enddo lambda_loop - write(*,*) Iam,'exiting' - end function run end module micm_ch3coch3_ch3co_ch3_quantum_yield_type diff --git a/test/oldtuv/quantum_yield/base.quantum_yield.type.F90 b/test/oldtuv/quantum_yield/base.quantum_yield.type.F90 index de77931d..5f36eb5b 100644 --- a/test/oldtuv/quantum_yield/base.quantum_yield.type.F90 +++ b/test/oldtuv/quantum_yield/base.quantum_yield.type.F90 @@ -69,8 +69,6 @@ subroutine initialize( this, config, mdlLambdaEdge ) type(netcdf_t), allocatable :: netcdf_obj type(string_t), allocatable :: netcdfFiles(:) - write(*,*) Iam,'entering' - !> set model wavelength array this%mdl_lambda_edge = mdlLambdaEdge nmdlLambda = size( this%mdl_lambda_edge ) @@ -123,8 +121,6 @@ subroutine initialize( this, config, mdlLambdaEdge ) endif endif has_netcdf_file - write(*,*) Iam,'exiting' - end subroutine initialize !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -143,12 +139,8 @@ function run( this, environment ) result( quantum_yield ) character(len=*), parameter :: Iam = 'base quantum yield calculate: ' - write(*,*) Iam,'entering' - quantum_yield = this%quantum_yield(1)%array(:,1) - write(*,*) Iam,'exiting' - end function run !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -161,8 +153,6 @@ subroutine finalize( this ) character(len=*), parameter :: Iam = 'base quantum yield finalize: ' integer(musica_dk) :: ndx - write(*,*) Iam,'entering' - if( allocated(this%quantum_yield) ) then do ndx = 1,size(this%quantum_yield) if( allocated(this%quantum_yield(ndx)%array ) ) then @@ -181,8 +171,6 @@ subroutine finalize( this ) deallocate(this%mdl_lambda_center) endif - write(*,*) Iam,'exiting' - end subroutine finalize end module micm_base_quantum_yield_type diff --git a/test/oldtuv/quantum_yield/c2h5cho.quantum_yield.type.F90 b/test/oldtuv/quantum_yield/c2h5cho.quantum_yield.type.F90 index c264ff9b..f7be4e1a 100644 --- a/test/oldtuv/quantum_yield/c2h5cho.quantum_yield.type.F90 +++ b/test/oldtuv/quantum_yield/c2h5cho.quantum_yield.type.F90 @@ -46,8 +46,6 @@ function run( this, environment ) result( quantum_yield ) character(len=*), parameter :: Iam = 'c2h5cho+hv->c2h5+hco calculate: ' real(musica_dk) :: air_den_fac - write(*,*) Iam,'entering' - air_den_fac = environment%number_density_air/2.45e19_musica_dk ! quantum yields: @@ -59,8 +57,6 @@ function run( this, environment ) result( quantum_yield ) quantum_yield = min( rONE,quantum_yield ) endwhere - write(*,*) Iam,'exiting' - end function run end module micm_c2h5cho_c2h5_hco_quantum_yield_type diff --git a/test/oldtuv/quantum_yield/ch2chcho.quantum_yield.type.F90 b/test/oldtuv/quantum_yield/ch2chcho.quantum_yield.type.F90 index 74429c2c..da91cebb 100644 --- a/test/oldtuv/quantum_yield/ch2chcho.quantum_yield.type.F90 +++ b/test/oldtuv/quantum_yield/ch2chcho.quantum_yield.type.F90 @@ -47,8 +47,6 @@ function run( this, environment ) result( quantum_yield ) character(len=*), parameter :: Iam = 'ch2chcho+hv->products calculate: ' real(musica_dk) :: phi0 - write(*,*) Iam,'entering' - associate( M => environment%number_density_air ) if( M > 2.6e19_musica_dk ) then quantum_yield = phiL @@ -62,8 +60,6 @@ function run( this, environment ) result( quantum_yield ) endif end associate - write(*,*) Iam,'exiting' - end function run end module micm_ch2chcho_quantum_yield_type diff --git a/test/oldtuv/quantum_yield/ch2o.quantum_yield.type.F90 b/test/oldtuv/quantum_yield/ch2o.quantum_yield.type.F90 index be645d44..f324195d 100644 --- a/test/oldtuv/quantum_yield/ch2o.quantum_yield.type.F90 +++ b/test/oldtuv/quantum_yield/ch2o.quantum_yield.type.F90 @@ -51,8 +51,6 @@ function run( this, environment ) result( quantum_yield ) real(musica_dk), allocatable :: quantum_yield_tmp(:) real(musica_dk), allocatable :: quantum_yield_wrk(:) - write(*,*) Iam,'entering' - quantum_yield_chnl1 = this%quantum_yield(1)%array(:,1) quantum_yield_chnl2 = this%quantum_yield(1)%array(:,2) quantum_yield_tmp = rONE - quantum_yield_chnl1 @@ -69,8 +67,6 @@ function run( this, environment ) result( quantum_yield ) quantum_yield = quantum_yield_chnl2 endwhere - write(*,*) Iam,'exiting' - end function run end module micm_ch2o_h2_co_quantum_yield_type diff --git a/test/oldtuv/quantum_yield/ch3cho-ch3_hco.quantum_yield.type.F90 b/test/oldtuv/quantum_yield/ch3cho-ch3_hco.quantum_yield.type.F90 index 98724d11..7e2ff320 100644 --- a/test/oldtuv/quantum_yield/ch3cho-ch3_hco.quantum_yield.type.F90 +++ b/test/oldtuv/quantum_yield/ch3cho-ch3_hco.quantum_yield.type.F90 @@ -48,8 +48,6 @@ function run( this, environment ) result( quantum_yield ) real(musica_dk), allocatable :: quantum_yield_chnl2(:) real(musica_dk), allocatable :: quantum_yield_wrk(:) - write(*,*) Iam,'entering' - quantum_yield_chnl1 = this%quantum_yield(1)%array(:,2) quantum_yield_chnl2 = rONE - this%quantum_yield(1)%array(:,1) quantum_yield_wrk = (/ (rZERO,m=1,size(this%quantum_yield(1)%array,dim=1)) /) @@ -63,8 +61,6 @@ function run( this, environment ) result( quantum_yield ) /(rONE + quantum_yield_wrk*air_den_factor) quantum_yield = min( rONE,max(rZERO,quantum_yield) ) - write(*,*) Iam,'exiting' - end function run end module micm_ch3cho_ch3_hco_quantum_yield_type diff --git a/test/oldtuv/quantum_yield/ch3coch2ch3-ch3co_ch2ch3.quantum_yield.type.F90 b/test/oldtuv/quantum_yield/ch3coch2ch3-ch3co_ch2ch3.quantum_yield.type.F90 index ceb34239..fb573e73 100644 --- a/test/oldtuv/quantum_yield/ch3coch2ch3-ch3co_ch2ch3.quantum_yield.type.F90 +++ b/test/oldtuv/quantum_yield/ch3coch2ch3-ch3co_ch2ch3.quantum_yield.type.F90 @@ -44,14 +44,10 @@ function run( this, environment ) result( quantum_yield ) character(len=*), parameter :: Iam = 'ch3coch2ch3+hv->ch3co+ch2ch3 calculate: ' real(musica_dk) :: ptorr - write(*,*) Iam,'entering' - ptorr = 760._musica_dk*environment%number_density_air/2.69e19_musica_dk quantum_yield = rONE/(0.96_musica_dk + 2.22E-3_musica_dk*ptorr) quantum_yield = min(quantum_yield, rONE) - write(*,*) Iam,'exiting' - end function run end module micm_ch3coch2ch3_quantum_yield_type diff --git a/test/oldtuv/quantum_yield/ch3cocho.quantum_yield.type.F90 b/test/oldtuv/quantum_yield/ch3cocho.quantum_yield.type.F90 index 5aa10ad5..dca962d5 100644 --- a/test/oldtuv/quantum_yield/ch3cocho.quantum_yield.type.F90 +++ b/test/oldtuv/quantum_yield/ch3cocho.quantum_yield.type.F90 @@ -75,8 +75,6 @@ function run( this, environment ) result( quantum_yield ) quantum_yield(wNdx) = qy enddo - write(*,*) Iam,'exiting' - end function run end module micm_ch3cocho_ch3co_hco_quantum_yield_type diff --git a/test/oldtuv/quantum_yield/clo-cl_o1d.quantum_yield.type.F90 b/test/oldtuv/quantum_yield/clo-cl_o1d.quantum_yield.type.F90 index d8ce056b..6a202579 100644 --- a/test/oldtuv/quantum_yield/clo-cl_o1d.quantum_yield.type.F90 +++ b/test/oldtuv/quantum_yield/clo-cl_o1d.quantum_yield.type.F90 @@ -43,16 +43,12 @@ function run( this, environment ) result( quantum_yield ) character(len=*), parameter :: Iam = 'clo+hv->cl+o1d calculate: ' - write(*,*) Iam,'entering' - where( this%mdl_lambda_center < 263.4_musica_dk ) quantum_yield = rONE elsewhere quantum_yield = rZERO endwhere - write(*,*) Iam,'exiting' - end function run end module micm_clo_cl_o1d_quantum_yield_type diff --git a/test/oldtuv/quantum_yield/clo-cl_o3p.quantum_yield.type.F90 b/test/oldtuv/quantum_yield/clo-cl_o3p.quantum_yield.type.F90 index 8e941271..8a268a33 100644 --- a/test/oldtuv/quantum_yield/clo-cl_o3p.quantum_yield.type.F90 +++ b/test/oldtuv/quantum_yield/clo-cl_o3p.quantum_yield.type.F90 @@ -43,16 +43,12 @@ function run( this, environment ) result( quantum_yield ) character(len=*), parameter :: Iam = 'clo+hv->cl+o3p calculate: ' - write(*,*) Iam,'entering' - where( this%mdl_lambda_center < 263.4_musica_dk ) quantum_yield = rZERO elsewhere quantum_yield = rONE endwhere - write(*,*) Iam,'exiting' - end function run end module micm_clo_cl_o3p_quantum_yield_type diff --git a/test/oldtuv/quantum_yield/clono2-cl_no3.quantum_yield.type.F90 b/test/oldtuv/quantum_yield/clono2-cl_no3.quantum_yield.type.F90 index 5aeeb5c2..13c320ee 100644 --- a/test/oldtuv/quantum_yield/clono2-cl_no3.quantum_yield.type.F90 +++ b/test/oldtuv/quantum_yield/clono2-cl_no3.quantum_yield.type.F90 @@ -46,8 +46,6 @@ function run( this, environment ) result( quantum_yield ) integer(musica_ik) :: wNdx real(musica_ik) :: lambda - write(*,*) Iam,'entering' - do wNdx = 1,size(this%mdl_lambda_center) lambda = this%mdl_lambda_center(wNdx) if( lambda < 308._musica_dk ) then @@ -59,8 +57,6 @@ function run( this, environment ) result( quantum_yield ) endif enddo - write(*,*) Iam,'exiting' - end function run end module micm_clono2_cl_no3_quantum_yield_type diff --git a/test/oldtuv/quantum_yield/clono2-clo_no2.quantum_yield.type.F90 b/test/oldtuv/quantum_yield/clono2-clo_no2.quantum_yield.type.F90 index f579963c..b642086f 100644 --- a/test/oldtuv/quantum_yield/clono2-clo_no2.quantum_yield.type.F90 +++ b/test/oldtuv/quantum_yield/clono2-clo_no2.quantum_yield.type.F90 @@ -46,8 +46,6 @@ function run( this, environment ) result( quantum_yield ) integer(musica_ik) :: wNdx real(musica_ik) :: lambda, qyield - write(*,*) Iam,'entering' - do wNdx = 1,size(this%mdl_lambda_center) lambda = this%mdl_lambda_center(wNdx) if( lambda < 308._musica_dk ) then @@ -60,8 +58,6 @@ function run( this, environment ) result( quantum_yield ) quantum_yield(wNdx) = rONE - qyield enddo - write(*,*) Iam,'exiting' - end function run end module micm_clono2_clo_no2_quantum_yield_type diff --git a/test/oldtuv/quantum_yield/ho2.quantum_yield.type.F90 b/test/oldtuv/quantum_yield/ho2.quantum_yield.type.F90 index 1abdc0d8..a4f9fb23 100644 --- a/test/oldtuv/quantum_yield/ho2.quantum_yield.type.F90 +++ b/test/oldtuv/quantum_yield/ho2.quantum_yield.type.F90 @@ -44,8 +44,6 @@ function run( this, environment ) result( quantum_yield ) real(musica_dk), parameter :: lambda0 = 193._musica_dk character(len=*), parameter :: Iam = 'ho2+hv->oh+o calculate: ' - write(*,*) Iam,'entering' - where( this%mdl_lambda_center >= 248._musica_dk ) quantum_yield = rONE elsewhere @@ -53,8 +51,6 @@ function run( this, environment ) result( quantum_yield ) quantum_yield = max( rZERO,quantum_yield ) endwhere - write(*,*) Iam,'exiting' - end function run end module micm_ho2_oh_o_quantum_yield_type diff --git a/test/oldtuv/quantum_yield/mvk.quantum_yield.type.F90 b/test/oldtuv/quantum_yield/mvk.quantum_yield.type.F90 index 098f3005..96a55e69 100644 --- a/test/oldtuv/quantum_yield/mvk.quantum_yield.type.F90 +++ b/test/oldtuv/quantum_yield/mvk.quantum_yield.type.F90 @@ -44,14 +44,10 @@ function run( this, environment ) result( quantum_yield ) character(len=*), parameter :: Iam = 'mvk+hv->products calculate: ' real(musica_dk) :: divisor - write(*,*) Iam,'entering' - divisor = 5.5_musica_dk + 9.2e-19_musica_dk*environment%number_density_air quantum_yield = exp( -0.055_musica_dk*(this%mdl_lambda_center - 308._musica_dk)) / divisor quantum_yield = min( quantum_yield,rONE ) - write(*,*) Iam,'exiting' - end function run end module micm_mvk_quantum_yield_type diff --git a/test/oldtuv/quantum_yield/no2.tint.quantum_yield.type.F90 b/test/oldtuv/quantum_yield/no2.tint.quantum_yield.type.F90 index 3c00800b..3590ff9f 100644 --- a/test/oldtuv/quantum_yield/no2.tint.quantum_yield.type.F90 +++ b/test/oldtuv/quantum_yield/no2.tint.quantum_yield.type.F90 @@ -72,8 +72,6 @@ subroutine initialize( this, config, mdlLambdaEdge ) type(netcdf_t), allocatable :: netcdf_obj type(string_t), allocatable :: netcdfFiles(:) - write(*,*) Iam,'entering' - !> set model wavelength array this%mdl_lambda_edge = mdlLambdaEdge nmdlLambda = size( this%mdl_lambda_edge ) @@ -154,8 +152,6 @@ subroutine initialize( this, config, mdlLambdaEdge ) call die_msg( 400000008, msg ) endif has_netcdf_file - write(*,*) Iam,'exiting' - end subroutine initialize !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -177,8 +173,6 @@ function run( this, environment ) result( quantum_yield ) integer(musica_ik) :: fileNdx, tNdx real(musica_dk) :: Tadj, Tstar - write(*,*) Iam,'entering' - quantum_yield = 0.0_musica_dk do fileNdx = 1,size(this%quantum_yield) associate( Temp => this%quantum_yield(fileNdx)%temperature, wrkQyield => this%quantum_yield(fileNdx) ) @@ -199,8 +193,6 @@ function run( this, environment ) result( quantum_yield ) end associate enddo - write(*,*) Iam,'exiting' - end function run !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -214,7 +206,6 @@ subroutine finalize( this ) character(len=*), parameter :: Iam = 'no2 tint quantum yield finalize: ' integer(musica_ik) :: ndx - write(*,*) Iam,'entering' if( allocated(this%quantum_yield) ) then do ndx = 1,size(this%quantum_yield) associate( Qyield => this%quantum_yield(ndx) ) @@ -238,8 +229,6 @@ subroutine finalize( this ) deallocate(this%mdl_lambda_center) endif - write(*,*) Iam,'exiting' - end subroutine finalize end module micm_no2_tint_quantum_yield_type diff --git a/test/oldtuv/quantum_yield/no3-_aq.quantum_yield.type.F90 b/test/oldtuv/quantum_yield/no3-_aq.quantum_yield.type.F90 index 1179bfcf..2a11c366 100644 --- a/test/oldtuv/quantum_yield/no3-_aq.quantum_yield.type.F90 +++ b/test/oldtuv/quantum_yield/no3-_aq.quantum_yield.type.F90 @@ -43,12 +43,8 @@ function run( this, environment ) result( quantum_yield ) character(len=*), parameter :: Iam = 'no3-_(aq)+hv->products calculate: ' - write(*,*) Iam,'entering' - quantum_yield = exp( -2400._musica_dk/environment%temperature + 3.6_musica_dk ) ! Chu & Anastasio, 2003 - write(*,*) Iam,'exiting' - end function run end module micm_no3m_aq_quantum_yield_type diff --git a/test/oldtuv/quantum_yield/o3-o2_o1d.quantum_yield.type.F90 b/test/oldtuv/quantum_yield/o3-o2_o1d.quantum_yield.type.F90 index acb01980..4a618d61 100644 --- a/test/oldtuv/quantum_yield/o3-o2_o1d.quantum_yield.type.F90 +++ b/test/oldtuv/quantum_yield/o3-o2_o1d.quantum_yield.type.F90 @@ -52,8 +52,6 @@ function run( this, environment ) result( quantum_yield ) real(musica_dk) :: kt, q1, q2, T300, lambda real(musica_dk) :: qfac1, qfac2 - write(*,*) Iam,'entering' - !-----------------------------------------------------------------------------* != PURPOSE: =* ! function to calculate the quantum yield O3 + hv -> O(1D) + O2, =* @@ -92,8 +90,6 @@ function run( this, environment ) result( quantum_yield ) end associate - write(*,*) Iam,'exiting' - end function run end module micm_o3_o2_o1d_quantum_yield_type diff --git a/test/oldtuv/quantum_yield/o3-o2_o3p.quantum_yield.type.F90 b/test/oldtuv/quantum_yield/o3-o2_o3p.quantum_yield.type.F90 index 0b7b3603..7652bebf 100644 --- a/test/oldtuv/quantum_yield/o3-o2_o3p.quantum_yield.type.F90 +++ b/test/oldtuv/quantum_yield/o3-o2_o3p.quantum_yield.type.F90 @@ -52,8 +52,6 @@ function run( this, environment ) result( quantum_yield ) real(musica_dk) :: kt, q1, q2, T300, lambda real(musica_dk) :: qfac1, qfac2 - write(*,*) Iam,'entering' - !-----------------------------------------------------------------------------* != PURPOSE: =* ! function to calculate the quantum yield O3 + hv -> O(1D) + O2, =* @@ -90,8 +88,6 @@ function run( this, environment ) result( quantum_yield ) end associate - write(*,*) Iam,'exiting' - end function run end module micm_o3_o2_o3p_quantum_yield_type diff --git a/test/oldtuv/quantum_yield/tint.quantum_yield.type.F90 b/test/oldtuv/quantum_yield/tint.quantum_yield.type.F90 index 5431e024..b05166f4 100644 --- a/test/oldtuv/quantum_yield/tint.quantum_yield.type.F90 +++ b/test/oldtuv/quantum_yield/tint.quantum_yield.type.F90 @@ -72,8 +72,6 @@ subroutine initialize( this, config, mdlLambdaEdge ) type(netcdf_t), allocatable :: netcdf_obj type(string_t), allocatable :: netcdfFiles(:) - write(*,*) Iam,'entering' - !> set model wavelength array this%mdl_lambda_edge = mdlLambdaEdge nmdlLambda = size( this%mdl_lambda_edge ) @@ -154,8 +152,6 @@ subroutine initialize( this, config, mdlLambdaEdge ) call die_msg( 400000008, msg ) endif has_netcdf_file - write(*,*) Iam,'exiting' - end subroutine initialize !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -177,8 +173,6 @@ function run( this, environment ) result( quantum_yield ) integer(musica_ik) :: fileNdx, tNdx real(musica_dk) :: Tadj, Tstar - write(*,*) Iam,'entering' - quantum_yield = 0.0_musica_dk do fileNdx = 1,size(this%quantum_yield) associate( Temp => this%quantum_yield(fileNdx)%temperature, wrkQyield => this%quantum_yield(fileNdx) ) @@ -196,8 +190,6 @@ function run( this, environment ) result( quantum_yield ) end associate enddo - write(*,*) Iam,'exiting' - end function run !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -211,7 +203,6 @@ subroutine finalize( this ) character(len=*), parameter :: Iam = 'tint quantum yield finalize: ' integer(musica_ik) :: ndx - write(*,*) Iam,'entering' if( allocated(this%quantum_yield) ) then do ndx = 1,size(this%quantum_yield) associate( Qyield => this%quantum_yield(ndx) ) @@ -235,8 +226,6 @@ subroutine finalize( this ) deallocate(this%mdl_lambda_center) endif - write(*,*) Iam,'exiting' - end subroutine finalize end module micm_tint_quantum_yield_type diff --git a/test/oldtuv/quantum_yield_factory.F90 b/test/oldtuv/quantum_yield_factory.F90 index 8a256ee1..2b1286bb 100644 --- a/test/oldtuv/quantum_yield_factory.F90 +++ b/test/oldtuv/quantum_yield_factory.F90 @@ -54,7 +54,6 @@ function quantum_yield_builder( config, mdlLambdaEdge ) result( new_quantum_yiel type(string_t) :: quantum_yield_type character(len=*), parameter :: Iam = 'quantum yield builder: ' - write(*,*) Iam,'entering' new_quantum_yield_t => null() call config%get( 'quantum yield type', quantum_yield_type, Iam ) @@ -102,7 +101,6 @@ function quantum_yield_builder( config, mdlLambdaEdge ) result( new_quantum_yiel quantum_yield_type%to_char( )//"'" ) end select call new_quantum_yield_t%initialize( config, mdlLambdaEdge ) - write(*,*) Iam,'exiting' end function quantum_yield_builder diff --git a/test/oldtuv/radXfer_cross_section/abstract.radXfer.cross_section.type.F90 b/test/oldtuv/radXfer_cross_section/abstract.radXfer.cross_section.type.F90 index 5b82cb7d..97e5a535 100644 --- a/test/oldtuv/radXfer_cross_section/abstract.radXfer.cross_section.type.F90 +++ b/test/oldtuv/radXfer_cross_section/abstract.radXfer.cross_section.type.F90 @@ -94,8 +94,6 @@ subroutine addpnts( this, config, data_lambda, data_parameter ) logical :: found character(len=:), allocatable :: number - write(*,*) Iam,'entering' - !> add endpoints to data arrays; first the lower bound nRows = size(data_lambda) lowerLambda = data_lambda(1) ; upperLambda = data_lambda(nRows) @@ -125,8 +123,6 @@ subroutine addpnts( this, config, data_lambda, data_parameter ) call addpnt(x=data_lambda,y=data_parameter,xnew=(rONE+deltax)*upperLambda,ynew=addpnt_val_upper) call addpnt(x=data_lambda,y=data_parameter,xnew=1.e38_musica_dk,ynew=addpnt_val_upper) - write(*,*) Iam,'exiting' - end subroutine addpnts end module micm_radXfer_abs_cross_section_type diff --git a/test/oldtuv/radXfer_cross_section/base.cross_section.type.F90 b/test/oldtuv/radXfer_cross_section/base.cross_section.type.F90 index 4e9e408a..1948dc30 100644 --- a/test/oldtuv/radXfer_cross_section/base.cross_section.type.F90 +++ b/test/oldtuv/radXfer_cross_section/base.cross_section.type.F90 @@ -77,7 +77,6 @@ subroutine initialize( this, config, gridWareHouse, ProfileWareHouse ) type(string_t), allocatable :: netcdfFiles(:) class(base_grid_t), pointer :: lambdaGrid - write(*,*) Iam,'entering' !> Get model wavelength grids Handle = 'Photolysis, wavelength' lambdaGrid => gridWareHouse%get_grid( Handle ) @@ -123,8 +122,6 @@ subroutine initialize( this, config, gridWareHouse, ProfileWareHouse ) enddo file_loop endif has_netcdf_file - write(*,*) Iam,'exiting' - end subroutine initialize !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -152,8 +149,6 @@ function run( this, gridWareHouse, ProfileWareHouse ) result( cross_section ) type(string_t) :: Handle real(musica_dk), allocatable :: wrkCrossSection(:,:) - write(*,*) Iam,'entering' - Handle = 'Vertical Z' zGrid => gridWareHouse%get_grid( Handle ) @@ -166,8 +161,6 @@ function run( this, gridWareHouse, ProfileWareHouse ) result( cross_section ) cross_section = transpose( wrkCrossSection ) - write(*,*) Iam,'exiting' - end function run !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -180,8 +173,6 @@ subroutine finalize( this ) character(len=*), parameter :: Iam = 'base cross section finalize: ' integer(musica_ik) :: ndx - write(*,*) Iam,'entering' - if( allocated(this%cross_section_parms) ) then do ndx = 1,size(this%cross_section_parms) if( allocated(this%cross_section_parms(ndx)%array ) ) then @@ -194,8 +185,6 @@ subroutine finalize( this ) deallocate(this%cross_section_parms) endif - write(*,*) Iam,'exiting' - end subroutine finalize end module micm_radXfer_base_cross_section_type diff --git a/test/oldtuv/radXfer_cross_section/o2.cross_section.type.F90 b/test/oldtuv/radXfer_cross_section/o2.cross_section.type.F90 index 80817cb0..2da0d5a7 100644 --- a/test/oldtuv/radXfer_cross_section/o2.cross_section.type.F90 +++ b/test/oldtuv/radXfer_cross_section/o2.cross_section.type.F90 @@ -79,7 +79,6 @@ subroutine initialize( this, config, gridWareHouse, ProfileWareHouse ) type(string_t), allocatable :: netcdfFiles(:) class(base_grid_t), pointer :: lambdaGrid - write(*,*) Iam,'entering' !> Get model wavelength grids Handle = 'Photolysis, wavelength' lambdaGrid => gridWareHouse%get_grid( Handle ) @@ -133,8 +132,6 @@ subroutine initialize( this, config, gridWareHouse, ProfileWareHouse ) call this%la_srb_obj_%initialize( lambdaGrid ) - write(*,*) Iam,'exiting' - end subroutine initialize !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -162,8 +159,6 @@ function run( this, gridWareHouse, ProfileWareHouse ) result( cross_section ) type(string_t) :: Handle real(musica_dk), allocatable :: wrkCrossSection(:,:) - write(*,*) Iam,'entering' - Handle = 'Vertical Z' zGrid => gridWareHouse%get_grid( Handle ) @@ -176,8 +171,6 @@ function run( this, gridWareHouse, ProfileWareHouse ) result( cross_section ) cross_section = transpose( wrkCrossSection ) - write(*,*) Iam,'exiting' - end function run !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -190,8 +183,6 @@ subroutine finalize( this ) character(len=*), parameter :: Iam = 'base cross section finalize: ' integer(musica_ik) :: ndx - write(*,*) Iam,'entering' - if( allocated(this%cross_section_parms) ) then do ndx = 1,size(this%cross_section_parms) if( allocated(this%cross_section_parms(ndx)%array ) ) then @@ -208,8 +199,6 @@ subroutine finalize( this ) deallocate(this%la_srb_obj_) endif - write(*,*) Iam,'exiting' - end subroutine finalize end module micm_radXfer_o2_cross_section_type diff --git a/test/oldtuv/radXfer_cross_section/o3.tint.cross_section.type.F90 b/test/oldtuv/radXfer_cross_section/o3.tint.cross_section.type.F90 index d503310f..c3c32196 100644 --- a/test/oldtuv/radXfer_cross_section/o3.tint.cross_section.type.F90 +++ b/test/oldtuv/radXfer_cross_section/o3.tint.cross_section.type.F90 @@ -79,8 +79,6 @@ subroutine initialize( this, config, gridWareHouse, ProfileWareHouse ) class(base_grid_t), pointer :: lambdaGrid type(string_t) :: Handle - write(*,*) Iam,'entering' - !> Get model wavelength grids Handle = 'Photolysis, wavelength' lambdaGrid => gridWareHouse%get_grid( Handle ) @@ -165,8 +163,6 @@ subroutine initialize( this, config, gridWareHouse, ProfileWareHouse ) call die_msg( 400000008, msg ) endif has_netcdf_file - write(*,*) Iam,'exiting' - end subroutine initialize !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -202,8 +198,6 @@ function run( this, gridWareHouse, ProfileWareHouse ) result( cross_section ) class(base_profile_t), pointer :: mdlTemperature type(string_t) :: Handle - write(*,*) Iam,'entering' - Handle = 'Vertical Z' zGrid => gridWareHouse%get_grid( Handle ) Handle = 'Photolysis, wavelength' @@ -250,8 +244,6 @@ function run( this, gridWareHouse, ProfileWareHouse ) result( cross_section ) cross_section = transpose( wrkCrossSection ) - write(*,*) Iam,'exiting' - end function run !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/test/oldtuv/radXfer_cross_section/radXfer_xsect_factory.F90 b/test/oldtuv/radXfer_cross_section/radXfer_xsect_factory.F90 index bf215450..22ee28db 100644 --- a/test/oldtuv/radXfer_cross_section/radXfer_xsect_factory.F90 +++ b/test/oldtuv/radXfer_cross_section/radXfer_xsect_factory.F90 @@ -42,7 +42,6 @@ function cross_section_builder( config, gridWareHouse, ProfileWareHouse ) result type(string_t) :: cross_section_type character(len=*), parameter :: Iam = 'cross section builder: ' - write(*,*) Iam,'entering' new_cross_section_t => null( ) call config%get( 'cross section type', cross_section_type, Iam ) @@ -64,7 +63,6 @@ function cross_section_builder( config, gridWareHouse, ProfileWareHouse ) result cross_section_type%to_char( )//"'" ) end select call new_cross_section_t%initialize( config, gridWareHouse, ProfileWareHouse ) - write(*,*) Iam,'exiting' end function cross_section_builder diff --git a/test/oldtuv/radXfer_cross_section/radXfer_xsect_warehouse.F90 b/test/oldtuv/radXfer_cross_section/radXfer_xsect_warehouse.F90 index c305d0ae..68314542 100644 --- a/test/oldtuv/radXfer_cross_section/radXfer_xsect_warehouse.F90 +++ b/test/oldtuv/radXfer_cross_section/radXfer_xsect_warehouse.F90 @@ -74,9 +74,6 @@ function constructor( config, gridWareHouse, ProfileWareHouse ) result( radXfer_ type(string_t), allocatable :: netcdfFiles(:) logical(musica_lk) :: found - write(*,*) ' ' - write(*,*) Iam // 'entering' - allocate( radXfer_xsect_obj ) associate(new_obj=>radXfer_xsect_obj) @@ -97,8 +94,6 @@ function constructor( config, gridWareHouse, ProfileWareHouse ) result( radXfer_ do while( iter%next( ) ) keychar = reaction_set%key(iter) areaction_key = keychar - write(*,*) ' ' - write(*,*) Iam,'key = ',trim(keychar) new_obj%handles_ = [new_obj%handles_,areaction_key] call reaction_set%get( iter, reaction_config, Iam ) !----------------------------------------------------------------------------- @@ -112,14 +107,9 @@ function constructor( config, gridWareHouse, ProfileWareHouse ) result( radXfer_ endif has_radXfer_xsects nSize = size(new_obj%cross_section_objs_) - write(*,*) ' ' - write(*,'(a,''There are '',i3,'' cross sections'')') Iam,nSize end associate - write(*,*) ' ' - write(*,*) Iam // 'exiting' - end function constructor !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -143,9 +133,6 @@ function get_radXfer_cross_section( this, radXfer_cross_section_handle ) result( integer(ik) :: ndx logical(lk) :: found - write(*,*) ' ' - write(*,*) Iam,'entering' - found = .false._lk do ndx = 1,size(this%handles_) if( radXfer_cross_section_handle .eq. this%handles_(ndx) ) then @@ -160,8 +147,6 @@ function get_radXfer_cross_section( this, radXfer_cross_section_handle ) result( call die_msg( 460768224, "Invalid radXfer_cross_section_handle: '"// radXfer_cross_section_handle%to_char()//"'" ) endif - write(*,*) Iam,'exiting' - end function get_radXfer_cross_section !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -175,8 +160,6 @@ subroutine finalize( this ) integer(kind=musica_ik) :: ndx character(len=*), parameter :: Iam = 'radXfer_xsect finalize: ' - write(*,*) Iam,'entering' - if( allocated( this%cross_section_objs_ ) ) then do ndx = 1,size(this%cross_section_objs_) if( associated( this%cross_section_objs_(ndx)%val_ ) ) then @@ -190,8 +173,6 @@ subroutine finalize( this ) deallocate( this%handles_ ) end if - write(*,*) Iam,'exiting' - end subroutine finalize !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/test/oldtuv/radXfer_cross_section/rayliegh.cross_section.type.F90 b/test/oldtuv/radXfer_cross_section/rayliegh.cross_section.type.F90 index c662eed4..8457d0d8 100644 --- a/test/oldtuv/radXfer_cross_section/rayliegh.cross_section.type.F90 +++ b/test/oldtuv/radXfer_cross_section/rayliegh.cross_section.type.F90 @@ -47,10 +47,6 @@ subroutine initialize( this, config, gridWareHouse, ProfileWareHouse ) character(len=*), parameter :: Iam = 'rayliegh cross section initialize: ' - write(*,*) Iam,'entering' - - write(*,*) Iam,'exiting' - end subroutine initialize !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -81,8 +77,6 @@ function run( this, gridWareHouse, ProfileWareHouse ) result( cross_section ) real(musica_dk), allocatable :: pwr(:), wrk(:) real(musica_dk), allocatable :: wrkCrossSection(:,:) - write(*,*) Iam,'entering' - Handle = 'Vertical Z' zGrid => gridWareHouse%get_grid( Handle ) Handle = 'Photolysis, wavelength' @@ -110,8 +104,6 @@ function run( this, gridWareHouse, ProfileWareHouse ) result( cross_section ) cross_section = transpose( wrkCrossSection ) - write(*,*) Iam,'exiting' - end function run !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/test/oldtuv/radXfer_cross_section/tint.cross_section.type.F90 b/test/oldtuv/radXfer_cross_section/tint.cross_section.type.F90 index e9e7189b..2dc9d2b8 100644 --- a/test/oldtuv/radXfer_cross_section/tint.cross_section.type.F90 +++ b/test/oldtuv/radXfer_cross_section/tint.cross_section.type.F90 @@ -78,7 +78,6 @@ subroutine initialize( this, config, gridWareHouse, ProfileWareHouse ) class(base_grid_t), pointer :: lambdaGrid type(string_t) :: Handle - write(*,*) Iam,'entering' !> Get model wavelength grids Handle = 'Photolysis, wavelength' lambdaGrid => gridWareHouse%get_grid( Handle ) @@ -161,8 +160,6 @@ subroutine initialize( this, config, gridWareHouse, ProfileWareHouse ) call die_msg( 400000008, msg ) endif has_netcdf_file - write(*,*) Iam,'exiting' - end subroutine initialize !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -196,8 +193,6 @@ function run( this, gridWareHouse, ProfileWareHouse ) result( cross_section ) class(base_profile_t), pointer :: mdlTemperature type(string_t) :: Handle - write(*,*) Iam,'entering' - Handle = 'Vertical Z' zGrid => gridWareHouse%get_grid( Handle ) Handle = 'Photolysis, wavelength' @@ -228,8 +223,6 @@ function run( this, gridWareHouse, ProfileWareHouse ) result( cross_section ) cross_section = transpose( wrkCrossSection ) - write(*,*) Iam,'exiting' - end function run !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -242,8 +235,6 @@ subroutine finalize( this ) character(len=*), parameter :: Iam = 'tint cross section finalize: ' integer(musica_ik) :: ndx - write(*,*) Iam,'entering' - if( allocated(this%cross_section_parms) ) then do ndx = 1,size(this%cross_section_parms) associate( Xsection => this%cross_section_parms(ndx) ) @@ -261,8 +252,6 @@ subroutine finalize( this ) deallocate(this%cross_section_parms) endif - write(*,*) Iam,'exiting' - end subroutine finalize end module micm_radXfer_tint_cross_section_type diff --git a/test/oldtuv/radiator/aerosol.radiator.type.F90 b/test/oldtuv/radiator/aerosol.radiator.type.F90 index d26c5c0a..af7bf417 100644 --- a/test/oldtuv/radiator/aerosol.radiator.type.F90 +++ b/test/oldtuv/radiator/aerosol.radiator.type.F90 @@ -66,9 +66,6 @@ subroutine initialize( this, radiator_config, gridWareHouse ) class(base_grid_t), pointer :: zGrid, lambdaGrid class(abs_interpolator_t), pointer :: theInterpolator - write(*,*) ' ' - write(*,*) Iam,'entering' - Handle = 'Vertical Z' ; zGrid => gridWareHouse%get_grid( Handle ) Handle = 'Photolysis, wavelength' ; lambdaGrid => gridWareHouse%get_grid( Handle ) @@ -76,7 +73,6 @@ subroutine initialize( this, radiator_config, gridWareHouse ) !> Get radiator "Handle" !----------------------------------------------------------------------------- call radiator_config%get( 'Handle', this%handle_, Iam ) - write(*,*) Iam // 'handle = ',this%handle_%to_char() !> allocate radiator state variables allocate( this%state_%layer_OD_(zGrid%ncells_,lambdaGrid%ncells_) ) @@ -89,25 +85,14 @@ subroutine initialize( this, radiator_config, gridWareHouse ) nInputBins = size(input_OD) if( nInputBins > 1 ) then !> interpolate input OD to state variable - write(*,*) Iam // 'OD from config' - write(*,*) Iam // 'size input_OD = ',nInputBins - write(*,*) Iam // 'input_OD' - write(*,'(1p10g15.7)') input_OD call diagout( 'rawOD.new',input_OD ) input_OD(:nInputBins-1) = .5_dk*(input_OD(:nInputBins-1)+input_OD(2:)) - write(*,'(1p10g15.7)') input_OD(:nInputBins-1) call diagout( 'inpaerOD.new',input_OD(:nInputBins-1) ) allocate( interp3_t :: theInterpolator ) input_zgrid = (/ (real(k,dk),k=0,nInputBins-1) /) - write(*,*) Iam // 'input zgrid' - write(*,'(1p10g15.7)') input_zgrid rad_OD = theInterpolator%interpolate( zGrid%edge_, input_zgrid,input_OD, 1 ) call diagout( 'cz.aer.new',rad_OD ) - write(*,*) 'size interpolated_OD = ',size(rad_OD) - write(*,*) 'size interpolated_OD = ',sizeof(rad_OD) - write(*,*) Iam // 'interpolated OD' - write(*,'(1p10g15.7)') rad_OD do binNdx = 1,lambdaGrid%ncells_ this%state_%layer_OD_(:,binNdx) = rad_OD enddo @@ -128,9 +113,6 @@ subroutine initialize( this, radiator_config, gridWareHouse ) do binNdx = 2,lambdaGrid%ncells_ this%state_%layer_SSA_(:,binNdx) = this%state_%layer_SSA_(:,1) enddo - write(*,*) Iam // 'SSA from config' - write(*,*) Iam // 'size SSA = ',size(input_SSA) - write(*,*) input_SSA endif call radiator_config%get( "Asymmetry factor", Aerosol_config, Iam ) @@ -146,15 +128,10 @@ subroutine initialize( this, radiator_config, gridWareHouse ) do binNdx = 2,lambdaGrid%ncells_ this%state_%layer_G_(:,binNdx) = this%state_%layer_G_(:,1) enddo - write(*,*) Iam // 'G from config' - write(*,*) Iam // 'size G = ',size(input_G) - write(*,*) input_G endif call radiator_config%get( "550 optical depth", tau550, Iam, default=0._dk ) call radiator_config%get( "Alpha", alpha, Iam, default=1._dk ) - write(*,*) Iam // 'tau550, alpha from config' - write(*,*) tau550, alpha if( tau550 > 0.235_dk ) then coldens = max( sum( this%state_%layer_OD_(:,1) ),pzero ) @@ -176,26 +153,6 @@ subroutine initialize( this, radiator_config, gridWareHouse ) endwhere enddo - write(*,*) Iam // 'layer OD @ lambda = ',lambdaGrid%mid_(1) - write(*,'(1p10g15.7)') this%state_%layer_OD_(:,1) - write(*,*) Iam // 'layer OD @ lambda = ',lambdaGrid%mid_(lambdaGrid%ncells_) - write(*,'(1p10g15.7)') this%state_%layer_OD_(:,lambdaGrid%ncells_) - write(*,*) ' ' - write(*,*) Iam // 'layer SSA @ lambda = ',lambdaGrid%mid_(1) - write(*,'(1p10g15.7)') this%state_%layer_SSA_(:,1) - write(*,*) Iam // 'layer SSA @ lambda = ',lambdaGrid%mid_(lambdaGrid%ncells_) - write(*,'(1p10g15.7)') this%state_%layer_SSA_(:,lambdaGrid%ncells_) - write(*,*) ' ' - write(*,*) Iam // 'layer G @ lambda = ',lambdaGrid%mid_(1) - write(*,'(1p10g15.7)') this%state_%layer_G_(:,1) - write(*,*) Iam // 'layer G @ lambda = ',lambdaGrid%mid_(lambdaGrid%ncells_) - write(*,'(1p10g15.7)') this%state_%layer_G_(:,lambdaGrid%ncells_) - - write(*,*) ' ' - write(*,*) Iam,'exiting' - -! stop 'Debugging' - end subroutine initialize !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -228,25 +185,17 @@ subroutine upDateState( this, gridWareHouse, ProfileWareHouse, radXferXsectWareH class(base_grid_t), pointer :: zGrid class(base_grid_t), pointer :: lambdaGrid - write(*,*) ' ' - write(*,*) Iam,'entering' - - write(*,*) Iam // 'handle = ',this%handle_%to_char() !----------------------------------------------------------------------------- !> get specific grids and profiles !----------------------------------------------------------------------------- Handle = 'Vertical Z' ; zGrid => gridWareHouse%get_grid( Handle ) Handle = 'Photolysis, wavelength' ; lambdaGrid => gridWareHouse%get_grid( Handle ) - write(*,*) Iam // 'nlyr,nbins = ',zGrid%ncells_,lambdaGrid%ncells_ !> check that radiator state is allocated if( .not. allocated( this%state_%layer_OD_ ) ) then call die_msg( 2222222,"In radiator%upDateState radiator state not allocate" ) endif - write(*,*) ' ' - write(*,*) Iam,'exiting' - end subroutine upDateState end module micm_aerosol_radiator_type diff --git a/test/oldtuv/radiator/base.radiator.type.F90 b/test/oldtuv/radiator/base.radiator.type.F90 index 84d2051d..539fb7c9 100644 --- a/test/oldtuv/radiator/base.radiator.type.F90 +++ b/test/oldtuv/radiator/base.radiator.type.F90 @@ -49,9 +49,6 @@ subroutine initialize( this, radiator_config, gridWareHouse ) type(string_t) :: Handle class(base_grid_t), pointer :: zGrid, lambdaGrid - write(*,*) ' ' - write(*,*) Iam,'entering' - Handle = 'Vertical Z' ; zGrid => gridWareHouse%get_grid( Handle ) Handle = 'Photolysis, wavelength' ; lambdaGrid => gridWareHouse%get_grid( Handle ) @@ -59,19 +56,11 @@ subroutine initialize( this, radiator_config, gridWareHouse ) !> Get radiator "Handle" !----------------------------------------------------------------------------- call radiator_config%get( 'Handle', this%handle_, Iam ) - write(*,*) Iam // 'handle = ',this%handle_%to_char() !> allocate radiator state_ variables allocate( this%state_%layer_OD_(zGrid%ncells_,lambdaGrid%ncells_) ) allocate( this%state_%layer_SSA_(zGrid%ncells_,lambdaGrid%ncells_) ) allocate( this%state_%layer_G_(zGrid%ncells_,lambdaGrid%ncells_) ) - write(*,*) Iam // 'state_%layer_OD_ is allocated = ',allocated(this%state_%layer_OD_) - write(*,*) Iam // 'state_%layer_SSA_ is allocated = ',allocated(this%state_%layer_SSA_) - write(*,*) Iam // 'state_%layer_G_ is allocated = ',allocated(this%state_%layer_G_) - write(*,*) Iam // 'state_%layer_OD_ is (',size(this%state_%layer_OD_,dim=1),' x ',size(this%state_%layer_OD_,dim=2),')' - - write(*,*) ' ' - write(*,*) Iam,'exiting' end subroutine initialize @@ -111,10 +100,6 @@ subroutine upDateState( this, gridWareHouse, ProfileWareHouse, radXferXsectWareH class(base_profile_t), pointer :: radiatorProfile class(abs_cross_section_t), pointer :: radiatorCrossSection - write(*,*) ' ' - write(*,*) Iam,'entering' - - write(*,*) Iam // 'handle = ',this%handle_%to_char() !----------------------------------------------------------------------------- !> get specific grids and profiles !----------------------------------------------------------------------------- @@ -122,7 +107,6 @@ subroutine upDateState( this, gridWareHouse, ProfileWareHouse, radXferXsectWareH zGrid => gridWareHouse%get_grid( Handle ) Handle = 'Photolysis, wavelength' lambdaGrid => gridWareHouse%get_grid( Handle ) - write(*,*) Iam // 'nlyr,nbins = ',zGrid%ncells_,lambdaGrid%ncells_ !> Note: uses radiator handle for Profile handle radiatorProfile => ProfileWareHouse%get_Profile( this%handle_ ) @@ -133,11 +117,7 @@ subroutine upDateState( this, gridWareHouse, ProfileWareHouse, radXferXsectWareH !> check radiator state type allocation if( .not. allocated( this%state_%layer_OD_ ) ) then call die_msg( 2222222,"In radiator%upDateState radiator state not allocate" ) - else - write(*,*) Iam // 'radiator state is allocated' endif - write(*,*) Iam // 'size OD = ',size(this%state_%layer_OD_,dim=1),' x ', & - size(this%state_%layer_OD_,dim=2) !> set radiator state members CrossSection = radiatorCrossSection%calculate( gridWareHouse, ProfileWareHouse ) @@ -155,9 +135,6 @@ subroutine upDateState( this, gridWareHouse, ProfileWareHouse, radXferXsectWareH this%state_%layer_G_ = 0._dk endif - write(*,*) ' ' - write(*,*) Iam,'exiting' - end subroutine upDateState end module micm_base_radiator_type diff --git a/test/oldtuv/radiator/radiator_factory.F90 b/test/oldtuv/radiator/radiator_factory.F90 index 83df2c7b..c18c1a40 100644 --- a/test/oldtuv/radiator/radiator_factory.F90 +++ b/test/oldtuv/radiator/radiator_factory.F90 @@ -39,7 +39,6 @@ function radiator_builder( config, gridWareHouse ) result( new_radiator_t ) type(string_t) :: radiator_type character(len=*), parameter :: Iam = 'Radiator builder: ' - write(*,*) Iam,'entering' new_radiator_t => null() call config%get( 'radiator type', radiator_type, Iam ) @@ -53,7 +52,6 @@ function radiator_builder( config, gridWareHouse ) result( new_radiator_t ) end select call new_radiator_t%initialize( config, gridWareHouse ) - write(*,*) Iam,'exiting' end function radiator_builder diff --git a/test/oldtuv/radiator/radiator_warehouse.F90 b/test/oldtuv/radiator/radiator_warehouse.F90 index ee8cc152..45c6743c 100644 --- a/test/oldtuv/radiator/radiator_warehouse.F90 +++ b/test/oldtuv/radiator/radiator_warehouse.F90 @@ -87,8 +87,6 @@ function constructor( config, gridWareHouse ) result( radiator_warehouse ) character(len=32) :: keychar type(string_t) :: keyString - write(*,*) Iam // 'entering' - call config%get( 'Radiators', radiator_config_set, Iam ) allocate( radiator_warehouse ) @@ -98,8 +96,6 @@ function constructor( config, gridWareHouse ) result( radiator_warehouse ) iter => radiator_config_set%get_iterator() do while( iter%next() ) keychar = radiator_config_set%key(iter) - write(*,*) ' ' - write(*,*) Iam,'key = ',trim(keychar) keyString = keychar call radiator_config_set%get( iter, radiator_config, Iam ) call radiator_config%add( 'Handle', keyString, Iam ) @@ -113,15 +109,6 @@ function constructor( config, gridWareHouse ) result( radiator_warehouse ) deallocate( iter ) - write(*,*) ' ' - write(*,'(a,''There are '',i3,'' radiators'')') Iam,size(radiator_warehouse%radiators_) - write(*,*) 'radiator handles' - do ndx = 1,size(radiator_warehouse%handle_) - write(*,'(a)') radiator_warehouse%handle_(ndx)%to_char() - enddo - - write(*,*) Iam // 'exiting' - end function constructor !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -144,9 +131,6 @@ function get_radiator_from_handle( this, radiator_handle ) result( radiator ) integer(ik) :: ndx logical(lk) :: found - write(*,*) ' ' - write(*,*) Iam,'entering' - found = .false._lk do ndx = 1,size(this%handle_) if( radiator_handle .eq. this%handle_(ndx) ) then @@ -161,8 +145,6 @@ function get_radiator_from_handle( this, radiator_handle ) result( radiator ) call die_msg( 460768324, "Invalid radiator handle: '"// radiator_handle%to_char()//"'" ) endif - write(*,*) Iam,'exiting' - end function get_radiator_from_handle !> Get index of a specific radiator object @@ -183,9 +165,6 @@ function get_radiator_ndx_from_handle( this, radiator_handle ) result( Index ) character(len=*), parameter :: Iam = 'radiator warehouse get_radiator_ndx: ' logical(lk) :: found - write(*,*) ' ' - write(*,*) Iam,'entering' - found = .false._lk do Index = 1,size(this%handle_) if( radiator_handle .eq. this%handle_(Index) ) then @@ -199,8 +178,6 @@ function get_radiator_ndx_from_handle( this, radiator_handle ) result( Index ) Index = -1 endif - write(*,*) Iam,'exiting' - end function get_radiator_ndx_from_handle !> Get copy of a radiator object using an iterator @@ -219,25 +196,10 @@ function get_radiator_from_iterator( this, iterator ) result( radiator ) character(len=*), parameter :: Iam = 'radiator warehouse get_radiator from iterator: ' integer(ik) :: ndx - write(*,*) ' ' - write(*,*) Iam,'entering' - ndx = iterator%id_ - write(*,*) Iam,'radiator handle = ',this%radiators_(ndx)%val_%handle_%to_char() radiator => this%radiators_(ndx)%val_ - write(*,*) Iam,'radiator diagnostics' - write(*,*) Iam,'radiator handle = ',radiator%handle_%to_char() - write(*,*) Iam,'radiator state OD is allocated = ',allocated(radiator%state_%layer_OD_) - write(*,*) Iam,'radiator state SSA is allocated = ',allocated(radiator%state_%layer_SSA_) - write(*,*) Iam,'radiator state G is allocated = ',allocated(radiator%state_%layer_G_) - - write(*,*) ' ' - write(*,*) Iam,'exiting' - -! stop 'debugging' - end function get_radiator_from_iterator !> Is a radiator in the warehouse? @@ -258,9 +220,6 @@ function in_warehouse( this, radiator_handle ) character(len=*), parameter :: Iam = 'radiator in warehouse: ' integer(ik) :: ndx - write(*,*) ' ' - write(*,*) Iam,'entering' - in_warehouse = .false._lk do ndx = 1,size(this%handle_) if( radiator_handle == this%handle_(ndx) ) then @@ -269,8 +228,6 @@ function in_warehouse( this, radiator_handle ) endif end do - write(*,*) Iam,'exiting' - end function in_warehouse !> Gets an interator for the radiator warehouse @@ -333,14 +290,10 @@ subroutine finalize( this ) integer(kind=musica_ik) :: ndx character(len=*), parameter :: Iam = 'radiator_warehouse finalize: ' - write(*,*) Iam,'entering' - if( allocated( this%radiators_ ) ) then deallocate( this%radiators_ ) endif - write(*,*) Iam,'exiting' - end subroutine finalize !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/test/oldtuv/radiator/radiator_warehouse.v0.F90 b/test/oldtuv/radiator/radiator_warehouse.v0.F90 index bf3df3d9..400477d6 100644 --- a/test/oldtuv/radiator/radiator_warehouse.v0.F90 +++ b/test/oldtuv/radiator/radiator_warehouse.v0.F90 @@ -62,8 +62,6 @@ function constructor( config ) result( radiator_warehouse ) character(len=32) :: keychar type(string_t) :: keyString - write(*,*) Iam // 'entering' - call config%get( 'Radiators', radiator_config_set, Iam ) iter => radiator_config_set%get_iterator() @@ -73,8 +71,6 @@ function constructor( config ) result( radiator_warehouse ) do while( iter%next() ) keychar = radiator_config_set%key(iter) - write(*,*) ' ' - write(*,*) Iam,'key = ',trim(keychar) keyString = keychar call radiator_config_set%get( iter, radiator_config, Iam ) call radiator_config%add( 'Handle', keyString, Iam ) @@ -88,9 +84,6 @@ function constructor( config ) result( radiator_warehouse ) deallocate( iter ) - write(*,*) ' ' - write(*,'(a,''There are '',i3,'' radiators'')') Iam,size(radiator_warehouse%radiators_) - end function constructor !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -114,9 +107,6 @@ function get_radiator( this, radiator_handle ) result( radiator_ptr ) integer(ik) :: ndx logical(lk) :: found - write(*,*) ' ' - write(*,*) Iam,'entering' - found = .false._lk do ndx = 1,size(this%handle_) if( radiator_handle .eq. this%handle_(ndx) ) then @@ -131,8 +121,6 @@ function get_radiator( this, radiator_handle ) result( radiator_ptr ) call die_msg( 460768324, "Invalid radiator handle: '"// radiator_handle%to_char()//"'" ) endif - write(*,*) Iam,'exiting' - end function get_radiator !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -146,14 +134,10 @@ subroutine finalize( this ) integer(kind=musica_ik) :: ndx character(len=*), parameter :: Iam = 'radiator_warehouse finalize: ' - write(*,*) Iam,'entering' - if( allocated( this%radiators_ ) ) then deallocate( this%radiators_ ) endif - write(*,*) Iam,'exiting' - end subroutine finalize !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/test/oldtuv/rdetfl.f b/test/oldtuv/rdetfl.f index 7ff2bad8..2217aa25 100644 --- a/test/oldtuv/rdetfl.f +++ b/test/oldtuv/rdetfl.f @@ -99,20 +99,6 @@ SUBROUTINE rdetfl(nw,wl,f) CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.) CALL addpnt(x1,y1,kdata,n, 1.e+38,0.) - write(*,*) ' ' - write(*,*) 'Diagnostics for atlas3_1994_317_a' - write(*,*) 'read1: size model lambdaGrid = ',nw - write(*,*) 'read1: lambdaGrid' - write(*,'(1p10g15.7)') wl(:nw) - write(*,*) ' ' - write(*,*) 'read1: size inputGrid = ',n - write(*,*) 'read1: inputGrid' - write(*,'(1p10g15.7)') x1(:n) - write(*,*) ' ' - write(*,*) 'read1: size inputData = ',n - write(*,*) 'read1: inputData' - write(*,'(1p10g15.7)') y1(:n) - call diagout( 'atlas.inputGrid.old', x1(:n) ) call diagout( 'atlas.inputData.old', y1(:n) ) @@ -124,11 +110,6 @@ SUBROUTINE rdetfl(nw,wl,f) call diagout( 'atlas.interpolated.old', yg2(:nw-1) ) - write(*,*) ' ' - write(*,*) 'read1: size yg2 = ',size(yg2) - write(*,*) 'read1: interpolated Etfl' - write(*,'(1p10g15.7)') yg2(:nw-1) - fil = 'odat/DATAE1/SUN/neckel.flx' write(kout,*) fil OPEN(UNIT=kin,FILE=fil,STATUS='old') @@ -156,24 +137,7 @@ SUBROUTINE rdetfl(nw,wl,f) call diagout( 'neckel.inputGrid.old', x1(:n+1) ) call diagout( 'neckel.inputData.old', y1(:n+1) ) - write(*,*) ' ' - write(*,*) 'Diagnostics for neckel.flx' - write(*,*) 'read1: size model lambdaGrid = ',nw - write(*,*) 'read1: lambdaGrid' - write(*,'(1p10g15.7)') wl(:nw) - write(*,*) ' ' - write(*,*) 'read1: size inputGrid = ',n+1 - write(*,*) 'read1: inputGrid' - write(*,'(1p10g15.7)') x1(:n+1) - write(*,*) ' ' - write(*,*) 'read1: size inputData = ',n+1 - write(*,*) 'read1: inputData' - write(*,'(1p10g15.7)') y1(:n+1) call inter4(nw,wl,yg3,n+1,x1,y1,0) - write(*,*) ' ' - write(*,*) 'read1: size yg3 = ',size(yg3) - write(*,*) 'read1: interpolated Etfl' - write(*,'(1p10g15.7)') yg3(:nw-1) call diagout( 'neckel.interpolated.old', yg3(:nw-1) ) nhead = 8 @@ -309,20 +273,6 @@ SUBROUTINE read1(nw,wl,f) > lambda_hi(n)*(1.+deltax),0.) CALL addpnt(lambda_hi,irrad_hi,10000,n, 1.e38,0.) - write(*,*) ' ' - write(*,*) 'Diagnostics for susim_hi.flx' - write(*,*) 'read1: size model lambdaGrid = ',nw - write(*,*) 'read1: lambdaGrid' - write(*,'(1p10g15.7)') wl(:nw) - write(*,*) ' ' - write(*,*) 'read1: size inputGrid = ',n - write(*,*) 'read1: inputGrid' - write(*,'(1p10g15.7)') lambda_hi(:n) - write(*,*) ' ' - write(*,*) 'read1: size inputData = ',n - write(*,*) 'read1: inputData' - write(*,'(1p10g15.7)') irrad_hi(:n) - call diagout( 'susim.inputGrid.old', lambda_hi(:n) ) call diagout( 'susim.inputData.old', irrad_hi(:n) ) @@ -334,11 +284,6 @@ SUBROUTINE read1(nw,wl,f) call diagout( 'susim.interpolated.old', f(:nw-1) ) - write(*,*) ' ' - write(*,*) 'read1: size f = ',size(f) - write(*,*) 'read1: interpolated Etfl' - write(*,'(1p10g15.7)') f(:nw-1) - END SUBROUTINE read1 *=============================================================================* diff --git a/test/oldtuv/rdxs.f b/test/oldtuv/rdxs.f index 245053ea..2c33c89c 100644 --- a/test/oldtuv/rdxs.f +++ b/test/oldtuv/rdxs.f @@ -1261,8 +1261,6 @@ SUBROUTINE no2xs_jpl06a(nz,t,nw,wl, no2xs) CALL addpnt(x2,y2,kdata,n2, 1.e+38, 0.) CALL inter2(nw,wl,yg2,n2,x2,y2,ierr) - write(*,*) 'no2xs_jpl06a: n1,n2 = ',n1,n2 - Tadj = max( 220.,min( 294.,t ) ) Tfac = (Tadj - 220.)/74. DO iw = 1, nw-1 diff --git a/test/oldtuv/rtrans.f b/test/oldtuv/rtrans.f index 278fd45d..df7fda80 100644 --- a/test/oldtuv/rtrans.f +++ b/test/oldtuv/rtrans.f @@ -1618,7 +1618,6 @@ SUBROUTINE FLUXES( tausla, tauslau, REAL :: ANG1, ANG2, DIRINT, FACT, FDNTOT, FNET, PLSORC, ZINT c .. - IF( PRNT( 2 ) ) WRITE( *, 9000 ) c ** Zero DISORT output arrays U0C = 0. FLDIR = 0. @@ -1749,26 +1748,16 @@ SUBROUTINE FLUXES( tausla, tauslau, & ( UAVG( LU ) - PLSORC ) 70 CONTINUE - IF( PRNT( 2 ) ) WRITE( *, FMT = 9010 ) UTAU( LU ), LYU, - & RFLDIR( LU ), RFLDN( LU ), FDNTOT, FLUP( LU ), FNET, - & UAVG( LU ), PLSORC, DFDT( LU ) - ENDDO LEVEL_LOOP IF( PRNT( 3 ) ) THEN - WRITE( *, FMT = 9020 ) - DO LU = 1, NTAU - WRITE( *, FMT = 9030 ) UTAU( LU ) - DO IQ = 1, NN ANG1 = 180./ PI* ACOS( CMU( 2*NN - IQ + 1 ) ) ANG2 = 180./ PI* ACOS( CMU( IQ ) ) - WRITE( *, 9040 ) ANG1, CMU(2*NN-IQ+1), U0C(IQ,LU), - $ ANG2, CMU(IQ), U0C(IQ+NN,LU) ENDDO ENDDO @@ -1944,26 +1933,13 @@ SUBROUTINE PRAVIN( UMU, NUMU, UTAU, NTAU, U0U ) IF( NUMU.LT.1 ) RETURN - WRITE( *, '(//,A)' ) - & ' ******* AZIMUTHALLY AVERAGED INTENSITIES ' // - & '(at user polar angles) ********' - LENFMT = 8 NPASS = 1 + (NUMU-1) / LENFMT - WRITE( *,'(/,A,/,A)') ' Optical Polar Angle Cosines', - & ' Depth' - DO 20 NP = 1, NPASS IUMIN = 1 + LENFMT * ( NP - 1 ) IUMAX = MIN( LENFMT*NP, NUMU ) - WRITE( *,'(/,10X,8F14.5)') ( UMU(IU), IU = IUMIN, IUMAX ) - - DO 10 LU = 1, NTAU - WRITE( *, '(0P,F10.4,1P,8E14.4)' ) UTAU( LU ), - & ( U0U( IU,LU ), IU = IUMIN, IUMAX ) - 10 CONTINUE 20 CONTINUE @@ -2000,110 +1976,12 @@ SUBROUTINE PRTINP( NLYR, DTAUC, DTAUCP, SSALB, PMOM, c .. - WRITE( *, '(/,A,I4,A,I4)' ) ' No. streams =', NSTR, - & ' No. computational layers =', NLYR - - IF( IBCND /= 1 ) WRITE( *, '(I4,A,10F10.4,/,(26X,10F10.4))' ) - & NTAU,' User optical depths :', ( UTAU(LU), LU = 1, NTAU ) - - IF( .NOT. ONLYFL ) WRITE( *, '(I4,A,10F9.5,/,(31X,10F9.5))' ) - & NUMU,' User polar angle cosines :',( UMU(IU), IU = 1, NUMU ) - - IF( .NOT. ONLYFL .AND. IBCND /= 1 ) - & WRITE( *, '(I4,A,10F9.2,/,(28X,10F9.2))' ) - & NPHI,' User azimuthal angles :',( PHI(J), J = 1, NPHI ) - - IF( .NOT. PLANK .OR. IBCND == 1 ) - & WRITE( *, '(A)' ) ' No thermal emission' - - - WRITE( *, '(A,I2)' ) ' Boundary condition flag: IBCND =', IBCND - - IF( IBCND == 0 ) THEN - - WRITE( *, '(A,1P,E11.3,A,0P,F8.5,A,F7.2,/,A,1P,E11.3)' ) - & ' Incident beam with intensity =', FBEAM, - & ' and polar angle cosine = ', UMU0, - & ' and azimuth angle =', PHI0, - & ' plus isotropic incident intensity =', FISOT - - IF( LAMBER ) WRITE( *, '(A,0P,F8.4)' ) - & ' Bottom albedo (Lambertian) =', ALBEDO - - IF( .NOT. LAMBER ) WRITE( *, '(A,/,(10X,10F9.5))' ) - & ' Legendre coeffs of bottom bidirectional reflectivity :', - & ( HL( K ), K = 0, NSTR ) - - ELSE IF( IBCND == 1 ) THEN - - WRITE(*,'(A)') ' Isotropic illumination from top and bottom' - WRITE( *, '(A,0P,F8.4)' ) - & ' Bottom albedo (Lambertian) =', ALBEDO - END IF - - - IF( DELTAM ) WRITE( *, '(A)' ) ' Uses delta-M method' - IF( .NOT.DELTAM ) WRITE( *, '(A)' ) ' Does not use delta-M method' - - - IF( IBCND == 1 ) THEN - - WRITE( *, '(A)' ) ' Calculate albedo and transmissivity of'// - & ' medium vs. incident beam angle' - - ELSE IF( ONLYFL ) THEN - - WRITE( *, '(A)' ) - & ' Calculate fluxes and azim-averaged intensities only' - - ELSE - - WRITE( *, '(A)' ) ' Calculate fluxes and intensities' - - END IF - - - WRITE( *, '(A,1P,E11.2)' ) - & ' Relative convergence criterion for azimuth series =', - & ACCUR - - IF( LYRCUT ) WRITE( *, '(A)' ) - & ' Sets radiation = 0 below absorption optical depth 10' - - -c ** Print layer variables - IF( PLANK ) WRITE( *, FMT = 9180 ) - IF( .NOT. PLANK ) WRITE( *, FMT = 9190 ) - YESSCT = rZERO DO LC = 1, NLYR YESSCT = YESSCT + SSALB( LC ) - - IF( PLANK ) - & WRITE(*,'(I4,2F10.4,F10.5,F12.5,2F10.4,F10.5,F9.4,F14.3)') - & LC, DTAUC( LC ), TAUC( LC ), SSALB( LC ), FLYR( LC ), - & DTAUCP( LC ), TAUCPR( LC ), OPRIM( LC ), PMOM(1,LC) - - IF( .NOT.PLANK ) - & WRITE(*,'(I4,2F10.4,F10.5,F12.5,2F10.4,F10.5,F9.4)') - & LC, DTAUC( LC ), TAUC( LC ), SSALB( LC ), FLYR( LC ), - & DTAUCP( LC ), TAUCPR( LC ), OPRIM( LC ), PMOM( 1,LC ) ENDDO - - IF( PRTMOM .AND. YESSCT > rZERO ) THEN - - WRITE( *, '(/,A)' ) ' Layer Phase Function Moments' - - DO LC = 1, NLYR - IF( SSALB( LC ).GT.rZERO ) - & WRITE( *, '(I6,10F11.6,/,(6X,10F11.6))' ) - & LC, ( PMOM( K, LC ), K = 0, NSTR ) - ENDDO - - END IF - c ** (Read every other line in these formats) 9180 FORMAT( /, 37X, '<------------- Delta-M --------------->', /, @@ -2156,17 +2034,9 @@ SUBROUTINE PRTINT( UU, UTAU, NTAU, UMU, NUMU, PHI ) IF( NPHI.LT.1 ) RETURN - WRITE( *, '(//,A)' ) - & ' ********* I N T E N S I T I E S *********' - LENFMT = 10 NPASS = 1 + (NPHI-1) / LENFMT - WRITE( *, '(/,A,/,A,/,A)' ) - & ' Polar Azimuth angles (degrees)', - & ' Optical Angle', - & ' Depth Cosine' - DO 30 LU = 1, NTAU DO 20 NP = 1, NPASS @@ -2174,18 +2044,6 @@ SUBROUTINE PRTINT( UU, UTAU, NTAU, UMU, NUMU, PHI ) JMIN = 1 + LENFMT * ( NP - 1 ) JMAX = MIN( LENFMT*NP, NPHI ) - WRITE( *, '(/,18X,10F11.2)' ) ( PHI(J), J = JMIN, JMAX ) - - IF( NP.EQ.1 ) WRITE( *, '(F10.4,F8.4,1P,10E11.3)' ) - & UTAU(LU), UMU(1), (UU(1, LU, J), J = JMIN, JMAX) - IF( NP.GT.1 ) WRITE( *, '(10X,F8.4,1P,10E11.3)' ) - & UMU(1), (UU(1, LU, J), J = JMIN, JMAX) - - DO 10 IU = 2, NUMU - WRITE( *, '(10X,F8.4,1P,10E11.3)' ) - & UMU( IU ), ( UU( IU, LU, J ), J = JMIN, JMAX ) - 10 CONTINUE - 20 CONTINUE 30 CONTINUE @@ -2966,9 +2824,6 @@ SUBROUTINE SOLEIG( AMB, APB, ARRAY, CMU, CWT, GL, MAZIM, IF( IER.GT.0 ) THEN - WRITE( *, FMT = '(//,A,I4,A)' ) ' ASYMTX--eigenvalue no. ', - & IER, ' didnt converge. Lower-numbered eigenvalues wrong.' - CALL ERRMSG( 'ASYMTX--convergence problems',.True.) END IF @@ -3738,15 +3593,6 @@ SUBROUTINE SOLVEC( AMB, APB, ARRAY, CMU, CWT, GL, SSA = DSSA - IF (DEBUG) THEN - write (*,*) '! *** The upward iteration did not converge.' - write (*,*) '! *** Had to iterate ', DAGAIN, - $ ' times in layer LC =', LC,';' - write (*,*) '! *** changed SSA from ', - $ OPRIM, ' to ', SSA,',' - write (*,*) '! *** by a factor of ', SSA/OPRIM - ENDIF - DONE = .TRUE. GOTO 777 ENDIF @@ -3754,15 +3600,6 @@ SUBROUTINE SOLVEC( AMB, APB, ARRAY, CMU, CWT, GL, *bm if downward iteration did not converge, we are done *bm (the result of the upward iteration will be used) IF (NODN) THEN - IF (DEBUG) THEN - write (*,*) '! *** The downward iteration did not converge.' - write (*,*) '! *** Had to iterate ', UAGAIN, - $ ' times in layer LC =', LC,';' - write (*,*) '! *** changed SSA from ', - $ OPRIM, ' to ', SSA,',' - write (*,*) '! *** by a factor of ', SSA/OPRIM - ENDIF - DONE = .TRUE. GOTO 998 ENDIF @@ -3780,30 +3617,10 @@ SUBROUTINE SOLVEC( AMB, APB, ARRAY, CMU, CWT, GL, SSA = DSSA - IF (DEBUG) THEN - write (*,*) '! *** Both iterations converged;', - $ ' using downward.' - write (*,*) '! *** Had to iterate ', DAGAIN, - $ ' times in layer LC =', LC,';' - write (*,*) '! *** changed SSA from ', - $ OPRIM, ' to ', SSA,',' - write (*,*) '! *** by a factor of ', SSA/OPRIM - ENDIF - DONE = .TRUE. GOTO 777 ELSE - IF (DEBUG) THEN - write (*,*) '! *** Both iterations converged;', - $ ' using upward.' - write (*,*) '! *** Had to iterate ', UAGAIN, - $ ' times in layer LC =', LC,';' - write (*,*) '! *** changed SSA from ', - $ OPRIM, ' to ', SSA,',' - write (*,*) '! *** by a factor of ', SSA/OPRIM - ENDIF - DONE = .TRUE. goto 998 ENDIF @@ -4227,7 +4044,6 @@ SUBROUTINE ErrMsg( MESSAG, FATAL ) IF ( NumMsg.LE.MaxMsg ) THEN WRITE ( *, '(/,2A,/)' ) ' ******* WARNING >>>>>> ', MESSAG ELSE - WRITE ( *,99 ) MsgLim = .True. ENDIF diff --git a/test/oldtuv/setaer.f b/test/oldtuv/setaer.f index a4fb1a11..1503a749 100644 --- a/test/oldtuv/setaer.f +++ b/test/oldtuv/setaer.f @@ -90,7 +90,6 @@ SUBROUTINE setaer( * Altitudes corresponding to Elterman profile, from bottom to top: - WRITE(kout,*)'aerosols: Elterman (1968) continental profile' nd = 51 zd = (/ (REAL(i-1),i=1,kdata) /) @@ -105,9 +104,6 @@ SUBROUTINE setaer( call diagout( 'rawOD.old',aer ) call diagout( 'inpaerOD.old',cd ) - write(*,*) 'setaer: hardwired OD' - write(*,'(1p10g15.7)') aer - write(*,'(1p10g15.7)') cd *********** end data input. @@ -164,7 +160,6 @@ SUBROUTINE setaer( *! overwrite for pbl: IF(ipbl > 0) THEN - write (*,*) 'pbl aerosols, aod330 = ', aod330 * create wavelength-dependent optical depth and single scattering albedo: DO iw = 1, nbins aodw(iw) = aod330*(wc(iw)/330.)**(-1.0) diff --git a/test/oldtuv/seth2o.f b/test/oldtuv/seth2o.f index ee5ebfa2..3074b73b 100644 --- a/test/oldtuv/seth2o.f +++ b/test/oldtuv/seth2o.f @@ -159,8 +159,6 @@ SUBROUTINE inter1(nz,z,cz, n,x,y) *! overwrite for specified pbl height IF(ipbl .GT. 0) THEN - write(*,*) 'pbl H2O = ', xpbl, ' ppb' - DO i = 1, nz-1 IF (i .LE. ipbl) THEN cz(i) = xpbl*1.E-9 * dcol(i) diff --git a/test/oldtuv/setno2.f b/test/oldtuv/setno2.f index 1a217061..25ba7799 100644 --- a/test/oldtuv/setno2.f +++ b/test/oldtuv/setno2.f @@ -126,7 +126,6 @@ FUNCTION setno2(ipbl, zpbl, xpbl, *! overwrite for specified pbl height IF(ipbl > 0) THEN - write(*,*) 'pbl NO2 = ', xpbl, ' ppb' DO i = 1, nz-1 IF (i .LE. ipbl) THEN cz(i) = xpbl * ppb * dcol(i) diff --git a/test/oldtuv/setsnw.f b/test/oldtuv/setsnw.f index e1ca9115..ccc4b988 100644 --- a/test/oldtuv/setsnw.f +++ b/test/oldtuv/setsnw.f @@ -133,18 +133,6 @@ SUBROUTINE setsnw(z,wl,dtsnw,omsnw,gsnw) cd(is) = rsct(is) + rabs(is) omd(is)= rsct(is) / cd(is) - if(iw == 1)then - print*,"Snowpack: is =",is,"; zs =",zs(is) - PRINT*," ksct =", ksct(is) - PRINT*," density =",snwdens(is) - PRINT*," csoot =",csoot(is) - PRINT*, 'cd = ',cd(is),' omd = ',omd(is),' gd = ',gd - WRITE(kout,*)'snwdens = ',snwdens,' g/cm3' - WRITE(kout,*)'ksct_snow = ',ksct(is),' m2.kg-1' - WRITE(kout,*)'soot = ',csoot(is),' ng/g' - WRITE(kout,*)'cd = ',cd(is),'omd = ',omd(is),'gd = ',gd - endif - * compute integrals and averages over snow layers: * for g and omega, use averages weighted by optical depth womd(is) = omd(is) * cd(is) diff --git a/test/oldtuv/setso2.f b/test/oldtuv/setso2.f index d3b593c2..2c6c2a33 100644 --- a/test/oldtuv/setso2.f +++ b/test/oldtuv/setso2.f @@ -123,7 +123,6 @@ FUNCTION setso2(ipbl, zpbl, xpbl, *! overwrite for specified pbl height, set concentration here IF(ipbl > 0) THEN - write(*,*) 'pbl SO2 = ', xpbl, ' ppb' DO i = 1, nz-1 IF (i <= ipbl) THEN cz(i) = xpbl * ppb * dcol(i) diff --git a/test/oldtuv/solvec.f b/test/oldtuv/solvec.f index 544192a2..2176539e 100644 --- a/test/oldtuv/solvec.f +++ b/test/oldtuv/solvec.f @@ -198,11 +198,6 @@ SUBROUTINE SOLVEC( AMB, APB, ARRAY, CMU, CWT, GL, SSA = OPRIM - IF (DEBUG) THEN - write (*,*) '! *** Neither upward nor downward iteration' - write (*,*) '! *** converged; using original result.' - ENDIF - DONE = .TRUE. GOTO 777 ENDIF @@ -216,15 +211,6 @@ SUBROUTINE SOLVEC( AMB, APB, ARRAY, CMU, CWT, GL, SSA = DSSA - IF (DEBUG) THEN - write (*,*) '! *** The upward iteration did not converge.' - write (*,*) '! *** Had to iterate ', DAGAIN, - $ ' times in layer LC =', LC,';' - write (*,*) '! *** changed SSA from ', - $ OPRIM, ' to ', SSA,',' - write (*,*) '! *** by a factor of ', SSA/OPRIM - ENDIF - DONE = .TRUE. GOTO 777 ENDIF @@ -232,15 +218,6 @@ SUBROUTINE SOLVEC( AMB, APB, ARRAY, CMU, CWT, GL, *bm if downward iteration did not converge, we are done *bm (the result of the upward iteration will be used) IF (NODN) THEN - IF (DEBUG) THEN - write (*,*) '! *** The downward iteration did not converge.' - write (*,*) '! *** Had to iterate ', UAGAIN, - $ ' times in layer LC =', LC,';' - write (*,*) '! *** changed SSA from ', - $ OPRIM, ' to ', SSA,',' - write (*,*) '! *** by a factor of ', SSA/OPRIM - ENDIF - DONE = .TRUE. GOTO 998 ENDIF @@ -258,30 +235,10 @@ SUBROUTINE SOLVEC( AMB, APB, ARRAY, CMU, CWT, GL, SSA = DSSA - IF (DEBUG) THEN - write (*,*) '! *** Both iterations converged;', - $ ' using downward.' - write (*,*) '! *** Had to iterate ', DAGAIN, - $ ' times in layer LC =', LC,';' - write (*,*) '! *** changed SSA from ', - $ OPRIM, ' to ', SSA,',' - write (*,*) '! *** by a factor of ', SSA/OPRIM - ENDIF - DONE = .TRUE. GOTO 777 ELSE - IF (DEBUG) THEN - write (*,*) '! *** Both iterations converged;', - $ ' using upward.' - write (*,*) '! *** Had to iterate ', UAGAIN, - $ ' times in layer LC =', LC,';' - write (*,*) '! *** changed SSA from ', - $ OPRIM, ' to ', SSA,',' - write (*,*) '! *** by a factor of ', SSA/OPRIM - ENDIF - DONE = .TRUE. goto 998 ENDIF diff --git a/test/oldtuv/spectral_wght/UV_Index.spectral_wght.type.F90 b/test/oldtuv/spectral_wght/UV_Index.spectral_wght.type.F90 index 63f42040..db776978 100644 --- a/test/oldtuv/spectral_wght/UV_Index.spectral_wght.type.F90 +++ b/test/oldtuv/spectral_wght/UV_Index.spectral_wght.type.F90 @@ -41,12 +41,8 @@ function run( this, environment ) result( spectral_wght ) character(len=*), parameter :: Iam = 'uv_index calculate: ' - write(*,*) Iam,'entering' - spectral_wght = 40._musica_dk*fery( this%mdl_lambda_center ) - write(*,*) Iam,'exiting' - end function run FUNCTION fery(w) diff --git a/test/oldtuv/spectral_wght/abstract.spectral_wght.type.F90 b/test/oldtuv/spectral_wght/abstract.spectral_wght.type.F90 index 0e85652f..ff1dd9ec 100644 --- a/test/oldtuv/spectral_wght/abstract.spectral_wght.type.F90 +++ b/test/oldtuv/spectral_wght/abstract.spectral_wght.type.F90 @@ -93,8 +93,6 @@ subroutine addpnts( this, config, data_lambda, data_parameter ) logical :: found character(len=:), allocatable :: number - write(*,*) Iam,'entering' - !> add endpoints to data arrays; first the lower bound nRows = size(data_lambda) lowerLambda = data_lambda(1) ; upperLambda = data_lambda(nRows) @@ -124,8 +122,6 @@ subroutine addpnts( this, config, data_lambda, data_parameter ) call addpnt(x=data_lambda,y=data_parameter,xnew=(rONE+deltax)*upperLambda,ynew=addpnt_val_upper) call addpnt(x=data_lambda,y=data_parameter,xnew=large,ynew=addpnt_val_upper) - write(*,*) Iam,'exiting' - end subroutine addpnts end module micm_abs_spectral_wght_type diff --git a/test/oldtuv/spectral_wght/base.spectral_wght.type.F90 b/test/oldtuv/spectral_wght/base.spectral_wght.type.F90 index 71ed480c..1f936d79 100644 --- a/test/oldtuv/spectral_wght/base.spectral_wght.type.F90 +++ b/test/oldtuv/spectral_wght/base.spectral_wght.type.F90 @@ -69,7 +69,6 @@ subroutine initialize( this, config, mdlLambdaEdge ) type(netcdf_t), allocatable :: netcdf_obj type(string_t), allocatable :: netcdfFiles(:) - write(*,*) Iam,'entering' !> set model wavelength array this%mdl_lambda_edge = mdlLambdaEdge nmdlLambda = size( this%mdl_lambda_edge ) @@ -115,8 +114,6 @@ subroutine initialize( this, config, mdlLambdaEdge ) enddo file_loop endif has_netcdf_file - write(*,*) Iam,'exiting' - end subroutine initialize !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -135,12 +132,8 @@ function run( this, environment ) result( spectral_wght ) character(len=*), parameter :: Iam = 'base spectral wght calculate: ' - write(*,*) Iam,'entering' - spectral_wght = this%spectral_wght(1)%array(:,1) - write(*,*) Iam,'exiting' - end function run !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -153,7 +146,6 @@ subroutine finalize( this ) character(len=*), parameter :: Iam = 'base spectral wght finalize: ' integer(musica_ik) :: ndx - write(*,*) Iam,'entering' if( allocated(this%spectral_wght) ) then do ndx = 1,size(this%spectral_wght) if( allocated(this%spectral_wght(ndx)%array ) ) then @@ -171,7 +163,6 @@ subroutine finalize( this ) if( allocated(this%mdl_lambda_center) ) then deallocate(this%mdl_lambda_center) endif - write(*,*) Iam,'exiting' end subroutine finalize diff --git a/test/oldtuv/spectral_wght/eppley_uv_photometer.spectral_wght.type.F90 b/test/oldtuv/spectral_wght/eppley_uv_photometer.spectral_wght.type.F90 index c0630262..1b384394 100644 --- a/test/oldtuv/spectral_wght/eppley_uv_photometer.spectral_wght.type.F90 +++ b/test/oldtuv/spectral_wght/eppley_uv_photometer.spectral_wght.type.F90 @@ -42,15 +42,11 @@ function run( this, environment ) result( spectral_wght ) real(kind=musica_dk) :: accum character(len=*), parameter :: Iam = 'eppley_uv_photometer spectral wght calculate: ' - write(*,*) Iam,'entering' - nLambda = size(this%mdl_lambda_edge) spectral_wght = this%spectral_wght(1)%array(:,1) accum = sum( spectral_wght*(this%mdl_lambda_edge(2:nLambda) - this%mdl_lambda_edge(1:nLambda-1)) ) spectral_wght = 90._musica_dk*spectral_wght/accum - write(*,*) Iam,'exiting' - end function run end module micm_eppley_uv_photometer_spectral_wght_type diff --git a/test/oldtuv/spectral_wght/exponential_decay.spectral_wght.type.F90 b/test/oldtuv/spectral_wght/exponential_decay.spectral_wght.type.F90 index 3f5c6cdd..5b27b54c 100644 --- a/test/oldtuv/spectral_wght/exponential_decay.spectral_wght.type.F90 +++ b/test/oldtuv/spectral_wght/exponential_decay.spectral_wght.type.F90 @@ -41,12 +41,8 @@ function run( this, environment ) result( spectral_wght ) character(len=*), parameter :: Iam = 'exponential_decay calculate: ' - write(*,*) Iam,'entering' - spectral_wght = 10._musica_dk**((300._musica_dk - this%mdl_lambda_center)/14._musica_dk) - write(*,*) Iam,'exiting' - end function run end module micm_exponential_decay_spectral_wght_type diff --git a/test/oldtuv/spectral_wght/gaussian_305_nm_10_nm_FWHM.spectral_wght.type.F90 b/test/oldtuv/spectral_wght/gaussian_305_nm_10_nm_FWHM.spectral_wght.type.F90 index 6f4bbef3..73e22d02 100644 --- a/test/oldtuv/spectral_wght/gaussian_305_nm_10_nm_FWHM.spectral_wght.type.F90 +++ b/test/oldtuv/spectral_wght/gaussian_305_nm_10_nm_FWHM.spectral_wght.type.F90 @@ -41,14 +41,10 @@ function run( this, environment ) result( spectral_wght ) real(kind=musica_dk) :: accum character(len=*), parameter :: Iam = 'gaussian_305_nm_10_nm_FWHM calculate: ' - write(*,*) Iam,'entering' - spectral_wght = exp( -(log(2._musica_dk)*.04_musica_dk*(this%mdl_lambda_center(:) - 305._musica_dk)**2) ) accum = sum( spectral_wght ) spectral_wght = spectral_wght/accum - write(*,*) Iam,'exiting' - end function run end module micm_gaussian_305_nm_10_nm_FWHM_spectral_wght_type diff --git a/test/oldtuv/spectral_wght/gaussian_320_nm_10_nm_FWHM.spectral_wght.type.F90 b/test/oldtuv/spectral_wght/gaussian_320_nm_10_nm_FWHM.spectral_wght.type.F90 index 9e34d6c2..2fbca2b1 100644 --- a/test/oldtuv/spectral_wght/gaussian_320_nm_10_nm_FWHM.spectral_wght.type.F90 +++ b/test/oldtuv/spectral_wght/gaussian_320_nm_10_nm_FWHM.spectral_wght.type.F90 @@ -41,14 +41,10 @@ function run( this, environment ) result( spectral_wght ) real(kind=musica_dk) :: accum character(len=*), parameter :: Iam = 'gaussian_320_nm_10_nm_FWHM calculate: ' - write(*,*) Iam,'entering' - spectral_wght = exp( -(log(2._musica_dk)*.04_musica_dk*(this%mdl_lambda_center(:) - 320._musica_dk)**2) ) accum = sum( spectral_wght ) spectral_wght = spectral_wght/accum - write(*,*) Iam,'exiting' - end function run end module micm_gaussian_320_nm_10_nm_FWHM_spectral_wght_type diff --git a/test/oldtuv/spectral_wght/gaussian_340_nm_10_nm_FWHM.spectral_wght.type.F90 b/test/oldtuv/spectral_wght/gaussian_340_nm_10_nm_FWHM.spectral_wght.type.F90 index b18bd3be..3fe03d3e 100644 --- a/test/oldtuv/spectral_wght/gaussian_340_nm_10_nm_FWHM.spectral_wght.type.F90 +++ b/test/oldtuv/spectral_wght/gaussian_340_nm_10_nm_FWHM.spectral_wght.type.F90 @@ -41,14 +41,10 @@ function run( this, environment ) result( spectral_wght ) real(kind=musica_dk) :: accum character(len=*), parameter :: Iam = 'gaussian_340_nm_10_nm_FWHM calculate: ' - write(*,*) Iam,'entering' - spectral_wght = exp( -(log(2._musica_dk)*.04_musica_dk*(this%mdl_lambda_center(:) - 340._musica_dk)**2) ) accum = sum( spectral_wght ) spectral_wght = spectral_wght/accum - write(*,*) Iam,'exiting' - end function run end module micm_gaussian_340_nm_10_nm_FWHM_spectral_wght_type diff --git a/test/oldtuv/spectral_wght/gaussian_380_nm_10_nm_FWHM.spectral_wght.type.F90 b/test/oldtuv/spectral_wght/gaussian_380_nm_10_nm_FWHM.spectral_wght.type.F90 index b7e23bbb..0d13fccb 100644 --- a/test/oldtuv/spectral_wght/gaussian_380_nm_10_nm_FWHM.spectral_wght.type.F90 +++ b/test/oldtuv/spectral_wght/gaussian_380_nm_10_nm_FWHM.spectral_wght.type.F90 @@ -41,14 +41,10 @@ function run( this, environment ) result( spectral_wght ) real(kind=musica_dk) :: accum character(len=*), parameter :: Iam = 'gaussian_380_nm_10_nm_FWHM calculate: ' - write(*,*) Iam,'entering' - spectral_wght = exp( -(log(2._musica_dk)*.04_musica_dk*(this%mdl_lambda_center(:) - 380._musica_dk)**2) ) accum = sum( spectral_wght ) spectral_wght = spectral_wght/accum - write(*,*) Iam,'exiting' - end function run end module micm_gaussian_380_nm_10_nm_FWHM_spectral_wght_type diff --git a/test/oldtuv/spectral_wght/par_400-700nm.spectral_wght.type.F90 b/test/oldtuv/spectral_wght/par_400-700nm.spectral_wght.type.F90 index 29327226..511bfe92 100644 --- a/test/oldtuv/spectral_wght/par_400-700nm.spectral_wght.type.F90 +++ b/test/oldtuv/spectral_wght/par_400-700nm.spectral_wght.type.F90 @@ -41,16 +41,12 @@ function run( this, environment ) result( spectral_wght ) character(len=*), parameter :: Iam = 'par_400_700nm calculate: ' - write(*,*) Iam,'entering' - where( 400._musica_dk < this%mdl_lambda_center(:) .and. this%mdl_lambda_center(:) < 700._musica_dk ) spectral_wght = 8.36e-3_musica_dk*this%mdl_lambda_center elsewhere spectral_wght = 0.0_musica_dk endwhere - write(*,*) Iam,'exiting' - end function run end module micm_par_400_700nm_spectral_wght_type diff --git a/test/oldtuv/spectral_wght/phytoplankton_boucher.spectral_wght.type.F90 b/test/oldtuv/spectral_wght/phytoplankton_boucher.spectral_wght.type.F90 index dee38747..457130d8 100644 --- a/test/oldtuv/spectral_wght/phytoplankton_boucher.spectral_wght.type.F90 +++ b/test/oldtuv/spectral_wght/phytoplankton_boucher.spectral_wght.type.F90 @@ -44,16 +44,12 @@ function run( this, environment ) result( spectral_wght ) real(musica_dk), parameter :: c = 7.67e-4_musica_dk character(len=*), parameter :: Iam = 'phytoplankton_boucher calculate: ' - write(*,*) Iam,'entering' - where( this%mdl_lambda_center > 290._musica_dk .and. this%mdl_lambda_center < 400._musica_dk ) spectral_wght = em + exp( a + this%mdl_lambda_center*(b + this%mdl_lambda_center*c) ) elsewhere spectral_wght = 0.0_musica_dk endwhere - write(*,*) Iam,'exiting' - end function run end module micm_phytoplankton_boucher_spectral_wght_type diff --git a/test/oldtuv/spectral_wght/plant_damage.spectral_wght.type.F90 b/test/oldtuv/spectral_wght/plant_damage.spectral_wght.type.F90 index 6ae17ada..07d1d47f 100644 --- a/test/oldtuv/spectral_wght/plant_damage.spectral_wght.type.F90 +++ b/test/oldtuv/spectral_wght/plant_damage.spectral_wght.type.F90 @@ -44,15 +44,11 @@ function run( this, environment ) result( spectral_wght ) real(musica_dk), parameter :: a3 = -1.13118e-5_musica_dk character(len=*), parameter :: Iam = 'plant_damage calculate: ' - write(*,*) Iam,'entering' - spectral_wght = a0 + this%mdl_lambda_center*(a1 + this%mdl_lambda_center*(a2 + this%mdl_lambda_center*a3)) where( spectral_wght < 0.0_musica_dk .or. this%mdl_lambda_center > 313._musica_dk ) spectral_wght = 0.0_musica_dk endwhere - write(*,*) Iam,'exiting' - end function run end module micm_plant_damage_spectral_wght_type diff --git a/test/oldtuv/spectral_wght/plant_damage_flint_caldwell.spectral_wght.type.F90 b/test/oldtuv/spectral_wght/plant_damage_flint_caldwell.spectral_wght.type.F90 index 1c4cbc49..97fa40d3 100644 --- a/test/oldtuv/spectral_wght/plant_damage_flint_caldwell.spectral_wght.type.F90 +++ b/test/oldtuv/spectral_wght/plant_damage_flint_caldwell.spectral_wght.type.F90 @@ -44,8 +44,6 @@ function run( this, environment ) result( spectral_wght ) real(musica_dk), parameter :: w2 = 390._musica_dk character(len=*), parameter :: Iam = 'plant_damage_flint_caldwell calculate: ' - write(*,*) Iam,'entering' - spectral_wght = EXP( a0*EXP(-EXP(a1*(this%mdl_lambda_center - w1)/1.15_musica_dk)) & + ((w2 - this%mdl_lambda_center)/121.7557_musica_dk - 4.183832_musica_dk) ) spectral_wght = spectral_wght * this%mdl_lambda_center / 300._musica_dk @@ -53,8 +51,6 @@ function run( this, environment ) result( spectral_wght ) spectral_wght = 0.0_musica_dk endwhere - write(*,*) Iam,'exiting' - end function run end module micm_plant_damage_flint_caldwell_spectral_wght_type diff --git a/test/oldtuv/spectral_wght/plant_damage_flint_caldwell_ext.spectral_wght.type.F90 b/test/oldtuv/spectral_wght/plant_damage_flint_caldwell_ext.spectral_wght.type.F90 index 4eb857c6..eb986c74 100644 --- a/test/oldtuv/spectral_wght/plant_damage_flint_caldwell_ext.spectral_wght.type.F90 +++ b/test/oldtuv/spectral_wght/plant_damage_flint_caldwell_ext.spectral_wght.type.F90 @@ -44,8 +44,6 @@ function run( this, environment ) result( spectral_wght ) real(musica_dk), parameter :: w2 = 390._musica_dk character(len=*), parameter :: Iam = 'plant_damage_flint_caldwell_ext calculate: ' - write(*,*) Iam,'entering' - spectral_wght = EXP( a0*EXP(-EXP(a1*(this%mdl_lambda_center - w1)/1.15_musica_dk)) & + ((w2 - this%mdl_lambda_center)/121.7557_musica_dk - 4.183832_musica_dk) ) spectral_wght = spectral_wght * this%mdl_lambda_center / 300._musica_dk @@ -53,8 +51,6 @@ function run( this, environment ) result( spectral_wght ) spectral_wght = 0.0_musica_dk endwhere - write(*,*) Iam,'exiting' - end function run end module micm_plant_damage_flint_caldwell_ext_spectral_wght_type diff --git a/test/oldtuv/spectral_wght/scup_mice.spectral_wght.type.F90 b/test/oldtuv/spectral_wght/scup_mice.spectral_wght.type.F90 index 4368cc38..127efe21 100644 --- a/test/oldtuv/spectral_wght/scup_mice.spectral_wght.type.F90 +++ b/test/oldtuv/spectral_wght/scup_mice.spectral_wght.type.F90 @@ -42,13 +42,9 @@ function run( this, environment ) result( spectral_wght ) real(kind=musica_dk) :: factor(1) character(len=*), parameter :: Iam = 'scup_mice calculate: ' - write(*,*) Iam,'entering' - factor = 1._musica_dk/sw_futr( (/300._musica_dk/) ) spectral_wght = sw_futr( this%mdl_lambda_center ) * factor(1) - write(*,*) Iam,'exiting' - end function run FUNCTION sw_futr(w) diff --git a/test/oldtuv/spectral_wght/spectral_wght_factory.F90 b/test/oldtuv/spectral_wght/spectral_wght_factory.F90 index 52622bfb..113f88a0 100644 --- a/test/oldtuv/spectral_wght/spectral_wght_factory.F90 +++ b/test/oldtuv/spectral_wght/spectral_wght_factory.F90 @@ -53,7 +53,6 @@ function spectral_wght_builder( config, mdlLambdaEdge ) result( new_spectral_wgh type(string_t) :: spectral_wght_type character(len=*), parameter :: Iam = 'spectral wght builder: ' - write(*,*) Iam,'entering' new_spectral_wght_t => null() call config%get( 'spectral wght type', spectral_wght_type, Iam ) @@ -101,7 +100,6 @@ function spectral_wght_builder( config, mdlLambdaEdge ) result( new_spectral_wgh spectral_wght_type%to_char()//"'" ) end select call new_spectral_wght_t%initialize( config, mdlLambdaEdge ) - write(*,*) Iam,'exiting' end function spectral_wght_builder diff --git a/test/oldtuv/spectral_wght/spectral_wght_warehouse.F90 b/test/oldtuv/spectral_wght/spectral_wght_warehouse.F90 index a02c90c4..5242fada 100644 --- a/test/oldtuv/spectral_wght/spectral_wght_warehouse.F90 +++ b/test/oldtuv/spectral_wght/spectral_wght_warehouse.F90 @@ -85,8 +85,6 @@ function constructor( config,mdlLambdaEdge ) result( spectral_wght_warehouse_obj do while( iter%next() ) keychar = spectral_weight_set%key(iter) aswkey = keychar - write(*,*) ' ' - write(*,*) Iam,'key = ',trim(keychar) new_obj%spectral_wght_key = [new_obj%spectral_wght_key,aswkey] call spectral_weight_set%get( iter, spectrum_config, Iam ) !----------------------------------------------------------------------------- @@ -100,8 +98,6 @@ function constructor( config,mdlLambdaEdge ) result( spectral_wght_warehouse_obj deallocate( iter ) nSize = size(new_obj%spectral_wght_objs_) - write(*,*) ' ' - write(*,'(a,''There are '',i3,'' spectral wghts'')') Iam,nSize !----------------------------------------------------------------------------- !> setup spectral weight arrays @@ -130,9 +126,6 @@ subroutine update_for_new_environmental_state( this, environment, nwave ) real(musica_dk), allocatable :: a_spectral_wght(:) real(musica_dk), allocatable :: spectral_wght_tray(:) - write(*,*) ' ' - write(*,*) Iam,'entering' - allocate(spectral_wght_tray(0)) do ndx = 1, size(this%spectral_wght_objs_) associate( calc_ftn => this%spectral_wght_objs_(ndx)%val_ ) @@ -144,11 +137,6 @@ subroutine update_for_new_environmental_state( this, environment, nwave ) this%spectral_wght_values_ = reshape( spectral_wght_tray, & (/nwave,size(this%spectral_wght_objs_) /) ) - write(*,*) Iam,'size of spectral weight values = ',& - size(this%spectral_wght_values_,dim=1), size(this%spectral_wght_values_,dim=2) - - write(*,*) Iam,'exiting' - end subroutine update_for_new_environmental_state !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -162,8 +150,6 @@ subroutine finalize( this ) integer(kind=musica_ik) :: ndx character(len=*), parameter :: Iam = 'spectral_wght_warehouse finalize: ' - write(*,*) Iam,'entering' - if( allocated( this%spectral_wght_values_ ) ) then deallocate( this%spectral_wght_values_ ) endif @@ -180,8 +166,6 @@ subroutine finalize( this ) deallocate( this%spectral_wght_key ) end if - write(*,*) Iam,'exiting' - end subroutine finalize !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/test/oldtuv/spectral_wght/standard_human_erythema.spectral_wght.type.F90 b/test/oldtuv/spectral_wght/standard_human_erythema.spectral_wght.type.F90 index 1a9ce652..6c00d574 100644 --- a/test/oldtuv/spectral_wght/standard_human_erythema.spectral_wght.type.F90 +++ b/test/oldtuv/spectral_wght/standard_human_erythema.spectral_wght.type.F90 @@ -41,12 +41,8 @@ function run( this, environment ) result( spectral_wght ) character(len=*), parameter :: Iam = 'standard_human_erythema calculate: ' - write(*,*) Iam,'entering' - spectral_wght = fery( this%mdl_lambda_center ) - write(*,*) Iam,'exiting' - end function run FUNCTION fery(w) diff --git a/test/oldtuv/spectral_wght/uv-a_315_400_nm.spectral_wght.type.F90 b/test/oldtuv/spectral_wght/uv-a_315_400_nm.spectral_wght.type.F90 index 715b56d8..7e2d43a7 100644 --- a/test/oldtuv/spectral_wght/uv-a_315_400_nm.spectral_wght.type.F90 +++ b/test/oldtuv/spectral_wght/uv-a_315_400_nm.spectral_wght.type.F90 @@ -41,16 +41,12 @@ function run( this, environment ) result( spectral_wght ) character(len=*), parameter :: Iam = 'uv_a_315_400_nm calculate: ' - write(*,*) Iam,'entering' - where( 315._musica_dk < this%mdl_lambda_center(:) .and. this%mdl_lambda_center(:) < 400._musica_dk ) spectral_wght = 1.0_musica_dk elsewhere spectral_wght = 0.0_musica_dk endwhere - write(*,*) Iam,'exiting' - end function run end module micm_uv_a_315_400_nm_spectral_wght_type diff --git a/test/oldtuv/spectral_wght/uv-b_280_315_nm.spectral_wght.type.F90 b/test/oldtuv/spectral_wght/uv-b_280_315_nm.spectral_wght.type.F90 index 8032617b..6d312e78 100644 --- a/test/oldtuv/spectral_wght/uv-b_280_315_nm.spectral_wght.type.F90 +++ b/test/oldtuv/spectral_wght/uv-b_280_315_nm.spectral_wght.type.F90 @@ -41,16 +41,12 @@ function run( this, environment ) result( spectral_wght ) character(len=*), parameter :: Iam = 'uv_b_280_315_nm calculate: ' - write(*,*) Iam,'entering' - where( 280._musica_dk < this%mdl_lambda_center(:) .and. this%mdl_lambda_center(:) < 315._musica_dk ) spectral_wght = 1.0_musica_dk elsewhere spectral_wght = 0.0_musica_dk endwhere - write(*,*) Iam,'exiting' - end function run end module micm_uv_b_280_315_nm_spectral_wght_type diff --git a/test/oldtuv/spectral_wght/uv-b_280_320_nm.spectral_wght.type.F90 b/test/oldtuv/spectral_wght/uv-b_280_320_nm.spectral_wght.type.F90 index 7b72bd03..d0a861e5 100644 --- a/test/oldtuv/spectral_wght/uv-b_280_320_nm.spectral_wght.type.F90 +++ b/test/oldtuv/spectral_wght/uv-b_280_320_nm.spectral_wght.type.F90 @@ -41,16 +41,12 @@ function run( this, environment ) result( spectral_wght ) character(len=*), parameter :: Iam = 'uv_b_280_320_nm calculate: ' - write(*,*) Iam,'entering' - where( 280._musica_dk < this%mdl_lambda_center(:) .and. this%mdl_lambda_center(:) < 320._musica_dk ) spectral_wght = 1.0_musica_dk elsewhere spectral_wght = 0.0_musica_dk endwhere - write(*,*) Iam,'exiting' - end function run end module micm_uv_b_280_320_nm_spectral_wght_type diff --git a/test/oldtuv/spectral_wght/visplus.spectral_wght.type.F90 b/test/oldtuv/spectral_wght/visplus.spectral_wght.type.F90 index 16ebc04e..6baf9dc8 100644 --- a/test/oldtuv/spectral_wght/visplus.spectral_wght.type.F90 +++ b/test/oldtuv/spectral_wght/visplus.spectral_wght.type.F90 @@ -41,16 +41,12 @@ function run( this, environment ) result( spectral_wght ) character(len=*), parameter :: Iam = 'visplus calculate: ' - write(*,*) Iam,'entering' - where( 400._musica_dk < this%mdl_lambda_center(:) .and. this%mdl_lambda_center(:) < 700._musica_dk ) spectral_wght = 1.0_musica_dk elsewhere spectral_wght = 0.0_musica_dk endwhere - write(*,*) Iam,'exiting' - end function run end module micm_visplus_spectral_wght_type diff --git a/test/oldtuv/swchem.f b/test/oldtuv/swchem.f index 35c9c944..c0215a8a 100644 --- a/test/oldtuv/swchem.f +++ b/test/oldtuv/swchem.f @@ -386,7 +386,6 @@ SUBROUTINE swchem(nw,wl,nz,tlev,airden, **************************************************************** IF (j .GT. kj) STOP '1002' - write(*,'(''swchem: Set '',i3,'' photorates'')') j END SUBROUTINE swchem diff --git a/test/oldtuv/tuv.f b/test/oldtuv/tuv.f index 03f6417a..7c93c45f 100644 --- a/test/oldtuv/tuv.f +++ b/test/oldtuv/tuv.f @@ -309,18 +309,15 @@ PROGRAM tuv command_tokens(1) = command_tokens(1)%to_upper() select case( command_tokens(1)%to_char() ) case( 'RADXFER_CONFIG_FILESPEC' ) - write(*,*) 'Processing radXfer json config file' radXfer_config_filespec = command_tokens(2)%to_char() CALL radXfer_config%from_file( radXfer_config_filespec ) Obj_radXfer_xsects = .true. case( 'PHOTO_RATE_CONFIG_FILESPEC' ) - write(*,*) 'Processing photo_rate json config file' photo_rate_config_filespec = command_tokens(2)%to_char() CALL $ photo_rate_config%from_file( photo_rate_config_filespec ) Obj_photo_rates = .true. case( 'SPECTRAL_WGHT_CONFIG_FILESPEC' ) - write(*,*) 'Processing spectral_wght json config file' spectral_wght_config_filespec = command_tokens(2)%to_char() CALL $ spectral_wght_config%from_file( @@ -343,13 +340,6 @@ PROGRAM tuv end select enddo - write(*,*) - $ 'TUV: uses xsect objects in radXfer = ',Obj_radXfer_xsects - write(*,*) - $ 'TUV: uses photo_rate objects = ',Obj_photo_rates - write(*,*) - $ 'TUV: uses spectral wght objects = ',Obj_spectral_wghts - * re-entry point 1000 CONTINUE @@ -493,15 +483,6 @@ PROGRAM tuv * nmj: number of j-values that will be reported. Selections must be * made interactively, or by editing input file. - IF(nstr < 2) THEN - WRITE(kout,*) 'Delta-Eddington 2-stream radiative transfer' - ELSE - WRITE(kout,*) 'Discrete ordinates ', - $ nstr, '-stream radiative transfer' - ENDIF - - WRITE(*,*) 'calculating....' - * ___ SECTION 2: SET GRIDS _________________________________________________ * altitudes (creates altitude grid, locates index for selected output, izout) @@ -578,7 +559,6 @@ PROGRAM tuv ENDDO ipbl = iz - 1 - write(*,*) 'top of PBL index, height (km) ', ipbl, z(ipbl) * specify pbl concetrations, in parts per billion @@ -828,10 +808,6 @@ PROGRAM tuv wdosei = rZERO dose(1:ks) = rZERO - write(*,*) 'Date, Lat, Lon, Min_SZA' - write(*,222) iyear,imonth,iday,lat,lon,sznoon - 222 format(i4,'/',i2,'/',i2,3(1x,F7.3)) - * Initialize lymana-alpha, schumann-runge bands call init_la_srb(wl) @@ -904,7 +880,6 @@ PROGRAM tuv zen = sza(it) - WRITE(*,200) it, zen, esfact(it) WRITE(kout,200) it, zen, esfact(it) 200 FORMAT('step = ', I4,' sza = ', F9.3, $ ' Earth-sun factor = ', F10.7) @@ -958,20 +933,6 @@ PROGRAM tuv if( .not. do_clouds ) then omcld = rZERO ; omsnw = rZERO endif - if( all( dtrl == 0. ) ) write(*,*) 'TUV: dtrl = 0' - if( all( dto3 == 0. ) ) write(*,*) 'TUV: dto3 = 0' - if( all( dto2 == 0. ) ) write(*,*) 'TUV: dto2 = 0' - if( all( dtso2 == 0. ) ) write(*,*) 'TUV: dtso2 = 0' - if( all( dtno2 == 0. ) ) write(*,*) 'TUV: dtno2 = 0' - if( all( dtcld == 0. ) ) write(*,*) 'TUV: dtcld = 0' - if( all( omcld == 0. ) ) write(*,*) 'TUV: omcld = 0' - if( all( gcld == 0. ) ) write(*,*) 'TUV: gcld = 0' - if( all( dtaer == 0. ) ) write(*,*) 'TUV: dtaer = 0' - if( all( omaer == 0. ) ) write(*,*) 'TUV: omaer = 0' - if( all( gaer == 0. ) ) write(*,*) 'TUV: gaer = 0' - if( all( dtsnw == 0. ) ) write(*,*) 'TUV: dtsnw = 0' - if( all( omsnw == 0. ) ) write(*,*) 'TUV: omsnw = 0' - if( all( gsnw == 0. ) ) write(*,*) 'TUV: gsnw = 0' * ____ SECTION 8: WAVELENGTH LOOP ______________________________________ diff --git a/test/oldtuv/util/la_srb.type.F90 b/test/oldtuv/util/la_srb.type.F90 index 29184801..f8e208f0 100644 --- a/test/oldtuv/util/la_srb.type.F90 +++ b/test/oldtuv/util/la_srb.type.F90 @@ -69,9 +69,6 @@ subroutine initialize( this, gridWareHouse ) type(string_t) :: Handle class(base_grid_t), pointer :: lambdaGrid - write(*,*) ' ' - write(*,*) Iam // 'entering' - Handle = 'Photolysis, wavelength' ; lambdaGrid => gridWareHouse%get_grid( Handle ) !> Are la and srb grids fully "inside" the model grid? @@ -129,9 +126,6 @@ subroutine initialize( this, gridWareHouse ) endif endif has_la_srb - write(*,*) ' ' - write(*,*) Iam // 'exiting' - end subroutine initialize subroutine la_srb_OD( this,gridWareHouse,ProfileWareHouse,Airvcol,Airscol,dto2 ) @@ -201,9 +195,6 @@ subroutine la_srb_OD( this,gridWareHouse,ProfileWareHouse,Airvcol,Airscol,dto2 ) !---------------------------------------------------------------------- real(dk) :: dto2k(size(Airvcol),nsrb) - write(*,*) ' ' - write(*,*) Iam // 'entering' - has_la_srb: & if( this%has_la_srb ) then !----------------------------------------------------------------------------- @@ -257,9 +248,6 @@ subroutine la_srb_OD( this,gridWareHouse,ProfileWareHouse,Airvcol,Airscol,dto2 ) endif endif has_la_srb - write(*,*) ' ' - write(*,*) Iam // 'exiting' - end subroutine la_srb_OD subroutine la_srb_xs( this,gridWareHouse,ProfileWareHouse,Airvcol,Airscol,o2xs ) diff --git a/test/oldtuv/vert_Profile/air.from_csv_file.type.F90 b/test/oldtuv/vert_Profile/air.from_csv_file.type.F90 index e8285cf3..d6e0c0f7 100644 --- a/test/oldtuv/vert_Profile/air.from_csv_file.type.F90 +++ b/test/oldtuv/vert_Profile/air.from_csv_file.type.F90 @@ -54,8 +54,6 @@ subroutine initialize( this, profile_config, gridWareHouse ) class(abs_interpolator_t), pointer :: theInterpolator class(base_grid_t), pointer :: zGrid - write(*,*) Iam // 'entering' - !> Get the configuration settings call profile_config%get( 'Filespec', Filespec, Iam ) call profile_config%get( 'Handle', this%handle_, Iam, default = 'None' ) @@ -128,16 +126,6 @@ subroutine initialize( this, profile_config, gridWareHouse ) this%edge_val_ = theInterpolator%interpolate( zGrid%edge_, zdata,airlog ) this%edge_val_ = exp( this%edge_val_ ) - write(*,*) ' ' - write(*,*) Iam // 'data z grid' - write(*,'(1p10g15.7)') zdata - write(*,*) ' ' - write(*,*) Iam // this%handle_%to_char() // ' on data z grid' - write(*,'(1p10g15.7)') Profile - write(*,*) ' ' - write(*,*) Iam // this%handle_%to_char() // ' @ mdl z grid edges' - write(*,'(1p10g15.7)') this%edge_val_ - this%mid_val_ = .5_dk & *(this%edge_val_(1_ik:this%ncells_) + this%edge_val_(2_ik:this%ncells_+1_ik)) this%delta_val_ = (this%edge_val_(2_ik:this%ncells_+1_ik) - this%edge_val_(1_ik:this%ncells_)) @@ -154,8 +142,6 @@ subroutine initialize( this, profile_config, gridWareHouse ) this%burden_dens_(k) = accum enddo - write(*,*) Iam // 'exiting' - end subroutine initialize subroutine finalize( this ) diff --git a/test/oldtuv/vert_Profile/from_csv_file.type.F90 b/test/oldtuv/vert_Profile/from_csv_file.type.F90 index a3cefea9..a16d0a27 100644 --- a/test/oldtuv/vert_Profile/from_csv_file.type.F90 +++ b/test/oldtuv/vert_Profile/from_csv_file.type.F90 @@ -52,8 +52,6 @@ subroutine initialize( this, profile_config, gridWareHouse ) type(string_t) :: Handle class(abs_interpolator_t), pointer :: theInterpolator - write(*,*) Iam // 'entering' - !> Get the configuration settings call profile_config%get( 'Filespec', Filespec, Iam ) call profile_config%get( 'Handle', this%handle_, Iam, default = 'None' ) @@ -122,24 +120,12 @@ subroutine initialize( this, profile_config, gridWareHouse ) this%edge_val_ = theInterpolator%interpolate( zGrid%edge_, zdata,Profile ) - write(*,*) ' ' - write(*,*) Iam // 'data z grid' - write(*,'(1p10g15.7)') zdata - write(*,*) ' ' - write(*,*) Iam // this%handle_%to_char() // ' on data z grid' - write(*,'(1p10g15.7)') Profile - write(*,*) ' ' - write(*,*) Iam // this%handle_%to_char() // ' @ mdl z grid edges' - write(*,'(1p10g15.7)') this%edge_val_ - this%mid_val_ = .5_dk & *(this%edge_val_(1_ik:this%ncells_) + this%edge_val_(2_ik:this%ncells_+1_ik)) this%delta_val_ = (this%edge_val_(2_ik:this%ncells_+1_ik) - this%edge_val_(1_ik:this%ncells_)) this%layer_dens_ = this%mid_val_ * zGrid%delta_ * km2cm this%layer_dens_(this%ncells_) = this%layer_dens_(this%ncells_) + this%edge_val_(this%ncells_+1_ik) * this%hscale_ * km2cm - write(*,*) Iam // 'exiting' - end subroutine initialize subroutine finalize( this ) diff --git a/test/oldtuv/vert_Profile/holdingtank/from_csv_file.type.F90 b/test/oldtuv/vert_Profile/holdingtank/from_csv_file.type.F90 index 9cf15a9b..4948119c 100644 --- a/test/oldtuv/vert_Profile/holdingtank/from_csv_file.type.F90 +++ b/test/oldtuv/vert_Profile/holdingtank/from_csv_file.type.F90 @@ -44,8 +44,6 @@ subroutine initialize( this, profile_config, zGrid ) character(len=132) :: InputLine type(string_t) :: Filespec - write(*,*) Iam // 'entering' - !> Get the configuration settings call profile_config%get( 'Filespec', Filespec, Iam ) call profile_config%get( 'Handle', this%handle_, Iam, default = 'None' ) @@ -94,16 +92,6 @@ subroutine initialize( this, profile_config, zGrid ) allocate( this%edge_val_(this%ncells_+1_ik) ) this%edge_val_ = this%inter1( zGrid, zdata,Profile ) - write(*,*) ' ' - write(*,*) Iam // 'data z grid' - write(*,'(1p10g15.7)') zdata - write(*,*) ' ' - write(*,*) Iam // this%handle_%to_char() // ' on data z grid' - write(*,'(1p10g15.7)') Profile - write(*,*) ' ' - write(*,*) Iam // this%handle_%to_char() // ' @ mdl z grid edges' - write(*,'(1p10g15.7)') this%edge_val_ - allocate( this%mid_val_(this%ncells_) ) allocate( this%delta_val_(this%ncells_) ) this%mid_val_(:) = .5_dk & @@ -112,8 +100,6 @@ subroutine initialize( this, profile_config, zGrid ) close(unit=inUnit) - write(*,*) Iam // 'exiting' - end subroutine initialize end module micm_from_csv_file_vert_Profile diff --git a/test/oldtuv/vert_Profile/o2.from_csv_file.type.F90 b/test/oldtuv/vert_Profile/o2.from_csv_file.type.F90 index a4333e15..3c83c418 100644 --- a/test/oldtuv/vert_Profile/o2.from_csv_file.type.F90 +++ b/test/oldtuv/vert_Profile/o2.from_csv_file.type.F90 @@ -55,8 +55,6 @@ subroutine initialize( this, profile_config, gridWareHouse ) class(abs_interpolator_t), pointer :: theInterpolator class(base_grid_t), pointer :: zGrid - write(*,*) Iam // 'entering' - !> Get the configuration settings call profile_config%get( 'Filespec', Filespec, Iam ) call profile_config%get( 'Handle', this%handle_, Iam, default = 'None' ) @@ -130,16 +128,6 @@ subroutine initialize( this, profile_config, gridWareHouse ) this%edge_val_ = exp( this%edge_val_ ) this%edge_val_ = o2Vmr * this%edge_val_ - write(*,*) ' ' - write(*,*) Iam // 'data z grid' - write(*,'(1p10g15.7)') zdata - write(*,*) ' ' - write(*,*) Iam // this%handle_%to_char() // ' on data z grid' - write(*,'(1p10g15.7)') Profile - write(*,*) ' ' - write(*,*) Iam // this%handle_%to_char() // ' @ mdl z grid edges' - write(*,'(1p10g15.7)') this%edge_val_ - this%mid_val_ = .5_dk & *(this%edge_val_(1_ik:this%ncells_) + this%edge_val_(2_ik:this%ncells_+1_ik)) this%delta_val_ = (this%edge_val_(2_ik:this%ncells_+1_ik) - this%edge_val_(1_ik:this%ncells_)) @@ -149,8 +137,6 @@ subroutine initialize( this, profile_config, gridWareHouse ) this%exo_layer_dens_ = [this%layer_dens_,exo_layer_dens] this%layer_dens_(this%ncells_) = this%layer_dens_(this%ncells_) + exo_layer_dens - write(*,*) Iam // 'exiting' - end subroutine initialize subroutine finalize( this ) diff --git a/test/oldtuv/vert_Profile/o3.from_csv_file.type.F90 b/test/oldtuv/vert_Profile/o3.from_csv_file.type.F90 index 69e0000f..af7aff3b 100644 --- a/test/oldtuv/vert_Profile/o3.from_csv_file.type.F90 +++ b/test/oldtuv/vert_Profile/o3.from_csv_file.type.F90 @@ -52,8 +52,6 @@ subroutine initialize( this, profile_config, gridWareHouse ) class(abs_interpolator_t), pointer :: theInterpolator class(base_grid_t), pointer :: zGrid - write(*,*) Iam // 'entering' - !> Get the configuration settings call profile_config%get( 'Filespec', Filespec, Iam ) call profile_config%get( 'Handle', this%handle_, Iam, default = 'None' ) @@ -139,24 +137,12 @@ subroutine initialize( this, profile_config, gridWareHouse ) this%edge_val_ = theInterpolator%interpolate( zGrid%edge_, zdata,Profile ) - write(*,*) ' ' - write(*,*) Iam // 'data z grid' - write(*,'(1p10g15.7)') zdata - write(*,*) ' ' - write(*,*) Iam // this%handle_%to_char() // ' on data z grid' - write(*,'(1p10g15.7)') Profile - write(*,*) ' ' - write(*,*) Iam // this%handle_%to_char() // ' @ mdl z grid edges' - write(*,'(1p10g15.7)') this%edge_val_ - this%mid_val_ = .5_dk & *(this%edge_val_(1_ik:this%ncells_) + this%edge_val_(2_ik:this%ncells_+1_ik)) this%delta_val_ = (this%edge_val_(2_ik:this%ncells_+1_ik) - this%edge_val_(1_ik:this%ncells_)) this%layer_dens_ = zGrid%delta_ * this%mid_val_ * km2cm this%layer_dens_(this%ncells_) = this%layer_dens_(this%ncells_) + this%edge_val_(this%ncells_+1_ik) * this%hscale_ * km2cm - write(*,*) Iam // 'exiting' - end subroutine initialize subroutine finalize( this ) diff --git a/test/oldtuv/vert_Profile/vert_Profile_factory.F90 b/test/oldtuv/vert_Profile/vert_Profile_factory.F90 index b4190363..2f341ac7 100644 --- a/test/oldtuv/vert_Profile/vert_Profile_factory.F90 +++ b/test/oldtuv/vert_Profile/vert_Profile_factory.F90 @@ -42,8 +42,6 @@ function Profile_builder( config, gridWareHouse ) result( new_Profile_t ) character(len=*), parameter :: Iam = 'Vert Profile builder: ' type(string_t) :: Profile_type - write(*,*) Iam,'entering' - new_Profile_t => null() call config%get( 'Vert Profile type', Profile_type, Iam ) @@ -62,8 +60,6 @@ function Profile_builder( config, gridWareHouse ) result( new_Profile_t ) call new_Profile_t%initialize( config, gridWareHouse ) - write(*,*) Iam,'exiting' - end function Profile_builder !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/test/oldtuv/vert_Profile/vert_Profile_warehouse.F90 b/test/oldtuv/vert_Profile/vert_Profile_warehouse.F90 index 1a60266d..e086410e 100644 --- a/test/oldtuv/vert_Profile/vert_Profile_warehouse.F90 +++ b/test/oldtuv/vert_Profile/vert_Profile_warehouse.F90 @@ -62,8 +62,6 @@ function constructor( config, gridwarehouse ) result( Profile_warehouse_obj ) character(len=32) :: keychar type(string_t) :: aswkey - write(*,*) Iam // 'entering' - allocate( Profile_warehouse_obj ) associate(new_obj=>Profile_warehouse_obj) @@ -78,8 +76,6 @@ function constructor( config, gridwarehouse ) result( Profile_warehouse_obj ) do while( iter%next() ) keychar = Profile_set%key(iter) aswkey = keychar - write(*,*) ' ' - write(*,*) Iam,'key = ',trim(keychar) call Profile_set%get( iter, Profile_config, Iam ) call Profile_config%add( 'Handle', aswkey, Iam ) !----------------------------------------------------------------------------- @@ -91,13 +87,8 @@ function constructor( config, gridwarehouse ) result( Profile_warehouse_obj ) deallocate( iter ) - write(*,*) ' ' - write(*,'(a,''There are '',i3,'' Profile objects'')') Iam,size(new_obj%Profile_objs_) - end associate - write(*,*) Iam // 'exiting' - end function constructor !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -121,9 +112,6 @@ function get_Profile( this, Profile_handle ) result( Profile_ptr ) integer(ik) :: ndx logical(lk) :: found - write(*,*) ' ' - write(*,*) Iam,'entering' - found = .false._lk do ndx = 1,size(this%Profile_objs_) if( Profile_handle .eq. this%Profile_objs_(ndx)%ptr_%handle_ ) then @@ -138,8 +126,6 @@ function get_Profile( this, Profile_handle ) result( Profile_ptr ) call die_msg( 460768214, "Invalid Profile handle: '"// Profile_handle%to_char()//"'" ) endif - write(*,*) Iam,'exiting' - end function get_Profile !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -156,14 +142,10 @@ subroutine finalize( this ) integer(kind=ik) :: ndx character(len=*), parameter :: Iam = 'Profile warehouse finalize: ' - write(*,*) Iam,'entering' - if( allocated( this%Profile_objs_ ) ) then deallocate( this%Profile_objs_ ) endif - write(*,*) Iam,'exiting' - end subroutine finalize !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/test/oldtuv/vert_Profile_v0/air.from_csv_file.type.F90 b/test/oldtuv/vert_Profile_v0/air.from_csv_file.type.F90 index 5eb02e9e..b1a4fba1 100644 --- a/test/oldtuv/vert_Profile_v0/air.from_csv_file.type.F90 +++ b/test/oldtuv/vert_Profile_v0/air.from_csv_file.type.F90 @@ -54,8 +54,6 @@ subroutine initialize( this, profile_config, gridWareHouse ) class(abs_interpolator_t), pointer :: theInterpolator class(base_grid_t), pointer :: zGrid - write(*,*) Iam // 'entering' - !> Get the configuration settings call profile_config%get( 'Filespec', Filespec, Iam ) call profile_config%get( 'Handle', this%handle_, Iam, default = 'None' ) @@ -128,16 +126,6 @@ subroutine initialize( this, profile_config, gridWareHouse ) this%edge_val_ = theInterpolator%interpolate( zGrid%edge_, zdata,airlog ) this%edge_val_ = exp( this%edge_val_ ) - write(*,*) ' ' - write(*,*) Iam // 'data z grid' - write(*,'(1p10g15.7)') zdata - write(*,*) ' ' - write(*,*) Iam // this%handle_%to_char() // ' on data z grid' - write(*,'(1p10g15.7)') Profile - write(*,*) ' ' - write(*,*) Iam // this%handle_%to_char() // ' @ mdl z grid edges' - write(*,'(1p10g15.7)') this%edge_val_ - this%mid_val_ = .5_dk & *(this%edge_val_(1_ik:this%ncells_) + this%edge_val_(2_ik:this%ncells_+1_ik)) this%delta_val_ = (this%edge_val_(2_ik:this%ncells_+1_ik) - this%edge_val_(1_ik:this%ncells_)) @@ -154,8 +142,6 @@ subroutine initialize( this, profile_config, gridWareHouse ) this%burden_dens_(k) = accum enddo - write(*,*) Iam // 'exiting' - end subroutine initialize subroutine finalize( this ) diff --git a/test/oldtuv/vert_Profile_v0/from_csv_file.type.F90 b/test/oldtuv/vert_Profile_v0/from_csv_file.type.F90 index 289bfe04..6d9cc213 100644 --- a/test/oldtuv/vert_Profile_v0/from_csv_file.type.F90 +++ b/test/oldtuv/vert_Profile_v0/from_csv_file.type.F90 @@ -52,8 +52,6 @@ subroutine initialize( this, profile_config, gridWareHouse ) type(string_t) :: Handle class(abs_interpolator_t), pointer :: theInterpolator - write(*,*) Iam // 'entering' - !> Get the configuration settings call profile_config%get( 'Filespec', Filespec, Iam ) call profile_config%get( 'Handle', this%handle_, Iam, default = 'None' ) @@ -122,24 +120,12 @@ subroutine initialize( this, profile_config, gridWareHouse ) this%edge_val_ = theInterpolator%interpolate( zGrid%edge_, zdata,Profile ) - write(*,*) ' ' - write(*,*) Iam // 'data z grid' - write(*,'(1p10g15.7)') zdata - write(*,*) ' ' - write(*,*) Iam // this%handle_%to_char() // ' on data z grid' - write(*,'(1p10g15.7)') Profile - write(*,*) ' ' - write(*,*) Iam // this%handle_%to_char() // ' @ mdl z grid edges' - write(*,'(1p10g15.7)') this%edge_val_ - this%mid_val_ = .5_dk & *(this%edge_val_(1_ik:this%ncells_) + this%edge_val_(2_ik:this%ncells_+1_ik)) this%delta_val_ = (this%edge_val_(2_ik:this%ncells_+1_ik) - this%edge_val_(1_ik:this%ncells_)) this%layer_dens_ = this%mid_val_ * zGrid%delta_ * km2cm this%layer_dens_(this%ncells_) = this%layer_dens_(this%ncells_) + this%edge_val_(this%ncells_+1_ik) * this%hscale_ * km2cm - write(*,*) Iam // 'exiting' - end subroutine initialize subroutine finalize( this ) diff --git a/test/oldtuv/vert_Profile_v0/holdingtank/from_csv_file.type.F90 b/test/oldtuv/vert_Profile_v0/holdingtank/from_csv_file.type.F90 index 9cf15a9b..4948119c 100644 --- a/test/oldtuv/vert_Profile_v0/holdingtank/from_csv_file.type.F90 +++ b/test/oldtuv/vert_Profile_v0/holdingtank/from_csv_file.type.F90 @@ -44,8 +44,6 @@ subroutine initialize( this, profile_config, zGrid ) character(len=132) :: InputLine type(string_t) :: Filespec - write(*,*) Iam // 'entering' - !> Get the configuration settings call profile_config%get( 'Filespec', Filespec, Iam ) call profile_config%get( 'Handle', this%handle_, Iam, default = 'None' ) @@ -94,16 +92,6 @@ subroutine initialize( this, profile_config, zGrid ) allocate( this%edge_val_(this%ncells_+1_ik) ) this%edge_val_ = this%inter1( zGrid, zdata,Profile ) - write(*,*) ' ' - write(*,*) Iam // 'data z grid' - write(*,'(1p10g15.7)') zdata - write(*,*) ' ' - write(*,*) Iam // this%handle_%to_char() // ' on data z grid' - write(*,'(1p10g15.7)') Profile - write(*,*) ' ' - write(*,*) Iam // this%handle_%to_char() // ' @ mdl z grid edges' - write(*,'(1p10g15.7)') this%edge_val_ - allocate( this%mid_val_(this%ncells_) ) allocate( this%delta_val_(this%ncells_) ) this%mid_val_(:) = .5_dk & @@ -112,8 +100,6 @@ subroutine initialize( this, profile_config, zGrid ) close(unit=inUnit) - write(*,*) Iam // 'exiting' - end subroutine initialize end module micm_from_csv_file_vert_Profile diff --git a/test/oldtuv/vert_Profile_v0/o2.from_csv_file.type.F90 b/test/oldtuv/vert_Profile_v0/o2.from_csv_file.type.F90 index 9dfeacfb..7bf80a77 100644 --- a/test/oldtuv/vert_Profile_v0/o2.from_csv_file.type.F90 +++ b/test/oldtuv/vert_Profile_v0/o2.from_csv_file.type.F90 @@ -55,8 +55,6 @@ subroutine initialize( this, profile_config, gridWareHouse ) class(abs_interpolator_t), pointer :: theInterpolator class(base_grid_t), pointer :: zGrid - write(*,*) Iam // 'entering' - !> Get the configuration settings call profile_config%get( 'Filespec', Filespec, Iam ) call profile_config%get( 'Handle', this%handle_, Iam, default = 'None' ) @@ -130,16 +128,6 @@ subroutine initialize( this, profile_config, gridWareHouse ) this%edge_val_ = exp( this%edge_val_ ) this%edge_val_ = o2Vmr * this%edge_val_ - write(*,*) ' ' - write(*,*) Iam // 'data z grid' - write(*,'(1p10g15.7)') zdata - write(*,*) ' ' - write(*,*) Iam // this%handle_%to_char() // ' on data z grid' - write(*,'(1p10g15.7)') Profile - write(*,*) ' ' - write(*,*) Iam // this%handle_%to_char() // ' @ mdl z grid edges' - write(*,'(1p10g15.7)') this%edge_val_ - this%mid_val_ = .5_dk & *(this%edge_val_(1_ik:this%ncells_) + this%edge_val_(2_ik:this%ncells_+1_ik)) this%delta_val_ = (this%edge_val_(2_ik:this%ncells_+1_ik) - this%edge_val_(1_ik:this%ncells_)) @@ -149,8 +137,6 @@ subroutine initialize( this, profile_config, gridWareHouse ) this%exo_layer_dens_ = [this%layer_dens_,exo_layer_dens] this%layer_dens_(this%ncells_) = this%layer_dens_(this%ncells_) + exo_layer_dens - write(*,*) Iam // 'exiting' - end subroutine initialize subroutine finalize( this ) diff --git a/test/oldtuv/vert_Profile_v0/o3.from_csv_file.type.F90 b/test/oldtuv/vert_Profile_v0/o3.from_csv_file.type.F90 index 3b5d49e2..92e3a647 100644 --- a/test/oldtuv/vert_Profile_v0/o3.from_csv_file.type.F90 +++ b/test/oldtuv/vert_Profile_v0/o3.from_csv_file.type.F90 @@ -52,8 +52,6 @@ subroutine initialize( this, profile_config, gridWareHouse ) class(abs_interpolator_t), pointer :: theInterpolator class(base_grid_t), pointer :: zGrid - write(*,*) Iam // 'entering' - !> Get the configuration settings call profile_config%get( 'Filespec', Filespec, Iam ) call profile_config%get( 'Handle', this%handle_, Iam, default = 'None' ) @@ -139,24 +137,12 @@ subroutine initialize( this, profile_config, gridWareHouse ) this%edge_val_ = theInterpolator%interpolate( zGrid%edge_, zdata,Profile ) - write(*,*) ' ' - write(*,*) Iam // 'data z grid' - write(*,'(1p10g15.7)') zdata - write(*,*) ' ' - write(*,*) Iam // this%handle_%to_char() // ' on data z grid' - write(*,'(1p10g15.7)') Profile - write(*,*) ' ' - write(*,*) Iam // this%handle_%to_char() // ' @ mdl z grid edges' - write(*,'(1p10g15.7)') this%edge_val_ - this%mid_val_ = .5_dk & *(this%edge_val_(1_ik:this%ncells_) + this%edge_val_(2_ik:this%ncells_+1_ik)) this%delta_val_ = (this%edge_val_(2_ik:this%ncells_+1_ik) - this%edge_val_(1_ik:this%ncells_)) this%layer_dens_ = zGrid%delta_ * this%mid_val_ * km2cm this%layer_dens_(this%ncells_) = this%layer_dens_(this%ncells_) + this%edge_val_(this%ncells_+1_ik) * this%hscale_ * km2cm - write(*,*) Iam // 'exiting' - end subroutine initialize subroutine finalize( this ) diff --git a/test/oldtuv/vert_Profile_v0/vert_Profile_factory.F90 b/test/oldtuv/vert_Profile_v0/vert_Profile_factory.F90 index 01da715f..5a343d61 100644 --- a/test/oldtuv/vert_Profile_v0/vert_Profile_factory.F90 +++ b/test/oldtuv/vert_Profile_v0/vert_Profile_factory.F90 @@ -42,8 +42,6 @@ function vert_Profile_builder( config, gridWareHouse ) result( new_vert_Profile_ character(len=*), parameter :: Iam = 'Vert Profile builder: ' type(string_t) :: vert_Profile_type - write(*,*) Iam,'entering' - new_vert_Profile_t => null() call config%get( 'Vert Profile type', vert_Profile_type, Iam ) @@ -62,8 +60,6 @@ function vert_Profile_builder( config, gridWareHouse ) result( new_vert_Profile_ call new_vert_Profile_t%initialize( config, gridWareHouse ) - write(*,*) Iam,'exiting' - end function vert_Profile_builder !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/test/oldtuv/vert_Profile_v0/vert_Profile_warehouse.F90 b/test/oldtuv/vert_Profile_v0/vert_Profile_warehouse.F90 index 285ef1b5..eb2abdf5 100644 --- a/test/oldtuv/vert_Profile_v0/vert_Profile_warehouse.F90 +++ b/test/oldtuv/vert_Profile_v0/vert_Profile_warehouse.F90 @@ -61,8 +61,6 @@ function constructor( config, gridwarehouse ) result( vert_Profile_warehouse_obj character(len=32) :: keychar type(string_t) :: aswkey - write(*,*) Iam // 'entering' - allocate( vert_Profile_warehouse_obj ) associate(new_obj=>vert_Profile_warehouse_obj) @@ -77,8 +75,6 @@ function constructor( config, gridwarehouse ) result( vert_Profile_warehouse_obj do while( iter%next() ) keychar = vert_Profile_set%key(iter) aswkey = keychar - write(*,*) ' ' - write(*,*) Iam,'key = ',trim(keychar) call vert_Profile_set%get( iter, vert_Profile_config, Iam ) call vert_Profile_config%add( 'Handle', aswkey, Iam ) !----------------------------------------------------------------------------- @@ -90,13 +86,8 @@ function constructor( config, gridwarehouse ) result( vert_Profile_warehouse_obj deallocate( iter ) - write(*,*) ' ' - write(*,'(a,''There are '',i3,'' vert Profile objects'')') Iam,size(new_obj%vert_Profile_objs_) - end associate - write(*,*) Iam // 'exiting' - end function constructor !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -120,9 +111,6 @@ function get_vert_Profile( this, vert_Profile_handle ) result( vert_Profile_ptr integer(ik) :: ndx logical(lk) :: found - write(*,*) ' ' - write(*,*) Iam,'entering' - found = .false._lk do ndx = 1,size(this%vert_Profile_objs_) if( vert_Profile_handle .eq. this%vert_Profile_objs_(ndx)%ptr_%handle_ ) then @@ -137,8 +125,6 @@ function get_vert_Profile( this, vert_Profile_handle ) result( vert_Profile_ptr call die_msg( 460768214, "Invalid vert Profile handle: '"// vert_Profile_handle%to_char()//"'" ) endif - write(*,*) Iam,'exiting' - end function get_vert_Profile !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -155,14 +141,10 @@ subroutine finalize( this ) integer(kind=ik) :: ndx character(len=*), parameter :: Iam = 'vert Profile warehouse finalize: ' - write(*,*) Iam,'entering' - if( allocated( this%vert_Profile_objs_ ) ) then deallocate( this%vert_Profile_objs_ ) endif - write(*,*) Iam,'exiting' - end subroutine finalize !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/test/oldtuv/vpo3.f b/test/oldtuv/vpo3.f index 1d971fcb..0a6a5293 100644 --- a/test/oldtuv/vpo3.f +++ b/test/oldtuv/vpo3.f @@ -130,12 +130,6 @@ END FUNCTION inter1 nlyr = nz - 1 con = inter1(z, zd,xd ) - write(*,*) 'vpo3: data z grid' - write(*,'(1p10g15.7)') zd - write(*,*) ' ' - write(*,*) 'vpo3: o3 on data z grid' - write(*,'(1p10g15.7)') xd - * compute column increments DO i = 1, nlyr @@ -171,17 +165,11 @@ END FUNCTION inter1 con(nz) = con(nz) * scale ENDIF - write(*,*) ' ' - write(*,*) 'vpo3: o3 on mdl z grid edges' - write(*,'(1p10g15.7)') con - write(*,*) ' ' - *-----------------------------------------------------------------------------* *! overwrite column increments for specified pbl height * use mixing ratio in pbl *-----------------------------------------------------------------------------* IF(ipbl > 0) THEN - write(*,*) 'pbl O3 = ', mr_pbl, ' ppb' DO i = 1, nlyr IF (i <= ipbl) THEN col(i) = mr_pbl*1.E-9 * aircol(i) diff --git a/test/oldtuv/vptmp.f b/test/oldtuv/vptmp.f index 60e930a7..a7f87542 100644 --- a/test/oldtuv/vptmp.f +++ b/test/oldtuv/vptmp.f @@ -78,16 +78,6 @@ END FUNCTION inter1 nz = size(z) tlev = inter1(z, zd,td) - write(*,*) 'vptmp: data z grid' - write(*,'(1p10g15.7)') zd - write(*,*) ' ' - write(*,*) 'vptmp: Temp on data z grid' - write(*,'(1p10g15.7)') td - write(*,*) ' ' - write(*,*) 'vptmp: Temp on mdl z grid edges' - write(*,'(1p10g15.7)') tlev - write(*,*) ' ' - * compute layer-averages tlay(1:nz-1) = .5*(tlev(2:nz) + tlev(1:nz-1)) c tlay(nz) = tlay(nz-1) diff --git a/test/regression/dose_rates/sw.compare.py b/test/regression/dose_rates/sw.compare.py index 15af0ae1..7f3f26d9 100644 --- a/test/regression/dose_rates/sw.compare.py +++ b/test/regression/dose_rates/sw.compare.py @@ -33,9 +33,6 @@ def compare_var(var_name,tolerance,var_old,var_new): diff = np.abs(diff) diff_2d = np.reshape( diff,[156,1] ) - print(f"Shape diff_2d = {np.shape(diff_2d)}") - print(f"Max diff @ (row,col) = {np.unravel_index(np.argmax(diff_2d),diff_2d.shape)}") - print(f"Max diff @ {np.argmax( diff_2d )}") # get comparison stats results = {} results["minimum difference"] = np.amin( diff ) @@ -79,40 +76,14 @@ def compare_output(fsw_new_path, fsw_old_path, labels_new, labels_old, config): nlabels_new = len( labels_new ) nlabels_old = len( labels_old ) - print(f"\nsw.new type = {sw_new.dtype}") ndata = int(sw_new.shape[0]/nlabels_new) - print(f"sw.new size = {ndata}") - - print( f"\nThere are {nlabels_new} new arrays") - print( f"There are {nlabels_old} old arrays\n") SW_new = np.reshape( sw_new,[nlabels_new,ndata] ) - print(f"\nSW_new type = {SW_new.dtype}") - print(f"SW_new shape = {SW_new.shape}") - print( SW_new[0,:] ) - print("") - # check reshape maxind = np.argmax( sw_new ) - print(f"\nMax val sw_new @ {maxind}") - print(f" {maxind-4} <= n <= {maxind+4}") - print("sw_new near Max") - print( sw_new[maxind-4:maxind-1] ) - print( sw_new[maxind] ) - print( sw_new[maxind+1:maxind+4] ) maxind = np.unravel_index( np.argmax(SW_new),SW_new.shape ) - print(f"\nMax val SW_new @ {maxind}") - print("SW_new near Max") - print( SW_new[maxind[0],maxind[1]-4:maxind[1]-1] ) - print( SW_new[maxind[0],maxind[1]] ) - print( SW_new[maxind[0],maxind[1]+1:maxind[1]+4] ) - print("") SW_old = np.reshape( sw_old,[nlabels_old,ndata] ) - print( SW_old.dtype ) - print( SW_old.shape ) - print( SW_old[0,:] ) - print("") success = True @@ -129,17 +100,8 @@ def compare_output(fsw_new_path, fsw_old_path, labels_new, labels_old, config): if( not indatasets ): print(f"\nNo match for {match} in old dataset") continue - print(f"\n{match} in both datasets; (old,new) = {ndx_old},{ndx_new}") # compare datasets; old first - print("old dataset") - print(f"Min = {np.amin(SW_old[ndx_old,:])}") - print(f"Max = {np.amax(SW_old[ndx_old,:])}") - print(f"Non-zero count = {np.count_nonzero(SW_old[ndx_old,:])}") # new last - print("\nnew dataset") - print(f"Min = {np.amin(SW_new[ndx_new,:])}") - print(f"Max = {np.amax(SW_new[ndx_new,:])}") - print(f"Non-zero count = {np.count_nonzero(SW_new[ndx_new,:])}\n") results = compare_var( match, options["maximum difference"], SW_old[ndx_old,:], SW_new[ndx_new,:] ) for metric, tolerance in options.items(): if not metric in results.keys(): @@ -160,8 +122,6 @@ def compare_output(fsw_new_path, fsw_old_path, labels_new, labels_old, config): print(f" Fail cnt = {results['fail count']}\n") success = False continue - else: - print(f"{match} {metric} within tolerance: {results[metric]}% <= {tolerance}%") # close open files fsw_old.close() @@ -174,10 +134,6 @@ def compare_output(fsw_new_path, fsw_old_path, labels_new, labels_old, config): script_path, old_output_path, new_output_path = get_paths() labels_new, labels_old = get_labels(script_path) -print("\nslabels.new\n-----------") -for label in labels_new: - print(label.strip()) - with open(os.path.join(script_path, f"sw.compare.json"),"r") as f : config=json.load(f) diff --git a/test/regression/photolysis_rates/xsqy.compare.py b/test/regression/photolysis_rates/xsqy.compare.py index caf8f233..470c2f7b 100644 --- a/test/regression/photolysis_rates/xsqy.compare.py +++ b/test/regression/photolysis_rates/xsqy.compare.py @@ -33,9 +33,6 @@ def compare_var(var_name,tolerance,var_old,var_new): diff = np.abs(diff) diff_2d = np.reshape( diff,[156,121] ) - print(f"Shape diff_2d = {np.shape(diff_2d)}") - print(f"Max diff @ (row,col) = {np.unravel_index(np.argmax(diff_2d),diff_2d.shape)}") - print(f"Max diff @ {np.argmax( diff_2d )}") # get comparison stats results = {} results["minimum difference"] = np.amin( diff ) @@ -79,40 +76,15 @@ def compare_output(fxsqy_new_path, fxsqy_old_path, labels_new, labels_old, confi nlabels_new = len( labels_new ) nlabels_old = len( labels_old ) - print(f"\nxsqy.new type = {xsqy_new.dtype}") ndata = int(xsqy_new.shape[0]/nlabels_new) - print(f"xsqy.new size = {ndata}") - - print( f"\nThere are {nlabels_new} new arrays") - print( f"There are {nlabels_old} old arrays\n") XSQY_new = np.reshape( xsqy_new,[nlabels_new,ndata] ) - print(f"\nXSQY_new type = {XSQY_new.dtype}") - print(f"XSQY_new shape = {XSQY_new.shape}") - print( XSQY_new[0,:] ) - print("") # check reshape maxind = np.argmax( xsqy_new ) - print(f"\nMax val xsqy_new @ {maxind}") - print(f" {maxind-4} <= n <= {maxind+4}") - print("xsqy_new near Max") - print( xsqy_new[maxind-4:maxind-1] ) - print( xsqy_new[maxind] ) - print( xsqy_new[maxind+1:maxind+4] ) maxind = np.unravel_index( np.argmax(XSQY_new),XSQY_new.shape ) - print(f"\nMax val XSQY_new @ {maxind}") - print("XSQY_new near Max") - print( XSQY_new[maxind[0],maxind[1]-4:maxind[1]-1] ) - print( XSQY_new[maxind[0],maxind[1]] ) - print( XSQY_new[maxind[0],maxind[1]+1:maxind[1]+4] ) - print("") XSQY_old = np.reshape( xsqy_old,[nlabels_old,ndata] ) - print( XSQY_old.dtype ) - print( XSQY_old.shape ) - print( XSQY_old[0,:] ) - print("") success = True @@ -129,17 +101,8 @@ def compare_output(fxsqy_new_path, fxsqy_old_path, labels_new, labels_old, confi if( not indatasets ): print(f"\nNo match for {match} in old dataset") continue - print(f"\n{match} in both datasets; (old,new) = {ndx_old},{ndx_new}") # compare datasets; old first - print("old dataset") - print(f"Min = {np.amin(XSQY_old[ndx_old,:])}") - print(f"Max = {np.amax(XSQY_old[ndx_old,:])}") - print(f"Non-zero count = {np.count_nonzero(XSQY_old[ndx_old,:])}") # new last - print("\nnew dataset") - print(f"Min = {np.amin(XSQY_new[ndx_new,:])}") - print(f"Max = {np.amax(XSQY_new[ndx_new,:])}") - print(f"Non-zero count = {np.count_nonzero(XSQY_new[ndx_new,:])}\n") results = compare_var( match, options["maximum difference"], XSQY_old[ndx_old,:], XSQY_new[ndx_new,:] ) for metric, tolerance in options.items(): if not metric in results.keys(): @@ -160,8 +123,6 @@ def compare_output(fxsqy_new_path, fxsqy_old_path, labels_new, labels_old, confi print(f" Fail cnt = {results['fail count']}\n") success = False continue - else: - print(f"{match} {metric} within tolerance: {results[metric]}% <= {tolerance}%") # close open files fxsqy_old.close() @@ -174,10 +135,6 @@ def compare_output(fxsqy_new_path, fxsqy_old_path, labels_new, labels_old, confi script_path, old_output_path, new_output_path = get_paths() labels_new, labels_old = get_labels(script_path) -print("\njlabels.new\n-----------") -for label in labels_new: - print(label.strip()) - with open(os.path.join(script_path, f"xsqy.compare.json"),"r") as f : config=json.load(f) diff --git a/test/unit/CMakeLists.txt b/test/unit/CMakeLists.txt index e2e46248..262cf009 100644 --- a/test/unit/CMakeLists.txt +++ b/test/unit/CMakeLists.txt @@ -14,11 +14,13 @@ add_subdirectory(radiative_transfer) add_subdirectory(radiator) add_subdirectory(spectral_weight) add_subdirectory(tuv_doug) +add_subdirectory(util) ################################################################################ # TUV-x tests create_standard_test(NAME grid_warehouse SOURCES grid_warehouse.F90) +create_standard_test(NAME heating_rates SOURCES heating_rates.F90) create_standard_test(NAME la_sr_bands SOURCES la_sr_bands.F90 ) create_standard_test(NAME spherical_geometry SOURCES spherical_geometry.F90 ) diff --git a/test/unit/cross_section/CMakeLists.txt b/test/unit/cross_section/CMakeLists.txt index 08b27742..4733957c 100644 --- a/test/unit/cross_section/CMakeLists.txt +++ b/test/unit/cross_section/CMakeLists.txt @@ -33,4 +33,6 @@ create_standard_test(NAME cross_section_rono2 SOURCES rono2_test.F90 ) create_standard_test(NAME cross_section_t_butyl_nitrate SOURCES t_butyl_nitrate_test.F90 ) create_standard_test(NAME cross_section_tint SOURCES tint_test.F90 ) +add_subdirectory(util) + ################################################################################ diff --git a/test/unit/cross_section/acetone-ch3co_ch3_test.F90 b/test/unit/cross_section/acetone-ch3co_ch3_test.F90 index 181a0bbc..e95feccf 100644 --- a/test/unit/cross_section/acetone-ch3co_ch3_test.F90 +++ b/test/unit/cross_section/acetone-ch3co_ch3_test.F90 @@ -5,11 +5,19 @@ !> Tests for the base cross_section_t type program test_cross_section - use musica_mpi, only : musica_mpi_init, & - musica_mpi_finalize use tuvx_cross_section, only : cross_section_t use tuvx_cross_section_ch3coch3_ch3co_ch3 use tuvx_test_utils, only : check_values + use musica_assert, only : assert + use musica_constants, only : dk => musica_dk + use musica_config, only : config_t + use musica_iterator, only : iterator_t + use musica_mpi + use musica_string, only : string_t + use tuvx_cross_section_factory, only : cross_section_type_name, & + cross_section_allocate + use tuvx_grid_warehouse, only : grid_warehouse_t + use tuvx_profile_warehouse, only : profile_warehouse_t implicit none @@ -23,17 +31,6 @@ program test_cross_section subroutine test_cross_section_ch3coch3_ch3co_ch3_t( ) - use musica_assert, only : assert - use musica_constants, only : dk => musica_dk - use musica_config, only : config_t - use musica_iterator, only : iterator_t - use musica_mpi - use musica_string, only : string_t - use tuvx_cross_section_factory, only : cross_section_type_name, & - cross_section_allocate - use tuvx_grid_warehouse, only : grid_warehouse_t - use tuvx_profile_warehouse, only : profile_warehouse_t - class(grid_warehouse_t), pointer :: grids class(profile_warehouse_t), pointer :: profiles class(cross_section_t), pointer :: cross_section diff --git a/test/unit/cross_section/base.F90 b/test/unit/cross_section/base.F90 index 3c28a18b..87739c63 100644 --- a/test/unit/cross_section/base.F90 +++ b/test/unit/cross_section/base.F90 @@ -218,6 +218,49 @@ subroutine test_cross_section_t( ) deallocate( input_grid ) deallocate( cross_section ) + ! load and test cross section w/ specified data points + call assert( 906510764, iter%next( ) ) + call cs_set%get( iter, cs_config, Iam ) + if( musica_mpi_rank( comm ) == 0 ) then + cross_section => cross_section_t( cs_config, grids, profiles ) + type_name = cross_section_type_name( cross_section ) + pack_size = type_name%pack_size( comm ) + cross_section%pack_size( comm ) + allocate( buffer( pack_size ) ) + pos = 0 + call type_name%mpi_pack( buffer, pos , comm ) + call cross_section%mpi_pack( buffer, pos , comm ) + call assert( 283721707, pos <= pack_size ) + end if + + call musica_mpi_bcast( pack_size , comm ) + if( musica_mpi_rank( comm ) .ne. 0 ) allocate( buffer( pack_size ) ) + call musica_mpi_bcast( buffer , comm ) + + if( musica_mpi_rank( comm ) .ne. 0 ) then + pos = 0 + call type_name%mpi_unpack( buffer, pos , comm ) + cross_section => cross_section_allocate( type_name ) + call cross_section%mpi_unpack( buffer, pos , comm ) + call assert( 396040052, pos <= pack_size ) + end if + deallocate( buffer ) + + results = cross_section%calculate( grids, profiles, at_mid_point = .false. ) + do i_height = 1, 6 + call assert( 666985743, results( i_height, 1 ) .eq. 12.3_dk ) + call assert( 775945315, results( i_height, 2 ) .eq. 12.3_dk ) + call assert( 940837912, results( i_height, 3 ) .eq. 92.3_dk ) + call assert( 488205759, results( i_height, 4 ) .eq. 53.2_dk ) + call assert( 383057255, results( i_height, 5 ) .eq. 12.3_dk ) + call assert( 547949852, results( i_height, 6 ) .eq. 12.3_dk ) + call assert( 430367200, results( i_height, 7 ) .eq. 12.3_dk ) + call assert( 942743446, results( i_height, 8 ) .eq. 12.3_dk ) + call assert( 207636044, results( i_height, 9 ) .eq. 12.3_dk ) + call assert( 655003890, results( i_height, 10 ) .eq. 12.3_dk ) + call assert( 884904887, results( i_height, 11 ) .eq. 12.3_dk ) + end do + deallocate( cross_section ) + ! clean up deallocate( iter ) deallocate( grids ) diff --git a/test/unit/cross_section/cross_section_warehouse.F90 b/test/unit/cross_section/cross_section_warehouse.F90 index b997a93f..6117ca24 100644 --- a/test/unit/cross_section/cross_section_warehouse.F90 +++ b/test/unit/cross_section/cross_section_warehouse.F90 @@ -3,9 +3,16 @@ ! program test_cross_section_warehouse - use musica_mpi, only : musica_mpi_init, & - musica_mpi_finalize + use musica_assert, only : almost_equal, assert + use musica_config, only : config_t + use musica_constants, only : dk => musica_dk + use musica_mpi, only : musica_mpi_init, musica_mpi_finalize, musica_mpi_rank, musica_mpi_bcast, & + MPI_COMM_WORLD + use musica_string, only : string_t + use tuvx_cross_section, only : cross_section_t use tuvx_cross_section_warehouse + use tuvx_grid_warehouse, only : grid_warehouse_t + use tuvx_profile_warehouse, only : profile_warehouse_t implicit none @@ -18,16 +25,6 @@ program test_cross_section_warehouse !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine test_cross_section_warehouse_t( ) - - use musica_assert, only : almost_equal, assert - use musica_constants, only : dk => musica_dk - use musica_config, only : config_t - use musica_mpi - use musica_string, only : string_t - use tuvx_cross_section, only : cross_section_t - use tuvx_grid_warehouse, only : grid_warehouse_t - use tuvx_profile_warehouse, only : profile_warehouse_t - class(grid_warehouse_t), pointer :: grids class(profile_warehouse_t), pointer :: profiles class(cross_section_warehouse_t), pointer :: cross_sections diff --git a/test/unit/cross_section/hno3-oh_no2_test.F90 b/test/unit/cross_section/hno3-oh_no2_test.F90 index c62b4e6a..4032ea01 100644 --- a/test/unit/cross_section/hno3-oh_no2_test.F90 +++ b/test/unit/cross_section/hno3-oh_no2_test.F90 @@ -45,75 +45,135 @@ subroutine test_cross_section_hno3_oh_no2_t( ) ! So, these tests are testing that any changes don't produce unexpected ! changes. The values here are meaningless. no_extrap = reshape([ & - 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, & - 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, & - 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, & - 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, & - 6.35e-21, 6.28e-21, 6.21e-21, 6.14e-21, 6.07e-21, 6.01e-21, & - 1.27e-17, 1.25e-17, 1.24e-17, 1.22e-17, 1.21e-17, 1.20e-17, & - 1.14e-17, 1.12e-17, 1.11e-17, 1.10e-17, 1.09e-17, 1.07e-17, & - 1.00e-17, 9.89e-18, 9.78e-18, 9.67e-18, 9.57e-18, 9.46e-18, & - 8.41e-18, 8.31e-18, 8.22e-18, 8.13e-18, 8.05e-18, 7.96e-18, & - 6.68e-18, 6.60e-18, 6.53e-18, 6.46e-18, 6.39e-18, 6.33e-18, & - 5.09e-18, 5.03e-18, 4.98e-18, 4.92e-18, 4.87e-18, 4.82e-18, & - 3.81e-18, 3.76e-18, 3.72e-18, 3.68e-18, 3.64e-18, 3.60e-18, & - 2.74e-18, 2.71e-18, 2.68e-18, 2.65e-18, 2.62e-18, 2.59e-18, & - 1.90e-18, 1.87e-18, 1.85e-18, 1.83e-18, 1.81e-18, 1.79e-18, & - 1.27e-18, 1.26e-18, 1.24e-18, 1.22e-18, 1.21e-18, 1.19e-18, & - 5.35e-22, 5.28e-22, 5.21e-22, 5.15e-22, 5.08e-22, 5.02e-22, & - 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, & - 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, & - 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, & - 0.0, 0.0, 0.0, 0.0, 0.0, 0.0], & - (/ size(no_extrap, 2), size(no_extrap, 1) /) & + 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, & + 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, & + 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, & + 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, & + 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, & + 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, & + 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, & + 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, & + 6.35272794E-21, 6.28292740E-21, 6.21391491E-21, & + 6.14568136E-21, 6.07821774E-21, 6.01152535E-21, & + 1.27103729E-17, 1.25707177E-17, 1.24326394E-17, & + 1.22961194E-17, 1.21611400E-17, 1.20277036E-17, & + 1.14073753E-17, 1.12820368E-17, 1.11581135E-17, & + 1.10355888E-17, 1.09144467E-17, 1.07946895E-17, & + 1.00060382E-17, 9.89609694E-18, 9.78739694E-18, & + 9.67992382E-18, 9.57366339E-18, 9.46861771E-18, & + 8.41009301E-18, 8.31903871E-18, 8.22899780E-18, & + 8.13995871E-18, 8.05191002E-18, 7.96485376E-18, & + 6.68020845E-18, 6.60874219E-18, 6.53806213E-18, & + 6.46815940E-18, 6.39902523E-18, 6.33066143E-18, & + 5.09031945E-18, 5.03520764E-18, 4.98070919E-18, & + 4.92681712E-18, 4.87352449E-18, 4.82083254E-18, & + 3.81009039E-18, 3.76785972E-18, 3.72610992E-18, & + 3.68483537E-18, 3.64403051E-18, 3.60369606E-18, & + 2.74709876E-18, 2.71594406E-18, 2.68515211E-18, & + 2.65471858E-18, 2.62463919E-18, 2.59491429E-18, & + 1.90080756E-18, 1.87857899E-18, 1.85661710E-18, & + 1.83491859E-18, 1.81348025E-18, 1.79230211E-18, & + 1.27577108E-18, 1.26003270E-18, 1.24449323E-18, & + 1.22915010E-18, 1.21400077E-18, 1.19904502E-18, & + 5.35507275E-22, 5.28694862E-22, 5.21971170E-22, & + 5.15335016E-22, 5.08785237E-22, 5.02321672E-22, & + 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, & + 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, & + 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, & + 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, & + 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, & + 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, & + 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, & + 0.00000000E+00, 0.00000000E+00, 0.00000000E+00], & + (/ size(no_extrap, 2), size(no_extrap, 1) /) & ) lower_extrap = reshape([ real:: & - 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, & - 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, & - 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, & - 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, & - 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, & - 1.27e-17, 1.25e-17, 1.24e-17, 1.22e-17, 1.21e-17, 1.20e-17, & - 1.14e-17, 1.12e-17, 1.11e-17, 1.10e-17, 1.09e-17, 1.07e-17, & - 1.00e-17, 9.89e-18, 9.78e-18, 9.67e-18, 9.57e-18, 9.46e-18, & - 8.41e-18, 8.31e-18, 8.22e-18, 8.13e-18, 8.05e-18, 7.96e-18, & - 6.68e-18, 6.60e-18, 6.53e-18, 6.46e-18, 6.39e-18, 6.33e-18, & - 5.09e-18, 5.03e-18, 4.98e-18, 4.92e-18, 4.87e-18, 4.82e-18, & - 3.81e-18, 3.76e-18, 3.72e-18, 3.68e-18, 3.64e-18, 3.60e-18, & - 2.74e-18, 2.71e-18, 2.68e-18, 2.65e-18, 2.62e-18, 2.59e-18, & - 1.90e-18, 1.87e-18, 1.85e-18, 1.83e-18, 1.81e-18, 1.79e-18, & - 1.27e-18, 1.26e-18, 1.24e-18, 1.22e-18, 1.21e-18, 1.19e-18, & - 5.35e-22, 5.28e-22, 5.21e-22, 5.15e-22, 5.08e-22, 5.02e-22, & - 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, & - 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, & - 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, & - 0.0, 0.0, 0.0, 0.0, 0.0, 0.0], & - (/ size(lower_extrap, 2), size(lower_extrap, 1) /) & + 1.84878151E+02, 1.82846803E+02, 1.80838391E+02, & + 1.78852646E+02, 1.76889309E+02, 1.74948416E+02, & + 1.84878151E+02, 1.82846803E+02, 1.80838391E+02, & + 1.78852646E+02, 1.76889309E+02, 1.74948416E+02, & + 1.84878151E+02, 1.82846803E+02, 1.80838391E+02, & + 1.78852646E+02, 1.76889309E+02, 1.74948416E+02, & + 1.84878151E+02, 1.82846803E+02, 1.80838391E+02, & + 1.78852646E+02, 1.76889309E+02, 1.74948416E+02, & + 1.84790334E+02, 1.82759951E+02, 1.80752492E+02, & + 1.78767691E+02, 1.76805286E+02, 1.74865315E+02, & + 1.27103729E-17, 1.25707177E-17, 1.24326394E-17, & + 1.22961194E-17, 1.21611400E-17, 1.20277036E-17, & + 1.14073753E-17, 1.12820368E-17, 1.11581135E-17, & + 1.10355888E-17, 1.09144467E-17, 1.07946895E-17, & + 1.00060382E-17, 9.89609694E-18, 9.78739694E-18, & + 9.67992382E-18, 9.57366339E-18, 9.46861771E-18, & + 8.41009301E-18, 8.31903871E-18, 8.22899780E-18, & + 8.13995871E-18, 8.05191002E-18, 7.96485376E-18, & + 6.68020845E-18, 6.60874219E-18, 6.53806213E-18, & + 6.46815940E-18, 6.39902523E-18, 6.33066143E-18, & + 5.09031945E-18, 5.03520764E-18, 4.98070919E-18, & + 4.92681712E-18, 4.87352449E-18, 4.82083254E-18, & + 3.81009039E-18, 3.76785972E-18, 3.72610992E-18, & + 3.68483537E-18, 3.64403051E-18, 3.60369606E-18, & + 2.74709876E-18, 2.71594406E-18, 2.68515211E-18, & + 2.65471858E-18, 2.62463919E-18, 2.59491429E-18, & + 1.90080756E-18, 1.87857899E-18, 1.85661710E-18, & + 1.83491859E-18, 1.81348025E-18, 1.79230211E-18, & + 1.27577108E-18, 1.26003270E-18, 1.24449323E-18, & + 1.22915010E-18, 1.21400077E-18, 1.19904502E-18, & + 5.35507275E-22, 5.28694862E-22, 5.21971170E-22, & + 5.15335016E-22, 5.08785237E-22, 5.02321672E-22, & + 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, & + 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, & + 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, & + 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, & + 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, & + 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, & + 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, & + 0.00000000E+00, 0.00000000E+00, 0.00000000E+00], & + (/ size(lower_extrap, 2), size(lower_extrap, 1) /) & ) upper_extrap = reshape([ real:: & - 1.33e-17, 1.32e-17, 1.30e-17, 1.29e-17, 1.27e-17, 1.26e-17, & - 1.33e-17, 1.32e-17, 1.30e-17, 1.29e-17, 1.27e-17, 1.26e-17, & - 1.33e-17, 1.32e-17, 1.30e-17, 1.29e-17, 1.27e-17, 1.26e-17, & - 1.33e-17, 1.32e-17, 1.30e-17, 1.29e-17, 1.27e-17, 1.26e-17, & - 1.33e-17, 1.32e-17, 1.30e-17, 1.29e-17, 1.27e-17, 1.26e-17, & - 1.27e-17, 1.25e-17, 1.24e-17, 1.22e-17, 1.21e-17, 1.20e-17, & - 1.14e-17, 1.12e-17, 1.11e-17, 1.10e-17, 1.09e-17, 1.07e-17, & - 1.00e-17, 9.89e-18, 9.78e-18, 9.67e-18, 9.57e-18, 9.46e-18, & - 8.41e-18, 8.31e-18, 8.22e-18, 8.13e-18, 8.05e-18, 7.96e-18, & - 6.68e-18, 6.60e-18, 6.53e-18, 6.46e-18, 6.39e-18, 6.33e-18, & - 5.09e-18, 5.03e-18, 4.98e-18, 4.92e-18, 4.87e-18, 4.82e-18, & - 3.81e-18, 3.76e-18, 3.72e-18, 3.68e-18, 3.64e-18, 3.60e-18, & - 2.74e-18, 2.71e-18, 2.68e-18, 2.65e-18, 2.62e-18, 2.59e-18, & - 1.90e-18, 1.87e-18, 1.85e-18, 1.83e-18, 1.81e-18, 1.79e-18, & - 1.27e-18, 1.26e-18, 1.24e-18, 1.22e-18, 1.21e-18, 1.19e-18, & - 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, & - 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, & - 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, & - 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, & - 0.0, 0.0, 0.0, 0.0, 0.0, 0.0], & - (/ size(upper_extrap, 2), size(upper_extrap, 1) /) & + 1.33741641E-17, 1.32272156E-17, 1.30819261E-17, & + 1.29382766E-17, 1.27962479E-17, 1.26558428E-17, & + 1.33741641E-17, 1.32272156E-17, 1.30819261E-17, & + 1.29382766E-17, 1.27962479E-17, 1.26558428E-17, & + 1.33741641E-17, 1.32272156E-17, 1.30819261E-17, & + 1.29382766E-17, 1.27962479E-17, 1.26558428E-17, & + 1.33741641E-17, 1.32272156E-17, 1.30819261E-17, & + 1.29382766E-17, 1.27962479E-17, 1.26558428E-17, & + 1.33741641E-17, 1.32272156E-17, 1.30819261E-17, & + 1.29382766E-17, 1.27962479E-17, 1.26558428E-17, & + 1.27103729E-17, 1.25707177E-17, 1.24326394E-17, & + 1.22961194E-17, 1.21611400E-17, 1.20277036E-17, & + 1.14073753E-17, 1.12820368E-17, 1.11581135E-17, & + 1.10355888E-17, 1.09144467E-17, 1.07946895E-17, & + 1.00060382E-17, 9.89609694E-18, 9.78739694E-18, & + 9.67992382E-18, 9.57366339E-18, 9.46861771E-18, & + 8.41009301E-18, 8.31903871E-18, 8.22899780E-18, & + 8.13995871E-18, 8.05191002E-18, 7.96485376E-18, & + 6.68020845E-18, 6.60874219E-18, 6.53806213E-18, & + 6.46815940E-18, 6.39902523E-18, 6.33066143E-18, & + 5.09031945E-18, 5.03520764E-18, 4.98070919E-18, & + 4.92681712E-18, 4.87352449E-18, 4.82083254E-18, & + 3.81009039E-18, 3.76785972E-18, 3.72610992E-18, & + 3.68483537E-18, 3.64403051E-18, 3.60369606E-18, & + 2.74709876E-18, 2.71594406E-18, 2.68515211E-18, & + 2.65471858E-18, 2.62463919E-18, 2.59491429E-18, & + 1.90080756E-18, 1.87857899E-18, 1.85661710E-18, & + 1.83491859E-18, 1.81348025E-18, 1.79230211E-18, & + 1.27577108E-18, 1.26003270E-18, 1.24449323E-18, & + 1.22915010E-18, 1.21400077E-18, 1.19904502E-18, & + 2.07816741E+02, 2.05173017E+02, 2.02563723E+02, & + 1.99988400E+02, 1.97446598E+02, 1.94938253E+02, & + 2.07925902E+02, 2.05280789E+02, 2.02670124E+02, & + 2.00093449E+02, 1.97550312E+02, 1.95040649E+02, & + 2.07925902E+02, 2.05280789E+02, 2.02670124E+02, & + 2.00093449E+02, 1.97550312E+02, 1.95040649E+02, & + 2.07925902E+02, 2.05280789E+02, 2.02670124E+02, & + 2.00093449E+02, 1.97550312E+02, 1.95040649E+02, & + 2.07925902E+02, 2.05280789E+02, 2.02670124E+02, & + 2.00093449E+02, 1.97550312E+02, 1.95040649E+02], & + (/ size(upper_extrap, 2), size(upper_extrap, 1) /) & ) ! load test grids @@ -142,6 +202,7 @@ subroutine test_cross_section_hno3_oh_no2_t( ) call cs_set%get( iter, cs_config, Iam ) cross_section => cross_section_hno3_oh_no2_t( cs_config, grids, profiles ) results = cross_section%calculate( grids, profiles ) + call check_values( results, lower_extrap, .01_dk ) deallocate( cross_section ) diff --git a/test/unit/cross_section/rono2_test.F90 b/test/unit/cross_section/rono2_test.F90 index d1bde104..e6184407 100644 --- a/test/unit/cross_section/rono2_test.F90 +++ b/test/unit/cross_section/rono2_test.F90 @@ -45,29 +45,44 @@ subroutine test_cross_section_rono2_t( ) ! So, these tests are testing that any changes don't produce unexpected ! changes. The values here are meaningless. no_extrap = reshape([ real:: & - 3.33e-24, 3.21e-24, 3.10e-24, 2.99e-24, 2.89e-24, 2.79e-24, & - 4.01e-21, 3.87e-21, 3.73e-21, 3.60e-21, 3.47e-21, 3.35e-21, & - 3.22e-21, 3.10e-21, 2.99e-21, 2.88e-21, 2.77e-21, 2.67e-21, & - 2.55e-21, 2.45e-21, 2.36e-21, 2.27e-21, 2.18e-21, 2.10e-21, & - 1.75e-24, 1.68e-24, 1.61e-24, 1.55e-24, 1.49e-24, 1.43e-24], & + 3.3302044212254328E-024, 3.2161952124512202E-024, 3.1061223947672814E-024, & + 2.9998489273903812E-024, 2.8972425790838159E-024, 2.7981907562917913E-024, & + 4.0122656353068610E-021, 3.8717595318338420E-021, 3.7362148177227141E-021, & + 3.6054548800794594E-021, 3.4793094427501407E-021, 3.3576327537719567E-021, & + 3.2269583072774368E-021, 3.1085946499675142E-021, 2.9946069663498917E-021, & + 2.8848322221146335E-021, 2.7791135029650159E-021, 2.6773151777054408E-021, & + 2.5576809099900323E-021, 2.4589071748754612E-021, 2.3639765819585908E-021, & + 2.2727385030188113E-021, 2.1850482559046444E-021, 2.1007795988510739E-021, & + 1.7524893730671802E-024, 1.6829505050933260E-024, 1.6161910805734185E-024, & + 1.5520992136486835E-024, 1.4905675538255535E-024, 1.4315020191061525E-024], & (/ size(no_extrap, 2), size(no_extrap, 1) /) & ) lower_extrap = reshape([ real:: & - 0, 0, 0, 0, 0, 0, & - 4.01e-21, 3.87e-21, 3.73e-21, 3.60e-21, 3.47e-21, 3.35e-21, & - 3.22e-21, 3.10e-21, 2.99e-21, 2.88e-21, 2.77e-21, 2.67e-21, & - 2.55e-21, 2.45e-21, 2.36e-21, 2.27e-21, 2.18e-21, 2.10e-21, & - 1.75e-24, 1.68e-24, 1.61e-24, 1.55e-24, 1.49e-24, 1.43e-24], & + 284.35719862387975, 274.62225892536395, 265.22343707474488, & + 256.14903152812633, 247.38775141585484, 238.92998267703231, & + 4.0122656353068610E-021, 3.8717595318338420E-021, 3.7362148177227141E-021, & + 3.6054548800794594E-021, 3.4793094427501407E-021, 3.3576327537719567E-021, & + 3.2269583072774368E-021, 3.1085946499675142E-021, 2.9946069663498917E-021, & + 2.8848322221146335E-021, 2.7791135029650159E-021, 2.6773151777054408E-021, & + 2.5576809099900323E-021, 2.4589071748754612E-021, 2.3639765819585908E-021, & + 2.2727385030188113E-021, 2.1850482559046444E-021, 2.1007795988510739E-021, & + 1.7524893730671802E-024, 1.6829505050933260E-024, 1.6161910805734185E-024, & + 1.5520992136486835E-024, 1.4905675538255535E-024, 1.4315020191061525E-024], & (/ size(lower_extrap, 2), size(lower_extrap, 1) /) & ) upper_extrap = reshape([ real:: & - 4.41e-21, 4.25e-21, 4.11e-21, 3.97e-21, 3.83e-21, 3.70e-21, & - 4.01e-21, 3.87e-21, 3.73e-21, 3.60e-21, 3.47e-21, 3.35e-21, & - 3.22e-21, 3.10e-21, 2.99e-21, 2.88e-21, 2.77e-21, 2.67e-21, & - 2.55e-21, 2.45e-21, 2.36e-21, 2.27e-21, 2.18e-21, 2.10e-21, & - 0, 0, 0, 0, 0, 0], & + 4.4108667830913617E-021, 4.2598612085555927E-021, 4.1140693970533126E-021, & + 3.9733098376133487E-021, 3.8374073895248339E-021, 3.7062129222502928E-021, & + 4.0122656353068610E-021, 3.8717595318338420E-021, 3.7362148177227141E-021, & + 3.6054548800794594E-021, 3.4793094427501407E-021, 3.3576327537719567E-021, & + 3.2269583072774368E-021, 3.1085946499675142E-021, 2.9946069663498917E-021, & + 2.8848322221146335E-021, 2.7791135029650159E-021, 2.6773151777054408E-021, & + 2.5576809099900323E-021, 2.4589071748754612E-021, 2.3639765819585908E-021, & + 2.2727385030188113E-021, 2.1850482559046444E-021, 2.1007795988510739E-021, & + 291.32413139180113, 279.76437495516359, 268.66665781098493, & + 258.01238067351579, 247.78369819101036, 237.96497069299082], & (/ size(upper_extrap, 2), size(upper_extrap, 1) /) & ) ! load test grids diff --git a/test/unit/cross_section/util/CMakeLists.txt b/test/unit/cross_section/util/CMakeLists.txt new file mode 100644 index 00000000..6b2abbbd --- /dev/null +++ b/test/unit/cross_section/util/CMakeLists.txt @@ -0,0 +1,14 @@ +################################################################################ +# Test utilities + +include(test_util) + +################################################################################ +# Cross section utility tests + +create_standard_test( NAME temperature_parameterization_burkholder + SOURCES temperature_parameterization_burkholder.F90 ) +create_standard_test( NAME temperature_parameterization_taylor_series + SOURCES temperature_parameterization_taylor_series.F90 ) + +################################################################################ \ No newline at end of file diff --git a/test/unit/cross_section/util/temperature_parameterization_burkholder.F90 b/test/unit/cross_section/util/temperature_parameterization_burkholder.F90 new file mode 100644 index 00000000..eb05df26 --- /dev/null +++ b/test/unit/cross_section/util/temperature_parameterization_burkholder.F90 @@ -0,0 +1,102 @@ +! Copyright (C) 2024 National Center for Atmospheric Research +! SPDX-License-Identifier: Apache-2.0 +! +!> \file +!> Tests for the temperature_parameterization_burkholder_t type +program test_temperature_parameterization_burkholder + + use musica_mpi, only : musica_mpi_init, & + musica_mpi_finalize + use tuvx_temperature_parameterization_burkholder + + implicit none + + call musica_mpi_init( ) + call test_burkholder_t( ) + call musica_mpi_finalize( ) + +contains + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine test_burkholder_t( ) + + use musica_assert, only : assert + use musica_constants, only : dk => musica_dk + use musica_config, only : config_t + use musica_mpi + use musica_string, only : string_t + use tuvx_test_utils, only : check_values + + type(temperature_parameterization_burkholder_t) :: burkholder_param + type(config_t) :: config + character, allocatable :: buffer(:) + integer :: pack_size, pos + integer, parameter :: comm = MPI_COMM_WORLD + + call config%from_file( & + "test/data/cross_sections/util/burkholder.config.json" ) + + if( musica_mpi_rank( comm ) == 0 ) then + burkholder_param = temperature_parameterization_burkholder_t( config ) + pack_size = burkholder_param%pack_size( comm ) + allocate( buffer( pack_size ) ) + pos = 0 + call burkholder_param%mpi_pack( buffer, pos, comm ) + call assert( 984049167, pos <= pack_size ) + end if + + call musica_mpi_bcast( pack_size, comm ) + if( musica_mpi_rank( comm ) .ne. 0 ) allocate( buffer( pack_size ) ) + call musica_mpi_bcast( buffer, comm ) + + if( musica_mpi_rank( comm ) .ne. 0 ) then + pos = 0 + call burkholder_param%mpi_unpack( buffer, pos, comm ) + call assert( 761318011, pos <= pack_size ) + end if + deallocate( buffer ) + + ! Check temperature parameterization data members + call check_values( 756053704, burkholder_param%wavelengths_, & + (/ 302.0_dk, 304.0_dk, 306.0_dk, 308.0_dk, 310.0_dk /),& + 1.0e-6_dk ) + call check_values( 973109062, burkholder_param%AA_, & + (/ 13.3_dk, 14.4_dk, 15.5_dk, 16.6_dk, 17.7_dk /), & + 1.0e-6_dk ) + call check_values( 187744433, burkholder_param%BB_, & + (/ 21.4_dk, 22.3_dk, 23.2_dk, 24.1_dk, 25.0_dk /), & + 1.0e-6_dk ) + call assert( 301968312, burkholder_param%A_ == 12.5_dk ) + call assert( 521340695, burkholder_param%B_ == 202.3_dk ) + call assert( 405663577, size( burkholder_param%ranges_ ) == 3 ) + call assert( 800457171, burkholder_param%ranges_(1)%min_temperature_ == & + 0.0_dk ) + call assert( 412833418, burkholder_param%ranges_(1)%max_temperature_ == & + 209.999999999999_dk ) + call assert( 860201264, burkholder_param%ranges_(1)%is_fixed_ .eqv. & + .true. ) + call assert( 125093862, burkholder_param%ranges_(1)%fixed_temperature_ == & + 210.0_dk ) + call assert( 289986459, burkholder_param%ranges_(2)%min_temperature_ == & + 210.0_dk ) + call assert( 802362705, burkholder_param%ranges_(2)%max_temperature_ == & + 300.0_dk ) + call assert( 967255302, burkholder_param%ranges_(2)%is_fixed_ .eqv. & + .false. ) + call assert( 514623149, burkholder_param%ranges_(2)%fixed_temperature_ == & + 0.0_dk ) + call assert( 126999396, burkholder_param%ranges_(3)%min_temperature_ == & + 300.00000000001_dk ) + call assert( 574367242, burkholder_param%ranges_(3)%max_temperature_ == & + huge(1.0_dk) ) + call assert( 739259839, burkholder_param%ranges_(3)%is_fixed_ .eqv. & + .true. ) + call assert( 351636086, burkholder_param%ranges_(3)%fixed_temperature_ == & + 300.0_dk ) + + end subroutine test_burkholder_t + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +end program test_temperature_parameterization_burkholder \ No newline at end of file diff --git a/test/unit/cross_section/util/temperature_parameterization_taylor_series.F90 b/test/unit/cross_section/util/temperature_parameterization_taylor_series.F90 new file mode 100644 index 00000000..509cad13 --- /dev/null +++ b/test/unit/cross_section/util/temperature_parameterization_taylor_series.F90 @@ -0,0 +1,103 @@ +! Copyright (C) 2024 National Center for Atmospheric Research +! SPDX-License-Identifier: Apache-2.0 +! +!> \file +!> Tests for the temperature_parameterization_taylor_series_t type +program test_temperature_parameterization_taylor_series + + use musica_mpi, only : musica_mpi_init, & + musica_mpi_finalize + use tuvx_temperature_parameterization_taylor_series + + implicit none + + call musica_mpi_init( ) + call test_taylor_series_t( ) + call musica_mpi_finalize( ) + +contains + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine test_taylor_series_t( ) + + use musica_assert, only : assert + use musica_constants, only : dk => musica_dk + use musica_config, only : config_t + use musica_mpi + use musica_string, only : string_t + use tuvx_test_utils, only : check_values + + type(temperature_parameterization_taylor_series_t) :: taylor_param + type(config_t) :: config + character, allocatable :: buffer(:) + integer :: pack_size, pos + integer, parameter :: comm = MPI_COMM_WORLD + + call config%from_file( "test/data/cross_sections/util/taylor.config.json" ) + + if( musica_mpi_rank( comm ) == 0 ) then + taylor_param = temperature_parameterization_taylor_series_t( config ) + pack_size = taylor_param%pack_size( comm ) + allocate( buffer( pack_size ) ) + pos = 0 + call taylor_param%mpi_pack( buffer, pos, comm ) + call assert( 857895829, pos <= pack_size ) + end if + + call musica_mpi_bcast( pack_size, comm ) + if( musica_mpi_rank( comm ) .ne. 0 ) allocate( buffer( pack_size ) ) + call musica_mpi_bcast( buffer, comm ) + + if( musica_mpi_rank( comm ) .ne. 0 ) then + pos = 0 + call taylor_param%mpi_unpack( buffer, pos, comm ) + call assert( 960137855, pos <= pack_size ) + end if + deallocate( buffer ) + + ! Check temperature parameterization data members + call check_values( 405965907, taylor_param%wavelengths_, & + (/ 302.0_dk, 304.0_dk, 306.0_dk, 308.0_dk, 310.0_dk /),& + 1.0e-6_dk ) + call check_values( 973109062, taylor_param%sigma_, & + (/ 13.3_dk, 14.4_dk, 15.5_dk, 16.6_dk, 17.7_dk /), & + 1.0e-6_dk ) + call assert( 614095855, size( taylor_param%A_, dim = 1) == 2 ) + call check_values( 178709862, taylor_param%A_(1,:), & + (/ 21.4_dk, 22.3_dk, 23.2_dk, 24.1_dk, 25.0_dk /), & + 1.0e-6_dk ) + call check_values( 842091318, taylor_param%A_(2,:), & + (/ 6.0_dk, 7.0_dk, 8.0_dk, 9.0_dk, 10.0_dk /), & + 1.0e-6_dk ) + call assert( 161915997, taylor_param%base_temperature_ == 295.2_dk ) + call assert( 940974571, taylor_param%min_wavelength_ == 280.5_dk ) + call assert( 992095584, taylor_param%max_wavelength_ == 540.2_dk ) + call assert( 483530406, size( taylor_param%ranges_ ) == 3 ) + call assert( 815221134, taylor_param%ranges_(1)%min_temperature_ == & + 0.0_dk ) + call assert( 182355758, taylor_param%ranges_(1)%max_temperature_ == & + 209.999999999999_dk ) + call assert( 977207253, taylor_param%ranges_(1)%is_fixed_ .eqv. .true. ) + call assert( 242099851, taylor_param%ranges_(1)%fixed_temperature_ == & + 210.0_dk ) + call assert( 689467697, taylor_param%ranges_(2)%min_temperature_ == & + 210.0_dk ) + call assert( 301843944, taylor_param%ranges_(2)%max_temperature_ == & + 300.0_dk ) + call assert( 466736541, taylor_param%ranges_(2)%is_fixed_ .eqv. .false. ) + call assert( 914104387, taylor_param%ranges_(2)%fixed_temperature_ == & + 0.0_dk ) + call assert( 178996985, taylor_param%ranges_(3)%min_temperature_ == & + 300.00000000001_dk ) + call assert( 691373231, taylor_param%ranges_(3)%max_temperature_ == & + huge(1.0_dk) ) + call assert( 856265828, taylor_param%ranges_(3)%is_fixed_ .eqv. .true. ) + call assert( 403633675, taylor_param%ranges_(3)%fixed_temperature_ == & + 300.0_dk ) + + end subroutine test_taylor_series_t + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +end program test_temperature_parameterization_taylor_series \ No newline at end of file diff --git a/test/unit/heating_rates.F90 b/test/unit/heating_rates.F90 new file mode 100644 index 00000000..002821a3 --- /dev/null +++ b/test/unit/heating_rates.F90 @@ -0,0 +1,138 @@ +! Copyright (C) 2024 National Center for Atmospheric Research +! SPDX-License-Identifier: Apache-2.0 +! +program test_heating_rates + + use musica_mpi, only : musica_mpi_init, & + musica_mpi_finalize + use tuvx_heating_rates + + implicit none + + call musica_mpi_init( ) + call test_heating_rates_t( ) + call musica_mpi_finalize( ) + +contains + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> @brief Test the heating rates + subroutine test_heating_rates_t( ) + + use musica_assert, only : assert + use musica_config, only : config_t + use musica_constants, only : dk => musica_dk + use musica_mpi, only : musica_mpi_bcast, & + musica_mpi_rank, & + MPI_COMM_WORLD + use musica_string, only : string_t + use tuvx_grid_warehouse, only : grid_warehouse_t + use tuvx_la_sr_bands, only : la_sr_bands_t + use tuvx_profile_warehouse, only : profile_warehouse_t + use tuvx_solver, only : radiation_field_t + use tuvx_spherical_geometry, only : spherical_geometry_t + use tuvx_test_utils, only : check_values + + type(heating_rates_t), pointer :: heating_rates + class(grid_warehouse_t), pointer :: grids + class(profile_warehouse_t), pointer :: profiles + + character(len=*), parameter :: Iam = "heating_rates_t tests" + type(config_t) :: config, sub_config, reactions_config + type(string_t), allocatable :: labels(:) + character, allocatable :: buffer(:) + integer :: pos, pack_size, i_height, i_wavelength + integer, parameter :: comm = MPI_COMM_WORLD + real(dk), parameter :: hc = 6.62608e-34_dk * 2.9979e8_dk / 1.e-9_dk + real(dk) :: bde(6,2), actinic_flux(5,6), etfl(6) + real(dk) :: wc(6) = (/ 425.0_dk, 475.0_dk, 525.0_dk, 575.0_dk, 625.0_dk, & + 675.0_dk /) + type(radiation_field_t) :: radiation_field + real(dk) :: calculated_rates(5,2), expected_rates(5,2) + type(la_sr_bands_t) :: la_srb + type(spherical_geometry_t) :: spherical_geometry + + call config%from_file( "test/data/heating_rates.json" ) + call config%get( "grids", sub_config, Iam ) + grids => grid_warehouse_t( sub_config ) + call config%get( "profiles", sub_config, Iam ) + profiles => profile_warehouse_t( sub_config, grids ) + + if( musica_mpi_rank( comm ) == 0 ) then + call config%get( "reactions", reactions_config, Iam ) + call sub_config%empty( ) + call sub_config%add( "reactions", reactions_config, Iam ) + heating_rates => heating_rates_t( sub_config, grids, profiles ) + pack_size = heating_rates%pack_size( comm ) + allocate( buffer( pack_size ) ) + pos = 0 + call heating_rates%mpi_pack( buffer, pos, comm ) + call assert( 534250649, pos <= pack_size ) + end if + + call musica_mpi_bcast( pack_size, comm ) + if( musica_mpi_rank( comm ) .ne. 0 ) allocate( buffer( pack_size ) ) + call musica_mpi_bcast( buffer, comm ) + + if( musica_mpi_rank( comm ) .ne. 0 ) then + pos = 0 + allocate( heating_rates ) + call heating_rates%mpi_unpack( buffer, pos, comm ) + call assert( 192483602, pos <= pack_size ) + end if + deallocate( buffer ) + + ! check labels + labels = heating_rates%labels( ) + call assert( 152892147, size(labels) == 2 ) + call assert( 437272930, labels(1) == "jfoo" ) + call assert( 884640776, labels(2) == "jbaz" ) + + ! check bond dissociation energies + call assert( 613305591, size( heating_rates%heating_parameters_ ) == 2 ) + bde(:,1) = max( 0.0_dk, hc * ( 2.0_dk - wc(:) ) / ( 2.0_dk * wc(:) ) ) + call check_values( heating_rates%heating_parameters_(1)%energy_, & + bde(:,1), 1.0e-4_dk ) + bde(:,2) = max( 0.0_dk, hc * ( 3000.0_dk - wc(:) ) / ( 3000.0_dk * wc(:) ) ) + call check_values( heating_rates%heating_parameters_(2)%energy_, & + bde(:,2), 1.0e-4_dk ) + + ! check calculated heating rates + calculated_rates(:,:) = 0.0_dk + allocate( radiation_field%fdr_(5,6), radiation_field%fdn_(5,6), & + radiation_field%fup_(5,6) ) + do i_wavelength = 1, 6 + etfl(i_wavelength) = 0.5_dk * ( 1.0e3_dk * 10.0_dk**i_wavelength + & + 1.0e4_dk * 10.0_dk**i_wavelength ) + end do + do i_height = 1, 5 + do i_wavelength = 1, 6 + radiation_field%fdr_( i_height, i_wavelength ) = & + 1.0_dk * i_height * i_wavelength + radiation_field%fdn_( i_height, i_wavelength ) = & + 2.0_dk * i_height * i_wavelength + radiation_field%fup_( i_height, i_wavelength ) = & + 3.0_dk * i_height * i_wavelength + actinic_flux( i_height, i_wavelength ) = & + 6.0_dk * i_height * i_wavelength * etfl( i_wavelength ) + expected_rates( i_height, 1 ) = & + dot_product( actinic_flux(i_height,:), bde(:,1) * 12.3_dk * 0.75_dk ) + expected_rates( i_height, 2 ) = 1.1_dk * & + dot_product( actinic_flux(i_height,:), bde(:,2) * 78.9_dk * 0.5_dk ) + end do + end do + call heating_rates%get( la_srb, spherical_geometry, grids, profiles, & + radiation_field, calculated_rates ) + + call check_values( calculated_rates, expected_rates, 1.0e-4_dk ) + + deallocate( grids ) + deallocate( profiles ) + deallocate( heating_rates ) + + end subroutine test_heating_rates_t + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +end program test_heating_rates diff --git a/test/unit/la_sr_bands.F90 b/test/unit/la_sr_bands.F90 index e5fb6c12..f1cbfed9 100644 --- a/test/unit/la_sr_bands.F90 +++ b/test/unit/la_sr_bands.F90 @@ -67,22 +67,31 @@ program test_la_sr_bands !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine test_optical_depth( ) - use tuvx_grid, only : grid_t - use tuvx_spherical_geometry, only : spherical_geometry_t + + use tuvx_profile, only : profile_t + use tuvx_grid, only : grid_t + use tuvx_spherical_geometry, only : spherical_geometry_t real(dk), allocatable :: air_vertical_column(:), air_slant_column(:) real(dk), allocatable :: o2_optical_depth(:,:) - class(grid_t), pointer :: height_grid => null( ) ! specified altitude working grid [km] - type(spherical_geometry_t) :: spherical_geometry + class(grid_t), pointer :: height_grid ! specified altitude working grid [km] + class(grid_t), pointer :: wavelength_grid ! [nm] + class(spherical_geometry_t), pointer :: spherical_geometry + class(profile_t), pointer :: air height_grid => grid_warehouse%get_grid( "height", "km" ) - allocate( air_vertical_column( height_grid%ncells_ ), & - air_slant_column( height_grid%ncells_ + 1 ) ) + wavelength_grid => grid_warehouse%get_grid( "wavelength", "nm" ) + air => profile_warehouse%get_profile( "air", "molecule cm-3" ) + + spherical_geometry => spherical_geometry_t( grid_warehouse ) + call spherical_geometry%set_parameters( 45.0_dk, grid_warehouse ) - allocate( o2_optical_depth(120, 38) ) + allocate( air_vertical_column( air%ncells_ ), & + air_slant_column( air%ncells_ + 1 ) ) + call spherical_geometry%air_mass( air%exo_layer_dens_, air_vertical_column,& + air_slant_column ) - air_vertical_column(:) = 1 - air_slant_column(:) = 3 + allocate( o2_optical_depth(height_grid%ncells_, wavelength_grid%ncells_) ) o2_optical_depth(:,:) = 0 ! just checking that it runs. This method apparently requires at least @@ -93,6 +102,9 @@ subroutine test_optical_depth( ) spherical_geometry ) deallocate( height_grid ) + deallocate( wavelength_grid ) + deallocate( air ) + deallocate( spherical_geometry ) deallocate( o2_optical_depth ) deallocate( air_vertical_column ) deallocate( air_slant_column ) diff --git a/test/unit/profile/from_host.F90 b/test/unit/profile/from_host.F90 index ced5d7e4..d23ee0ea 100644 --- a/test/unit/profile/from_host.F90 +++ b/test/unit/profile/from_host.F90 @@ -96,7 +96,6 @@ subroutine test_profile_from_host_t( ) call check_values( 447131776, my_profile%layer_dens_, dens, tol ) call check_values( 612024373, my_profile%exo_layer_dens_, exos, tol ) call check_values( 159392220, my_profile%burden_dens_, burden, tol ) - call my_profile%output( ) ! specify edges, mids, dens edges = (/ 0.5_dk, 9.8_dk, 15.4_dk, 45.0_dk /) @@ -115,7 +114,6 @@ subroutine test_profile_from_host_t( ) call check_values( 613341306, my_profile%layer_dens_, dens, tol ) call check_values( 466544996, my_profile%exo_layer_dens_, exos, tol ) call check_values( 796782485, my_profile%burden_dens_, burden, tol ) - call my_profile%output( ) ! specify edges, dens, scale height edges = (/ 1.0_dk, 2.0_dk, 4.0_dk, 10.0_dk /) @@ -136,7 +134,6 @@ subroutine test_profile_from_host_t( ) call check_values( 927373531, my_profile%layer_dens_, dens, tol ) call check_values( 192266129, my_profile%exo_layer_dens_, exos, tol ) call check_values( 639633975, my_profile%burden_dens_, burden, tol ) - call my_profile%output( ) ! specify edges, mids, dens, exo density edges = (/ 0.5_dk, 9.8_dk, 15.4_dk, 45.0_dk /) @@ -158,7 +155,6 @@ subroutine test_profile_from_host_t( ) call check_values( 124351251, my_profile%layer_dens_, dens, tol ) call check_values( 571719097, my_profile%exo_layer_dens_, exos, tol ) call check_values( 184095344, my_profile%burden_dens_, burden, tol ) - call my_profile%output( ) deallocate( my_profile ) diff --git a/test/unit/quantum_yield/CMakeLists.txt b/test/unit/quantum_yield/CMakeLists.txt index c662cdcb..66a31f22 100644 --- a/test/unit/quantum_yield/CMakeLists.txt +++ b/test/unit/quantum_yield/CMakeLists.txt @@ -7,6 +7,7 @@ include(test_util) # Quantum yield tests create_standard_test(NAME quantum_yield SOURCES base.F90 ) +create_standard_test(NAME quantum_yield_h2so4_mills SOURCES h2so4_mills.F90 ) create_standard_test(NAME quantum_yield_no2_tint SOURCES no2_tint.F90 ) create_standard_test(NAME quantum_yield_tint SOURCES tint.F90 ) diff --git a/test/unit/quantum_yield/base.F90 b/test/unit/quantum_yield/base.F90 index a68e6fba..86044638 100644 --- a/test/unit/quantum_yield/base.F90 +++ b/test/unit/quantum_yield/base.F90 @@ -217,7 +217,7 @@ subroutine test_quantum_yield_t( ) call assert( 896493526, results( i_height, 8 ) == 0.932_dk ) call assert( 443861373, results( i_height, 9 ) == 0.122_dk ) call assert( 891229219, results( i_height, 10 ) == 0.122_dk ) - call assert( 438597066, results( i_height, 11 ) == 0.0_dk ) + call assert( 438597066, results( i_height, 11 ) == 0.243_dk ) end do call add_points( input, input_grid, 0.0_dk, 0.0_dk ) call check_values( results(:,1:4), input, input_grid, 6 ) diff --git a/test/unit/quantum_yield/h2so4_mills.F90 b/test/unit/quantum_yield/h2so4_mills.F90 new file mode 100644 index 00000000..90822fd0 --- /dev/null +++ b/test/unit/quantum_yield/h2so4_mills.F90 @@ -0,0 +1,210 @@ +! Copyright (C) 2024 National Center for Atmospheric Research +! SPDX-License-Identifier: Apache-2.0 +! +program test_quantum_yield_h2so4_mills + + use musica_mpi + use tuvx_quantum_yield_h2so4_mills + + implicit none + + call musica_mpi_init( ) + call test_quantum_yield_h2so4_mills_t( ) + call musica_mpi_finalize( ) + +contains + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Test the temperature and pressure dependent H2SO4 quantum yield + !! calculations against previously generated results from an older version + !! of TUV + subroutine test_quantum_yield_h2so4_mills_t( ) + + use musica_assert, only : assert, die, almost_equal + use musica_config, only : config_t + use musica_constants, only : dk => musica_dk + use musica_io, only : io_t + use musica_io_netcdf, only : io_netcdf_t + use musica_string, only : string_t + use tuvx_constants, only : gas_constant, Avogadro, pi + use tuvx_cross_section, only : cross_section_t + use tuvx_grid, only : grid_t + use tuvx_grid_from_host, only : grid_from_host_t + use tuvx_grid_warehouse, only : grid_warehouse_t + use tuvx_profile, only : profile_t + use tuvx_profile_from_host, only : profile_from_host_t, & + profile_updater_t + use tuvx_profile_warehouse, only : profile_warehouse_t + use tuvx_quantum_yield, only : quantum_yield_t + use tuvx_quantum_yield_factory + use tuvx_test_utils, only : check_values + + character(len=*), parameter :: my_name = "h2so4 quantum yield test" + class(grid_warehouse_t), pointer :: grids + class(profile_warehouse_t), pointer :: profiles + class(quantum_yield_t), pointer :: quantum_yield + class(cross_section_t), pointer :: cross_section + type(config_t) :: config, qy_config, cs_config, grids_config, & + profiles_config + + class(grid_from_host_t), pointer :: heights + class(profile_from_host_t), pointer :: temperature, air + type(profile_updater_t) :: temperature_updater, air_updater + class(grid_t), pointer :: wavelength_grid + class(profile_t), pointer :: temperature_profile, air_profile + character, allocatable :: buffer(:) + real(kind=dk), allocatable :: update_temperatures(:), update_air(:) + real(kind=dk), allocatable :: file_temperatures(:), file_pressures(:), & + file_photo_rates(:,:,:), & + file_wavelengths(:), & + quantum_yields(:,:), cross_sections(:,:) + class(io_t), pointer :: file + type(string_t) :: type_name, file_name, var_name + integer :: pos, pack_size, n_bins, i_temp, i_pres, i_wl, i_height, n_wl, & + i_file_offset + integer, parameter :: comm = MPI_COMM_WORLD + + file_name = "test/data/quantum_yields/jh2so4.nc" + file => io_netcdf_t( file_name ) + var_name = "temperature" + call file%read( var_name, file_temperatures, my_name ) + var_name = "pressure" + call file%read( var_name, file_pressures, my_name ) + file_pressures(:) = file_pressures(:) * 100.0_dk ! convert hPa to Pa + var_name = "jh2so4" + call file%read( var_name, file_photo_rates, my_name ) + var_name = "wavelength" + call file%read( var_name, file_wavelengths, my_name ) + deallocate( file ) + + call config%from_file( "test/data/quantum_yields/h2so4_mills.config.json" ) + call config%get( "grids", grids_config, my_name ) + call config%get( "quantum yield", qy_config, my_name ) + call config%get( "cross section", cs_config, my_name ) + + n_bins = size( file_temperatures ) * size( file_pressures ) - 1 + heights => grid_from_host_t( "height", "km", n_bins ) + temperature => profile_from_host_t( "temperature", "K", n_bins ) + air => profile_from_host_t( "air", "molecule cm-3", n_bins ) + + grids => grid_warehouse_t( grids_config ) + call grids%add( heights ) + call profiles_config%empty( ) + profiles => profile_warehouse_t( profiles_config, grids ) + call profiles%add( temperature ) + call profiles%add( air ) + temperature_updater = profiles%get_updater( temperature ) + air_updater = profiles%get_updater( air ) + + cross_section => cross_section_t( cs_config, grids, profiles ) + + if( musica_mpi_rank( comm ) == 0 ) then + quantum_yield => quantum_yield_builder( qy_config, grids, profiles ) + type_name = quantum_yield_type_name( quantum_yield ) + pack_size = type_name%pack_size( comm ) + quantum_yield%pack_size( comm ) + allocate( buffer( pack_size ) ) + pos = 0 + call type_name%mpi_pack( buffer, pos, comm ) + call quantum_yield%mpi_pack( buffer, pos, comm ) + call assert( 837477723, pos <= pack_size ) + end if + + call musica_mpi_bcast( pack_size, comm ) + if( musica_mpi_rank( comm ) .ne. 0 ) allocate( buffer( pack_size ) ) + call musica_mpi_bcast( buffer, comm ) + + if( musica_mpi_rank( comm ) .ne. 0 ) then + pos = 0 + call type_name%mpi_unpack( buffer, pos, comm ) + quantum_yield => quantum_yield_allocate( type_name ) + call quantum_yield%mpi_unpack( buffer, pos, comm ) + call assert( 599405941, pos <= pack_size ) + end if + deallocate( buffer ) + + i_height = 0 + allocate( update_temperatures( n_bins + 1 ) ) + allocate( update_air( n_bins + 1 ) ) + do i_temp = 1, size( file_temperatures ) + do i_pres = 1, size( file_pressures ) + i_height = i_height + 1 + update_temperatures( i_height ) = file_temperatures( i_temp ) + update_air( i_height ) = file_pressures( i_pres ) / gas_constant / & + update_temperatures( i_height ) * & + Avogadro * 1.0e-6_dk ! convert mol m-3 to molec cm-3 + end do + end do + call temperature_updater%update( edge_values = update_temperatures ) + call air_updater%update( edge_values = update_air ) + + quantum_yields = quantum_yield%calculate( grids, profiles ) + cross_sections = cross_section%calculate( grids, profiles ) + + wavelength_grid => grids%get_grid( "wavelength", "nm" ) + temperature_profile => profiles%get_profile( "temperature", "K" ) + air_profile => profiles%get_profile( "air", "molecule cm-3" ) + + n_wl = size( quantum_yields, 2 ) + i_file_offset = 1 + do i_wl = 1, n_wl + if ( almost_equal( file_wavelengths( 1 ), & + wavelength_grid%mid_( i_wl ) ) ) then + exit + end if + i_file_offset = i_file_offset + 1 + end do + call assert( 462064586, size( cross_sections, 2 ) .eq. n_wl ) + call assert( 234069123, size( file_photo_rates, 1 ) + i_file_offset - 1 & + .eq. n_wl ) + + i_height = 0 + do i_temp = 1, size( file_temperatures ) + do i_pres = 1, size( file_pressures ) + i_height = i_height + 1 + do i_wl = 1, i_file_offset - 1 + call assert( 897976065, & + almost_equal( quantum_yields( i_height, i_wl ), & + 1.0_dk ) ) + if( i_wl .eq. 2 ) then + call assert( 126374455, & + almost_equal( cross_sections( i_height, i_wl ), & + 6.3e-17_dk ) ) + else + call assert( 291267052, & + almost_equal( cross_sections( i_height, i_wl ), & + 0.0_dk ) ) + end if + end do + do i_wl = i_file_offset, n_wl + ! the top pressure level has different logic, but we're putting + ! all pressure/temperature combos in one profile for this test, + ! so skip the lowest pressure util we're on the last profile element + if( i_pres .eq. size( file_pressures ) .and. & + i_temp < size( file_temperatures ) ) cycle + call assert( 342289277, & + almost_equal( quantum_yields( i_height, i_wl ) * & + cross_sections( i_height, i_wl ), & + file_photo_rates( i_wl - i_file_offset + 1, i_temp, i_pres ), & + relative_tolerance = 1.0e-3_dk )) + end do + end do + end do + + ! clean up + deallocate( grids ) + deallocate( profiles ) + deallocate( quantum_yield ) + deallocate( cross_section ) + deallocate( wavelength_grid ) + deallocate( temperature_profile ) + deallocate( air_profile ) + deallocate( heights ) + deallocate( temperature ) + deallocate( air ) + + end subroutine test_quantum_yield_h2so4_mills_t + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +end program test_quantum_yield_h2so4_mills \ No newline at end of file diff --git a/test/unit/radiative_transfer/radiative_transfer_core.F90 b/test/unit/radiative_transfer/radiative_transfer_core.F90 index 95940791..2624223e 100644 --- a/test/unit/radiative_transfer/radiative_transfer_core.F90 +++ b/test/unit/radiative_transfer/radiative_transfer_core.F90 @@ -94,8 +94,6 @@ subroutine run( this ) class(cross_section_t), pointer :: RaylieghCrossSection type(string_t) :: Handle - write(*,*) Iam // 'entering' - !> Get copy of grid zGrid => this%theGridWarehouse_%get_grid( "height", "km" ) call assert( 412238768, zGrid%ncells_ .eq. 120_ik ) @@ -110,13 +108,6 @@ subroutine run( this ) AirProfile => this%theProfileWarehouse_%get_profile( "air", "molecule cm-3" ) call assert( 412238771, all( AirProfile%delta_val_ < 0._dk ) ) call assert( 412238771, all( AirProfile%layer_dens_ > 0._dk ) ) - write(*,*) ' ' - write(*,*) Iam // 'Air layer density' - write(*,'(1p10g15.7)') AirProfile%layer_dens_ - - write(*,*) ' ' - write(*,*) Iam // 'Air burden density' - write(*,'(1p10g15.7)') AirProfile%burden_dens_ !> Get copy of the temperature Profile TemperatureProfile => this%theProfileWarehouse_%get_profile( "temperature", "K" ) @@ -131,15 +122,9 @@ subroutine run( this ) call assert( 412238776, all( aCrossSection >= 0._dk ) ) call assert( 412238776, all( aCrossSection < 1._dk ) ) - write(*,*) ' ' - write(*,*) Iam // 'aCrossSection is (',size(aCrossSection,dim=1),' x ',size(aCrossSection,dim=2),')' - tstCrossSection = aCrossSection(1,1) call assert( 412238774, all( aCrossSection(:,1) == tstCrossSection ) ) - write(*,*) ' ' - write(*,*) Iam // 'Rayliegh cross section' - write(*,'(1p10g15.7)') aCrossSection(1,:) call assert( 412238775, all( aCrossSection(1,:) == aCrossSection(zGrid%ncells_,:) ) ) deallocate( zGrid ) @@ -147,7 +132,6 @@ subroutine run( this ) deallocate( TemperatureProfile ) deallocate( AirProfile ) deallocate( RaylieghCrossSection ) - write(*,*) Iam // 'exiting' end subroutine run diff --git a/test/unit/radiator/from_host.F90 b/test/unit/radiator/from_host.F90 index eea1e50c..9117bf73 100644 --- a/test/unit/radiator/from_host.F90 +++ b/test/unit/radiator/from_host.F90 @@ -3,9 +3,20 @@ ! program test_radiator_from_host - use musica_mpi, only : musica_mpi_init, & - musica_mpi_finalize - use tuvx_test_utils, only : check_values + use musica_mpi, only : musica_mpi_finalize, musica_mpi_init, musica_mpi_rank, musica_mpi_bcast, & + MPI_COMM_WORLD + use tuvx_grid, only : grid_t + use tuvx_radiator, only : radiator_t + use tuvx_cross_section_warehouse, only : cross_section_warehouse_t + use tuvx_grid_from_host, only : grid_from_host_t + use tuvx_grid_warehouse, only : grid_warehouse_t + use tuvx_profile_warehouse, only : profile_warehouse_t + use tuvx_radiator_from_host, only : radiator_updater_t, radiator_from_host_t + use musica_string, only : string_t + use musica_constants, only : dk => musica_dk + use musica_assert, only : assert, die + use tuvx_radiator_factory, only : radiator_type_name, radiator_allocate + use tuvx_test_utils, only : check_values implicit none @@ -19,31 +30,16 @@ program test_radiator_from_host subroutine test_radiator_from_host_t( ) - use musica_assert, only : assert, almost_equal, die - use musica_constants, only : dk => musica_dk - use musica_mpi - use musica_string, only : string_t - use tuvx_cross_section_warehouse, only : cross_section_warehouse_t - use tuvx_grid, only : grid_t - use tuvx_grid_from_host, only : grid_from_host_t - use tuvx_grid_warehouse, only : grid_warehouse_t - use tuvx_profile_warehouse, only : profile_warehouse_t - use tuvx_radiator, only : radiator_t - use tuvx_radiator_from_host, only : radiator_from_host_t, & - radiator_updater_t - use tuvx_radiator_factory, only : radiator_type_name, & - radiator_allocate - - class(radiator_t), pointer :: radiator - type(radiator_updater_t) :: radiator_updater + character, allocatable :: buffer(:) class(grid_t), pointer :: height, wavelength + class(radiator_t), pointer :: radiator + integer :: pos, pack_size + integer, parameter :: comm = MPI_COMM_WORLD + type(cross_section_warehouse_t) :: cross_sections type(grid_warehouse_t) :: grids type(profile_warehouse_t) :: profiles - type(cross_section_warehouse_t) :: cross_sections - character, allocatable :: buffer(:) - integer :: pos, pack_size + type(radiator_updater_t) :: radiator_updater type(string_t) :: type_name - integer, parameter :: comm = MPI_COMM_WORLD real(kind=dk), parameter :: tol = 1.0e-10_dk real(kind=dk) :: od(3,2) diff --git a/test/unit/radiator/radiator_core.F90 b/test/unit/radiator/radiator_core.F90 index bff23859..e21addf2 100644 --- a/test/unit/radiator/radiator_core.F90 +++ b/test/unit/radiator/radiator_core.F90 @@ -120,8 +120,6 @@ subroutine run( this ) logical :: found integer, parameter :: comm = MPI_COMM_WORLD - write(*,*) Iam // 'entering' - !> Get copy of grid zGrid => this%theGridWarehouse_%get_grid( "height", "km" ) call assert( 412238768, zGrid%ncells_ .eq. 120_ik ) @@ -136,13 +134,6 @@ subroutine run( this ) AirProfile => this%theProfileWarehouse_%get_profile( "air", "molecule cm-3" ) call assert( 412238771, all( AirProfile%delta_val_ < 0._dk ) ) call assert( 412238771, all( AirProfile%layer_dens_ > 0._dk ) ) - write(*,*) ' ' - write(*,*) Iam // 'Air layer density' - write(*,'(1p10g15.7)') AirProfile%layer_dens_ - - write(*,*) ' ' - write(*,*) Iam // 'Air burden density' - write(*,'(1p10g15.7)') AirProfile%burden_dens_ !> Get copy of the temperature Profile TemperatureProfile => this%theProfileWarehouse_%get_profile( "temperature", "K" ) @@ -158,15 +149,9 @@ subroutine run( this ) call assert( 412238776, all( aCrossSection < 1._dk ) ) deallocate( RaylieghCrossSection ) - write(*,*) ' ' - write(*,*) Iam // 'aCrossSection is (',size(aCrossSection,dim=1),' x ',size(aCrossSection,dim=2),')' - tstCrossSection = aCrossSection(1,1) call assert( 412238774, all( aCrossSection(:,1) == tstCrossSection ) ) - write(*,*) ' ' - write(*,*) Iam // 'Rayliegh cross section' - write(*,'(1p10g15.7)') aCrossSection(1,:) call assert( 412238775, all( aCrossSection(1,:) == aCrossSection(zGrid%ncells_,:) ) ) ! Get copy of the rayliegh radiator and test MPI functions @@ -201,23 +186,9 @@ subroutine run( this ) ! Evaluate radiator state call assert( 312238775, all( RaylieghRadiator%state_%layer_OD_ >= 0._dk ) ) - write(*,*) Iam // 'layer_OD_ is (',size(RaylieghRadiator%state_%layer_OD_,dim=1),' x ', & - size(RaylieghRadiator%state_%layer_OD_,dim=2),')' call assert( 312238776, all( RaylieghRadiator%state_%layer_SSA_ >= 0._dk ) ) - write(*,*) Iam // 'layer_SSA_ is (',size(RaylieghRadiator%state_%layer_SSA_,dim=1),' x ', & - size(RaylieghRadiator%state_%layer_SSA_,dim=2),')' call assert( 312238777, all( RaylieghRadiator%state_%layer_G_ >= 0._dk ) ) call assert( 312238778, all( RaylieghRadiator%state_%layer_SSA_ == 1._dk ) ) - write(*,*) Iam // 'layer_G_ is (',size(RaylieghRadiator%state_%layer_G_,dim=1),' x ', & - size(RaylieghRadiator%state_%layer_G_,dim=2),')' - write(*,*) ' ' - write(*,*) Iam // 'Air radiator OD @ top of model' - write(*,'(1p10g15.7)') RaylieghRadiator%state_%layer_OD_(zGrid%ncells_,:) - write(*,*) ' ' - write(*,*) Iam // 'Air radiator OD @ ground' - write(*,'(1p10g15.7)') RaylieghRadiator%state_%layer_OD_(1,:) - - write(*,*) Iam // 'Before radiator iterator test' !> Test warehouse iterator and MPI passed warehouse found = .false. @@ -244,7 +215,6 @@ subroutine run( this ) deallocate( lambdaGrid ) deallocate( AirProfile ) deallocate( TemperatureProfile ) - write(*,*) Iam // 'exiting' end subroutine run diff --git a/test/unit/test_utils.F90 b/test/unit/test_utils.F90 index c4d88bb8..7f01b4b7 100644 --- a/test/unit/test_utils.F90 +++ b/test/unit/test_utils.F90 @@ -15,8 +15,9 @@ module tuvx_test_utils subroutine check_values_1D( code, results, expected_results, & relative_tolerance ) - use musica_assert, only : assert, almost_equal + use musica_assert, only : assert, assert_msg, almost_equal use musica_constants, only : dk => musica_dk + use musica_string, only : to_char integer, intent(in) :: code real(kind=dk), intent(in) :: results(:) @@ -27,10 +28,15 @@ subroutine check_values_1D( code, results, expected_results, & call assert( code, size( results ) == size( expected_results ) ) do i_elem = 1, size( results ) - call assert( code, almost_equal( & + call assert_msg( code, almost_equal( & results( i_elem ), & expected_results( i_elem ), & - relative_tolerance)) + relative_tolerance), "Array check failed at index "// & + trim( to_char( i_elem ) )//"; expected "// & + trim( to_char( expected_results( i_elem ) ) )//" but got "// & + trim( to_char( results( i_elem ) ) )// & + " which is outside of tolerance "// & + trim( to_char( relative_tolerance ) ) ) end do end subroutine check_values_1D @@ -40,8 +46,9 @@ end subroutine check_values_1D subroutine check_values_2D( code, results, expected_results, & relative_tolerance ) - use musica_assert, only : assert, almost_equal + use musica_assert, only : assert, assert_msg, almost_equal use musica_constants, only : dk => musica_dk + use musica_string, only : to_char integer, intent(in) :: code real(kind=dk), intent(in) :: results(:,:) @@ -56,10 +63,17 @@ subroutine check_values_2D( code, results, expected_results, & size( results, dim = 2 ) == size( expected_results, dim = 2) ) do i_wavelength = 1, size( results, dim = 2 ) do i_level = 1, size( results, dim = 1 ) - call assert( code, almost_equal( & + call assert_msg( code, almost_equal( & results( i_level, i_wavelength ), & expected_results( i_level, i_wavelength ), & - relative_tolerance)) + relative_tolerance), "2D Array check failed at indices "// & + trim( to_char( i_level ) )//","// & + trim( to_char( i_wavelength ) )//"; expected "// & + trim( to_char( expected_results( i_level, i_wavelength ) ) ) & + //" but got "// & + trim( to_char( results( i_level, i_wavelength ) ) )// & + " which is outside of tolerance "// & + trim( to_char( relative_tolerance ) ) ) end do end do diff --git a/test/unit/tuv_doug/CMakeLists.txt b/test/unit/tuv_doug/CMakeLists.txt index b5d422d0..5de66475 100644 --- a/test/unit/tuv_doug/CMakeLists.txt +++ b/test/unit/tuv_doug/CMakeLists.txt @@ -20,16 +20,21 @@ target_sources(tuv_doug inter2.f inter3.f inter4.f + la_srb.f + lymana.f + rdo2xs.f + schum.f + ../test_utils.F90 ) add_subdirectory(JCALC) -target_link_libraries(tuv_doug PUBLIC musica::tuvx musica::musicacore) +target_link_libraries(tuv_doug PUBLIC musica::tuvx) ################################################################################ # Tests refactored configurations based on Doug's data sets and Fortran code -add_executable(test_data_sets data_sets.F90 ../test_utils.F90) +add_executable(test_data_sets data_sets.F90) target_link_libraries(test_data_sets PUBLIC tuv_doug) if(ENABLE_OPENMP) target_link_libraries(test_data_sets PUBLIC OpenMP::OpenMP_Fortran) @@ -37,3 +42,14 @@ endif() add_tuvx_test(data_sets test_data_sets "" ${CMAKE_BINARY_DIR}) ################################################################################ + +# Tests the Lymann-Alpha and Schumann Runge bands calculations in TUV-x against +# Doug's version used to generate the lookup tables used in CAM +add_executable(test_la_srb_lut test_la_srb.F90) +target_link_libraries(test_la_srb_lut PUBLIC tuv_doug) +if(ENABLE_OPENMP) + target_link_libraries(test_la_srb_lut PUBLIC OpenMP::OpenMP_Fortran) +endif() +add_tuvx_test(la_srb_lut test_la_srb_lut "" ${CMAKE_BINARY_DIR}) + +################################################################################ diff --git a/test/unit/tuv_doug/JCALC/CMakeLists.txt b/test/unit/tuv_doug/JCALC/CMakeLists.txt index 93fd2604..20069a21 100644 --- a/test/unit/tuv_doug/JCALC/CMakeLists.txt +++ b/test/unit/tuv_doug/JCALC/CMakeLists.txt @@ -3,9 +3,30 @@ target_sources(tuv_doug PRIVATE + XSQY_ACETONE.f + XSQY_BRO.f + XSQY_BRONO2.f + XSQY_CF2CL2.f + XSQY_CFC113.f + XSQY_CFC114.f + XSQY_CFC115.f + XSQY_CFCL3.f XSQY_CH2BR2.f + XSQY_CH3BR.f + XSQY_CH3CL.f + XSQY_CHBR3.f + XSQY_CL2O2.f + XSQY_CLO.f XSQY_H2O.f + XSQY_H1301.f + XSQY_H2402.f + XSQY_HCFC22.f + XSQY_HCFC141b.f + XSQY_HCFC142b.f + XSQY_HNO3.f + XSQY_HO2NO2.f XSQY_N2O5.f + XSQY_SO2.f ) ################################################################################ diff --git a/test/unit/tuv_doug/JCALC/XSQY_ACETONE.f b/test/unit/tuv_doug/JCALC/XSQY_ACETONE.f new file mode 100644 index 00000000..f5dd4d1f --- /dev/null +++ b/test/unit/tuv_doug/JCALC/XSQY_ACETONE.f @@ -0,0 +1,274 @@ + SUBROUTINE XSQY_ACETONE(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,pn) +!---------------------------------------------------------------------------! +! PURPOSE: ! +! Provide product (cross section) x (quantum yield) for CH3COCH3 photolysis! +! CH3COCH3 + hv -> Products ! +! ! +! Cross section: Choice between ! +! (1) Calvert and Pitts ! +! (2) Martinez et al., 1991, alson in IUPAC 97 ! +! (3) NOAA, 1998, unpublished as of 01/98 ! +! Quantum yield: Choice between ! +! (1) Gardiner et al, 1984 ! +! (2) IUPAC 97 ! +! (3) McKeen et al., 1997 ! +!---------------------------------------------------------------------------! +! PARAMETERS: ! +! NW - INTEGER, number of specified intervals + 1 in working (I)! +! wavelength grid ! +! WL - REAL, vector of lower limits of wavelength intervals in (I)! +! working wavelength grid ! +! WC - REAL, vector of center points of wavelength intervals in (I)! +! working wavelength grid ! +! NZ - INTEGER, number of altitude levels in working altitude grid (I)! +! TLEV - REAL, temperature (K) at each specified altitude level (I)! +! AIRDEN - REAL, air density (molec/cc) at each altitude level (I)! +! J - INTEGER, counter for number of weighting functions defined (IO)! +! SQ - REAL, cross section x quantum yield (cm^2) for each (O)! +! photolysis reaction defined, at each defined wavelength and ! +! at each defined altitude level ! +! JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)! +! defined ! +!---------------------------------------------------------------------------! + IMPLICIT NONE + INCLUDE 'params' + +!---------------------------------------------------------------------------! +! ... input ! +!---------------------------------------------------------------------------! + real, intent(in) :: wl(kw) + real, intent(in) :: wc(kw) + real, intent(in) :: tlev(kz) + real, intent(in) :: airden(kz) + + integer, intent(in) :: nz + integer, intent(in) :: nw + + character*80, intent(in) :: pn + character*60, intent(out) :: jlabel(kj) + real, intent(out) :: sq(kj,kz,kw) + +!-----------------------------------------------------------------------------! +! ... input/output ! +!-----------------------------------------------------------------------------! + integer, intent(inout) :: j + +!-----------------------------------------------------------------------------! +! ... local ! +!-----------------------------------------------------------------------------! + integer kdata + parameter (kdata=150) + + integer i, n, n1, n2, n3, iw, ierr, iz, idum + real x1(kdata), x2(kdata), A(kdata), B(kdata), C(kdata) + real y1(kdata), y2(kdata), y3(kdata) + real xs(nz,kdata), sig(nz,kw) + real yg(kw), yg1(kw), yg2(kw), yg3(kw) + real tin(nz), AD(nz) + real qytot(kw), qyCO(kw), qyCH3CO(kw) + real AA0, a0, b0 + real AA1, a1, b1, t, qy + real AA2, AA3, AA4, a2, b2, a3, b3, c3, a4, b4 + + !!! TUV-x MOD - initializing qyCO, qyCH3CO !!! + qyCO(:) = 0.0 + qyCH3CO(:) = 0.0 + !!! end TUV-x mod !!! + +!--------------------------------------------- +! ... tin set to tlev +!--------------------------------------------- + tin(:) = tlev(:) + AD (:) = airden(:) + +!--------------------------------------------- +! ... CH3COCH3 photodissociation +!--------------------------------------------- + j = j + 1 + jlabel(j) = 'CH3COCH3 + hv -> CH3CO3 + CH3O2' + +!--------------------------------------------- +! ... cross sections JPL06 +!--------------------------------------------- + open(kin,file=TRIM(pn)//'XS_ACETONE_JPL06.txt',status='old') + + read(kin,*) idum, n + do i = 1, idum-2 + read(kin,*) + enddo + + do i = 1, n + read(kin,*) x1(i), y1(i) +! print*, x1(i), y1(i) + enddo + close(kin) + +!--------------------------------------------- +! ... cross sections TD coeff JPL06 +!--------------------------------------------- + open(kin,file=TRIM(pn)//'XS_ACETONE_TD_JPL06.txt',status='old') + + read(kin,*) idum, n1 + do i = 1, idum-2 + read(kin,*) + enddo + + do i = 1, n1 + read(kin,*) x1(i), A(i), B(i), C(i) + A(i) = A(i)*1e-3 + B(i) = B(i)*1e-5 + C(i) = C(i)*1e-8 +! print*, x1(i), y1(i), A(i), B(i), C(i) + enddo + close(kin) +! stop +!--------------------------------------------- +! ... Derive XS at given temperature +!--------------------------------------------- + + do iz = 1, nz + + do iw = 1, n1 + + if ((tin(iz) .GE. 235.) .AND. (tin(iz) .LE. 298.)) Then + xs(iz,iw) = y1(iw) *( 1 + (A(iw)*tin(iz)) + + & (B(iw)*tin(iz)**2) + + & (C(iw)*tin(iz)**3) ) + + endif + + if (tin(iz) .LT. 235.) then + xs(iz,iw) = y1(iw) *( 1 + (A(iw)*235.) + + & (B(iw)*(235.)**2) + + & (C(iw)*(235.)**3) ) + + endif + + if (tin(iz) .GT. 298.) then + xs(iz,iw) = y1(iw) *( 1 + (A(iw)*298.) + + & (B(iw)*(298.)**2) + + & (C(iw)*(298.)**3) ) + + endif + + enddo + + n = n1 + x2(:) = x1(:) + y2(:) = xs(iz,:) + +!--------------------------------------------- +! ... Interpolate +!--------------------------------------------- + call addpnt(x2,y2,kdata,n,x2(1)*(1.-deltax),0.) + call addpnt(x2,y2,kdata,n, 0.,0.) + call addpnt(x2,y2,kdata,n,x2(n)*(1.+deltax),0.) + call addpnt(x2,y2,kdata,n, 1e38,0.) + call inter2(nw,wl,yg, n,x2, y2,ierr) + + sig(iz,:) = yg(:) + + if (ierr .ne. 0) then + write(*,*) ierr, jlabel(j) + stop + endif + + enddo + +!--------------------------------------------- +! ... Check Routine +! iz = 10 +! print*, 'tin=', tin(iz) +! do iw = 40, 80 +! print*, iw, wc(iw), sig(iz,iw) +! enddo +! stop +!--------------------------------------------- +!--------------------------------------------- +! ... quantum yield JPL06 +!--------------------------------------------- + DO iz = 1, nz + + T = min(tin(iz), 295.) + T = max(T, 218.) + + DO iw = 1, nw-1 + + IF ((wc(iw) .GE. 279.).AND.(wc(iw) .LT. 327.) ) THEN + + a0 = 0.350* (T/295.)**(-1.28) + b0 = 0.068* (T/295.)**(-2.65) + AA0 = (a0 / (1-a0))* exp(b0*(wc(iw)-248.)) + qyCO(iw) = 1. / (1. + AA0) + ! print*, 'qyCO', qyCO(iw) + + ENDIF + + IF ((wc(iw) .GE. 279.).AND.(wc(iw) .LT. 302.)) THEN + + a1 = 1.6e-19* (T/295.)**(-2.38) + b1 = 0.55e-3* (T/295.)**(-3.19) + AA1 = a1* exp(-b1*((1e7/wc(iw)) - 33113.)) + qyCH3CO(iw) = (1-qyCO(iw)) / (1 + AA1*AD(iz)) + + ! print*, 'qyCO', qyCO(iw), 'qyCH3CO', qyCH3CO(iw) + + ELSEIF ((wc(iw) .GE. 302.).AND.(wc(iw) .LE. 327.5)) THEN + + a2= 1.62e-17* (T/295.)**(-10.03) + b2= 1.79e-3 * (T/295.)**(-1.364) + AA2= a2* exp(-b2*((1e7/wc(iw))-30488.)) + + a3= 26.29* (T/295.)**(-6.59) + b3= 5.72e-7* (T/295.)**(-2.93) + c3= 30006.* (T/295.)**(-0.064) + AA3= a3* exp(-b3*((1e7/wc(iw))-c3)**2) + + a4= 1.67e-15* (T/295.)**(-7.25) + b4= 2.08e-3* (T/295.)**(-1.16) + AA4= a4* exp(-b4*((1e7/wc(iw)) - 30488.)) + + qyCH3CO(iw) = ((1 + AA4*AD(iz) + AA3) / + & ((1 + AA2*AD(iz) + AA3)* + & (1 + AA4*AD(iz))))*(1-qyCO(iw)) + +! print*, 'qyCH3CO', qyCH3CO(iw) + + ELSEIF (wc(iw) .GT. 327.5) THEN + qytot(iw) = 0. + ENDIF + + qytot(iw) = qyCO(iw) + qyCH3CO(iw) + + if (wc(iw) .LT. 279.) then + qytot(iw) = 1.0 + endif + + qytot(iw) = max(0., qytot(iw)) + qytot(iw) = min(1., qytot(iw)) + + + sq(j,iz,iw) = sig(iz,iw)*qytot(iw) + + ENDDO + ENDDO +!--------------------------------------------- +! ... Check Routine +! iz = 10 +! print*, 'tin=', tin(iz) +! do iw = 40, 80 +! print*, iw, wc(iw), sig(iz,iw), qytot(iw) +! print*, iw, wc(iw), sq(j,iz,iw) +! enddo +! stop +!--------------------------------------------- +! c210417 there are issues with Actone being less than zero. +! do iz = 1, nz-1 +! do iw = 1, nw-1 +! IF (sq(j,iz,iw) .LE. 0.0) THEN +! sq(j,iz,iw) = 0.0 +! ENDIF +! ENDDO +! ENDDO + + end subroutine XSQY_ACETONE diff --git a/test/unit/tuv_doug/JCALC/XSQY_BRO.f b/test/unit/tuv_doug/JCALC/XSQY_BRO.f new file mode 100644 index 00000000..df054c6e --- /dev/null +++ b/test/unit/tuv_doug/JCALC/XSQY_BRO.f @@ -0,0 +1,116 @@ + subroutine XSQY_BRO(nw,wl,wc,nz,tlev,airlev,j,sq,jlabel,pn) +!-----------------------------------------------------------------------------! +! purpose: ! +! provide product (cross section) x (quantum yield): ! +! BrO + hv -> Br + O ! +! cross section: JPL06 ! +! quantum yield: is unity. ! +!-----------------------------------------------------------------------------! +! parameters: ! +! nw - integer, number of specified intervals + 1 in working (i) ! +! wavelength grid ! +! wl - real, vector of lower limits of wavelength intervals in (i) ! +! working wavelength grid ! +! wc - real, vector of center points of wavelength intervals in (i) ! +! working wavelength grid ! +! nz - integer, number of altitude levels in working altitude grid (i) ! +! tlev - real, temperature (k) at each specified altitude level (i) ! +! airlev - real, air density (molec/cc) at each altitude level (i) ! +! j - integer, counter for number of weighting functions defined (io) ! +! sq - real, cross section x quantum yield (cm^2) for each (o) ! +! photolysis reaction defined, at each defined wavelength and ! +! at each defined altitude level ! +! jlabel - character*60, string identifier for each photolysis reaction (o) ! +! defined ! +!-----------------------------------------------------------------------------! +! edit history: ! +! 07/27/07 Doug Kinnison ! +!-----------------------------------------------------------------------------! + implicit none + include 'params' + +!-----------------------------------------------------------------------------! +! ... input ! +!-----------------------------------------------------------------------------! + real, intent(in) :: wl(kw) + real, intent(in) :: wc(kw) + real, intent(in) :: tlev(kz) + real, intent(in) :: airlev(kz) + + integer, intent(in) :: nz + integer, intent(in) :: nw + + character*80, intent(in) :: pn + character*60, intent(out) :: jlabel(kj) + real, intent(out) :: sq(kj,kz,kw) + +!-----------------------------------------------------------------------------! +! ... input/output ! +!-----------------------------------------------------------------------------! + integer, intent(inout) :: j + +!-----------------------------------------------------------------------------! +! ... local ! +!-----------------------------------------------------------------------------! + integer kdata + parameter(kdata=300) + integer i, iw, n, idum, ierr, iz + real x1(kdata) + real y1(kdata) + real yg(kw) + real qy + +!---------------------------------------------- +! ... jlabel(j) = 'BRO + hv -> Br + O' +!---------------------------------------------- + j = j+1 + jlabel(j) = 'BRO + hv -> Br + O' + +!---------------------------------------------------- +! ... cross sections from JPL06 recommendation +!---------------------------------------------------- +! ... 0.5nm resolution JPL06. + open(kin,file=TRIM(pn)//'XS_BRO_JPL06.txt',status='old') + + read(kin,*) idum, n + do i = 1, idum-2 + read(kin,*) + enddo + + do i = 1, n + read(kin,*) x1(i), y1(i) + enddo + close(kin) + + call addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.) + call addpnt(x1,y1,kdata,n, 0.,0.) + call addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.) + call addpnt(x1,y1,kdata,n, 1e38,0.) + call inter2(nw,wl,yg, n,x1, y1,ierr) + + if (ierr .ne. 0) then + write(*,*) ierr, jlabel(j) + stop + endif + +!------------------------------------------------------- +! ... quantum yield (assumed) to be unity (JPL06) +!------------------------------------------------------- + qy = 1.0 + + do iw = 1, nw-1 + do iz = 1, nz + sq(j,iz,iw) = qy * yg(iw) + + enddo + enddo + +!------------------------------------------------------- +! ... Check Routine +! do iw = 61, 87 +! print*, iw, wc(iw), (qy * yg(iw)) +! enddo +! stop +!------------------------------------------------------- + + end subroutine XSQY_BRO diff --git a/test/unit/tuv_doug/JCALC/XSQY_BRONO2.f b/test/unit/tuv_doug/JCALC/XSQY_BRONO2.f new file mode 100644 index 00000000..5083671a --- /dev/null +++ b/test/unit/tuv_doug/JCALC/XSQY_BRONO2.f @@ -0,0 +1,176 @@ + subroutine XSQY_BRONO2(nw,wl,wc,nz,tlev,airlev,j,sq,jlabel,pn) +!-----------------------------------------------------------------------------! +! purpose: ! +! provide product (cross section) x (quantum yield) for brono2 photolysis: ! +! BrONO2 + hv -> products ! +! ! +! cross section: jpl 06 recommendation ! +! quantum yield: jpl 06 recommendation ! +!-----------------------------------------------------------------------------! +! parameters: ! +! nw - integer, number of specified intervals + 1 in working (i) ! +! wavelength grid ! +! wl - real, vector of lower limits of wavelength intervals in (i) ! +! working wavelength grid ! +! wc - real, vector of center points of wavelength intervals in (i) ! +! working wavelength grid ! +! nz - integer, number of altitude levels in working altitude grid (i) ! +! tlev - real, temperature (k) at each specified altitude level (i) ! +! airlev - real, air density (molec/cc) at each altitude level (i) ! +! j - integer, counter for number of weighting functions defined (io) ! +! sq - real, cross section x quantum yield (cm^2) for each (o) ! +! photolysis reaction defined, at each defined wavelength and ! +! at each defined altitude level ! +! jlabel - character*60, string identifier for each photolysis reaction (o) ! +! defined ! +!-----------------------------------------------------------------------------! +! edit history: ! +! 07/27/07: Doug Kinnison ! +!-----------------------------------------------------------------------------! + implicit none + include 'params' + +!-----------------------------------------------------------------------------! +! ... input ! +!-----------------------------------------------------------------------------! + real, intent(in) :: wl(kw) + real, intent(in) :: wc(kw) + real, intent(in) :: tlev(kz) + real, intent(in) :: airlev(kz) + + integer, intent(in) :: nz + integer, intent(in) :: nw + + character*80, intent(in) :: pn + character*60, intent(out) :: jlabel(kj) + + real, intent(out) :: sq(kj,kz,kw) + +!-----------------------------------------------------------------------------! +! ... input/output ! +!-----------------------------------------------------------------------------! + integer, intent(inout) :: j + +!-----------------------------------------------------------------------------! +! ... local ! +!-----------------------------------------------------------------------------! + integer kdata + parameter(kdata=200) + integer i, iw, n, n1, idum, ierr, iz + real x1 (kdata), y1(kdata) + real xin (kdata) + real a1 (kdata), a2(kdata) + real ytmp(nz,kdata) + real ytd (nz,kw) + real yg1 (kw) + real tin (nz) + real qy1 + real qy2 +!----------------------------------------------- +! ... tin set to tlev +!----------------------------------------------- + tin(:) = tlev(:) + +!----------------------------------------------- +! ... jlabel(j) = 'BrONO2 + hv -> Br + NO3' +! ... jlabel(j) = 'BrONO2 + hv -> BrO + NO2' +!----------------------------------------------- + j = j+1 + jlabel(j) = 'BrONO2 + hv -> Br + NO3' + +!----------------------------------------------- +! ... cross sections from JPL06 +!----------------------------------------------- + open(kin, + & file=TRIM(pn)//'XS_BRONO2_JPL06.txt',status='old') + + read(kin,*) idum, n + do i = 1, idum-2 + read(kin,*) + enddo + + do iw = 1, n + read(kin,*) xin(iw), y1(iw) + enddo + close(kin) + +!----------------------------------------------- +! ... Read in temperature dep coeff +!----------------------------------------------- + open(kin, + & file=TRIM(pn)//'XS_BRONO2_td_JPL06.txt',status='old') + + read(kin,*) idum, n + do i = 1, idum-2 + read(kin,*) + enddo + + do iw = 1, n + read(kin,*) xin(iw), a1(iw), a2(iw) + enddo + close(kin) + +!----------------------------------------------- +! ... derive T-dep (200-296K) +!----------------------------------------------- + do iz = 1, nz + do iw = 1 , n + if ((tin(iz) .GE. 200.) .AND. (tin(iz) .LE. 296.)) Then + ytmp(iz,iw) = y1(iw) * + & ( 1. + + & A1(iw)* (tin(iz)-296.) + + & A2(iw)*((tin(iz)-296.)**2) + & ) + endif + if (tin(iz) .LT. 200.) then + ytmp(iz,iw) = y1(iw) * + & ( 1. + + & A1(iw)* (200.-296.) + + & A2(iw)*((200.-296.)**2) + & ) + endif + if (tin(iz) .GT. 296.) then + ytmp(iz,iw) = y1(iw) + endif + enddo + enddo + +!----------------------------------------------- +! ... Interpolate +!----------------------------------------------- + do iz = 1, nz + n1 = n + y1 = ytmp(iz,:) + x1 = xin + + call addpnt(x1,y1,kdata,n1,x1(1)*(1.-deltax),0.) + call addpnt(x1,y1,kdata,n1, 0.,0.) + call addpnt(x1,y1,kdata,n1,x1(n1)*(1.+deltax),0.) + call addpnt(x1,y1,kdata,n1, 1e38,0.) + call inter2(nw,wl,yg1,n1,x1,y1,ierr) + ytd(iz,:) = yg1(:) + + if (ierr .ne. 0) then + write(*,*) ierr, jlabel(j) + stop + endif + enddo + +!---------------------------------------------- +! ...Quantum yields JPL06 +! ...This recommendation is only for >300nm +! However, it is used at all wavelengths +!---------------------------------------------- + qy1 = 0.85 + qy2 = 0.15 + do iw = 1, nw-1 + do iz = 1, nz + sq(j,iz,iw) = qy1 * ytd(iz,iw) + sq(j+1,iz,iw) = qy2 * ytd(iz,iw) + enddo + enddo + + j = j+1 + jlabel(j) = 'BrONO2 + hv -> BrO + NO2' + + end subroutine XSQY_BRONO2 diff --git a/test/unit/tuv_doug/JCALC/XSQY_CF2CL2.f b/test/unit/tuv_doug/JCALC/XSQY_CF2CL2.f new file mode 100644 index 00000000..c9fab686 --- /dev/null +++ b/test/unit/tuv_doug/JCALC/XSQY_CF2CL2.f @@ -0,0 +1,234 @@ + subroutine XSQY_CF2CL2(nw,wl,wc,nz,tlev,airlev,j,sq,jlabel,pn) +!-----------------------------------------------------------------------------! +! purpose: ! +! provide product (cross section) x (quantum yield) for cf2cl2 photolysis: ! +! CF2Cl2 + hv -> 2Cl ! +! cross section: from JPL06 recommendation ! +! quantum yield: assumed to be unity ! +!-----------------------------------------------------------------------------! +! parameters: ! +! nw - integer, number of specified intervals + 1 in working (i) ! +! wavelength grid ! +! wl - real, vector of lower limits of wavelength intervals in (i) ! +! working wavelength grid ! +! wc - real, vector of center points of wavelength intervals in (i) ! +! working wavelength grid ! +! nz - integer, number of altitude levels in working altitude grid (i) ! +! tlev - real, temperature (k) at each specified altitude level (i) ! +! airlev - real, air density (molec/cc) at each altitude level (i) ! +! j - integer, counter for number of weighting functions defined (io) ! +! sq - real, cross section x quantum yield (cm^2) for each (o) ! +! photolysis reaction defined, at each defined wavelength and ! +! at each defined altitude level ! +! jlabel - character*60, string identifier for each photolysis reaction (o) ! +! defined ! +!-----------------------------------------------------------------------------! +! edit history: ! +! 01/16/08 Doug Kinnison ! +!-----------------------------------------------------------------------------! + implicit none + include 'params' + +!-----------------------------------------------------------------------------! +! ... input ! +!-----------------------------------------------------------------------------! + real, intent(in) :: wl(kw) + real, intent(in) :: wc(kw) + real, intent(in) :: tlev(kz) + real, intent(in) :: airlev(kz) + + integer, intent(in) :: nz + integer, intent(in) :: nw + + character*80, intent(in) :: pn + character*60, intent(out) :: jlabel(kj) + real, intent(out) :: sq(kj,kz,kw) + +!-----------------------------------------------------------------------------! +! ... input/output ! +!-----------------------------------------------------------------------------! + integer, intent(inout) :: j + +!-----------------------------------------------------------------------------! +! ... local ! +!-----------------------------------------------------------------------------! + integer kdata + parameter(kdata=300) + integer i, iw, n, idum, nloop, n1 + integer ierr, iz, iwc, icnt + real x1 (kdata), y1 (kdata) + real xin (kdata), yin (kdata) + real wctmp(kdata), wcb (kdata) + real ytmp (nz,kdata), ycomb(nz,kdata) + real yg1(kw), tin (nz) + real ytd (nz,kw) + real AA(5), BB(5), lp(5) + real qy, ysave + + + AA(1) = -43.8954569 + AA(2) = -2.403597e-1 + AA(3) = -4.2619e-4 + AA(4) = 9.8743e-6 + + BB(1) = 4.8438e-3 + BB(2) = 4.96145e-4 + BB(3) = -5.6953e-6 + + lp(1) = 0.0 + lp(2) = 1.0 + lp(3) = 2.0 + lp(4) = 3.0 + lp(5) = 4.0 + +!--------------------------------------------------- +! ... tin set to tlev +!--------------------------------------------------- + tin(:) = tlev(:) + +!--------------------------------------------------- +! ... jlabel(j) = 'CF2Cl2 + hv -> 2Cl' +!--------------------------------------------------- + j = j+1 + jlabel(j) = 'CF2Cl2 + hv -> 2Cl' + +!--------------------------------------------------- +! Derive temperature dependence +!--------------------------------------------------- +! Temperature dependence good between +! 220-296K and 200 nm-231 nm +!--------------------------------------------------- + iwc = 1 + ytmp(:,:)= 0.0 + + do iw = 1, nw-1 + + IF ((wc(iw) .GE. 200.) .AND. (wc(iw) .LE.231.)) THEN + + do iz = 1, nz + + IF (tin(iz) .LT. 220.) THEN + do nloop = 1, 4 + ytmp(iz,iwc) = ytmp(iz,iwc) + & + AA(nloop)* (wc(iw)-200.)**lp(nloop) + enddo + do nloop = 1, 3 + ytmp(iz,iwc) = ytmp(iz,iwc) + & + (220.-296.)* BB(nloop)*(wc(iw)-200.)**lp(nloop) + enddo + wctmp(iwc) = wc(iw) + ENDIF + + IF ((tin(iz) .GE. 220.).AND.(tin(iz) .LE. 296.)) THEN + do nloop = 1, 4 + ytmp(iz,iwc) = ytmp(iz,iwc) + & + AA(nloop)* (wc(iw)-200.)**lp(nloop) + enddo + do nloop = 1, 3 + ytmp(iz,iwc) = ytmp(iz,iwc) + & + (tin(iz)-296.)* BB(nloop)*(wc(iw)-200.)**lp(nloop) + enddo + wctmp(iwc) = wc(iw) + ENDIF + + IF (tin(iz) .GT. 296.) THEN + do nloop = 1, 4 + ytmp(iz,iwc) = ytmp(iz,iwc) + & + AA(nloop)* (wc(iw)-200.)**lp(nloop) + enddo + wctmp(iwc) = wc(iw) + ENDIF + + enddo + iwc = iwc+ 1 + + ENDIF + + enddo +!--------------------------------------------------- +! ... For wavelengths >232 nm and <200 nm +!--------------------------------------------------- + open(kin,file=TRIM(pn)//'XS_CF2CL2_JPL06.txt',status='old') + + read(kin,*) idum, n + do i = 1, idum-2 + read(kin,*) + enddo + + do i = 1, n + read(kin,*) xin(i), yin(i) + enddo + + close(kin) +!--------------------------------------------------- +! ... Combine cross sections +!--------------------------------------------------- + do iz = 1, nz + icnt = 1 + +! ... < 200nm + do i = 1, n + IF (xin(i) .LT. 200.) THEN + ycomb(iz,icnt) = yin(i) + wcb (icnt) = xin(i) + icnt = icnt + 1 + ENDIF + enddo +! ... 200-231 nm + do i = 1, iwc-1 + ycomb(iz,icnt) = exp(ytmp(iz,i)) + wcb (icnt) = wctmp(i) + icnt = icnt+1 + enddo +! ... >231nm + do i = 1, n + IF (xin(i) .GT. 231.) THEN + ycomb(iz,icnt) = yin(i) + wcb (icnt) = xin(i) + icnt = icnt+1 + ENDIF + enddo + enddo +!--------------------------------------------------- +! ... interpolate +!--------------------------------------------------- + do iz = 1, nz + n1 = icnt-1 + y1 = ycomb(iz,:) + x1 = wcb +!--------------------------------------------------- +! do iw = 1, icnt-1 +! print*, iw, wcb(iw), ycomb(iz,iw), tin(iz) +! enddo +! stop +!--------------------------------------------------- + call addpnt(x1,y1,kdata,n1,x1(1)*(1.-deltax),0.) + call addpnt(x1,y1,kdata,n1, 0.,0.) + call addpnt(x1,y1,kdata,n1,x1(n1)*(1.+deltax),0.) + call addpnt(x1,y1,kdata,n1, 1e38,0.) + call inter2(nw,wl,yg1,n1,x1,y1,ierr) + ytd(iz,:) = yg1(:) + + if (ierr .ne. 0) then + write(*,*) ierr, jlabel(j) + stop + endif + enddo +!-------------------------------------------------- +! iz = 1 +! do iw = 19, 64 +! print*, iw, wc(iw), ytd(iz,iw), tin(iz) +! enddo +! stop +!-------------------------------------------------- +!-------------------------------------------------- +! ...quantum yield assumed to be unity +!-------------------------------------------------- + qy = 1. + do iw = 1, nw-1 + do iz = 1, nz + sq(j,iz,iw) = qy * ytd(iz,iw) + enddo + enddo + + end subroutine XSQY_CF2CL2 diff --git a/test/unit/tuv_doug/JCALC/XSQY_CFC113.f b/test/unit/tuv_doug/JCALC/XSQY_CFC113.f new file mode 100644 index 00000000..8a3e4ac1 --- /dev/null +++ b/test/unit/tuv_doug/JCALC/XSQY_CFC113.f @@ -0,0 +1,233 @@ + subroutine XSQY_CFC113(nw,wl,wc,nz,tlev,airlev,j,sq,jlabel,pn) +!-----------------------------------------------------------------------------! +! purpose: ! +! provide product (cross section) x (quantum yield) for cfc113 photolysis: ! +! CFC113 + hv -> 3Cl ! +! cross section: from JPL06 recommendation ! +! quantum yield: assumed to be unity ! +!-----------------------------------------------------------------------------! +! parameters: ! +! nw - integer, number of specified intervals + 1 in working (i) ! +! wavelength grid ! +! wl - real, vector of lower limits of wavelength intervals in (i) ! +! working wavelength grid ! +! wc - real, vector of center points of wavelength intervals in (i) ! +! working wavelength grid ! +! nz - integer, number of altitude levels in working altitude grid (i) ! +! tlev - real, temperature (k) at each specified altitude level (i) ! +! airlev - real, air density (molec/cc) at each altitude level (i) ! +! j - integer, counter for number of weighting functions defined (io) ! +! sq - real, cross section x quantum yield (cm^2) for each (o) ! +! photolysis reaction defined, at each defined wavelength and ! +! at each defined altitude level ! +! jlabel - character*60, string identifier for each photolysis reaction (o) ! +! defined ! +!-----------------------------------------------------------------------------! +! edit history: ! +! 07/30/07 Doug Kinnison ! +!-----------------------------------------------------------------------------! + implicit none + include 'params' + +!-----------------------------------------------------------------------------! +! ... input ! +!-----------------------------------------------------------------------------! + real, intent(in) :: wl(kw) + real, intent(in) :: wc(kw) + real, intent(in) :: tlev(kz) + real, intent(in) :: airlev(kz) + + integer, intent(in) :: nz + integer, intent(in) :: nw + + character*80, intent(in) :: pn + character*60, intent(out) :: jlabel(kj) + real, intent(out) :: sq(kj,kz,kw) + +!-----------------------------------------------------------------------------! +! ... input/output ! +!-----------------------------------------------------------------------------! + integer, intent(inout) :: j + +!-----------------------------------------------------------------------------! +! ... local ! +!-----------------------------------------------------------------------------! + integer kdata + parameter(kdata=300) + integer i, iw, n, idum, nloop, n1 + integer ierr, iz, iwc, icnt + real x1 (kdata), y1 (kdata) + real xin (kdata), yin (kdata) + real wctmp(kdata), wcb (kdata) + real ytmp (nz,kdata), ycomb(nz,kdata) + real yg1(kw), tin (nz) + real ytd (nz,kw) + real AA(5), BB(5), lp(5) + real qy, ysave + + AA(1) = -1087.9 + AA(2) = 20.004 + AA(3) = -1.3920e-1 + AA(4) = 4.2828e-4 + AA(5) = -4.9384e-7 + + BB(1) = 12.493 + BB(2) = -2.3937e-1 + BB(3) = 1.7142e-3 + BB(4) = -5.4393e-6 + BB(5) = 6.4548e-9 + + lp(1) = 0.0 + lp(2) = 1.0 + lp(3) = 2.0 + lp(4) = 3.0 + lp(5) = 4.0 + +!--------------------------------------------------- +! ... tin set to tlev +!--------------------------------------------------- + tin(:) = tlev(:) + +!--------------------------------------------------- +! ... jlabel(j) = 'cfc113 -> 3cl' +!--------------------------------------------------- + j = j+1 + jlabel(j) = 'CFC113 + hv -> 3Cl' + +!--------------------------------------------------- +! Derive temperature dependence +!--------------------------------------------------- +! Temperature dependence good between +! 210-300K and 182 nm-230 nm +!--------------------------------------------------- + iwc = 1 + ytmp(:,:)= 0.0 + + do iw = 1, nw-1 + + IF ((wc(iw) .GE. 182.) .AND. (wc(iw) .LE.230.)) THEN + + do iz = 1, nz + + IF (tin(iz) .LT. 210.) THEN + do nloop = 1, 5 + ytmp(iz,iwc) = ytmp(iz,iwc) + & + AA(nloop)* (wc(iw)**lp(nloop)) + & + (210.0-273.0)*BB(nloop)*wc(iw)**lp(nloop) + enddo + wctmp(iwc) = wc(iw) + ENDIF + + IF ((tin(iz) .GE. 210.).AND.(tin(iz) .LE. 300.)) THEN + do nloop = 1,5 + + ytmp(iz,iwc) = ytmp(iz,iwc) + & + AA(nloop)* (wc(iw)**lp(nloop)) + & + (tin(iz)-273.0)*BB(nloop)*wc(iw)**lp(nloop) + enddo + wctmp(iwc) = wc(iw) + ENDIF + + IF (tin(iz) .GT. 300.) THEN + do nloop = 1, 5 + ytmp(iz,iwc) = ytmp(iz,iwc) + & + AA(nloop)* (wc(iw)**lp(nloop)) + & + (300.0-273.0)*BB(nloop)*wc(iw)**lp(nloop) + enddo + wctmp(iwc) = wc(iw) + ENDIF + enddo + iwc = iwc+ 1 + + ENDIF + + enddo +!--------------------------------------------------- +! ... For wavelengths >230nm and <182 nm +!--------------------------------------------------- + open(kin,file=TRIM(pn)//'XS_CFC113_JPL06.txt',status='old') + + read(kin,*) idum, n + do i = 1, idum-2 + read(kin,*) + enddo + + do i = 1, n + read(kin,*) xin(i), yin(i) + enddo + close(kin) + +!--------------------------------------------------- +! ... Combine cross sections +!--------------------------------------------------- + do iz = 1, nz + icnt = 1 + +! ... < 182nm + do i = 1, n + IF (xin(i) .LT. 182.) THEN + ycomb(iz,icnt) = yin(i) + wcb (icnt) = xin(i) + icnt = icnt + 1 + ENDIF + enddo +! ... 182-230 nm + do i = 1, iwc-1 + ycomb(iz,icnt) = 10**(ytmp(iz,i)) + wcb (icnt) = wctmp(i) + icnt = icnt+1 + enddo +! ... >230nm + do i = 1, n + IF (xin(i) .GT. 230.) THEN + ycomb(iz,icnt) = yin(i) + wcb (icnt) = xin(i) + icnt = icnt+1 + ENDIF + enddo + enddo +!--------------------------------------------------- +! ... interpolate +!--------------------------------------------------- + do iz = 1, nz + n1 = icnt-1 + y1 = ycomb(iz,:) + x1 = wcb +!--------------------------------------------------- +! iz = 1 +! do iw = 1, icnt-1 +! print*, iw, wcb(iw), ycomb(iz,iw), tin(iz) +! enddo +! stop +!--------------------------------------------------- + call addpnt(x1,y1,kdata,n1,x1(1)*(1.-deltax),0.) + call addpnt(x1,y1,kdata,n1, 0.,0.) + call addpnt(x1,y1,kdata,n1,x1(n1)*(1.+deltax),0.) + call addpnt(x1,y1,kdata,n1, 1e38,0.) + call inter2(nw,wl,yg1,n1,x1,y1,ierr) + ytd(iz,:) = yg1(:) + + if (ierr .ne. 0) then + write(*,*) ierr, jlabel(j) + stop + endif + enddo + +!---------------------------------------------------- +! iz = 1 +! do iw = 19, 64 +! print*, iw, wc(iw), ytd(iz,iw), tin(iz) +! enddo +! stop +!---------------------------------------------------- +!---------------------------------------------------- +! ...quantum yield assumed to be unity +!---------------------------------------------------- + qy = 1. + do iw = 1, nw-1 + do iz = 1, nz + sq(j,iz,iw) = qy * ytd(iz,iw) + enddo + enddo + + end subroutine XSQY_CFC113 diff --git a/test/unit/tuv_doug/JCALC/XSQY_CFC114.f b/test/unit/tuv_doug/JCALC/XSQY_CFC114.f new file mode 100644 index 00000000..d51129ec --- /dev/null +++ b/test/unit/tuv_doug/JCALC/XSQY_CFC114.f @@ -0,0 +1,224 @@ + subroutine XSQY_CFC114(nw,wl,wc,nz,tlev,airlev,j,sq,jlabel,pn) +!-----------------------------------------------------------------------------! +! purpose: ! +! provide product (cross section) x (quantum yield) for cfc113 photolysis: ! +! CFC114 + hv -> 2Cl ! +! cross section: from JPL06 recommendation ! +! quantum yield: assumed to be unity ! +!-----------------------------------------------------------------------------! +! parameters: ! +! nw - integer, number of specified intervals + 1 in working (i) ! +! wavelength grid ! +! wl - real, vector of lower limits of wavelength intervals in (i) ! +! working wavelength grid ! +! wc - real, vector of center points of wavelength intervals in (i) ! +! working wavelength grid ! +! nz - integer, number of altitude levels in working altitude grid (i) ! +! tlev - real, temperature (k) at each specified altitude level (i) ! +! airlev - real, air density (molec/cc) at each altitude level (i) ! +! j - integer, counter for number of weighting functions defined (io) ! +! sq - real, cross section x quantum yield (cm^2) for each (o) ! +! photolysis reaction defined, at each defined wavelength and ! +! at each defined altitude level ! +! jlabel - character*60, string identifier for each photolysis reaction (o) ! +! defined ! +!-----------------------------------------------------------------------------! +! edit history: ! +! 01/06/12 Doug Kinnison ! +!-----------------------------------------------------------------------------! + implicit none + include 'params' + +!-----------------------------------------------------------------------------! +! ... input ! +!-----------------------------------------------------------------------------! + real, intent(in) :: wl(kw) + real, intent(in) :: wc(kw) + real, intent(in) :: tlev(kz) + real, intent(in) :: airlev(kz) + + integer, intent(in) :: nz + integer, intent(in) :: nw + + character*80, intent(in) :: pn + character*60, intent(out) :: jlabel(kj) + real, intent(out) :: sq(kj,kz,kw) + +!-----------------------------------------------------------------------------! +! ... input/output ! +!-----------------------------------------------------------------------------! + integer, intent(inout) :: j + +!-----------------------------------------------------------------------------! +! ... local ! +!-----------------------------------------------------------------------------! + integer kdata + parameter(kdata=300) + integer i, iw, n, idum, nloop, n1 + integer ierr, iz, iwc, icnt + real x1 (kdata), y1 (kdata) + real xin (kdata), yin (kdata) + real wctmp(kdata), wcb (kdata) + real ytmp (nz,kdata), ycomb(nz,kdata) + real yg1(kw), tin (nz) + real ytd (nz,kw) + real AA(5), BB(5), lp(5) + real qy, ysave + + AA(1) = -160.50 + AA(2) = 2.4807 + AA(3) = -1.5202e-2 + AA(4) = 3.8412e-5 + AA(5) = -3.4373e-8 + + BB(1) = -1.5296 + BB(2) = 3.5248e-2 + BB(3) = -2.9951e-4 + BB(4) = 1.1129e-6 + BB(5) = -1.5259e-9 + + lp(1) = 0.0 + lp(2) = 1.0 + lp(3) = 2.0 + lp(4) = 3.0 + lp(5) = 4.0 + +!--------------------------------------------------- +! ... tin set to tlev +!--------------------------------------------------- + tin(:) = tlev(:) +!--------------------------------------------------- +! ... jlabel(j) = 'cfc114 -> 2cl' +!--------------------------------------------------- + j = j+1 + jlabel(j) = 'CFC114 + hv -> 2Cl' + +!--------------------------------------------------- +! Derive temperature dependence +!--------------------------------------------------- +! Temperature dependence good between +! 210-300K and 172 nm-220 nm +!--------------------------------------------------- + iwc = 1 + ytmp(:,:)= 0.0 + + do iw = 1, nw-1 + + IF ((wc(iw) .GE. 172.) .AND. (wc(iw) .LE.220.)) THEN + + do iz = 1, nz + + IF (tin(iz) .LT. 210.) THEN + do nloop = 1, 5 + ytmp(iz,iwc) = ytmp(iz,iwc) + & + AA(nloop)* (wc(iw)**lp(nloop)) + & + (210.0-273.0)*BB(nloop)*wc(iw)**lp(nloop) + enddo + wctmp(iwc) = wc(iw) + ENDIF + + IF ((tin(iz) .GE. 210.).AND.(tin(iz) .LE. 300.)) THEN + do nloop = 1,5 + + ytmp(iz,iwc) = ytmp(iz,iwc) + & + AA(nloop)* (wc(iw)**lp(nloop)) + & + (tin(iz)-273.0)*BB(nloop)*wc(iw)**lp(nloop) + enddo + wctmp(iwc) = wc(iw) + ENDIF + + IF (tin(iz) .GT. 300.) THEN + do nloop = 1, 5 + ytmp(iz,iwc) = ytmp(iz,iwc) + & + AA(nloop)* (wc(iw)**lp(nloop)) + & + (300.0-273.0)*BB(nloop)*wc(iw)**lp(nloop) + enddo + wctmp(iwc) = wc(iw) + ENDIF + enddo + iwc = iwc+ 1 + + ENDIF + + enddo +!--------------------------------------------------- +! ... For wavelengths >220nm +!--------------------------------------------------- + open(kin,file=TRIM(pn)//'XS_CFC114_JPL10.txt',status='old') + + read(kin,*) idum, n + do i = 1, idum-2 + read(kin,*) + enddo + + do i = 1, n + read(kin,*) xin(i), yin(i) + enddo + close(kin) + +!--------------------------------------------------- +! ... Combine cross sections +!--------------------------------------------------- + do iz = 1, nz + icnt = 1 + +! ... 172-220 nm + do i = 1, iwc-1 + ycomb(iz,icnt) = 10**(ytmp(iz,i)) + wcb (icnt) = wctmp(i) + icnt = icnt+1 + enddo +! ... >20nm + do i = 1, n + IF (xin(i) .GT. 220.) THEN + ycomb(iz,icnt) = yin(i) + wcb (icnt) = xin(i) + icnt = icnt+1 + ENDIF + enddo + enddo +!--------------------------------------------------- +! ... interpolate +!--------------------------------------------------- + do iz = 1, nz + n1 = icnt-1 + y1 = ycomb(iz,:) + x1 = wcb +!--------------------------------------------------- +! iz = 1 +! do iw = 1, icnt-1 +! print*, iw, wcb(iw), ycomb(iz,iw), tin(iz) +! enddo +! stop +!--------------------------------------------------- + call addpnt(x1,y1,kdata,n1,x1(1)*(1.-deltax),0.) + call addpnt(x1,y1,kdata,n1, 0.,0.) + call addpnt(x1,y1,kdata,n1,x1(n1)*(1.+deltax),0.) + call addpnt(x1,y1,kdata,n1, 1e38,0.) + call inter2(nw,wl,yg1,n1,x1,y1,ierr) + ytd(iz,:) = yg1(:) + + if (ierr .ne. 0) then + write(*,*) ierr, jlabel(j) + stop + endif + enddo + +!---------------------------------------------------- +! iz = 1 +! do iw = 10, 64 +! print*, iw, wc(iw), ytd(iz,iw), tin(iz) +! enddo +! stop +!---------------------------------------------------- +!---------------------------------------------------- +! ...quantum yield assumed to be unity +!---------------------------------------------------- + qy = 1. + do iw = 1, nw-1 + do iz = 1, nz + sq(j,iz,iw) = qy * ytd(iz,iw) + enddo + enddo + + end subroutine XSQY_CFC114 diff --git a/test/unit/tuv_doug/JCALC/XSQY_CFC115.f b/test/unit/tuv_doug/JCALC/XSQY_CFC115.f new file mode 100644 index 00000000..f5253398 --- /dev/null +++ b/test/unit/tuv_doug/JCALC/XSQY_CFC115.f @@ -0,0 +1,227 @@ + subroutine XSQY_CFC115(nw,wl,wc,nz,tlev,airlev,j,sq,jlabel,pn) +!-----------------------------------------------------------------------------! +! purpose: ! +! provide product (cross section) x (quantum yield) for cfc113 photolysis: ! +! CFC115 + hv -> Cl ! +! cross section: from JPL10 recommendation ! +! quantum yield: assumed to be unity ! +!-----------------------------------------------------------------------------! +! parameters: ! +! nw - integer, number of specified intervals + 1 in working (i) ! +! wavelength grid ! +! wl - real, vector of lower limits of wavelength intervals in (i) ! +! working wavelength grid ! +! wc - real, vector of center points of wavelength intervals in (i) ! +! working wavelength grid ! +! nz - integer, number of altitude levels in working altitude grid (i) ! +! tlev - real, temperature (k) at each specified altitude level (i) ! +! airlev - real, air density (molec/cc) at each altitude level (i) ! +! j - integer, counter for number of weighting functions defined (io) ! +! sq - real, cross section x quantum yield (cm^2) for each (o) ! +! photolysis reaction defined, at each defined wavelength and ! +! at each defined altitude level ! +! jlabel - character*60, string identifier for each photolysis reaction (o) ! +! defined ! +!-----------------------------------------------------------------------------! +! edit history: ! +! 01/06/12 Doug Kinnison ! +!-----------------------------------------------------------------------------! + implicit none + include 'params' + +!-----------------------------------------------------------------------------! +! ... input ! +!-----------------------------------------------------------------------------! + real, intent(in) :: wl(kw) + real, intent(in) :: wc(kw) + real, intent(in) :: tlev(kz) + real, intent(in) :: airlev(kz) + + integer, intent(in) :: nz + integer, intent(in) :: nw + + character*80, intent(in) :: pn + character*60, intent(out) :: jlabel(kj) + real, intent(out) :: sq(kj,kz,kw) + +!-----------------------------------------------------------------------------! +! ... input/output ! +!-----------------------------------------------------------------------------! + integer, intent(inout) :: j + +!-----------------------------------------------------------------------------! +! ... local ! +!-----------------------------------------------------------------------------! + integer kdata + parameter(kdata=300) + integer i, iw, n, idum, nloop, n1 + integer ierr, iz, iwc, icnt + real x1 (kdata), y1 (kdata) + real xin (kdata), yin (kdata) + real wctmp(kdata), wcb (kdata) + real ytmp (nz,kdata), ycomb(nz,kdata) + real yg1(kw), tin (nz) + real ytd (nz,kw) + real AA(4), BB(4), lp(4) + real qy, ysave + + AA(1) = 5.8281 + AA(2) = -2.9990e-1 + AA(3) = 1.3525e-3 + AA(4) = -2.6851e-6 + + BB(1) = 0.0 + BB(2) = 0.0 + BB(3) = 0.0 + BB(4) = 0.0 + + + lp(1) = 0.0 + lp(2) = 1.0 + lp(3) = 2.0 + lp(4) = 3.0 + + +!--------------------------------------------------- +! ... tin set to tlev +!--------------------------------------------------- + tin(:) = tlev(:) +!--------------------------------------------------- +! ... jlabel(j) = 'cfc115 -> cl' +!--------------------------------------------------- + j = j+1 + jlabel(j) = 'CFC115 + hv -> Cl' + +!--------------------------------------------------- +! Derive temperature dependence +!--------------------------------------------------- +! Temperature dependence good between +! 210-300K and 172 nm-204 nm +!--------------------------------------------------- + iwc = 1 + ytmp(:,:)= 0.0 + + do iw = 1, nw-1 + + IF ((wc(iw) .GE. 172.) .AND. (wc(iw) .LE.204.)) THEN + + do iz = 1, nz + + IF (tin(iz) .LT. 210.) THEN + do nloop = 1, 4 + ytmp(iz,iwc) = ytmp(iz,iwc) + & + AA(nloop)* (wc(iw)**lp(nloop)) + & + (210.0-273.0)*BB(nloop)*wc(iw)**lp(nloop) + enddo + wctmp(iwc) = wc(iw) + ENDIF + + IF ((tin(iz) .GE. 210.).AND.(tin(iz) .LE. 300.)) THEN + do nloop = 1,4 + + ytmp(iz,iwc) = ytmp(iz,iwc) + & + AA(nloop)* (wc(iw)**lp(nloop)) + & + (tin(iz)-273.0)*BB(nloop)*wc(iw)**lp(nloop) + enddo + wctmp(iwc) = wc(iw) + ENDIF + + IF (tin(iz) .GT. 300.) THEN + do nloop = 1, 4 + ytmp(iz,iwc) = ytmp(iz,iwc) + & + AA(nloop)* (wc(iw)**lp(nloop)) + & + (300.0-273.0)*BB(nloop)*wc(iw)**lp(nloop) + enddo + wctmp(iwc) = wc(iw) + ENDIF + enddo + iwc = iwc+ 1 + + ENDIF + + enddo +!--------------------------------------------------- +! ... For wavelengths >220nm +!--------------------------------------------------- + open(kin,file=TRIM(pn)//'XS_CFC115_JPL10.txt',status='old') + + read(kin,*) idum, n + do i = 1, idum-2 + read(kin,*) + enddo + + do i = 1, n + read(kin,*) xin(i), yin(i) + enddo + close(kin) + +!--------------------------------------------------- +! ... Combine cross sections +!--------------------------------------------------- + do iz = 1, nz + icnt = 1 + +! ... 172-204 nm +! do i = 1, iwc-1 +! ycomb(iz,icnt) = 10**(ytmp(iz,i)) +! wcb (icnt) = wctmp(i) +! icnt = icnt+1 +! enddo +! ... >204nm + +!NOTE: I left the temperature depence logic in, but am not using it. +! See comment in JPL-10. +! These results are from Table 4F-40. + do i = 1, n + IF (xin(i) .GE. 170.) THEN + ycomb(iz,icnt) = yin(i) + wcb (icnt) = xin(i) + icnt = icnt+1 + ENDIF + enddo + enddo +!--------------------------------------------------- +! ... interpolate +!--------------------------------------------------- + do iz = 1, nz + n1 = icnt-1 + y1 = ycomb(iz,:) + x1 = wcb +!--------------------------------------------------- +! iz = 1 +! do iw = 1, icnt-1 +! print*, iw, wcb(iw), ycomb(iz,iw), tin(iz) +! enddo +! stop +!--------------------------------------------------- + call addpnt(x1,y1,kdata,n1,x1(1)*(1.-deltax),0.) + call addpnt(x1,y1,kdata,n1, 0.,0.) + call addpnt(x1,y1,kdata,n1,x1(n1)*(1.+deltax),0.) + call addpnt(x1,y1,kdata,n1, 1e38,0.) + call inter2(nw,wl,yg1,n1,x1,y1,ierr) + ytd(iz,:) = yg1(:) + + if (ierr .ne. 0) then + write(*,*) ierr, jlabel(j) + stop + endif + enddo + +!---------------------------------------------------- +! iz = 1 +! do iw = 10, 64 +! print*, iw, wc(iw), ytd(iz,iw), tin(iz) +! enddo +! stop +!---------------------------------------------------- +!---------------------------------------------------- +! ...quantum yield assumed to be unity +!---------------------------------------------------- + qy = 1. + do iw = 1, nw-1 + do iz = 1, nz + sq(j,iz,iw) = qy * ytd(iz,iw) + enddo + enddo + + end subroutine XSQY_CFC115 diff --git a/test/unit/tuv_doug/JCALC/XSQY_CFCL3.f b/test/unit/tuv_doug/JCALC/XSQY_CFCL3.f new file mode 100644 index 00000000..d2d89948 --- /dev/null +++ b/test/unit/tuv_doug/JCALC/XSQY_CFCL3.f @@ -0,0 +1,231 @@ + subroutine XSQY_CFCL3(nw,wl,wc,nz,tlev,airlev,j,sq,jlabel,pn) +!-----------------------------------------------------------------------------! +! purpose: ! +! provide product (cross section) x (quantum yield) for cfcl3 photolysis: ! +! CFCl3 + hv -> 3Cl ! +! cross section: from JPL06 recommendation ! +! quantum yield: assumed to be unity ! +!-----------------------------------------------------------------------------! +! parameters: ! +! nw - integer, number of specified intervals + 1 in working (i) ! +! wavelength grid ! +! wl - real, vector of lower limits of wavelength intervals in (i) ! +! working wavelength grid ! +! wc - real, vector of center points of wavelength intervals in (i) ! +! working wavelength grid ! +! nz - integer, number of altitude levels in working altitude grid (i) ! +! tlev - real, temperature (k) at each specified altitude level (i) ! +! airlev - real, air density (molec/cc) at each altitude level (i) ! +! j - integer, counter for number of weighting functions defined (io) ! +! sq - real, cross section x quantum yield (cm^2) for each (o) ! +! photolysis reaction defined, at each defined wavelength and ! +! at each defined altitude level ! +! jlabel - character*60, string identifier for each photolysis reaction (o) ! +! defined ! +!-----------------------------------------------------------------------------! +! edit history: ! +! 01/16/08 Doug Kinnison ! +!-----------------------------------------------------------------------------! + implicit none + include 'params' + +!-----------------------------------------------------------------------------! +! ... input ! +!-----------------------------------------------------------------------------! + real, intent(in) :: wl(kw) + real, intent(in) :: wc(kw) + real, intent(in) :: tlev(kz) + real, intent(in) :: airlev(kz) + + integer, intent(in) :: nz + integer, intent(in) :: nw + + character*80, intent(in) :: pn + character*60, intent(out) :: jlabel(kj) + real, intent(out) :: sq(kj,kz,kw) + +!-----------------------------------------------------------------------------! +! ... input/output ! +!-----------------------------------------------------------------------------! + integer, intent(inout) :: j + +!-----------------------------------------------------------------------------! +! ... local ! +!-----------------------------------------------------------------------------! + integer kdata + parameter(kdata=300) + integer i, iw, n, idum, nloop, n1 + integer ierr, iz, iwc, icnt + real x1 (kdata), y1 (kdata) + real xin (kdata), yin (kdata) + real wctmp(kdata), wcb (kdata) + real ytmp (nz,kdata), ycomb(nz,kdata) + real yg1(kw), tin (nz) + real ytd (nz,kw) + real AA(5), BB(5), lp(5) + real qy, ysave + + AA(1) = -84.611 + AA(2) = 7.9551e-1 + AA(3) = -2.0550e-3 + AA(4) = -4.4812e-6 + AA(5) = 1.5838e-8 + + BB(1) = -5.7912 + BB(2) = 1.1689e-1 + BB(3) = -8.8069e-4 + BB(4) = 2.9335e-6 + BB(5) = -3.6421e-9 + + lp(1) = 0.0 + lp(2) = 1.0 + lp(3) = 2.0 + lp(4) = 3.0 + lp(5) = 4.0 +!--------------------------------------------------- +! ... tin set to tlev +!--------------------------------------------------- + tin(:) = tlev(:) + +!--------------------------------------------------- +! ... jlabel(j) = 'CFCl3 + hv -> 3Cl' +!--------------------------------------------------- + j = j+1 + jlabel(j) = 'CFCl3 + hv -> 3Cl' + +!--------------------------------------------------- +! Derive temperature dependence +!--------------------------------------------------- +! Temperature dependence good between +! 210-300K and 174 nm-230 nm +!--------------------------------------------------- + iwc = 1 + ytmp(:,:)= 0.0 + + do iw = 1, nw-1 + + IF ((wc(iw) .GE. 174.) .AND. (wc(iw) .LE.230.)) THEN + + do iz = 1, nz + + IF (tin(iz) .LT. 210.) THEN + do nloop = 1, 5 + ytmp(iz,iwc) = ytmp(iz,iwc) + & + AA(nloop)* (wc(iw)**lp(nloop)) + & + (210.0-273.0)*BB(nloop)*wc(iw)**lp(nloop) + enddo + wctmp(iwc) = wc(iw) + ENDIF + + IF ((tin(iz) .GE. 210.).AND.(tin(iz) .LE. 300.)) THEN + do nloop = 1,5 + + ytmp(iz,iwc) = ytmp(iz,iwc) + & + AA(nloop)* (wc(iw)**lp(nloop)) + & + (tin(iz)-273.0)*BB(nloop)*wc(iw)**lp(nloop) + enddo + wctmp(iwc) = wc(iw) + ENDIF + + IF (tin(iz) .GT. 300.) THEN + do nloop = 1, 5 + ytmp(iz,iwc) = ytmp(iz,iwc) + & + AA(nloop)* (wc(iw)**lp(nloop)) + & + (300.0-273.0)*BB(nloop)*wc(iw)**lp(nloop) + enddo + wctmp(iwc) = wc(iw) + ENDIF + enddo + iwc = iwc+ 1 + + ENDIF + + enddo +!--------------------------------------------------- +! ... For wavelengths >230 nm and <174 nm +!--------------------------------------------------- + open(kin,file=TRIM(pn)//'XS_CFCL3_JPL06.txt',status='old') + + read(kin,*) idum, n + do i = 1, idum-2 + read(kin,*) + enddo + + do i = 1, n + read(kin,*) xin(i), yin(i) + enddo + + close(kin) +!--------------------------------------------------- +! ... Combine cross sections +!--------------------------------------------------- + do iz = 1, nz + icnt = 1 + +! ... < 174nm + do i = 1, n + IF (xin(i) .LT. 174.1) THEN + ycomb(iz,icnt) = yin(i) + wcb (icnt) = xin(i) + icnt = icnt + 1 + ENDIF + enddo +! ... 174-230 nm + do i = 1, iwc-1 + ycomb(iz,icnt) = 10**(ytmp(iz,i)) + wcb (icnt) = wctmp(i) + icnt = icnt+1 + enddo +! ... >230nm + do i = 1, n + IF (xin(i) .GT. 230.) THEN + ycomb(iz,icnt) = yin(i) + wcb (icnt) = xin(i) + icnt = icnt+1 + ENDIF + enddo + enddo +!--------------------------------------------------- +! ... interpolate +!--------------------------------------------------- + do iz = 1, nz + n1 = icnt-1 + y1 = ycomb(iz,:) + x1 = wcb +!--------------------------------------------------- +! do iw = 1, icnt-1 +! print*, iw, wcb(iw), ycomb(iz,iw), tin(iz) +! enddo +! stop +!--------------------------------------------------- + call addpnt(x1,y1,kdata,n1,x1(1)*(1.-deltax),0.) + call addpnt(x1,y1,kdata,n1, 0.,0.) + call addpnt(x1,y1,kdata,n1,x1(n1)*(1.+deltax),0.) + call addpnt(x1,y1,kdata,n1, 1e38,0.) + call inter2(nw,wl,yg1,n1,x1,y1,ierr) + ytd(iz,:) = yg1(:) + + if (ierr .ne. 0) then + write(*,*) ierr, jlabel(j) + stop + endif + enddo + +!--------------------------------------------------- +! iz = 1 +! do iw = 19, 64 +! print*, iw, wc(iw), ytd(iz,iw), tin(iz) +! enddo +! stop +!--------------------------------------------------- +!--------------------------------------------------- +! ...quantum yield assumed to be unity +!--------------------------------------------------- + qy = 1. + do iw = 1, nw-1 + do iz = 1, nz + sq(j,iz,iw) = qy * ytd(iz,iw) + enddo + enddo + + end subroutine XSQY_CFCL3 diff --git a/test/unit/tuv_doug/JCALC/XSQY_CH3BR.f b/test/unit/tuv_doug/JCALC/XSQY_CH3BR.f new file mode 100644 index 00000000..687b8d3d --- /dev/null +++ b/test/unit/tuv_doug/JCALC/XSQY_CH3BR.f @@ -0,0 +1,235 @@ + subroutine XSQY_CH3BR(nw,wl,wc,nz,tlev,airlev,j,sq,jlabel,pn) +!-----------------------------------------------------------------------------! +! purpose: ! +! provide product (cross section) x (quantum yield) for ch3br photolysis: ! +! CH3Br + hv -> Br ! +! cross section: from JPL06 recommendation ! +! quantum yield: assumed to be unity ! +!-----------------------------------------------------------------------------! +! parameters: ! +! nw - integer, number of specified intervals + 1 in working (i) ! +! wavelength grid ! +! wl - real, vector of lower limits of wavelength intervals in (i) ! +! working wavelength grid ! +! wc - real, vector of center points of wavelength intervals in (i) ! +! working wavelength grid ! +! nz - integer, number of altitude levels in working altitude grid (i) ! +! tlev - real, temperature (k) at each specified altitude level (i) ! +! airlev - real, air density (molec/cc) at each altitude level (i) ! +! j - integer, counter for number of weighting functions defined (io) ! +! sq - real, cross section x quantum yield (cm^2) for each (o) ! +! photolysis reaction defined, at each defined wavelength and ! +! at each defined altitude level ! +! jlabel - character*60, string identifier for each photolysis reaction (o) ! +! defined ! +!-----------------------------------------------------------------------------! +! edit history: ! +! 07/30/07 Doug Kinnison ! +!-----------------------------------------------------------------------------! + implicit none + include 'params' + +!-----------------------------------------------------------------------------! +! ... input ! +!-----------------------------------------------------------------------------! + real, intent(in) :: wl(kw) + real, intent(in) :: wc(kw) + real, intent(in) :: tlev(kz) + real, intent(in) :: airlev(kz) + + integer, intent(in) :: nz + integer, intent(in) :: nw + + character*80, intent(in) :: pn + character*60, intent(out) :: jlabel(kj) + real, intent(out) :: sq(kj,kz,kw) + +!-----------------------------------------------------------------------------! +! ... input/output ! +!-----------------------------------------------------------------------------! + integer, intent(inout) :: j + +!-----------------------------------------------------------------------------! +! ... local ! +!-----------------------------------------------------------------------------! + integer kdata + parameter(kdata=300) + integer i, iw, n, idum, nloop, n1 + integer ierr, iz, iwc, icnt + real x1 (kdata), y1(kdata) + real xin (kdata), yin(kdata) + real ytmp (nz,kdata) + real ycomb(nz,kdata) + real wctmp(kdata), wcb(kdata) + real yg1 (kw) + real ytd (nz,kw) + real AA(5), BB(5), lp(5) + real tin(nz) + real ysave, qy + + AA(1) = 46.520 + AA(2) = -1.4580 + AA(3) = 1.1469e-2 + AA(4) = -3.7627e-5 + AA(5) = 4.3264e-8 + + BB(1) = 9.3408e-1 + BB(2) = -1.6887e-2 + BB(3) = 1.1487e-4 + BB(4) = -3.4881e-7 + BB(5) = 3.9945e-10 + + lp(1) = 0.0 + lp(2) = 1.0 + lp(3) = 2.0 + lp(4) = 3.0 + lp(5) = 4.0 + +!---------------------------------------------- +! ... tin set to tlev +!---------------------------------------------- + tin(:) = tlev(:) + +!---------------------------------------------- +! ... jlabel(j) = 'CH3Br -> Br' +!---------------------------------------------- + j = j+1 + jlabel(j) = 'CH3Br + hv -> Br' + +!---------------------------------------------------------- +! Derive temperature dependence +!---------------------------------------------------------- +! Temperature dependence good between 210-300K and 200-280nm + iwc = 1 + ytmp(:,:)= 0.0 + + do iw = 1, nw-1 + + IF ((wc(iw) .GE. 200.) .AND. (wc(iw) .LE.280.)) THEN + + do iz = 1, nz + + IF (tin(iz) .LT. 210.) THEN + do nloop = 1, 5 + ytmp(iz,iwc) = ytmp(iz,iwc) + & + AA(nloop)* (wc(iw)**lp(nloop)) + & + (210.0-273.0)*BB(nloop)*wc(iw)**lp(nloop) + enddo + wctmp(iwc) = wc(iw) + ENDIF + + IF ((tin(iz) .GE. 210.).AND.(tin(iz) .LE. 300.)) THEN + do nloop = 1,5 + + ytmp(iz,iwc) = ytmp(iz,iwc) + & + AA(nloop)* (wc(iw)**lp(nloop)) + & + (tin(iz)-273.0)*BB(nloop)*wc(iw)**lp(nloop) + enddo + wctmp(iwc) = wc(iw) + ENDIF + + IF (tin(iz) .GT. 300.) THEN + do nloop = 1, 5 + ytmp(iz,iwc) = ytmp(iz,iwc) + & + AA(nloop)* (wc(iw)**lp(nloop)) + & + (300.0-273.0)*BB(nloop)*wc(iw)**lp(nloop) + enddo + wctmp(iwc) = wc(iw) + ENDIF + enddo + iwc = iwc+ 1 + + ENDIF + + enddo + +!---------------------------------------------------------- +! ... For wavelengths >280nm and <200 nm +!---------------------------------------------------------- + open(kin,file=TRIM(pn)//'XS_CH3BR_JPL06.txt',status='old') + + read(kin,*) idum, n + do i = 1, idum-2 + read(kin,*) + enddo + + do i = 1, n + read(kin,*) xin(i), yin(i) + enddo + close(kin) + +!---------------------------------------------------------- +! ... Combine cross sections +!---------------------------------------------------------- + do iz = 1, nz + icnt = 1 + +! ... < 200nm + do i = 1, n + IF (xin(i) .LT. 200.) THEN + ycomb(iz,icnt) = yin(i) + wcb (icnt) = xin(i) + icnt = icnt + 1 + ENDIF + enddo +! ... 200-280 nm + do i = 1, iwc-1 + ycomb(iz,icnt) = 10**(ytmp(iz,i)) + wcb (icnt) = wctmp(i) + icnt = icnt+1 + enddo +! ... >280nm + do i = 1, n + IF (xin(i) .GT. 280.) THEN + ycomb(iz,icnt) = yin(i) + wcb (icnt) = xin(i) + icnt = icnt+1 + ENDIF + enddo + enddo +!---------------------------------------------------------- +! ... interpolate +!---------------------------------------------------------- + do iz = 1, nz + n1 = icnt-1 + y1 = ycomb(iz,:) + x1 = wcb +!---------------------------------------------------------- +! iz = 1 +! do iw = 1, icnt-1 +! print*, iw, wcb(iw), ycomb(iz,iw), tin(iz) +! enddo +! stop +!---------------------------------------------------------- + call addpnt(x1,y1,kdata,n1,x1(1)*(1.-deltax),0.) + call addpnt(x1,y1,kdata,n1, 0.,0.) + call addpnt(x1,y1,kdata,n1,x1(n1)*(1.+deltax),0.) + call addpnt(x1,y1,kdata,n1, 1e38,0.) + call inter2(nw,wl,yg1,n1,x1,y1,ierr) + ytd(iz,:) = yg1(:) + + if (ierr .ne. 0) then + write(*,*) ierr, jlabel(j) + stop + endif + enddo + +!---------------------------------------------------------- +! iz = 1 +! do iw = 19, 64 +! print*, iw, wc(iw), ytd(iz,iw), tin(iz) +! enddo +! stop +!---------------------------------------------------------- +!---------------------------------------------------------- +! ...quantum yield assumed to be unity +!---------------------------------------------------------- + qy = 1. + + do iw = 1, nw-1 + do iz = 1, nz + sq(j,iz,iw) = qy * ytd(iz,iw) + enddo + enddo + + end subroutine XSQY_CH3BR diff --git a/test/unit/tuv_doug/JCALC/XSQY_CH3CL.f b/test/unit/tuv_doug/JCALC/XSQY_CH3CL.f new file mode 100644 index 00000000..7f14e97a --- /dev/null +++ b/test/unit/tuv_doug/JCALC/XSQY_CH3CL.f @@ -0,0 +1,236 @@ + subroutine XSQY_CH3CL(nw,wl,wc,nz,tlev,airlev,j,sq,jlabel,pn) +!-----------------------------------------------------------------------------! +! purpose: ! +! provide product (cross section) x (quantum yield) for ch3cl photolysis: ! +! ch3cl + hv -> products ! +! cross section: from JPL06 recommendation ! +! quantum yield: assumed to be unity ! +!-----------------------------------------------------------------------------! +! parameters: ! +! nw - integer, number of specified intervals + 1 in working (i) ! +! wavelength grid ! +! wl - real, vector of lower limits of wavelength intervals in (i) ! +! working wavelength grid ! +! wc - real, vector of center points of wavelength intervals in (i) ! +! working wavelength grid ! +! nz - integer, number of altitude levels in working altitude grid (i) ! +! tlev - real, temperature (k) at each specified altitude level (i) ! +! airlev - real, air density (molec/cc) at each altitude level (i) ! +! j - integer, counter for number of weighting functions defined (io) ! +! sq - real, cross section x quantum yield (cm^2) for each (o) ! +! photolysis reaction defined, at each defined wavelength and ! +! at each defined altitude level ! +! jlabel - character*60, string identifier for each photolysis reaction (o) ! +! defined ! +!-----------------------------------------------------------------------------! +! edit history: ! +! 07/30/07 Doug Kinnison ! +!-----------------------------------------------------------------------------! + implicit none + include 'params' + +!-----------------------------------------------------------------------------! +! ... input ! +!-----------------------------------------------------------------------------! + real, intent(in) :: wl(kw) + real, intent(in) :: wc(kw) + real, intent(in) :: tlev(kz) + real, intent(in) :: airlev(kz) + + integer, intent(in) :: nz + integer, intent(in) :: nw + + character*80, intent(in) :: pn + character*60, intent(out) :: jlabel(kj) + real, intent(out) :: sq(kj,kz,kw) + +!-----------------------------------------------------------------------------! +! ... input/output ! +!-----------------------------------------------------------------------------! + integer, intent(inout) :: j + +!-----------------------------------------------------------------------------! +! ... local ! +!-----------------------------------------------------------------------------! + integer kdata + parameter(kdata=300) + integer i, iw, n, idum, nloop, n1 + integer ierr, iz, iwc, icnt + real x1 (kdata), y1 (kdata) + real xin (kdata), yin (kdata) + real wctmp(kdata), wcb (kdata) + real ytmp (nz,kdata), ycomb(nz,kdata) + real ytd (nz,kw), tin (nz) + real AA(5), BB(5), lp(5) + real yg1 (kw) + real qy, ysave + + AA(1) = -299.80 + AA(2) = 5.1047 + AA(3) = -3.3630e-2 + AA(4) = 9.5805e-5 + AA(5) = -1.0135e-7 + + BB(1) = -7.1727 + BB(2) = 1.4837e-1 + BB(3) = -1.1463e-3 + BB(4) = 3.9188e-6 + BB(5) = -4.9994e-9 + + lp(1) = 0.0 + lp(2) = 1.0 + lp(3) = 2.0 + lp(4) = 3.0 + lp(5) = 4.0 + +!---------------------------------------------- +! ... tin set to tlev +!---------------------------------------------- + tin(:) = tlev(:) + +!---------------------------------------------- +! ... jlabel(j) = 'CH3Cl + hv -> Cl' +!---------------------------------------------- + j = j+1 + jlabel(j) = 'CH3Cl + hv -> Cl' + +!---------------------------------------------- +! Derive temperature dependence +!---------------------------------------------- +! Temperature dependence good between 210-300K +! and 174 nm-216 nm. +!---------------------------------------------- + iwc = 1 + ytmp(:,:)= 0.0 + + do iw = 1, nw-1 + + IF ((wc(iw) .GE. 174.) .AND. (wc(iw) .LE.216.)) THEN + + do iz = 1, nz + + IF (tin(iz) .LT. 210.) THEN + do nloop = 1, 5 + ytmp(iz,iwc) = ytmp(iz,iwc) + & + AA(nloop)* (wc(iw)**lp(nloop)) + & + (210.0-273.0)*BB(nloop)*wc(iw)**lp(nloop) + enddo + wctmp(iwc) = wc(iw) + ENDIF + + IF ((tin(iz) .GE. 210.).AND.(tin(iz) .LE. 300.)) THEN + do nloop = 1,5 + + ytmp(iz,iwc) = ytmp(iz,iwc) + & + AA(nloop)* (wc(iw)**lp(nloop)) + & + (tin(iz)-273.0)*BB(nloop)*wc(iw)**lp(nloop) + enddo + wctmp(iwc) = wc(iw) + ENDIF + + IF (tin(iz) .GT. 300.) THEN + do nloop = 1, 5 + ytmp(iz,iwc) = ytmp(iz,iwc) + & + AA(nloop)* (wc(iw)**lp(nloop)) + & + (300.0-273.0)*BB(nloop)*wc(iw)**lp(nloop) + enddo + wctmp(iwc) = wc(iw) + ENDIF + enddo + iwc = iwc+ 1 + + ENDIF + + enddo + +!---------------------------------------------- +! ... For wavelengths >216 nm and <174 nm +!---------------------------------------------- + open(kin,file=TRIM(pn)//'XS_CH3CL_JPL06.txt',status='old') + + read(kin,*) idum, n + do i = 1, idum-2 + read(kin,*) + enddo + + do i = 1, n + read(kin,*) xin(i), yin(i) + enddo + close(kin) + +!---------------------------------------------- +! ... Combine cross sections +!---------------------------------------------- + do iz = 1, nz + icnt = 1 + +! ... < 174nm + do i = 1, n + IF (xin(i) .LT. 174.1) THEN + ycomb(iz,icnt) = yin(i) + wcb (icnt) = xin(i) + icnt = icnt + 1 + ENDIF + enddo +! ... 174-216 nm + do i = 1, iwc-1 + ycomb(iz,icnt) = 10**(ytmp(iz,i)) + wcb (icnt) = wctmp(i) + icnt = icnt+1 + enddo +! ... >216nm + do i = 1, n + IF (xin(i) .GT. 216.) THEN + ycomb(iz,icnt) = yin(i) + wcb (icnt) = xin(i) + icnt = icnt+1 + ENDIF + enddo + enddo + +!---------------------------------------------- +! ... interpolate +!---------------------------------------------- + do iz = 1, nz + n1 = icnt-1 + y1 = ycomb(iz,:) + x1 = wcb +!---------------------------------------------- +! Check routine +! do iw = 1, icnt-1 +! print*, iw, wcb(iw), ycomb(iz,iw), tin(iz) +! enddo +! stop +!---------------------------------------------- + call addpnt(x1,y1,kdata,n1,x1(1)*(1.-deltax),0.) + call addpnt(x1,y1,kdata,n1, 0.,0.) + call addpnt(x1,y1,kdata,n1,x1(n1)*(1.+deltax),0.) + call addpnt(x1,y1,kdata,n1, 1e38,0.) + call inter2(nw,wl,yg1,n1,x1,y1,ierr) + ytd(iz,:) = yg1(:) + + if (ierr .ne. 0) then + write(*,*) ierr, jlabel(j) + stop + endif + enddo + +!---------------------------------------------- +! Check routine +! iz = 1 +! do iw = 19, 64 +! print*, iw, wc(iw), ytd(iz,iw), tin(iz) +! enddo +! stop +!---------------------------------------------- +!---------------------------------------------- +! ...quantum yield assumed to be unity +!---------------------------------------------- + qy = 1. + do iw = 1, nw-1 + do iz = 1, nz + sq(j,iz,iw) = qy * ytd(iz,iw) + enddo + enddo + + end subroutine XSQY_CH3CL diff --git a/test/unit/tuv_doug/JCALC/XSQY_CHBR3.f b/test/unit/tuv_doug/JCALC/XSQY_CHBR3.f new file mode 100644 index 00000000..d7351720 --- /dev/null +++ b/test/unit/tuv_doug/JCALC/XSQY_CHBR3.f @@ -0,0 +1,241 @@ + subroutine XSQY_CHBR3(nw,wl,wc,nz,tlev,airlev,j,sq,jlabel,pn) +!-----------------------------------------------------------------------------! +! purpose: ! +! provide product (cross section) x (quantum yield) for chbr3 photolysis: ! +! CHBr3 + hv -> 3Br ! +! cross section: from Papanastasiou et al, ACP, 2014 ! +! quantum yield: assumed to be unity ! +!-----------------------------------------------------------------------------! +! parameters: ! +! nw - integer, number of specified intervals + 1 in working (i) ! +! wavelength grid ! +! wl - real, vector of lower limits of wavelength intervals in (i) ! +! working wavelength grid ! +! wc - real, vector of center points of wavelength intervals in (i) ! +! working wavelength grid ! +! nz - integer, number of altitude levels in working altitude grid (i) ! +! tlev - real, temperature (k) at each specified altitude level (i) ! +! airlev - real, air density (molec/cc) at each altitude level (i) ! +! j - integer, counter for number of weighting functions defined (io) ! +! sq - real, cross section x quantum yield (cm^2) for each (o) ! +! photolysis reaction defined, at each defined wavelength and ! +! at each defined altitude level ! +! jlabel - character*60, string identifier for each photolysis reaction (o) ! +! defined ! +!-----------------------------------------------------------------------------! +! edit history: ! +! 07/02/14 Doug Kinnison ! +! 09/17/14 added <260 +!-----------------------------------------------------------------------------! + implicit none + include 'params' + +!-----------------------------------------------------------------------------! +! ... input ! +!-----------------------------------------------------------------------------! + real, intent(in) :: wl(kw) + real, intent(in) :: wc(kw) + real, intent(in) :: tlev(kz) + real, intent(in) :: airlev(kz) + + integer, intent(in) :: nz + integer, intent(in) :: nw + + character*80, intent(in) :: pn + character*60, intent(out) :: jlabel(kj) + real, intent(out) :: sq(kj,kz,kw) + +!-----------------------------------------------------------------------------! +! ... input/output ! +!-----------------------------------------------------------------------------! + integer, intent(inout) :: j + +!-----------------------------------------------------------------------------! +! ... local ! +!-----------------------------------------------------------------------------! + integer kdata + parameter(kdata=300) + integer i, iw, n, idum, nloopAA, nloopBB, n1 + integer ierr, iz, iwc, icnt + + real x1 (kdata), y1 (kdata) + real xin (kdata), yin (kdata) + real wctmp(kdata), wcb (kdata) + real ytmp (nz,kdata),ycomb(nz,kdata) + real yg1 (kw), ytd (nz,kw) + real qy + real AA(6), BB(5), lp(6) + real tin(nz) + + AA(1) = -32.6067 + AA(2) = 0.10308 + AA(3) = 6.39e-5 + AA(4) = -7.7392e-7 + AA(5) = -2.2513e-9 + AA(6) = 6.1376e-12 + + BB(1) = 0.1582 + BB(2) = -0.0014758 + BB(3) = 3.8058e-6 + BB(4) = 9.187e-10 + BB(5) = -1.0772e-11 + + lp(1) = 0.0 + lp(2) = 1.0 + lp(3) = 2.0 + lp(4) = 3.0 + lp(5) = 4.0 + lp(6) = 5.0 + +!---------------------------------------------- +! ... set tin to tlev +!---------------------------------------------- + tin(:) = tlev(:) +!---------------------------------------------- +! ... jlabel(j) = 'CHBr3 + hv -> 3Br' +!---------------------------------------------- + j = j+1 + jlabel(j) = 'CHBr3 + hv -> 3Br' + +!---------------------------------------------- +! Derive temperature dependence +!---------------------------------------------- +! Temperature dependence good between +! 260-330K and 260 nm to 345 nm +! 99% of the loss in this region +!---------------------------------------------- + iwc = 1 + ytmp(:,:)= 0.0 + + do iw = 1, nw-1 + + +! Extrapolate to 357.5nm with TUV grid + IF ((wc(iw) .GE. 260.) .AND. (wc(iw) .LE. 362.)) THEN + do iz = 1, nz + + IF (tin(iz) .LT. 260.) THEN + do nloopAA = 1, 6 + ytmp(iz,iwc) = ytmp(iz,iwc) + & + AA(nloopAA)* (wc(iw)**lp(nloopAA)) + enddo + do nloopBB = 1, 5 + ytmp(iz,iwc) = ytmp(iz,iwc) + + & (296.0-260.0)*BB(nloopBB)*wc(iw)**lp(nloopBB) + enddo + wctmp(iwc) = wc(iw) + ENDIF + + IF ((tin(iz) .GE. 260.).AND.(tin(iz) .LE. 330.)) THEN + do nloopAA = 1, 6 + ytmp(iz,iwc) = ytmp(iz,iwc) + & + AA(nloopAA)* (wc(iw)**lp(nloopAA)) + enddo + do nloopBB = 1, 5 + ytmp(iz,iwc) = ytmp(iz,iwc) + + & (296.0-tin(iz))*BB(nloopBB)*wc(iw)**lp(nloopBB) + enddo + wctmp(iwc) = wc(iw) + ENDIF + + IF (tin(iz) .GT. 330.) THEN + do nloopAA = 1, 6 + ytmp(iz,iwc) = ytmp(iz,iwc) + & + AA(nloopAA)* (wc(iw)**lp(nloopAA)) + enddo + do nloopBB = 1, 5 + ytmp(iz,iwc) = ytmp(iz,iwc) + + & (296.0-tin(iz))*BB(nloopBB)*wc(iw)**lp(nloopBB) + enddo + wctmp(iwc) = wc(iw) + ENDIF + + enddo + iwc = iwc+ 1 + + ENDIF + + enddo + +!---------------------------------------------- +! ... For wavelengths >310 nm and <240 nm +!---------------------------------------------- + open(kin,file=TRIM(pn)//'XS_CHBR3_JPL10.txt',status='old') + + read(kin,*) idum, n + do i = 1, idum-2 + read(kin,*) + enddo + + do i = 1, n + read(kin,*) xin(i), yin(i) + enddo + close(kin) + +!---------------------------------------------- +! ... Combine cross sections +!---------------------------------------------- + do iz = 1, nz + icnt = 1 + +! ... < 260nm + do i = 1, n + IF (xin(i) .LT. 260.) THEN + ycomb(iz,icnt) = yin(i) + wcb (icnt) = xin(i) + icnt = icnt + 1 + ENDIF + enddo +! ... 260-362 nm + do i = 1, iwc-1 + ycomb(iz,icnt) = 10**(ytmp(iz,i)) + wcb (icnt) = wctmp(i) + icnt = icnt+1 + enddo + + enddo +!---------------------------------------------- +! ... interpolate +!---------------------------------------------- + do iz = 1, nz + n1 = icnt-1 + y1 = ycomb(iz,:) + x1 = wcb +!---------------------------------------------- +! +! do iw = 1, icnt-1 +! print*, iw, wcb(iw), ycomb(iz,iw), tin(iz) +! enddo +! stop +!---------------------------------------------- + call addpnt(x1,y1,kdata,n1,x1(1)*(1.-deltax),0.) + call addpnt(x1,y1,kdata,n1, 0.,0.) + call addpnt(x1,y1,kdata,n1,x1(n1)*(1.+deltax),0.) + call addpnt(x1,y1,kdata,n1, 1e38,0.) + call inter2(nw,wl,yg1,n1,x1,y1,ierr) + ytd(iz,:) = yg1(:) + + if (ierr .ne. 0) then + write(*,*) ierr, jlabel(j) + stop + endif + enddo +!---------------------------------------------- +! iz = 1 +! do iw = 1, nw-1 +! print*, iw, wc(iw), ytd(iz,iw), tin(iz) +! enddo +! stop +!---------------------------------------------- +!---------------------------------------------- +! ...quantum yield assumed to be unity +!---------------------------------------------- + qy = 1. + + do iw = 1, nw-1 + do iz = 1, nz + sq(j,iz,iw) = qy * ytd(iz,iw) + enddo + enddo + + end subroutine XSQY_CHBR3 diff --git a/test/unit/tuv_doug/JCALC/XSQY_CL2O2.f b/test/unit/tuv_doug/JCALC/XSQY_CL2O2.f new file mode 100644 index 00000000..87abe738 --- /dev/null +++ b/test/unit/tuv_doug/JCALC/XSQY_CL2O2.f @@ -0,0 +1,117 @@ + subroutine XSQY_CL2O2(nw,wl,wc,nz,tlev,airlev,j,sq,jlabel,pn) +!-----------------------------------------------------------------------------! +! purpose: ! +! provide product (cross section) x (quantum yield) for hcl photolysis: ! +! cl2o2 + hv -> cl + cloo ! +! cross section: from JPL10 ! +! ! +!-----------------------------------------------------------------------------! +! parameters: ! +! nw - integer, number of specified intervals + 1 in working (i) ! +! wavelength grid ! +! wl - real, vector of lower limits of wavelength intervals in (i) ! +! working wavelength grid ! +! wc - real, vector of center points of wavelength intervals in (i) ! +! working wavelength grid ! +! nz - integer, number of altitude levels in working altitude grid (i) ! +! tlev - real, temperature (k) at each specified altitude level (i) ! +! airlev - real, air density (molec/cc) at each altitude level (i) ! +! j - integer, counter for number of weighting functions defined (io) ! +! sq - real, cross section x quantum yield (cm^2) for each (o) ! +! photolysis reaction defined, at each defined wavelength and ! +! at each defined altitude level ! +! jlabel - character*60, string identifier for each photolysis reaction (o) ! +! defined ! +!-----------------------------------------------------------------------------! +! edit history: ! +! 01/13/2012 Doug Kinnison ! +!-----------------------------------------------------------------------------! + implicit none + include 'params' + +!-----------------------------------------------------------------------------! +! ... input ! +!-----------------------------------------------------------------------------! + real, intent(in) :: wl(kw) + real, intent(in) :: wc(kw) + real, intent(in) :: tlev(kz) + real, intent(in) :: airlev(kz) + + integer, intent(in) :: nz + integer, intent(in) :: nw + + character*80, intent(in) :: pn + character*60, intent(out) :: jlabel(kj) + real, intent(out) :: sq(kj,kz,kw) + +!-----------------------------------------------------------------------------! +! ... input/output ! +!-----------------------------------------------------------------------------! + integer, intent(inout) :: j + +!-----------------------------------------------------------------------------! +! ... local ! +!-----------------------------------------------------------------------------! + integer kdata + parameter(kdata=600) + integer i, iw, n, idum, ierr, iz + real x1(kdata) + real y1(kdata) + real yg(kw) + real qy + +!---------------------------------------------- +! ... jlabel(j) = 'cl2o2 -> cl + cloo' +!---------------------------------------------- + j = j+1 + jlabel(j) = 'Cl2O2 + hv -> Cl + ClOO' +! print*,jlabel(j) +!---------------------------------------------------- +! ... cross sections +!---------------------------------------------------- + open(kin,file= + $ TRIM(pn)//'XS_CL2O2_JPL10_500nm.txt',status='old') + + read(kin,*) idum, n + do i = 1, idum-2 + read(kin,*) + enddo + do i = 1, n + read(kin,*) x1(i), y1(i) + enddo + close(kin) + +!---------------------------------------------------------- +! do i = 1, n +! print*, i, x1(i), y1(i) +! enddo +! stop +!---------------------------------------------------------- + call addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.) + call addpnt(x1,y1,kdata,n, 0.,0.) + call addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.) + call addpnt(x1,y1,kdata,n, 1e38,0.) + call inter2(nw,wl,yg,n,x1,y1,ierr) + + + if (ierr .ne. 0) then + write(*,*) ierr, jlabel(j) + stop + endif + +!-------------------------------------------------------------- +! ... quantum yield assumed to be 1.0 +!-------------------------------------------------------------- + qy = 1.0 + do iw = 1, nw-1 + do iz = 1, nz + sq(j,iz,iw) = qy * yg(iw) + enddo + enddo +!---------------------------------------------------------- +! do iw = 28, 99 +! print*, iw, wc(iw), yg(iw) +! enddo +! stop +!---------------------------------------------------------- + end subroutine XSQY_CL2O2 diff --git a/test/unit/tuv_doug/JCALC/XSQY_CLO.f b/test/unit/tuv_doug/JCALC/XSQY_CLO.f new file mode 100644 index 00000000..2dab1cae --- /dev/null +++ b/test/unit/tuv_doug/JCALC/XSQY_CLO.f @@ -0,0 +1,115 @@ + subroutine XSQY_CLO(nw,wl,wc,nz,tlev,airlev,j,sq,jlabel,pn) +!-----------------------------------------------------------------------------! +! purpose: ! +! provide product (cross section) x (quantum yield): ! +! ClO + hv -> Cl + O ! +! cross section: JPL06 ! +! quantum yield: is unity. ! +!-----------------------------------------------------------------------------! +! parameters: ! +! nw - integer, number of specified intervals + 1 in working (i) ! +! wavelength grid ! +! wl - real, vector of lower limits of wavelength intervals in (i) ! +! working wavelength grid ! +! wc - real, vector of center points of wavelength intervals in (i) ! +! working wavelength grid ! +! nz - integer, number of altitude levels in working altitude grid (i) ! +! tlev - real, temperature (k) at each specified altitude level (i) ! +! airlev - real, air density (molec/cc) at each altitude level (i) ! +! j - integer, counter for number of weighting functions defined (io) ! +! sq - real, cross section x quantum yield (cm^2) for each (o) ! +! photolysis reaction defined, at each defined wavelength and ! +! at each defined altitude level ! +! jlabel - character*60, string identifier for each photolysis reaction (o) ! +! defined ! +!-----------------------------------------------------------------------------! +! edit history: ! +! 07/27/07 Doug Kinnison ! +!-----------------------------------------------------------------------------! + implicit none + include 'params' + +!-----------------------------------------------------------------------------! +! ... input ! +!-----------------------------------------------------------------------------! + real, intent(in) :: wl(kw) + real, intent(in) :: wc(kw) + real, intent(in) :: tlev(kz) + real, intent(in) :: airlev(kz) + + integer, intent(in) :: nz + integer, intent(in) :: nw + + character*80, intent(in) :: pn + character*60, intent(out) :: jlabel(kj) + real, intent(out) :: sq(kj,kz,kw) + +!-----------------------------------------------------------------------------! +! ... input/output ! +!-----------------------------------------------------------------------------! + integer, intent(inout) :: j + +!-----------------------------------------------------------------------------! +! ... local ! +!-----------------------------------------------------------------------------! + integer kdata + parameter(kdata=300) + integer i, iw, n, idum, ierr, iz + real x1(kdata) + real y1(kdata) + real yg(kw) + real qy + +!---------------------------------------------- +! ... jlabel(j) = 'ClO + hv -> Cl + O' +!---------------------------------------------- + j = j+1 + jlabel(j) = 'ClO + hv -> Cl + O' + +!---------------------------------------------------- +! ... cross sections from JPL06 recommendation +!---------------------------------------------------- + open(kin,file=TRIM(pn)//'XS_CLO_JPL06.txt',status='old') + + read(kin,*) idum, n + do i = 1, idum-2 + read(kin,*) + enddo + + do i = 1, n + read(kin,*) x1(i), y1(i) + enddo + close(kin) + + call addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.) + call addpnt(x1,y1,kdata,n, 0.,0.) + call addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.) + call addpnt(x1,y1,kdata,n, 1e38,0.) + + call inter2(nw,wl,yg,n,x1,y1,ierr) + + if (ierr .ne. 0) then + write(*,*) ierr, jlabel(j) + stop + endif +!------------------------------------------------------- +! ... quantum yield (assumed) to be unity (JPL06) +!------------------------------------------------------- + qy = 1.0 + + do iw = 1, nw-1 + do iz = 1, nz + sq(j,iz,iw) = qy * yg(iw) + + enddo + enddo +!------------------------------------------------------- +! ... Check routine (no temperature dependence +! print*,'jclo' +! do iw = 30, 72 +! print*, iw, wc(iw), (qy * yg(iw)) +! enddo +! stop +!------------------------------------------------------- + + end subroutine XSQY_CLO diff --git a/test/unit/tuv_doug/JCALC/XSQY_H1301.f b/test/unit/tuv_doug/JCALC/XSQY_H1301.f new file mode 100644 index 00000000..dcfa341e --- /dev/null +++ b/test/unit/tuv_doug/JCALC/XSQY_H1301.f @@ -0,0 +1,230 @@ + subroutine XSQY_H1301(nw,wl,wc,nz,tlev,airlev,j,sq,jlabel,pn) +!-----------------------------------------------------------------------------! +! purpose: ! +! provide product (cross section) x (quantum yield) for h1301 photolysis: ! +! h1301 + hv -> products ! +! cross section: from JPL06 recommendation ! +! quantum yield: assumed to be unity ! +!-----------------------------------------------------------------------------! +! parameters: ! +! nw - integer, number of specified intervals + 1 in working (i) ! +! wavelength grid ! +! wl - real, vector of lower limits of wavelength intervals in (i) ! +! working wavelength grid ! +! wc - real, vector of center points of wavelength intervals in (i) ! +! working wavelength grid ! +! nz - integer, number of altitude levels in working altitude grid (i) ! +! tlev - real, temperature (k) at each specified altitude level (i) ! +! airlev - real, air density (molec/cc) at each altitude level (i) ! +! j - integer, counter for number of weighting functions defined (io) ! +! sq - real, cross section x quantum yield (cm^2) for each (o) ! +! photolysis reaction defined, at each defined wavelength and ! +! at each defined altitude level ! +! jlabel - character*60, string identifier for each photolysis reaction (o) ! +! defined ! +!-----------------------------------------------------------------------------! +! edit history: ! +! 07/30/07 Doug Kinnison ! +!-----------------------------------------------------------------------------! + implicit none + include 'params' + +!-----------------------------------------------------------------------------! +! ... input ! +!-----------------------------------------------------------------------------! + real, intent(in) :: wl(kw) + real, intent(in) :: wc(kw) + real, intent(in) :: tlev(kz) + real, intent(in) :: airlev(kz) + + integer, intent(in) :: nz + integer, intent(in) :: nw + + character*80, intent(in) :: pn + character*60, intent(out) :: jlabel(kj) + real, intent(out) :: sq(kj,kz,kw) + +!-----------------------------------------------------------------------------! +! ... input/output ! +!-----------------------------------------------------------------------------! + integer, intent(inout) :: j + +!-----------------------------------------------------------------------------! +! ... local ! +!-----------------------------------------------------------------------------! + integer kdata + parameter(kdata=300) + integer i, iw, n, idum, nloop, n1 + integer ierr, iz, iwc, icnt + + real x1 (kdata), y1 (kdata) + real xin (kdata), yin(kdata) + real wctmp (kdata), wcb(kdata) + real ytmp (nz,kdata) + real ycomb (nz,kdata) + real ytd (nz,kw) + real yg1 (kw) + real AA (5), BB(5), lp(5) + real tin(nz) + real ysave, qy + + AA(1) = 62.563 + AA(2) = -2.0068 + AA(3) = 1.6592e-2 + AA(4) = -5.6465e-5 + AA(5) = 6.7459e-8 + + BB(1) = -9.1755e-1 + BB(2) = 1.8575e-2 + BB(3) = -1.3857e-4 + BB(4) = 4.5066e-7 + BB(5) = -5.3803e-10 + + lp(1) = 0.0 + lp(2) = 1.0 + lp(3) = 2.0 + lp(4) = 3.0 + lp(5) = 4.0 + +!---------------------------------------------- +! ... tin set to tlev +!---------------------------------------------- + tin(:) = tlev(:) + +!---------------------------------------------- +! ... jlabel(j) = 'H1301 -> Br' +!---------------------------------------------- + j = j+1 + jlabel(j) = 'H1301 + hv -> Br' + +!---------------------------------------------------------- +! Derive temperature dependence +!----------------------------------------------------------- +! Temperature dependence good between 210-300K and 178 nm-280 nm + iwc = 1 + ytmp(:,:)= 0.0 + + do iw = 1, nw-1 + + IF ((wc(iw) .GE. 178.) .AND. (wc(iw) .LE.280.)) THEN + + do iz = 1, nz + + IF (tin(iz) .LT. 210.) THEN + do nloop = 1, 5 + ytmp(iz,iwc) = ytmp(iz,iwc) + & + AA(nloop)* (wc(iw)**lp(nloop)) + & + (210.0-273.0)*BB(nloop)*wc(iw)**lp(nloop) + enddo + wctmp(iwc) = wc(iw) + ENDIF + + IF ((tin(iz) .GE. 210.).AND.(tin(iz) .LE. 300.)) THEN + do nloop = 1,5 + + ytmp(iz,iwc) = ytmp(iz,iwc) + & + AA(nloop)* (wc(iw)**lp(nloop)) + & + (tin(iz)-273.0)*BB(nloop)*wc(iw)**lp(nloop) + enddo + wctmp(iwc) = wc(iw) + ENDIF + + IF (tin(iz) .GT. 300.) THEN + do nloop = 1, 5 + ytmp(iz,iwc) = ytmp(iz,iwc) + & + AA(nloop)* (wc(iw)**lp(nloop)) + & + (300.0-273.0)*BB(nloop)*wc(iw)**lp(nloop) + enddo + wctmp(iwc) = wc(iw) + ENDIF + enddo + iwc = iwc+ 1 + + ENDIF + + enddo + +! ... For wavelengths >280 nm and <178 nm + open(kin,file=TRIM(pn)//'XS_H1301_JPL06.txt',status='old') + + read(kin,*) idum, n + do i = 1, idum-2 + read(kin,*) + enddo + + do i = 1, n + read(kin,*) xin(i), yin(i) + enddo + close(kin) + +! ... Combine cross sections + do iz = 1, nz + icnt = 1 + +! ... < 178nm + do i = 1, n + IF (xin(i) .LT. 178.) THEN + ycomb(iz,icnt) = yin(i) + wcb (icnt) = xin(i) + icnt = icnt + 1 + ENDIF + enddo +! ... 178-280 nm + do i = 1, iwc-1 + ycomb(iz,icnt) = 10**(ytmp(iz,i)) + wcb (icnt) = wctmp(i) + icnt = icnt+1 + enddo +! ... >280nm + do i = 1, n + IF (xin(i) .GT. 280.) THEN + ycomb(iz,icnt) = yin(i) + wcb (icnt) = xin(i) + icnt = icnt+1 + ENDIF + enddo + enddo + +! ... interpolate + do iz = 1, nz + n1 = icnt-1 + y1 = ycomb(iz,:) + x1 = wcb +!---------------------------------------------------------- +! do iw = 1, icnt-1 +! print*, iw, wcb(iw), ycomb(iz,iw), tin(iz) +! enddo +! stop +!---------------------------------------------------------- + call addpnt(x1,y1,kdata,n1,x1(1)*(1.-deltax),0.) + call addpnt(x1,y1,kdata,n1, 0.,0.) + call addpnt(x1,y1,kdata,n1,x1(n1)*(1.+deltax),0.) + call addpnt(x1,y1,kdata,n1, 1e38,0.) + call inter2(nw,wl,yg1,n1,x1,y1,ierr) + ytd(iz,:) = yg1(:) + + if (ierr .ne. 0) then + write(*,*) ierr, jlabel(j) + stop + endif + enddo + +!---------------------------------------------------------- +! iz = 1 +! do iw = 15, 70 +! print*, iw, wc(iw), ytd(iz,iw), tin(iz) +! enddo +! stop +!---------------------------------------------------------- +!---------------------------------------------------------- +! ...quantum yield assumed to be unity +!---------------------------------------------------------- + qy = 1. + + do iw = 1, nw-1 + do iz = 1, nz + sq(j,iz,iw) = qy * ytd(iz,iw) + enddo + enddo + + end subroutine XSQY_H1301 diff --git a/test/unit/tuv_doug/JCALC/XSQY_H2402.f b/test/unit/tuv_doug/JCALC/XSQY_H2402.f new file mode 100644 index 00000000..23b9f246 --- /dev/null +++ b/test/unit/tuv_doug/JCALC/XSQY_H2402.f @@ -0,0 +1,235 @@ + subroutine XSQY_H2402(nw,wl,wc,nz,tlev,airlev,j,sq,jlabel,pn) +!-----------------------------------------------------------------------------! +! purpose: ! +! provide product (cross section) x (quantum yield) for h2402 photolysis: ! +! H2402 (CF2BrCF2Br)+ hv -> 2Br ! +! cross section: from JPL06 recommendation ! +! quantum yield: assumed to be unity ! +!-----------------------------------------------------------------------------! +! parameters: ! +! nw - integer, number of specified intervals + 1 in working (i) ! +! wavelength grid ! +! wl - real, vector of lower limits of wavelength intervals in (i) ! +! working wavelength grid ! +! wc - real, vector of center points of wavelength intervals in (i) ! +! working wavelength grid ! +! nz - integer, number of altitude levels in working altitude grid (i) ! +! tlev - real, temperature (k) at each specified altitude level (i) ! +! airlev - real, air density (molec/cc) at each altitude level (i) ! +! j - integer, counter for number of weighting functions defined (io) ! +! sq - real, cross section x quantum yield (cm^2) for each (o) ! +! photolysis reaction defined, at each defined wavelength and ! +! at each defined altitude level ! +! jlabel - character*60, string identifier for each photolysis reaction (o) ! +! defined ! +!-----------------------------------------------------------------------------! +! edit history: ! +! 07/30/07 Doug Kinnison ! +!-----------------------------------------------------------------------------! + implicit none + include 'params' + +!-----------------------------------------------------------------------------! +! ... input ! +!-----------------------------------------------------------------------------! + real, intent(in) :: wl(kw) + real, intent(in) :: wc(kw) + real, intent(in) :: tlev(kz) + real, intent(in) :: airlev(kz) + + integer, intent(in) :: nz + integer, intent(in) :: nw + + character*80, intent(in) :: pn + character*60, intent(out) :: jlabel(kj) + real, intent(out) :: sq(kj,kz,kw) + +!-----------------------------------------------------------------------------! +! ... input/output ! +!-----------------------------------------------------------------------------! + integer, intent(inout) :: j + +!-----------------------------------------------------------------------------! +! ... local ! +!-----------------------------------------------------------------------------! + integer kdata + parameter(kdata=300) + integer i, iw, n, idum, nloop, n1 + integer ierr, iz, iwc, icnt + real x1 (kdata), y1 (kdata) + real xin (kdata), yin (kdata) + real wctmp(kdata), wcb (kdata) + real ytmp (nz,kdata),ycomb(nz,kdata) + real yg1 (kw), ytd (nz,kw) + real qy + real AA(5), BB(5), lp(5) + real tin(nz) + + AA(1) = 34.026 + AA(2) = -1.152616 + AA(3) = 8.959798e-3 + AA(4) = -2.9089e-5 + AA(5) = 3.307212e-8 + + BB(1) = 4.010664e-1 + BB(2) = -8.358968e-3 + BB(3) = 6.415741e-5 + BB(4) = -2.157554e-7 + BB(5) = 2.691871e-10 + + lp(1) = 0.0 + lp(2) = 1.0 + lp(3) = 2.0 + lp(4) = 3.0 + lp(5) = 4.0 + +!---------------------------------------------- +! ... set tin to tlev +!---------------------------------------------- + tin(:) = tlev(:) + +!---------------------------------------------- +! ... jlabel(j) = 'H2402 (CF2BrCF2Br)+ hv -> 2Br' +!---------------------------------------------- + j = j+1 + jlabel(j) = 'H2402 + hv -> 2Br' + +!---------------------------------------------- +! Derive temperature dependence +!---------------------------------------------- +! Temperature dependence good between +! 210-300K and 190 nm to 290 nm +!---------------------------------------------- + iwc = 1 + ytmp(:,:)= 0.0 + + + do iw = 1, nw-1 + + IF ((wc(iw) .GE. 190.) .AND. (wc(iw) .LE.290.)) THEN + + do iz = 1, nz + + IF (tin(iz) .LT. 210.) THEN + do nloop = 1, 5 + ytmp(iz,iwc) = ytmp(iz,iwc) + & + AA(nloop)* (wc(iw)**lp(nloop)) + & + (210.0-273.0)*BB(nloop)*wc(iw)**lp(nloop) + enddo + wctmp(iwc) = wc(iw) + ENDIF + + IF ((tin(iz) .GE. 210.).AND.(tin(iz) .LE. 300.)) THEN + do nloop = 1,5 + + ytmp(iz,iwc) = ytmp(iz,iwc) + & + AA(nloop)* (wc(iw)**lp(nloop)) + & + (tin(iz)-273.0)*BB(nloop)*wc(iw)**lp(nloop) + enddo + wctmp(iwc) = wc(iw) + ENDIF + + IF (tin(iz) .GT. 300.) THEN + do nloop = 1, 5 + ytmp(iz,iwc) = ytmp(iz,iwc) + & + AA(nloop)* (wc(iw)**lp(nloop)) + & + (300.0-273.0)*BB(nloop)*wc(iw)**lp(nloop) + enddo + wctmp(iwc) = wc(iw) + ENDIF + enddo + iwc = iwc+ 1 + + ENDIF + + enddo +!---------------------------------------------- +! ... For wavelengths >290 nm and <190 nm +!---------------------------------------------- + open(kin,file=TRIM(pn)//'XS_H2402_JPL06.txt',status='old') + + read(kin,*) idum, n + do i = 1, idum-2 + read(kin,*) + enddo + + do i = 1, n + read(kin,*) xin(i), yin(i) + enddo + close(kin) + +!---------------------------------------------- +! ... Combine cross sections +!---------------------------------------------- + do iz = 1, nz + icnt = 1 + +! ... < 190nm + do i = 1, n + IF (xin(i) .LT. 190.) THEN + ycomb(iz,icnt) = yin(i) + wcb (icnt) = xin(i) + icnt = icnt + 1 + ENDIF + enddo +! ... 190-290 nm + do i = 1, iwc-1 + ycomb(iz,icnt) = 10**(ytmp(iz,i)) + wcb (icnt) = wctmp(i) + icnt = icnt+1 + enddo +! ... >290nm + do i = 1, n + IF (xin(i) .GT. 290.) THEN + ycomb(iz,icnt) = yin(i) + wcb (icnt) = xin(i) + icnt = icnt+1 + ENDIF + enddo + enddo +!---------------------------------------------- +! ... interpolate +!---------------------------------------------- + do iz = 1, nz + n1 = icnt-1 + y1 = ycomb(iz,:) + x1 = wcb +!---------------------------------------------- +! print*,'jh2402' +! do iw = 1, icnt-1 +! print*, iw, wcb(iw), ycomb(iz,iw), tin(iz) +! enddo +! stop +!---------------------------------------------- + call addpnt(x1,y1,kdata,n1,x1(1)*(1.-deltax),0.) + call addpnt(x1,y1,kdata,n1, 0.,0.) + call addpnt(x1,y1,kdata,n1,x1(n1)*(1.+deltax),0.) + call addpnt(x1,y1,kdata,n1, 1e38,0.) + call inter2(nw,wl,yg1,n1,x1,y1,ierr) + ytd(iz,:) = yg1(:) + + if (ierr .ne. 0) then + write(*,*) ierr, jlabel(j) + stop + endif + enddo + +!---------------------------------------------- +! iz = 1 +! do iw = 15, 77 +! print*, iw, wc(iw), ytd(iz,iw), tin(iz) +! enddo +! stop +!---------------------------------------------- +!---------------------------------------------- +! ...quantum yield assumed to be unity +!---------------------------------------------- + qy = 1. + + do iw = 1, nw-1 + do iz = 1, nz + sq(j,iz,iw) = qy * ytd(iz,iw) + enddo + enddo + + end subroutine XSQY_H2402 diff --git a/test/unit/tuv_doug/JCALC/XSQY_HCFC141b.f b/test/unit/tuv_doug/JCALC/XSQY_HCFC141b.f new file mode 100644 index 00000000..9c49b980 --- /dev/null +++ b/test/unit/tuv_doug/JCALC/XSQY_HCFC141b.f @@ -0,0 +1,231 @@ + subroutine XSQY_HCFC141b(nw,wl,wc,nz,tlev,airlev,j,sq,jlabel,pn) +!-----------------------------------------------------------------------------! +! purpose: ! +! provide product (cross section) x (quantum yield) for cfc113 photolysis: ! +! HCFC141b + hv -> 2Cl ! +! cross section: from JPL10 recommendation ! +! quantum yield: assumed to be unity ! +!-----------------------------------------------------------------------------! +! parameters: ! +! nw - integer, number of specified intervals + 1 in working (i) ! +! wavelength grid ! +! wl - real, vector of lower limits of wavelength intervals in (i) ! +! working wavelength grid ! +! wc - real, vector of center points of wavelength intervals in (i) ! +! working wavelength grid ! +! nz - integer, number of altitude levels in working altitude grid (i) ! +! tlev - real, temperature (k) at each specified altitude level (i) ! +! airlev - real, air density (molec/cc) at each altitude level (i) ! +! j - integer, counter for number of weighting functions defined (io) ! +! sq - real, cross section x quantum yield (cm^2) for each (o) ! +! photolysis reaction defined, at each defined wavelength and ! +! at each defined altitude level ! +! jlabel - character*60, string identifier for each photolysis reaction (o) ! +! defined ! +!-----------------------------------------------------------------------------! +! edit history: ! +! 01/06/12 Doug Kinnison ! +!-----------------------------------------------------------------------------! + implicit none + include 'params' + +!-----------------------------------------------------------------------------! +! ... input ! +!-----------------------------------------------------------------------------! + real, intent(in) :: wl(kw) + real, intent(in) :: wc(kw) + real, intent(in) :: tlev(kz) + real, intent(in) :: airlev(kz) + + integer, intent(in) :: nz + integer, intent(in) :: nw + + character*80, intent(in) :: pn + character*60, intent(out) :: jlabel(kj) + real, intent(out) :: sq(kj,kz,kw) + +!-----------------------------------------------------------------------------! +! ... input/output ! +!-----------------------------------------------------------------------------! + integer, intent(inout) :: j + +!-----------------------------------------------------------------------------! +! ... local ! +!-----------------------------------------------------------------------------! + integer kdata + parameter(kdata=300) + integer i, iw, n, idum, nloop, n1 + integer ierr, iz, iwc, icnt + real x1 (kdata), y1 (kdata) + real xin (kdata), yin (kdata) + real wctmp(kdata), wcb (kdata) + real ytmp (nz,kdata), ycomb(nz,kdata) + real yg1(kw), tin (nz) + real ytd (nz,kw) + real AA(5), BB(5), lp(5) + real qy, ysave + + AA(1) = -682.913042 + AA(2) = 12.122290 + AA(3) = -8.187699e-2 + AA(4) = 2.437244e-4 + AA(5) = -2.719103e-7 + + BB(1) = 4.074747 + BB(2) = -8.053899e-2 + BB(3) = 5.946552e-4 + BB(4) = -1.945048e-6 + BB(5) = 2.380143e-9 + + lp(1) = 0.0 + lp(2) = 1.0 + lp(3) = 2.0 + lp(4) = 3.0 + lp(5) = 4.0 + +!--------------------------------------------------- +! ... tin set to tlev +!--------------------------------------------------- + tin(:) = tlev(:) +!--------------------------------------------------- +! ... jlabel(j) = 'hcfc141b -> 2cl' +!--------------------------------------------------- + j = j+1 + jlabel(j) = 'HCFC141b + hv -> 2Cl' + +!--------------------------------------------------- +! Derive temperature dependence +!--------------------------------------------------- +! Temperature dependence good between +! 210-300K and 172 nm-240 nm +!--------------------------------------------------- + iwc = 1 + ytmp(:,:)= 0.0 + + do iw = 1, nw-1 + + IF ((wc(iw) .GE. 172.) .AND. (wc(iw) .LE.240.)) THEN + + do iz = 1, nz + + IF (tin(iz) .LT. 210.) THEN + do nloop = 1, 5 + ytmp(iz,iwc) = ytmp(iz,iwc) + & + AA(nloop)* (wc(iw)**lp(nloop)) + & + (210.0-273.0)*BB(nloop)*wc(iw)**lp(nloop) + enddo + wctmp(iwc) = wc(iw) + ENDIF + + IF ((tin(iz) .GE. 210.).AND.(tin(iz) .LE. 300.)) THEN + do nloop = 1,5 + + ytmp(iz,iwc) = ytmp(iz,iwc) + & + AA(nloop)* (wc(iw)**lp(nloop)) + & + (tin(iz)-273.0)*BB(nloop)*wc(iw)**lp(nloop) + enddo + wctmp(iwc) = wc(iw) + ENDIF + + IF (tin(iz) .GT. 300.) THEN + do nloop = 1, 5 + ytmp(iz,iwc) = ytmp(iz,iwc) + & + AA(nloop)* (wc(iw)**lp(nloop)) + & + (300.0-273.0)*BB(nloop)*wc(iw)**lp(nloop) + enddo + wctmp(iwc) = wc(iw) + ENDIF + enddo + iwc = iwc+ 1 + + ENDIF + + enddo +!--------------------------------------------------- +! ... For wavelengths >220nm +!--------------------------------------------------- + open(kin,file=TRIM(pn)//'XS_HCFC141b_JPL10.txt',status='old') + + read(kin,*) idum, n + do i = 1, idum-2 + read(kin,*) + enddo + + do i = 1, n + read(kin,*) xin(i), yin(i) + enddo + close(kin) + +!--------------------------------------------------- +! ... Combine cross sections +!--------------------------------------------------- + do iz = 1, nz + icnt = 1 +! ... LT 172nm + do i = 1, n + IF (xin(i) .LT. 172.) THEN + ycomb(iz,icnt) = yin(i) + wcb (icnt) = xin(i) + icnt = icnt+1 + ENDIF + enddo +! ... 172-240 nm + do i = 1, iwc-1 + ycomb(iz,icnt) = 10**(ytmp(iz,i)) + wcb (icnt) = wctmp(i) + icnt = icnt+1 + enddo +! ... >240nm + do i = 1, n + IF (xin(i) .GT. 240.) THEN + ycomb(iz,icnt) = yin(i) + wcb (icnt) = xin(i) + icnt = icnt+1 + ENDIF + enddo + enddo +!--------------------------------------------------- +! ... interpolate +!--------------------------------------------------- + do iz = 1, nz + n1 = icnt-1 + y1 = ycomb(iz,:) + x1 = wcb +!--------------------------------------------------- +! iz = 1 +! do iw = 1, icnt-1 +! print*, iw, wcb(iw), ycomb(iz,iw), tin(iz) +! enddo +! stop +!--------------------------------------------------- + call addpnt(x1,y1,kdata,n1,x1(1)*(1.-deltax),0.) + call addpnt(x1,y1,kdata,n1, 0.,0.) + call addpnt(x1,y1,kdata,n1,x1(n1)*(1.+deltax),0.) + call addpnt(x1,y1,kdata,n1, 1e38,0.) + call inter2(nw,wl,yg1,n1,x1,y1,ierr) + ytd(iz,:) = yg1(:) + + if (ierr .ne. 0) then + write(*,*) ierr, jlabel(j) + stop + endif + enddo + +!---------------------------------------------------- +! iz = 1 +! do iw = 10, 64 +! print*, iw, wc(iw), ytd(iz,iw), tin(iz) +! enddo +! stop +!---------------------------------------------------- +!---------------------------------------------------- +! ...quantum yield assumed to be unity +!---------------------------------------------------- + qy = 1. + do iw = 1, nw-1 + do iz = 1, nz + sq(j,iz,iw) = qy * ytd(iz,iw) + enddo + enddo + + end subroutine XSQY_HCFC141b diff --git a/test/unit/tuv_doug/JCALC/XSQY_HCFC142b.f b/test/unit/tuv_doug/JCALC/XSQY_HCFC142b.f new file mode 100644 index 00000000..723ced35 --- /dev/null +++ b/test/unit/tuv_doug/JCALC/XSQY_HCFC142b.f @@ -0,0 +1,231 @@ + subroutine XSQY_HCFC142b(nw,wl,wc,nz,tlev,airlev,j,sq,jlabel,pn) +!-----------------------------------------------------------------------------! +! purpose: ! +! provide product (cross section) x (quantum yield) for cfc113 photolysis: ! +! HCFC142b + hv -> Cl ! +! cross section: from JPL10 recommendation ! +! quantum yield: assumed to be unity ! +!-----------------------------------------------------------------------------! +! parameters: ! +! nw - integer, number of specified intervals + 1 in working (i) ! +! wavelength grid ! +! wl - real, vector of lower limits of wavelength intervals in (i) ! +! working wavelength grid ! +! wc - real, vector of center points of wavelength intervals in (i) ! +! working wavelength grid ! +! nz - integer, number of altitude levels in working altitude grid (i) ! +! tlev - real, temperature (k) at each specified altitude level (i) ! +! airlev - real, air density (molec/cc) at each altitude level (i) ! +! j - integer, counter for number of weighting functions defined (io) ! +! sq - real, cross section x quantum yield (cm^2) for each (o) ! +! photolysis reaction defined, at each defined wavelength and ! +! at each defined altitude level ! +! jlabel - character*60, string identifier for each photolysis reaction (o) ! +! defined ! +!-----------------------------------------------------------------------------! +! edit history: ! +! 01/06/12 Doug Kinnison ! +!-----------------------------------------------------------------------------! + implicit none + include 'params' + +!-----------------------------------------------------------------------------! +! ... input ! +!-----------------------------------------------------------------------------! + real, intent(in) :: wl(kw) + real, intent(in) :: wc(kw) + real, intent(in) :: tlev(kz) + real, intent(in) :: airlev(kz) + + integer, intent(in) :: nz + integer, intent(in) :: nw + + character*80, intent(in) :: pn + character*60, intent(out) :: jlabel(kj) + real, intent(out) :: sq(kj,kz,kw) + +!-----------------------------------------------------------------------------! +! ... input/output ! +!-----------------------------------------------------------------------------! + integer, intent(inout) :: j + +!-----------------------------------------------------------------------------! +! ... local ! +!-----------------------------------------------------------------------------! + integer kdata + parameter(kdata=300) + integer i, iw, n, idum, nloop, n1 + integer ierr, iz, iwc, icnt + real x1 (kdata), y1 (kdata) + real xin (kdata), yin (kdata) + real wctmp(kdata), wcb (kdata) + real ytmp (nz,kdata), ycomb(nz,kdata) + real yg1(kw), tin (nz) + real ytd (nz,kw) + real AA(5), BB(5), lp(5) + real qy, ysave + + AA(1) = -328.092008 + AA(2) = 6.342799 + AA(3) = -4.810362e-2 + AA(4) = 1.611991e-4 + AA(5) = -2.042613e-7 + + BB(1) = 4.289533e-1 + BB(2) = -9.042817e-3 + BB(3) = 7.018009e-5 + BB(4) = -2.389064e-7 + BB(5) = 3.039799e-10 + + lp(1) = 0.0 + lp(2) = 1.0 + lp(3) = 2.0 + lp(4) = 3.0 + lp(5) = 4.0 + +!--------------------------------------------------- +! ... tin set to tlev +!--------------------------------------------------- + tin(:) = tlev(:) +!--------------------------------------------------- +! ... jlabel(j) = 'hcfc142b -> cl' +!--------------------------------------------------- + j = j+1 + jlabel(j) = 'HCFC142b + hv -> Cl' + +!--------------------------------------------------- +! Derive temperature dependence +!--------------------------------------------------- +! Temperature dependence good between +! 210-300K and 172 nm-243 nm +!--------------------------------------------------- + iwc = 1 + ytmp(:,:)= 0.0 + + do iw = 1, nw-1 + + IF ((wc(iw) .GE. 172.) .AND. (wc(iw) .LE.230.)) THEN + + do iz = 1, nz + + IF (tin(iz) .LT. 210.) THEN + do nloop = 1, 5 + ytmp(iz,iwc) = ytmp(iz,iwc) + & + AA(nloop)* (wc(iw)**lp(nloop)) + & + (210.0-273.0)*BB(nloop)*wc(iw)**lp(nloop) + enddo + wctmp(iwc) = wc(iw) + ENDIF + + IF ((tin(iz) .GE. 210.).AND.(tin(iz) .LE. 300.)) THEN + do nloop = 1,5 + + ytmp(iz,iwc) = ytmp(iz,iwc) + & + AA(nloop)* (wc(iw)**lp(nloop)) + & + (tin(iz)-273.0)*BB(nloop)*wc(iw)**lp(nloop) + enddo + wctmp(iwc) = wc(iw) + ENDIF + + IF (tin(iz) .GT. 300.) THEN + do nloop = 1, 5 + ytmp(iz,iwc) = ytmp(iz,iwc) + & + AA(nloop)* (wc(iw)**lp(nloop)) + & + (300.0-273.0)*BB(nloop)*wc(iw)**lp(nloop) + enddo + wctmp(iwc) = wc(iw) + ENDIF + enddo + iwc = iwc+ 1 + + ENDIF + + enddo +!--------------------------------------------------- +! ... For wavelengths >220nm +!--------------------------------------------------- + open(kin,file=TRIM(pn)//'XS_HCFC142b_JPL10.txt',status='old') + + read(kin,*) idum, n + do i = 1, idum-2 + read(kin,*) + enddo + + do i = 1, n + read(kin,*) xin(i), yin(i) + enddo + close(kin) + +!--------------------------------------------------- +! ... Combine cross sections +!--------------------------------------------------- + do iz = 1, nz + icnt = 1 +! ... LT 172nm + do i = 1, n + IF (xin(i) .LT. 172.) THEN + ycomb(iz,icnt) = yin(i) + wcb (icnt) = xin(i) + icnt = icnt+1 + ENDIF + enddo +! ... 172-240 nm + do i = 1, iwc-1 + ycomb(iz,icnt) = 10**(ytmp(iz,i)) + wcb (icnt) = wctmp(i) + icnt = icnt+1 + enddo +! ... >240nm + do i = 1, n + IF (xin(i) .GT. 240.) THEN + ycomb(iz,icnt) = yin(i) + wcb (icnt) = xin(i) + icnt = icnt+1 + ENDIF + enddo + enddo +!--------------------------------------------------- +! ... interpolate +!--------------------------------------------------- + do iz = 1, nz + n1 = icnt-1 + y1 = ycomb(iz,:) + x1 = wcb +!--------------------------------------------------- +! iz = 1 +! do iw = 1, icnt-1 +! print*, iw, wcb(iw), ycomb(iz,iw), tin(iz) +! enddo +! stop +!--------------------------------------------------- + call addpnt(x1,y1,kdata,n1,x1(1)*(1.-deltax),0.) + call addpnt(x1,y1,kdata,n1, 0.,0.) + call addpnt(x1,y1,kdata,n1,x1(n1)*(1.+deltax),0.) + call addpnt(x1,y1,kdata,n1, 1e38,0.) + call inter2(nw,wl,yg1,n1,x1,y1,ierr) + ytd(iz,:) = yg1(:) + + if (ierr .ne. 0) then + write(*,*) ierr, jlabel(j) + stop + endif + enddo + +!---------------------------------------------------- +! iz = 1 +! do iw = 10, 64 +! print*, iw, wc(iw), ytd(iz,iw), tin(iz) +! enddo +! stop +!---------------------------------------------------- +!---------------------------------------------------- +! ...quantum yield assumed to be unity +!---------------------------------------------------- + qy = 1. + do iw = 1, nw-1 + do iz = 1, nz + sq(j,iz,iw) = qy * ytd(iz,iw) + enddo + enddo + + end subroutine XSQY_HCFC142b diff --git a/test/unit/tuv_doug/JCALC/XSQY_HCFC22.f b/test/unit/tuv_doug/JCALC/XSQY_HCFC22.f new file mode 100644 index 00000000..a3901a4b --- /dev/null +++ b/test/unit/tuv_doug/JCALC/XSQY_HCFC22.f @@ -0,0 +1,238 @@ + subroutine XSQY_HCFC22(nw,wl,wc,nz,tlev,airlev,j,sq,jlabel,pn) +!-----------------------------------------------------------------------------! +! purpose: ! +! provide product (cross section) x (quantum yield) for photolysis: ! +! HCFC22 + hv -> Cl ! +! cross section: from JPL06 recommendation ! +! quantum yield: assumed to be unity ! +!-----------------------------------------------------------------------------! +! parameters: ! +! nw - integer, number of specified intervals + 1 in working (i) ! +! wavelength grid ! +! wl - real, vector of lower limits of wavelength intervals in (i) ! +! working wavelength grid ! +! wc - real, vector of center points of wavelength intervals in (i) ! +! working wavelength grid ! +! nz - integer, number of altitude levels in working altitude grid (i) ! +! tlev - real, temperature (k) at each specified altitude level (i) ! +! airlev - real, air density (molec/cc) at each altitude level (i) ! +! j - integer, counter for number of weighting functions defined (io) ! +! sq - real, cross section x quantum yield (cm^2) for each (o) ! +! photolysis reaction defined, at each defined wavelength and ! +! at each defined altitude level ! +! jlabel - character*60, string identifier for each photolysis reaction (o) ! +! defined ! +!-----------------------------------------------------------------------------! +! edit history: ! +! 07/30/07 Doug Kinnison ! +!-----------------------------------------------------------------------------! + implicit none + include 'params' + +!-----------------------------------------------------------------------------! +! ... input ! +!-----------------------------------------------------------------------------! + real, intent(in) :: wl(kw) + real, intent(in) :: wc(kw) + real, intent(in) :: tlev(kz) + real, intent(in) :: airlev(kz) + + integer, intent(in) :: nz + integer, intent(in) :: nw + + character*80, intent(in) :: pn + character*60, intent(out) :: jlabel(kj) + real, intent(out) :: sq(kj,kz,kw) + +!-----------------------------------------------------------------------------! +! ... input/output ! +!-----------------------------------------------------------------------------! + integer, intent(inout) :: j + +!-----------------------------------------------------------------------------! +! ... local ! +!-----------------------------------------------------------------------------! + integer kdata + parameter(kdata=300) + + integer i, iw, n, idum, nloop, n1 + integer ierr, iz, iwc, icnt + real x1 (kdata), y1 (kdata) + real xin (kdata), yin (kdata) + real wctmp(kdata), wcb (kdata) + real ytmp (nz,kdata), ycomb(nz,kdata) + real yg1(kw), tin (nz) + real ytd (nz,kw) + real AA(4), BB(4), lp(4) + real qy, ysave + real wctd(26) + + data wctd /170., 172., 174., 176., 178., 180., 182., 184., 186., + $ 188., 190., 192., 194., 196., 198., 200., 202., 204., + $ 206., 208., 210., 212., 214., 216., 218., 220./ + + AA(1) =-106.029 + AA(2) = 1.5038 + AA(3) = -8.2476e-3 + AA(4) = 1.4206e-5 + + BB(1) = -1.3399e-1 + BB(2) = 2.7405e-3 + BB(3) = -1.8028e-5 + BB(4) = 3.8504e-8 + + lp(1) = 0.0 + lp(2) = 1.0 + lp(3) = 2.0 + lp(4) = 3.0 + +!--------------------------------------------------- +! ... tin set to tlev +!--------------------------------------------------- + tin(:) = tlev(:) + +!--------------------------------------------------- +! ... jlabel(j) = 'HCFC22 -> Cl' +!--------------------------------------------------- + j = j+1 + jlabel(j) = 'HCFC22 + hv -> Cl' + +!--------------------------------------------------- +! Derive temperature dependence +!--------------------------------------------------- +! Temperature dependence good between +! 210-300K and 174 nm-204 nm +!--------------------------------------------------- + iwc = 1 + ytmp(:,:)= 0.0 + wctmp(:) = 0.0 + + do iw = 1, 26 + + IF ((wctd(iw) .GE. 174.) .AND. (wctd(iw) .LE.204.)) THEN + + do iz = 1, nz + + IF (tin(iz) .LT. 210.) THEN + do nloop = 1, 4 + ytmp(iz,iwc) = ytmp(iz,iwc) + & + AA(nloop)* (wctd(iw)**lp(nloop)) + & + (210.0-273.0)*BB(nloop)*wctd(iw)**lp(nloop) + enddo + wctmp(iwc) = wctd(iw) + ENDIF + + IF ((tin(iz) .GE. 210.).AND.(tin(iz) .LE. 300.)) THEN + do nloop = 1, 4 + + ytmp(iz,iwc) = ytmp(iz,iwc) + & + AA(nloop)* (wctd(iw)**lp(nloop)) + & +(tin(iz)-273.0)*BB(nloop)*wctd(iw)**lp(nloop) + enddo + wctmp(iwc) = wctd(iw) + ENDIF + + IF (tin(iz) .GT. 300.) THEN + do nloop = 1, 4 + ytmp(iz,iwc) = ytmp(iz,iwc) + & + AA(nloop)* (wctd(iw)**lp(nloop)) + & + (300.0-273.0)*BB(nloop)*wctd(iw)**lp(nloop) + enddo + wctmp(iwc) = wctd(iw) + ENDIF + enddo + iwc = iwc+ 1 + + ENDIF + + enddo + +!--------------------------------------------------- +! ... For wavelengths >204 nm and <174 nm +!--------------------------------------------------- + open(kin,file=TRIM(pn)//'XS_HCFC22_JPL06.txt',status='old') + + read(kin,*) idum, n + do i = 1, idum-2 + read(kin,*) + enddo + + do i = 1, n + read(kin,*) xin(i), yin(i) + enddo + close(kin) + +!--------------------------------------------------- +! ... Combine cross sections +!--------------------------------------------------- + do iz = 1, nz + icnt = 1 + +! ... < 174nm + do i = 1, n + IF (xin(i) .LT. 174.) THEN + ycomb(iz,icnt) = yin(i) + wcb (icnt) = xin(i) + icnt = icnt + 1 + ENDIF + enddo +! ... 174-204 nm + do i = 1, iwc-1 + ycomb(iz,icnt) = 10**(ytmp(iz,i)) + wcb (icnt) = wctmp(i) + icnt = icnt+1 + enddo +! ... >204nm + do i = 1, n + IF (xin(i) .GT. 204.) THEN + ycomb(iz,icnt) = yin(i) + wcb (icnt) = xin(i) + icnt = icnt+1 + ENDIF + enddo + enddo +!--------------------------------------------------- +! ... interpolate +!--------------------------------------------------- + do iz = 1, nz + n1 = icnt-1 + y1 = ycomb(iz,:) + x1 = wcb +!--------------------------------------------------- +! do iw = 1, icnt-1 +! print*, iw, wcb(iw), ycomb(iz,iw), tin(iz) +! enddo +! stop +!--------------------------------------------------- + call addpnt(x1,y1,kdata,n1,x1(1)*(1.-deltax),0.) + call addpnt(x1,y1,kdata,n1, 0.,0.) + call addpnt(x1,y1,kdata,n1,x1(n1)*(1.+deltax),0.) + call addpnt(x1,y1,kdata,n1, 1e38,0.) + call inter2(nw,wl,yg1,n1,x1,y1,ierr) + ytd(iz,:) = yg1(:) + + if (ierr .ne. 0) then + write(*,*) ierr, jlabel(j) + stop + endif + enddo + +!--------------------------------------------------- +! iz = 1 +! do iw = 10, 45 +! print*, iw, wc(iw), ytd(iz,iw), tin(iz) +! enddo +! stop +!--------------------------------------------------- +!--------------------------------------------------- +! ...quantum yield assumed to be unity +!--------------------------------------------------- + qy = 1. + + do iw = 1, nw-1 + do iz = 1, nz + sq(j,iz,iw) = qy * ytd(iz,iw) + enddo + enddo + + end subroutine XSQY_HCFC22 diff --git a/test/unit/tuv_doug/JCALC/XSQY_HNO3.f b/test/unit/tuv_doug/JCALC/XSQY_HNO3.f new file mode 100644 index 00000000..67792b40 --- /dev/null +++ b/test/unit/tuv_doug/JCALC/XSQY_HNO3.f @@ -0,0 +1,140 @@ + subroutine XSQY_HNO3(nw,wl,wc,nz,tlev,airlev,j,sq,jlabel,pn) +!-----------------------------------------------------------------------------! +! purpose: ! +! provide product of (cross section) x (quantum yield) for photolysis ! +! hno3 + hv -> oh + no2 ! +! cross section: burkholder et al., 1993 (and JPL06) ! +! quantum yield: assumed to be unity ! +!-----------------------------------------------------------------------------! +! parameters: ! +! nw - integer, number of specified intervals + 1 in working (i) ! +! wavelength grid ! +! wl - real, vector of lower limits of wavelength intervals in (i) ! +! working wavelength grid ! +! wc - real, vector of center points of wavelength intervals in (i) ! +! working wavelength grid ! +! nz - integer, number of altitude levels in working altitude grid (i) ! +! tlev - real, temperature (k) at each specified altitude level (i) ! +! airlev - real, air density (molec/cc) at each altitude level (i) ! +! j - integer, counter for number of weighting functions defined (io) ! +! sq - real, cross section x quantum yield (cm^2) for each (o) ! +! photolysis reaction defined, at each defined wavelength and ! +! at each defined altitude level ! +! jlabel - character*60, string identifier for each photolysis reaction (o) ! +! defined ! +!-----------------------------------------------------------------------------! +! edit history: ! +! 05/98 original, adapted from former jspec1 subroutine ! +! 01/15/08 minor update,dek ! +!-----------------------------------------------------------------------------! + implicit none + include 'params' + +!-----------------------------------------------------------------------------! +! ... input ! +!-----------------------------------------------------------------------------! + real, intent(in) :: wl(kw) + real, intent(in) :: wc(kw) + real, intent(in) :: tlev(kz) + real, intent(in) :: airlev(kz) + + integer, intent(in) :: nz + integer, intent(in) :: nw + + character*80, intent(in) :: pn + character*60, intent(out) :: jlabel(kj) + real, intent(out) :: sq(kj,kz,kw) + +!-----------------------------------------------------------------------------! +! ... input/output ! +!-----------------------------------------------------------------------------! + integer, intent(inout) :: j + +!-----------------------------------------------------------------------------! +! ... local ! +!-----------------------------------------------------------------------------! + integer kdata + parameter(kdata=100) + integer n1, n2 + integer i, iw, n, idum, iz + integer ierr + real x1 (kdata), x2 (kdata) + real y1 (kdata), y2 (kdata) + real yg1(kw), yg2(kw) + real yg( kw) + real tin(nz) + +!---------------------------------------------- +! ... tin set to tlev +!---------------------------------------------- + tin(:) = tlev(:) + +!---------------------------------------------- +! ... jlabel(j) = 'HNO3 -> OH + NO2 +!---------------------------------------------- + j = j + 1 + jlabel(j) = 'HNO3 + hv -> OH + NO2' + +!----------------------------------------------------------------------- +! ... hno3 cross section parameters from burkholder et al. 1993 +!----------------------------------------------------------------------- + open(kin,file=TRIM(pn)//'XS_HNO3_JPL06.txt',status='old') + +!... read lambda and cross sections + read(kin,*) idum, n + do i = 1, idum-2 + read(kin,*) + enddo + do i = 1, n + read(kin,*) x1(i), y1(i) + enddo + +!... read lambda and T-dep coeff. + read(kin,*) + do i = 1, n + read(kin,*) x2(i), y2(i) + enddo + close(kin) + + call addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.) + call addpnt(x1,y1,kdata,n, 0.,0.) + call addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.) + call addpnt(x1,y1,kdata,n, 1e38,0.) + call inter2(nw,wl,yg1,n,x1,y1,ierr) + if (ierr .ne. 0) then + write(*,*) ierr, jlabel(j) + stop + endif + + n= 80 + call addpnt(x2,y2,kdata,n,x2(1)*(1.-deltax),0.) + call addpnt(x2,y2,kdata,n, 0.,0.) + call addpnt(x2,y2,kdata,n,x2(n)*(1.+deltax),0.) + call addpnt(x2,y2,kdata,n, 1.e+38,0.) + call inter2(nw,wl,yg2,n,x2,y2,ierr) + if (ierr .ne. 0) then + write(*,*) ierr, jlabel(j) + stop + endif + +!-------------------------------------------------- +! ... quantum yield = 1 +! correct for temperature dependence +!-------------------------------------------------- + do iw = 1, nw - 1 + do iz = 1, nz + sq(j,iz,iw) = yg1(iw) + $ * exp( yg2(iw)/1.e3*(tin(iz)-298.) ) + enddo + enddo + +!------------------------------------------------------- +! ... Check routine (no temperature dependence +! iz = 1 +! do iw = 29, 79 +! print*, iw, wc(iw), sq(j,iz,iw) +! enddo +! stop +!------------------------------------------------------- + + end subroutine XSQY_HNO3 diff --git a/test/unit/tuv_doug/JCALC/XSQY_HO2NO2.f b/test/unit/tuv_doug/JCALC/XSQY_HO2NO2.f new file mode 100644 index 00000000..5865bf03 --- /dev/null +++ b/test/unit/tuv_doug/JCALC/XSQY_HO2NO2.f @@ -0,0 +1,210 @@ + subroutine XSQY_HO2NO2(nw,wl,wc,nz,tlev,airlev,j,sq,jlabel,pn) +!-----------------------------------------------------------------------------! +! purpose: ! +! provide product of (cross section) x (quantum yield) for hno4 photolysis ! +! 1) HO2NO2 + hv -> HO2 + NO2 ! +! 2) HO2NO2 + hv -> OH + NO3 ! +! cross sections and QY from JPL06 ! +!-----------------------------------------------------------------------------! +! parameters: ! +! nw - integer, number of specified intervals + 1 in working (i) ! +! wavelength grid ! +! wl - real, vector of lower limits of wavelength intervals in (i) ! +! working wavelength grid ! +! wc - real, vector of center points of wavelength intervals in (i) ! +! working wavelength grid ! +! nz - integer, number of altitude levels in working altitude grid (i) ! +! tlev - real, temperature (k) at each specified altitude level (i) ! +! airlev - real, air density (molec/cc) at each altitude level (i) ! +! j - integer, counter for number of weighting functions defined (io) ! +! sq - real, cross section x quantum yield (cm^2) for each (o) ! +! photolysis reaction defined, at each defined wavelength and ! +! at each defined altitude level ! +! jlabel - character*60, string identifier for each photolysis reaction (o) ! +! defined ! +!-----------------------------------------------------------------------------! +! edit history: ! +! 05/98 original, adapted from former jspec1 subroutine ! +! 06/01 modified by doug kinnison ! +! 01/08 modified by Doug Kinnison ! +!-----------------------------------------------------------------------------! + implicit none + include 'params' + +!-----------------------------------------------------------------------------! +! ... input ! +!-----------------------------------------------------------------------------! + real, intent(in) :: wl(kw) + real, intent(in) :: wc(kw) + real, intent(in) :: tlev(kz) + real, intent(in) :: airlev(kz) + + integer, intent(in) :: nz + integer, intent(in) :: nw + + character*80, intent(in) :: pn + character*60, intent(out) :: jlabel(kj) + real, intent(out) :: sq(kj,kz,kw) + +!-----------------------------------------------------------------------------! +! ... input/output ! +!-----------------------------------------------------------------------------! + integer, intent(inout) :: j + +!-----------------------------------------------------------------------------! +! ... local ! +!-----------------------------------------------------------------------------! + integer kdata + parameter(kdata=100) + integer i, iw, iz, n, n1, idum, ierr, icnt + real x1 (kdata), x2(kdata), wcb(kdata) + real y1 (kdata), aa(kdata), bb (kdata) + real ytmp (nz,kdata), ycomb(nz,kdata) + real ytd (nz,kw), yg(kw) + real Q(nz), tin(nz), t + +!---------------------------------------------- +! ... tin set to tlev +!---------------------------------------------- + tin(:) = tlev(:) + +!---------------------------------------------- +! ... jlabel(j) = 'HO2NO2 -> HO2 + NO2 +! jlabel(j) = 'HO2NO2 -> OH + NO3 +!---------------------------------------------- + j = j + 1 + jlabel(j) = 'HO2NO2 + hv -> OH + NO3' + +!---------------------------------------------- +! ...ho2no2 cross sections plus T-dep. +! (Burkholder et al., 2002.) +!---------------------------------------------- + open(kin,file=TRIM(pn)//'XS_HO2NO2_JPL06.txt',status='old') + +!... read lambda and cross sections + read(kin,*) idum, n + do i = 1, idum-2 + read(kin,*) + enddo + do i = 1, n + read(kin,*) x1(i), y1(i) + enddo + +!... read lambda and T-dep coeff. + read(kin,*) + read(kin,*) idum, n1 + do i = 1, n1 + read(kin,*) x2(i), aa(i), bb(i) + enddo + close(kin) + +!---------------------------------------------- +! ...Derive T-dep Burkholder et al., 2002.) +!---------------------------------------------- + do iz = 1, nz + do iw = 1, n1 + t = MAX(280.,MIN(tin(iz),350.)) + Q(iz) = 1 + exp(-988./(0.69*t)) + ytmp(iz,iw) = ( aa(iw)/Q(iz) + bb(iw)*(1-1/Q(iz)))*1e-20 + enddo + enddo +!---------------------------------------------- +! ... Check routine +! iz = 1 +! do iw = 1, n1 +! print*, iw, x2(iw), ytmp(iz,iw) +! enddo +! stop +!---------------------------------------------- +! ... Combine cross sections + do iz = 1, nz + icnt = 1 + +! ... < 280 nm +! ... x1(iw) goes from 190-350nm + do iw = 1, n + IF (x1(iw) .LT. 280.) THEN + ycomb(iz,icnt) = y1(iw) + wcb (icnt) = x1(iw) + icnt = icnt + 1 + ENDIF + enddo +! ... 280-350 nm + do iw = 1, n1 + ycomb(iz,icnt) = ytmp(iz,iw) + wcb (icnt) = x2 (iw) + icnt = icnt+1 + enddo + enddo + +!... Test No TD +! do iz = 1, nz +! icnt = 1 +! do iw = 1, n +! ycomb(iz,icnt) = y1(iw) +! wcb (icnt) = x1(iw) +! icnt = icnt + 1 +! enddo +! enddo +!---------------------------------------------- +! ... Check routine +! iz = 1 +! print*,"tin=", tin(iz) +! do iw = 1, icnt-1 +! print*, iw, wcb(iw), ycomb(iz,iw) +! enddo +! stop +!---------------------------------------------- +! ... Interpolate Combine cross sections + do iz = 1, nz + n = icnt-1 + y1 = ycomb(iz,:) + x1 = wcb + + call addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.) + call addpnt(x1,y1,kdata,n, 0.,0.) + call addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.) + call addpnt(x1,y1,kdata,n, 1.e+38,0.) + call inter2(nw,wl,yg,n,x1,y1,ierr) + ytd(iz,:) = yg(:) + + if (ierr .ne. 0) then + write(*,*) ierr, jlabel(j) + stop + endif + enddo + +!------------------------------------------------- +! iz = 1 +! do iw = 24, 80 +! print*, iw, wc(iw), ytd(iz,iw), tin(iz) +! enddo +! stop +!------------------------------------------------- + do iw = 1, nw - 1 + IF (wc(iw) .LT. 200.0) THEN + do iz = 1, nz + sq(j, iz,iw) = 0.30 * ytd(iz,iw) + sq(j+1,iz,iw) = 0.70 * ytd(iz,iw) + enddo + ENDIF + IF (wc(iw) .GE. 200.0) THEN + do iz = 1, nz + sq(j, iz,iw) = 0.20 * ytd(iz,iw) + sq(j+1,iz,iw) = 0.80 * ytd(iz,iw) + enddo + ENDIF + enddo + +!-------------------------------------------------- +! iz = 1 +! do iw = 24, 80 +! print*, wc(iw), sq(j,iz,iw), sq(j+1,iz,iw) +! print*, sq(j,iz,iw)+sq(j+1,iz,iw) +! enddo +! stop +!------------------------------------------------- + j = j + 1 + jlabel(j) = 'HO2NO2 + hv -> HO2 + NO2' + + end subroutine XSQY_HO2NO2 diff --git a/test/unit/tuv_doug/JCALC/XSQY_SO2.f b/test/unit/tuv_doug/JCALC/XSQY_SO2.f new file mode 100644 index 00000000..c0e49950 --- /dev/null +++ b/test/unit/tuv_doug/JCALC/XSQY_SO2.f @@ -0,0 +1,108 @@ + SUBROUTINE XSQY_SO2(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,pn) +!---------------------------------------------------------------------------! +! PURPOSE: ! +! Provide the product (cross section) x (quantum yield) for photolysis: ! +! SO2 + hv -> Products ! +! ! +! Cross section from Mike Mills, CU/LASP, Base on: ! +! 1. Yung, Y.L., and W.B. Demore (1982) Photochemistry of the Stratosphere ! +! of Venus: Implications for Atmospheric Evolution, Icarus, 51, 199-247. ! +! 2. Okabe, H. In Photochemistry of Small Molecules; John Wiley and Sons ! +! Inc.: New York, 1978; pp 248-249 ! +! ! +! Quantum yield = 1.0 ! +!---------------------------------------------------------------------------! +! PARAMETERS: ! +! NW - INTEGER, number of specified intervals + 1 in working (I)! +! wavelength grid ! +! WL - REAL, vector of lower limits of wavelength intervals in (I)! +! working wavelength grid ! +! WC - REAL, vector of center points of wavelength intervals in (I)! +! working wavelength grid ! +! NZ - INTEGER, number of altitude levels in working altitude grid (I)! +! TLEV - REAL, temperature (K) at each specified altitude level (I)! +! AIRDEN - REAL, air density (molec/cc) at each altitude level (I)! +! J - INTEGER, counter for number of weighting functions defined (IO)! +! SQ - REAL, cross section x quantum yield (cm^2) for each (O)! +! photolysis reaction defined, at each defined wavelength and ! +! at each defined altitude level ! +! JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)! +! defined ! +!---------------------------------------------------------------------------! + IMPLICIT NONE + INCLUDE 'params' + +!---------------------------------------------------------------------------! +! ... input ! +!---------------------------------------------------------------------------! + real, intent(in) :: wl(kw) + real, intent(in) :: wc(kw) + real, intent(in) :: tlev(kz) + real, intent(in) :: airden(kz) + + integer, intent(in) :: nz + integer, intent(in) :: nw + + character*80, intent(in) :: pn + character*60, intent(out) :: jlabel(kj) + real, intent(out) :: sq(kj,kz,kw) + +!---------------------------------------------------------------------------! +! ... input/output ! +!---------------------------------------------------------------------------! + integer, intent(inout) :: j + +!---------------------------------------------------------------------------! +! ... local ! +!---------------------------------------------------------------------------! + integer kdata + parameter (kdata=300) + integer i, n, ierr, iw + real x_min(kdata), x_max(kdata), x(kdata), y(kdata) + real yg(kw) + real qy + +!----------------------------------------------- +! ... SO2 photolysis +!----------------------------------------------- + j = j+1 + jlabel(j) = 'SO2 + hv -> SO + O' + +!----------------------------------------------- +! ... SO2 cross sections +!---------------------------------------------- + OPEN(UNIT=kin,FILE=TRIM(pn)//'XS_SO2_mills.txt', + $ STATUS='old') + DO i = 1, 13 + READ(kin,*) + ENDDO + n = 125 + DO i = 1, n + READ(kin,*) x_min(i), x_max(i), y(i) + x(i) = (x_min(i)+x_max(i)) / 2.0 + ENDDO + + CLOSE(kin) + + CALL addpnt(x,y,kdata,n,x(1)*(1.-deltax),0.) + CALL addpnt(x,y,kdata,n, 0.,0.) + CALL addpnt(x,y,kdata,n,x(n)*(1.+deltax),0.) + CALL addpnt(x,y,kdata,n, 1.e+38,0.) + CALL inter2(nw,wl,yg,n,x,y,ierr) + IF (ierr .NE. 0) THEN + WRITE(*,*) ierr, jlabel(j) + STOP + ENDIF + +!----------------------------------------------- +! ... combine +!----------------------------------------------- + qy = 1.0 + + DO iw = 1, nw - 1 + DO i = 1, nz + sq(j,i,iw) = yg(iw) * qy + ENDDO + ENDDO + + end subroutine XSQY_SO2 diff --git a/test/unit/tuv_doug/data_sets.F90 b/test/unit/tuv_doug/data_sets.F90 index 434014ee..4347753f 100644 --- a/test/unit/tuv_doug/data_sets.F90 +++ b/test/unit/tuv_doug/data_sets.F90 @@ -10,6 +10,8 @@ program doug_data_set implicit none + integer, parameter :: OUTPUT_LEVEL = 62 + call musica_mpi_init( ) call test_data_set( ) call musica_mpi_finalize( ) @@ -36,7 +38,8 @@ subroutine test_data_set( ) use tuvx_profile, only : profile_t use tuvx_profile_warehouse, only : profile_warehouse_t use tuvx_quantum_yield, only : quantum_yield_t - use tuvx_quantum_yield_factory, only : quantum_yield_type_name, & + use tuvx_quantum_yield_factory, only : quantum_yield_builder, & + quantum_yield_type_name, & quantum_yield_allocate use tuvx_test_utils, only : check_values @@ -45,9 +48,10 @@ subroutine test_data_set( ) class(cross_section_t), pointer :: cross_section class(quantum_yield_t), pointer :: quantum_yield - character(len=*), parameter :: Iam = "H2O cross section test" + character(len=*), parameter :: Iam = "Doug's cross section tests" type(config_t) :: config, config_pair, cs_config, qy_config - class(iterator_t), pointer :: iter + type(config_t) :: mask_points_config, mask_point_config + class(iterator_t), pointer :: iter, mask_points_iter type(string_t) :: cs_type_name, qy_type_name, label character, allocatable :: buffer(:) integer :: pos, pack_size @@ -59,7 +63,9 @@ subroutine test_data_set( ) class(profile_t), pointer :: air, temperature class(grid_t), pointer :: wavelength real(kind=dk) :: tolerance + integer, allocatable :: mask_points(:) integer :: i + logical :: found ! Load grids based on Doug's TUV grids => get_grids( ) @@ -84,12 +90,28 @@ subroutine test_data_set( ) call config_pair%get( "label", label, Iam ) call config_pair%get( "tolerance", tolerance, Iam, & default = 1.0e-6_dk ) + call config_pair%get( "mask", mask_points_config, Iam, & + found = found ) + if( found ) then + mask_points_iter => mask_points_config%get_iterator( ) + allocate( mask_points( mask_points_config%number_of_children( ) ) ) + do i = 1, size( mask_points ) + call assert( 564855121, mask_points_iter%next( ) ) + call mask_points_config%get( mask_points_iter, mask_point_config, & + Iam ) + call mask_point_config%get( "index", mask_points( i ), Iam ) + end do + call assert( 888375064, .not. mask_points_iter%next( ) ) + deallocate( mask_points_iter ) + else + allocate( mask_points(0) ) + end if ! Load and test cross section if( musica_mpi_rank( comm ) == 0 ) then cross_section => cross_section_builder( cs_config, grids, profiles ) cs_type_name = cross_section_type_name( cross_section ) - quantum_yield => quantum_yield_t( qy_config, grids, profiles ) + quantum_yield => quantum_yield_builder( qy_config, grids, profiles ) qy_type_name = quantum_yield_type_name( quantum_yield ) pack_size = cs_type_name%pack_size( comm ) + & cross_section%pack_size( comm ) + & @@ -127,23 +149,13 @@ subroutine test_data_set( ) call calculate( label%val_, & real( temperature%edge_val_(:temperature%ncells_+1) ), & - real( air%mid_val_ ), doug_xsqy ) - - wavelength => grids%get_grid( "wavelength", "nm" ) - write(*,*) label%val_ - do i = 1, size( tuvx_xsqy, dim=2 ) - write(*,*) i, wavelength%edge_(i), wavelength%mid_(i), & - cross_section_data(62,i), & - quantum_yield_data(62,i), tuvx_xsqy(62,i), wl(i), & - real( doug_xsqy(62,i), kind=dk ) - end do - write(*,*) size( tuvx_xsqy, dim=2 ) + 1, & - wavelength%edge_(wavelength%ncells_+1) - deallocate( wavelength ) + real( air%edge_val_ ), doug_xsqy ) ! Skip first two bins because Lyman-Alpha bins are different in ! Doug's version of TUV-x. Data sets were adapted to have Lyman-Alpha ! specific data go into the TUV-x Lyman-Alpha bin 121.4-121.9 nm + ! Also skip any points explicitly masked in the configuration + tuvx_xsqy(:,mask_points(:)) = doug_xsqy(:,mask_points(:)) call check_values( 377150482, tuvx_xsqy(:,3:), & real( doug_xsqy(:,3:), kind=dk ), tolerance ) @@ -152,6 +164,7 @@ subroutine test_data_set( ) deallocate( cross_section_data ) deallocate( quantum_yield_data ) deallocate( tuvx_xsqy ) + deallocate( mask_points ) end do diff --git a/test/unit/tuv_doug/driver.F90 b/test/unit/tuv_doug/driver.F90 index cbdd8a7c..952c2503 100644 --- a/test/unit/tuv_doug/driver.F90 +++ b/test/unit/tuv_doug/driver.F90 @@ -141,6 +141,75 @@ subroutine calculate( label, temperature, air_density, xsqy ) case( "CH2Br2 + hv -> 2Br" ) call XSQY_CH2BR2(nw,wl,wc,nz,temperature,air_density,j,l_xsqy,all_labels,pn) xsqy(:,:) = l_xsqy(1,:nz,:nw) + case( "BRO + hv -> Br + O" ) + call XSQY_BRO(nw,wl,wc,nz,temperature,air_density,j,l_xsqy,all_labels,pn) + xsqy(:,:) = l_xsqy(1,:nz,:nw) + case( "Cl2O2 + hv -> Cl + ClOO" ) + call XSQY_CL2O2(nw,wl,wc,nz,temperature,air_density,j,l_xsqy,all_labels,pn) + xsqy(:,:) = l_xsqy(1,:nz,:nw) + case( "ClO + hv -> Cl + O" ) + call XSQY_CLO(nw,wl,wc,nz,temperature,air_density,j,l_xsqy,all_labels,pn) + xsqy(:,:) = l_xsqy(1,:nz,:nw) + case ( "HNO3 + hv -> OH + NO2" ) + call XSQY_HNO3(nw,wl,wc,nz,temperature,air_density,j,l_xsqy,all_labels,pn) + xsqy(:,:) = l_xsqy(1,:nz,:nw) + case ( "CF2Cl2 + hv -> 2Cl" ) + call XSQY_CF2CL2(nw,wl,wc,nz,temperature,air_density,j,l_xsqy,all_labels,pn) + xsqy(:,:) = l_xsqy(1,:nz,:nw) + case ( "CFC113 + hv -> 3Cl" ) + call XSQY_CFC113(nw,wl,wc,nz,temperature,air_density,j,l_xsqy,all_labels,pn) + xsqy(:,:) = l_xsqy(1,:nz,:nw) + case ( "CFC114 + hv -> 2Cl" ) + call XSQY_CFC114(nw,wl,wc,nz,temperature,air_density,j,l_xsqy,all_labels,pn) + xsqy(:,:) = l_xsqy(1,:nz,:nw) + case( "CFC115 + hv -> Cl" ) + call XSQY_CFC115(nw,wl,wc,nz,temperature,air_density,j,l_xsqy,all_labels,pn) + xsqy(:,:) = l_xsqy(1,:nz,:nw) + case ( "CFCl3 + hv -> 3Cl" ) + call XSQY_CFCL3(nw,wl,wc,nz,temperature,air_density,j,l_xsqy,all_labels,pn) + xsqy(:,:) = l_xsqy(1,:nz,:nw) + case( "CH3Br + hv -> Br" ) + call XSQY_CH3BR(nw,wl,wc,nz,temperature,air_density,j,l_xsqy,all_labels,pn) + xsqy(:,:) = l_xsqy(1,:nz,:nw) + case ( "CHBr3 + hv -> 3Br" ) + call XSQY_CHBR3(nw,wl,wc,nz,temperature,air_density,j,l_xsqy,all_labels,pn) + xsqy(:,:) = l_xsqy(1,:nz,:nw) + case( "H1301 + hv -> Br" ) + call XSQY_H1301(nw,wl,wc,nz,temperature,air_density,j,l_xsqy,all_labels,pn) + xsqy(:,:) = l_xsqy(1,:nz,:nw) + case( "H2402 + hv -> 2Br" ) + call XSQY_H2402(nw,wl,wc,nz,temperature,air_density,j,l_xsqy,all_labels,pn) + xsqy(:,:) = l_xsqy(1,:nz,:nw) + case( "HCFC22 + hv -> Cl" ) + call XSQY_HCFC22(nw,wl,wc,nz,temperature,air_density,j,l_xsqy,all_labels,pn) + xsqy(:,:) = l_xsqy(1,:nz,:nw) + case( "HCFC141b + hv -> 2Cl" ) + call XSQY_HCFC141b(nw,wl,wc,nz,temperature,air_density,j,l_xsqy,all_labels,pn) + xsqy(:,:) = l_xsqy(1,:nz,:nw) + case( "HCFC142b + hv -> Cl" ) + call XSQY_HCFC142b(nw,wl,wc,nz,temperature,air_density,j,l_xsqy,all_labels,pn) + xsqy(:,:) = l_xsqy(1,:nz,:nw) + case( "BrONO2 + hv -> Br + NO3" ) + call XSQY_BRONO2(nw,wl,wc,nz,temperature,air_density,j,l_xsqy,all_labels,pn) + xsqy(:,:) = l_xsqy(1,:nz,:nw) + case( "BrONO2 + hv -> BrO + NO2" ) + call XSQY_BRONO2(nw,wl,wc,nz,temperature,air_density,j,l_xsqy,all_labels,pn) + xsqy(:,:) = l_xsqy(2,:nz,:nw) + case( "HO2NO2 + hv -> OH + NO3" ) + call XSQY_HO2NO2(nw,wl,wc,nz,temperature,air_density,j,l_xsqy,all_labels,pn) + xsqy(:,:) = l_xsqy(1,:nz,:nw) + case( "HO2NO2 + hv -> HO2 + NO2" ) + call XSQY_HO2NO2(nw,wl,wc,nz,temperature,air_density,j,l_xsqy,all_labels,pn) + xsqy(:,:) = l_xsqy(2,:nz,:nw) + case( "CH3Cl + hv -> Cl" ) + call XSQY_CH3CL(nw,wl,wc,nz,temperature,air_density,j,l_xsqy,all_labels,pn) + xsqy(:,:) = l_xsqy(1,:nz,:nw) + case( "SO2 + hv -> SO + O" ) + call XSQY_SO2(nw,wl,wc,nz,temperature,air_density,j,l_xsqy,all_labels,pn) + xsqy(:,:) = l_xsqy(1,:nz,:nw) + case( "CH3COCH3 + hv -> CH3CO3 + CH3O2" ) + call xsqy_acetone(nw,wl,wc,nz,temperature,air_density,j,l_xsqy,all_labels,pn) + xsqy(:,:) = l_xsqy(1,:nz,:nw) case default call die( 946669022 ) end select diff --git a/test/unit/tuv_doug/la_srb.f b/test/unit/tuv_doug/la_srb.f new file mode 100644 index 00000000..eddd17e6 --- /dev/null +++ b/test/unit/tuv_doug/la_srb.f @@ -0,0 +1,196 @@ + SUBROUTINE la_srb(nz,z,tlev,nw,wl,o2col,vcol,scol, + $ o2xs1,dto2,o2xs,pathname) +!---------------------------------------------------------------------------! +! PURPOSE: ! +! Compute equivalent optical depths for O2 absorption, and O2 effective ! +! absorption cross sections, parameterized in the Lyman-alpha and SR bands ! +!---------------------------------------------------------------------------! +! PARAMETERS: ! +! NZ - INTEGER, number of specified altitude levels in the working (I)! +! grid ! +! Z - REAL, specified altitude working grid (km) (I)! +! NW - INTEGER, number of specified intervals + 1 in working (I)! +! wavelength grid ! +! WL - REAL, vector of lxower limits of wavelength intervals in (I)! +! working wavelength grid ! +! CZ - REAL, number of air molecules per cm^2 at each specified (I)! +! altitude layer ! +! ZEN - REAL, solar zenith angle (I)! +! ! +! O2XS1 - REAL, O2 cross section from rdo2xs (I)! +! ! +! DTO2 - REAL, optical depth due to O2 absorption at each specified (O)! +! vertical layer at each specified wavelength ! +! O2XS - REAL, molecular absorption cross section in SR bands at (O)! +! each specified altitude and wavelength. Includes Herzberg ! +! continuum. ! +!---------------------------------------------------------------------------! +! EDIT HISTORY: ! +! 02/02 Major revision only over-write LA and SRB ! +! 02/02 add Koppers and delete Korcarts ! +! 02/98 Included Lyman-alpha parameterization ! +! 03/97 Fix dto2 problem at top level (nz) ! +! 02/97 Changed offset for grid-end interpolation to relative number ! +! (x * (1 +- deltax)) ! +! 08/96 Modified for early exit, no redundant read of data and smaller ! +! internal grid if possible; internal grid uses user grid points ! +! whenever possible ! +! 07/96 Modified to work on internal grid and interpolate final values ! +! onto the user-defined grid ! +!---------------------------------------------------------------------------! + implicit none + include 'params' + + integer nz, nw, iz, iw + real wl(kw), z(kz) + real vcol (kz), scol (kz) + real o2col(kz), o2xs1(kw) + real dto2(kz,kw), o2xs(kz,kw) + real secchi(kz) + real tlev(kz) + character*80 pathname + +!---------------------------------------------------------------------- +! Lyman-alpha variables +! O2 optical depth and equivalent cross section in the +! Lyman-alpha region +!---------------------------------------------------------------------- + integer ila, nla, kla + parameter (kla = 2) + real wlla(kla) + real dto2la(kz, kla-1), o2xsla(kz, kla-1) + save ila + +!---------------------------------------------------------------------- +! Grid on which Koppers' parameterization is defined +! O2 optical depth and equivalent cross section on Koppers' grid +!---------------------------------------------------------------------- + integer isrb, nsrb, ksrb + parameter(ksrb = 18) + real wlsrb(ksrb) + real dto2k(kz, ksrb-1), o2xsk(kz, ksrb-1) + save isrb + + integer i + + logical call1 + data call1/.TRUE./ + save call1 + +!---------------------------------------------------------------------- +! Wavelengths for Lyman alpha and SRB parameterizations: +!---------------------------------------------------------------------- + data nla /1/ + data wlla/ 121.0, 122.0/ + + data nsrb /17/ + data wlsrb/174.4, 177.0, 178.6, 180.2, 181.8, 183.5, 185.2, 186.9, + $ 188.7, 190.5, 192.3, 194.2, 196.1, 198.0, 200.0, 202.0, + $ 204.1, 205.8/ + +!---------------------------------------------------------------------- +! initalize O2 cross sections +!---------------------------------------------------------------------- + DO iz = 1, nz + DO iw =1, nw - 1 + o2xs(iz,iw) = o2xs1(iw) + ENDDO + ENDDO + + IF(wl(1) .GT. wlsrb(nsrb)) RETURN + +!---------------------------------------------------------------------- +! On first call, check that the user wavelength grid, WL(IW), is compatible +! with the wavelengths for the parameterizations of the Lyman-alpha and SRB. +! Also compute and save corresponding grid indices (ILA, ISRB) +!---------------------------------------------------------------------- + IF (call1) THEN + +! locate Lyman-alpha wavelengths on grid + + ila = 0 + DO iw = 1, nw + IF(ABS(wl(iw) - wlla(1)) .LT. 10.*precis) THEN + ila = iw + GO TO 5 + ENDIF + ENDDO + 5 CONTINUE + +! check + IF(ila .EQ. 0) STOP ' Lyman alpha grid mis-match - 1' + DO i = 2, nla + 1 + IF(ABS(wl(ila + i - 1) - wlla(i)) .GT. 10.*precis) THEN + WRITE(*,*) 'Lyman alpha grid mis-match - 2' + STOP + ENDIF + ENDDO + +! locate Schumann-Runge wavelengths on grid + isrb = 0 + DO iw = 1, nw + IF(ABS(wl(iw) - wlsrb(1)) .LT. 10.*precis) THEN + isrb = iw + GO TO 6 + ENDIF + ENDDO + 6 CONTINUE + + +! check + IF(isrb .EQ. 0) STOP ' SRB grid mis-match - 1' + DO i = 2, nsrb + 1 + IF(ABS(wl(isrb + i - 1) - wlsrb(i)) .GT. 10.* precis) THEN + WRITE(*,*) ' SRB grid mismatch - w' + STOP + ENDIF + ENDDO + + IF (call1) call1 = .FALSE. + ENDIF + +!---------------------------------------------------------------------- +! Effective secant of solar zenith angle. +! Use 2.0 if no direct sun (value for isotropic radiation) +! For nz, use value at nz-1 +!---------------------------------------------------------------------- + DO i = 1, nz - 1 + secchi(i) = scol(i)/vcol(i) + IF(scol(i) .GT. largest/10.) secchi(i) = 2. + ENDDO + secchi(nz) = secchi(nz-1) + +!--------------------------------------------------------------------- +! Lyman-Alpha parameterization, output values of O2 optical depth +! and O2 effective (equivalent) cross section +!--------------------------------------------------------------------- + CALL lymana(nz,o2col,secchi,dto2la,o2xsla) + + DO iw = ila, ila + nla - 1 + DO iz = 1, nz + dto2(iz,iw) = dto2la(iz, iw - ila + 1) + o2xs(iz,iw) = o2xsla(iz, iw - ila + 1) + ENDDO + ENDDO + +!---------------------------------------------------------------------- +! Koppers' parameterization of the SR bands, output values of O2 +! optical depth and O2 equivalent cross section +!---------------------------------------------------------------------- + + CALL schum(nz,o2col,tlev,secchi,dto2k,o2xsk,pathname) + DO iw = isrb, isrb + nsrb - 1 + DO iz = 1, nz + dto2(iz,iw) = dto2k(iz, iw - isrb + 1) + o2xs(iz,iw) = o2xsk(iz, iw - isrb + 1) + ENDDO + ENDDO + + + RETURN + END + + + + + diff --git a/test/unit/tuv_doug/lymana.f b/test/unit/tuv_doug/lymana.f new file mode 100644 index 00000000..45f3b268 --- /dev/null +++ b/test/unit/tuv_doug/lymana.f @@ -0,0 +1,120 @@ + SUBROUTINE lymana(nz,o2col,secchi,dto2la,o2xsla) + +*-----------------------------------------------------------------------------* +*= PURPOSE: =* +*= Calculate the effective absorption cross section of O2 in the Lyman-Alpha=* +*= bands and an effective O2 optical depth at all altitudes. Parameterized =* +*= after: Chabrillat, S., and G. Kockarts, Simple parameterization of the =* +*= absorption of the solar Lyman-Alpha line, Geophysical Research Letters, =* +*= Vol.24, No.21, pp 2659-2662, 1997. =* +*-----------------------------------------------------------------------------* +*= PARAMETERS: =* +*= NZ - INTEGER, number of specified altitude levels in the working (I)=* +*= grid =* +*= O2COL - REAL, slant overhead O2 column (molec/cc) at each specified (I)=* +*= altitude =* +*= DTO2LA - REAL, optical depth due to O2 absorption at each specified (O)=* +*= vertical layer =* +*= O2XSLA - REAL, molecular absorption cross section in LA bands (O)=* +*-----------------------------------------------------------------------------* +*= EDIT HISTORY: =* +*= 01/98 Original =* +*-----------------------------------------------------------------------------* +*= This program is free software; you can redistribute it and/or modify =* +*= it under the terms of the GNU General Public License as published by the =* +*= Free Software Foundation; either version 2 of the license, or (at your =* +*= option) any later version. =* +*= The TUV package is distributed in the hope that it will be useful, but =* +*= WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTIBI- =* +*= LITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public =* +*= License for more details. =* +*= To obtain a copy of the GNU General Public License, write to: =* +*= Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. =* +*-----------------------------------------------------------------------------* +*= To contact the authors, please mail to: =* +*= Sasha Madronich, NCAR/ACD, P.O.Box 3000, Boulder, CO, 80307-3000, USA or =* +*= send email to: sasha@ucar.edu =* +*-----------------------------------------------------------------------------* +*= Copyright (C) 1994 - 1998 University Corporation for Atmospheric Research =* +*-----------------------------------------------------------------------------* + + IMPLICIT NONE + +* input: + + INCLUDE 'params' + INTEGER nz + REAL o2col(kz) + REAL secchi(kz) + +* output + + REAL dto2la(kz,*), o2xsla(kz,*) + +* local variables + + DOUBLE PRECISION rm(kz), ro2(kz) + DOUBLE PRECISION b(3), c(3), d(3), e(3) + DATA b/ 6.8431D-01, 2.29841D-01, 8.65412D-02/, + > c/8.22114D-21, 1.77556D-20, 8.22112D-21/, + > d/ 6.0073D-21, 4.28569D-21, 1.28059D-20/, + > e/8.21666D-21, 1.63296D-20, 4.85121D-17/ + + INTEGER iz, i + REAL xsmin +*------------------------------------------------------------------------------* +! sm: set minimum cross section + xsmin = 1.D-20 + + DO iz = 1, nz + rm(iz) = 0.D+00 + ro2(iz) = 0.D+00 + DO i = 1, 3 + rm(iz) = rm(iz) + b(i) * DEXP(-c(i) * DBLE(o2col(iz))) + END DO + ! TUV-x logic difference + ! DO i = 1, 2 + DO i = 1, 3 + ro2(iz) = ro2(iz) + d(i) * DEXP(-e(i) * DBLE(o2col(iz))) + ENDDO + + ENDDO + +* calculate effective O2 optical depths and effective O2 cross sections + DO iz = 1, nz-1 + + IF (rm(iz) .GT. 1.0D-100) THEN + IF (ro2(iz) .GT. 1.D-100) THEN + o2xsla(iz,1) = ro2(iz)/rm(iz) + ELSE + ! TUV-x logic difference + ! o2xsla(iz,1) = 0. + o2xsla(iz,1) = xsmin + ENDIF + + IF (rm(iz+1) .GT. 0.) THEN + + dto2la(iz,1) = LOG(rm(iz+1)) / secchi(iz+1) + $ - LOG(rm(iz)) / secchi(iz) + + ELSE + dto2la(iz,1) = 1000. + ENDIF + ELSE + dto2la(iz,1) = 1000. + o2xsla(iz,1) = xsmin + ENDIF + + ENDDO + +* do top layer separately + + dto2la(nz,1) = 0. + IF(rm(nz) .GT. 1.D-100) THEN + o2xsla(nz,1) = ro2(nz)/rm(nz) + ELSE + o2xsla(nz,1) = xsmin + ENDIF + +*------------------------------------------------------------------------------* + END diff --git a/test/unit/tuv_doug/rdo2xs.f b/test/unit/tuv_doug/rdo2xs.f new file mode 100644 index 00000000..2f874245 --- /dev/null +++ b/test/unit/tuv_doug/rdo2xs.f @@ -0,0 +1,117 @@ + SUBROUTINE rdo2xs(nw,wl,wc,o2xs1,pn) +!---------------------------------------------------------------------------! +! PURPOSE: ! +! Read O2 absorption cross section. Except the SR bands and L-alpha line ! +!---------------------------------------------------------------------------! +! PARAMETERS: ! +! NW - INTEGER, number of specified intervals + 1 in working (I)! +! wavelength grid ! +! WL - REAL, vector of lower limits of wavelength intervals in (I)! +! working wavelength grid ! +!---------------------------------------------------------------------------! +! EDIT HISTORY: ! +! 02/02 By Xuexi ! +!---------------------------------------------------------------------------! + IMPLICIT NONE + INCLUDE 'params' + +!-----------------------------------------------------------------------------! +! ... input ! +!-----------------------------------------------------------------------------! + real, intent(in) :: wl(kw) + real, intent(in) :: wc(kw) + integer, intent(in) :: nw + +!-----------------------------------------------------------------------------! +! ... output ! +!-----------------------------------------------------------------------------! + real, intent(out) :: o2xs1(kw) + +!... Internal + + integer i, iw, n, kdata, ierr + parameter (kdata = 200) + real x1(kdata), y1(kdata) + real x, y + character*80 pn + +!------------------------------------------------------------------------ +! NOTE: Output O2 xsect, is temporary and will be over-written in +! Lyman-alpha and Schumann-Runge wavelength bands. +!------------------------------------------------------------------------ +! ... data +!------------------------------------------------------------------------ +! Read O2 absorption cross section data: +! 116.65 to 203.05 nm = from Brasseur and Solomon 1986 +! 205 to 240 nm = Yoshino et al. 1988 (same as JPL06) +! +! Note that subroutine seto2.f will over-write values in the +! spectral regions corresponding to: +! Lyman-alpha (LA: 121.4-121.9 nm, Chabrillat and Kockarts +! parameterization +! Schumann-Runge bands (SRB: 174.4-205.8 nm, Koppers +! parameteriaztion) +!----------------------------------------------------------------------- + n = 0 + + OPEN(UNIT=kin,FILE=Trim(pn)//'XS_O2_brasseur.txt') + DO i = 1, 7 + READ(kin,*) + ENDDO + DO i = 1, 78 + READ(kin,*) x, y + IF (x .LE. 204.) THEN + n = n + 1 + x1(n) = x + y1(n) = y +! print*, x1(n), y1(n) + ENDIF + ENDDO + CLOSE(kin) + + OPEN(UNIT=kin, + $ FILE=Trim(pn)//'XS_O2_yoshino.txt',STATUS='old') + DO i = 1, 8 + READ(kin,*) + ENDDO + DO i = 1, 36 + n = n + 1 + READ(kin,*) x, y + y1(n) = y*1.E-24 + x1(n) = x +! print*, x1(n), y1(n) + END DO + CLOSE (kin) + +!----------------------------------------------------------------------------- +! Add termination points and interpolate onto the +! user grid (set in subroutine gridw): +!----------------------------------------------------------------------------- + CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),y1(1)) + CALL addpnt(x1,y1,kdata,n,0. ,y1(1)) + CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.) + CALL addpnt(x1,y1,kdata,n, 1.E+38,0.) + +! CALL inter2(nw,wl,o2xs1, n,x1,y1, ierr) + print*, "* interp4 used in rdo2xs.f" + ierr = 0 + CALL inter4(nw,wl,o2xs1, n+1,x1,y1, ierr) +!--------------------------------------------------------------- +! ... Check routine +! do iw = 1,51 +! print*, iw, wc(iw), o2xs1(iw) +! enddo +! stop +!--------------------------------------------------------------- + IF (ierr .NE. 0) THEN + WRITE(*,*) ierr, 'O2 -> O + O' + STOP + ENDIF + + end subroutine rdo2xs + + + + + + diff --git a/test/unit/tuv_doug/schum.f b/test/unit/tuv_doug/schum.f new file mode 100644 index 00000000..3823c8e0 --- /dev/null +++ b/test/unit/tuv_doug/schum.f @@ -0,0 +1,320 @@ + SUBROUTINE schum(nz, o2col,tlev,secchi,dto2,o2xsk,pathname) + +*-----------------------------------------------------------------------------* +*= PURPOSE: =* +*= Calculate the equivalent absorption cross section of O2 in the SR bands. =* +*= The algorithm is based on parameterization of G.A. Koppers, and =* +*= D.P. Murtagh [ref. Ann.Geophys., 14 68-79, 1996] =* +*= Final values do include effects from the Herzberg continuum. =* +*-----------------------------------------------------------------------------* +*= PARAMETERS: =* +*= NZ - INTEGER, number of specified altitude levels in the working (I)=* +*= grid =* +*= O2COL - REAL, slant overhead O2 column (molec/cc) at each specified (I)=* +*= altitude =* +*= TLEV - tmeperature at each level (I)=* +*= SECCHI - ratio of slant to vertical o2 columns (I)=* +*= DTO2 - REAL, optical depth due to O2 absorption at each specified (O)=* +*= vertical layer at each specified wavelength =* +*= O2XSK - REAL, molecular absorption cross section in SR bands at (O)=* +*= each specified wavelength. Includes Herzberg continuum =* +*-----------------------------------------------------------------------------* + + + IMPLICIT NONE + INCLUDE 'params' + + INTEGER nz + REAL o2col(kz), o2col1(kz) + REAL tlev(kz), secchi(kz) + + REAL dto2(kz,17), o2xsk(kz,17) + + CHARACTER*80 pathname + INTEGER i, k, ktop, ktop1, kbot + + REAL XS(17), X + REAL xslod(17) + LOGICAL firstcall + SAVE firstcall + DATA firstcall /.TRUE./ + + DATA xslod /6.2180730E-21, 5.8473627E-22, 5.6996334E-22, + $ 4.5627094E-22, 1.7668250E-22, 1.1178808E-22, + $ 1.2040544E-22, 4.0994668E-23, 1.8450616E-23, + $ 1.5639540E-23, 8.7961075E-24, 7.6475608E-24, + $ 7.6260556E-24, 7.5565696E-24, 7.6334338E-24, + $ 7.4371992E-24, 7.3642966E-24/ +c------------------------------------------ +C Initialize values +c------------------------------------------ + dto2(:,:) = 0.0 + +c------------------------------------------ +c sm Initialize cross sections to values +c sm at large optical depth +c------------------------------------------ + + DO k = 1, nz + DO i = 1, 17 + o2xsk(k,i) = xslod(i) + ENDDO + ENDDO + +c------------------------------------------ +c Loads Chebyshev polynomial Coeff. +c------------------------------------------ + + if (firstcall) then + call INIT_XS(pathname) + firstcall = .FALSE. + endif + +c------------------------------------------ +c Calculate cross sections +c sm: Set smallest O2col = exp(38.) molec cm-2 +c sm to stay in range of parameterization +c sm given by Koppers et al. at top of atm. +c------------------------------------------ + + ktop = nz + kbot = 0 + +c EXP(38.) = 3.185e16 +c EXP(56.) = 2.091e24 + DO k=1,nz !! loop for alt + o2col1(k) = MAX(o2col(k),EXP(38.)) + + x = ALOG(o2col1(k)) + + IF (x .LT. 38.0) THEN + ktop1 = k-1 + write(*,*) ktop1 + ktop = MIN(ktop1,ktop) + ELSE IF (x .GT. 56.0) THEN + kbot = k + ELSE + CALL effxs( x, tlev(k), xs ) + DO i=1,17 + o2xsk(k,i) = xs(i) + END DO + ENDIF + + END DO !! finish loop for alt + +c------------------------------------------ +c fill in cross section where X is out of range +c by repeating edge table values +c------------------------------------------ + +c sm do not allow kbot = nz to avoid division by zero in +c no light case. + + IF(kbot .EQ. nz) kbot = nz - 1 + + DO k=1,kbot + DO i=1,17 + o2xsk(k,i) = o2xsk(kbot+1,i) + END DO + END DO + + DO k=ktop+1,nz + DO i=1,17 + o2xsk(k,i) = o2xsk(ktop,i) + END DO + END DO + +c------------------------------------------ +c Calculate incremental optical depths +c------------------------------------------ + + DO i=1,17 ! loop over wavelength + + DO k=1,nz-1 ! loop for alt + +c... calculate an optical depth weighted by density +c sm: put in mean value estimate, if in shade + + IF (ABS(1. - o2col1(k+1)/o2col1(k)) .LE. 2.*precis) THEN + + dto2(k,i) = o2xsk(k+1,i)*o2col1(k+1)/(nz-1) + + ELSE + + dto2(k,i) = ABS( + $ ( o2xsk(k+1,i)*o2col1(k+1) - o2xsk(k,i)*o2col1(k) ) + $ / ( 1. + ALOG(o2xsk(k+1,i)/o2xsk(k,i)) + $ / ALOG(o2col1(k+1)/o2col1(k)) ) ) + +c... change to vertical optical depth + + dto2(k,i) = 2. * dto2(k,i) / (secchi(k)+secchi(k+1)) + + ENDIF + + END DO + dto2(nz,i) = 0.0 ! set optical depth to zero at top + + + END DO + + return + end + +C------------------------------------------------------------- + SUBROUTINE EFFXS( X, T, XS ) +C------------------------------------------------------------- +C +C Subroutine for evaluating the effective cross section +C of O2 in the Schumann-Runge bands using parameterization +C of G.A. Koppers, and D.P. Murtagh [ref. Ann.Geophys., 14 +C 68-79, 1996] +C +C method: +C ln(xs) = A(X)[T-220]+B(X) +C X = log of slant column of O2 +C A,B calculated from Chebyshev polynomial coeffs +C AC and BC using NR routine chebev. Assume interval +C is 38 Tests against Doug's LA and SR band calculations + + use musica_assert, only : assert, almost_equal + use musica_constants, only : dk => musica_dk + use musica_config, only : config_t + use tuvx_cross_section, only : cross_section_t + use tuvx_grid_warehouse, only : grid_warehouse_t + use tuvx_profile_warehouse, only : profile_warehouse_t + use tuvx_la_sr_bands, only : la_sr_bands_t + use tuvx_test_utils, only : check_values + + implicit none + + character(len=*), parameter :: my_name = "LUT LA/SRB test" + character(len=*), parameter :: conf_l = 'test/data/la_srb_bands.config.json' + type(config_t) :: grid_config, la_config, profile_config, o2_config + class(grid_warehouse_t), pointer :: grids => null( ) + class(profile_warehouse_t), pointer :: profiles => null( ) + class(la_sr_bands_t), pointer :: la_sr_bands => null( ) + class(cross_section_t), pointer :: o2_cross_section => null( ) + character, allocatable :: buffer(:) + + call la_config%from_file( conf_l ) + call la_config%get( "grids", grid_config, my_name ) + call la_config%get( "profiles", profile_config, my_name ) + call la_config%get( "O2 cross section", o2_config, my_name ) + + grids => grid_warehouse_t( grid_config ) + profiles => profile_warehouse_t( profile_config, grids ) + la_sr_bands => la_sr_bands_t( la_config, grids, profiles ) + o2_cross_section => cross_section_t( o2_config, grids, profiles ) + + call compare_o2_cross_sections( la_sr_bands, grids, profiles ) + + deallocate( grids ) + deallocate( profiles ) + deallocate( la_sr_bands ) + deallocate( o2_cross_section ) + +contains + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine compare_o2_cross_sections( la_sr_bands, grids, profiles ) + + use tuvx_grid, only : grid_t + use tuvx_profile, only : profile_t + use tuvx_spherical_geometry, only : spherical_geometry_t + + class(la_sr_bands_t), intent(inout) :: la_sr_bands + class(grid_warehouse_t), intent(inout) :: grids + class(profile_warehouse_t), intent(inout) :: profiles + + character(len=80) :: file_path + real(dk), allocatable :: air_vertical_column(:), air_slant_column(:) + real(dk), allocatable :: o2_vertical_column(:), o2_slant_column(:) + real(dk), allocatable :: tuvx_o2_optical_depth(:,:), & + tuvx_o2_cross_section(:,:) + real, dimension(151) :: lut_heights, lut_temperature, & + lut_air_vertical_column, lut_air_slant_column, & + lut_o2_column + real, dimension(700) :: lut_wavelength_edges, lut_wavelength_centers, & + lut_o2_base_cross_section + real, dimension(151,700) :: lut_o2_cross_section, lut_o2_optical_depth + class(grid_t), pointer :: heights, wavelengths, lut_wavelengths + class(spherical_geometry_t), pointer :: geometry + class(profile_t), pointer :: air, o2, temperature + real(dk), allocatable :: solar_zenith_angles(:) + integer :: i_sza, i_height, i_wl, n_heights, n_wavelengths, i_output_height + integer :: output_heights(4) = (/ 1, 50, 100, 150 /) + real(dk) :: rel_tol + + heights => grids%get_grid( "height", "km" ) + wavelengths => grids%get_grid( "wavelength", "nm" ) + lut_wavelengths => grids%get_grid( "LUT wavelength", "nm" ) + air => profiles%get_profile( "air", "molecule cm-3" ) + o2 => profiles%get_profile( "O2", "molecule cm-3" ) + temperature => profiles%get_profile( "temperature", "K" ) + geometry => spherical_geometry_t( grids ) + solar_zenith_angles = (/ 0.0_dk, 13.2_dk, 45.0_dk, 87.3_dk, 90.0_dk /) + allocate( air_vertical_column( air%ncells_ ), & + air_slant_column( air%ncells_ + 1 ) ) + allocate( o2_vertical_column( o2%ncells_ ), & + o2_slant_column( o2%ncells_ + 1) ) + allocate( tuvx_o2_optical_depth( heights%ncells_, wavelengths%ncells_ ) ) + lut_heights(:) = huge(1.0) + lut_temperature(:) = huge(1.0) + lut_air_vertical_column(:) = huge(1.0) + lut_air_slant_column(:) = huge(1.0) + lut_o2_column(:) = huge(1.0) + lut_wavelength_edges(:) = huge(1.0) + lut_wavelength_centers(:) = huge(1.0) + lut_o2_base_cross_section(:) = huge(1.0) + lut_o2_cross_section(:,:) = huge(1.0) + lut_o2_optical_depth(:,:) = huge(1.0) + + do i_sza = 1, size( solar_zenith_angles ) + + ! calculate slant O2 column + call geometry%set_parameters( solar_zenith_angles( i_sza ), grids ) + call geometry%air_mass( air%exo_layer_dens_, & + air_vertical_column, & + air_slant_column ) + call geometry%air_mass( o2%exo_layer_dens_, & + o2_vertical_column, & + o2_slant_column ) + + tuvx_o2_optical_depth(:,:) = 0.0_dk + lut_o2_cross_section(:,:) = 0.0 + lut_o2_optical_depth(:,:) = 0.0 + + ! get TUV-x O2 optical depths and cross sections + call la_sr_bands%optical_depth( grids, profiles, air_vertical_column, & + air_slant_column, tuvx_o2_optical_depth, geometry ) + tuvx_o2_cross_section = o2_cross_section%calculate( grids, profiles ) + call la_sr_bands%cross_section( grids, profiles, air_vertical_column, & + air_slant_column, tuvx_o2_cross_section, geometry ) + + ! get LUT O2 optical depths and cross sections + n_heights = heights%ncells_ + 1 + n_wavelengths = lut_wavelengths%ncells_ + 1 + lut_heights(1:n_heights) = real( heights%edge_(:) ) + lut_temperature(1:n_heights) = real( temperature%edge_val_(:) ) + lut_wavelength_edges(1:n_wavelengths) = real( lut_wavelengths%edge_(:) ) + lut_wavelength_centers(1:n_wavelengths-1) = & + real( lut_wavelengths%mid_(:) ) + lut_o2_column(1:n_heights) = real( o2_slant_column(:) ) + lut_air_vertical_column(1:air%ncells_) = real( air_vertical_column(:) ) + lut_air_slant_column(1:air%ncells_+1) = real( air_slant_column(:) ) + + file_path = "test/unit/tuv_doug/INPUT/XSQY/" + call rdo2xs( n_wavelengths, lut_wavelength_edges, & + lut_wavelength_centers, lut_o2_base_cross_section, & + file_path ) + + call la_srb( n_heights, lut_heights, lut_temperature, & + n_wavelengths, lut_wavelength_edges, lut_o2_column, & + lut_air_vertical_column, lut_air_slant_column, & + lut_o2_base_cross_section, lut_o2_optical_depth, & + lut_o2_cross_section, file_path ) + + do i_height = 1, n_heights - 1 + do i_wl = 1, n_wavelengths - 1 + rel_tol = 1.0e-4 + if ( i_wl == 1 .or. i_wl == 3 ) cycle + if ( i_wl == 20 .or. i_wl == 38 ) rel_tol = 0.5_dk + if ( i_wl == 2 .and. i_height >= 112 ) rel_tol = 0.05_dk + call assert( 624510149, & + almost_equal( tuvx_o2_cross_section( i_height, i_wl ), & + real( lut_o2_cross_section( i_height, i_wl ), kind=dk ),& + relative_tolerance = rel_tol ) ) + call assert( 746904813, & + almost_equal( tuvx_o2_optical_depth( i_height, i_wl ), & + real( lut_o2_optical_depth( i_height, i_wl ), kind=dk ),& + relative_tolerance = rel_tol ) ) + end do + end do + deallocate( tuvx_o2_cross_section ) + end do + + deallocate( heights ) + deallocate( wavelengths ) + deallocate( lut_wavelengths ) + deallocate( air ) + deallocate( o2 ) + deallocate( temperature ) + deallocate( geometry ) + deallocate( tuvx_o2_optical_depth ) + deallocate( air_vertical_column ) + deallocate( air_slant_column ) + deallocate( o2_vertical_column ) + deallocate( o2_slant_column ) + + end subroutine compare_o2_cross_sections + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +end program test_la_srb \ No newline at end of file diff --git a/test/unit/util/CMakeLists.txt b/test/unit/util/CMakeLists.txt new file mode 100644 index 00000000..8ea1a485 --- /dev/null +++ b/test/unit/util/CMakeLists.txt @@ -0,0 +1,29 @@ +################################################################################ +# Test utilities + +include(test_util) + +################################################################################ +# Utility tests + +create_standard_test(NAME util_array SOURCES array.F90) + +create_standard_test(NAME util_assert SOURCES assert.F90) +add_executable(util_assert_failure assert.F90) +add_std_test_script(util_assert_failure assert.sh) + +create_standard_test(NAME util_config SOURCES config.F90) + +create_standard_test(NAME util_map SOURCES map.F90) +add_executable(util_map_failure map.F90) +add_std_test_script(util_map_failure map.sh) + +create_standard_test(NAME util_mpi SOURCES mpi.F90) + +create_standard_test(NAME util_string SOURCES string.F90) +add_executable(util_string_failure string.F90) +add_std_test_script(util_string_failure string.sh) + +add_subdirectory(io) + +################################################################################ diff --git a/test/unit/util/array.F90 b/test/unit/util/array.F90 new file mode 100644 index 00000000..2e2f16a6 --- /dev/null +++ b/test/unit/util/array.F90 @@ -0,0 +1,152 @@ +! Copyright (C) 2021 National Center for Atmospheric Research +! SPDX-License-Identifier: Apache-2.0 +! +!> \file +!> Tests for the musica_array module + +!> Tests for the musica_array module +program test_util_array + + use musica_assert, only : assert, almost_equal + use musica_array + use musica_constants, only : musica_ik, musica_rk, musica_dk + use musica_string, only : string_t +#ifdef MUSICA_USE_OPENMP + use omp_lib +#endif + + implicit none + +#ifdef MUSICA_USE_OPENMP + write(*,*) "Testing with ", omp_get_max_threads( ), " threads" +#else + write(*,*) "Testing without OpenMP support" +#endif + + !$omp parallel + call test_array_functions( ) + !$omp end parallel + +contains + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Tests array functions + subroutine test_array_functions( ) + + type(string_t) :: str_array(3) + real(kind=musica_dk), allocatable :: dbl_array(:), dbl_array_2(:) + real(kind=musica_dk), allocatable :: merged_array(:) + real(kind=musica_rk), allocatable :: flt_array(:) + integer(kind=musica_ik), allocatable :: int_array(:) + logical, allocatable :: bool_array(:) + type(string_t) :: str + integer(kind=musica_ik) :: idx + + allocate( dbl_array( 0 ) ) + allocate( flt_array( 0 ) ) + allocate( int_array( 0 ) ) + allocate( bool_array( 0 ) ) + + ! test find_string_in_array( ) + str_array(1) = "foo" + str_array(2) = "bar" + str_array(3) = "foObar" + + call assert( 301097835, size( str_array ) .eq. 3 ) + call assert( 184681299, find_string_in_array( str_array, "foo", idx ) ) + call assert( 360841928, idx .eq. 1 ) + call assert( 520470218, find_string_in_array( str_array, "foObar", idx, & + case_sensitive = .true. ) ) + call assert( 745106908, idx .eq. 3 ) + call assert( 239900503, .not. find_string_in_array( str_array, "fooBar", & + idx, case_sensitive = .true. ) ) + call assert( 234636196, .not. find_string_in_array( str_array, & + "not there", idx ) ) + str = "bar" + call assert( 911905039, find_string_in_array( str_array, str, idx ) ) + call assert( 689173883, idx .eq. 2 ) + str = "Bar" + call assert( 183967478, .not. find_string_in_array( str_array, str, idx, & + case_sensitive = .true. ) ) + str = "not there" + call assert( 231277423, .not. find_string_in_array( str_array, str, idx ) ) + + ! test find_string_in_split_array( ) + str_array( 1 ) = "foo.BaR" + str_array( 2 ) = "Bar.foO" + str_array( 3 ) = "justfoo" + + call assert( 100527721, find_string_in_split_array( str_array, "foo", ".",& + 1, idx ) ) + call assert( 253438465, idx .eq. 1 ) + call assert( 192693428, find_string_in_split_array( str_array, "foo", ".",& + 2, idx ) ) + call assert( 522478622, idx .eq. 2 ) + call assert( 634796967, .not. find_string_in_split_array( str_array, & + "foo", ".", 2, idx, case_sensitive = .true. ) ) + call assert( 747115312, find_string_in_split_array( str_array, "BaR", ".",& + 2, idx, case_sensitive = .true. ) ) + call assert( 859433657, idx .eq. 1 ) + str = "foo" + call assert( 929884076, find_string_in_split_array( str_array, str, ".", & + 1, idx ) ) + call assert( 477251923, idx .eq. 1 ) + call assert( 924619769, find_string_in_split_array( str_array, str, ".", & + 2, idx ) ) + call assert( 471987616, idx .eq. 2 ) + call assert( 366839112, .not. find_string_in_split_array( str_array, & + str, ".", 2, idx, case_sensitive = .true. ) ) + str = "BaR" + call assert( 196682208, find_string_in_split_array( str_array, str, ".", & + 2, idx, case_sensitive = .true. ) ) + call assert( 926525303, idx .eq. 1 ) + + ! test merge_series( ) + if( allocated( dbl_array ) ) deallocate( dbl_array ) + if( allocated( dbl_array_2 ) ) deallocate( dbl_array_2 ) + dbl_array = [ 3.5_musica_dk, 5.0_musica_dk, 12.3_musica_dk ] + dbl_array_2 = [ 1.0_musica_dk, 4.2_musica_dk, 5.0_musica_dk, & + 12.3_musica_dk, 24.3_musica_dk ] + merged_array = merge_series( dbl_array, dbl_array_2 ) + call assert( 182507698, size( merged_array ) .eq. 6 ) + call assert( 105969740, merged_array( 1 ) .eq. 1.0_musica_dk ) + call assert( 835812835, merged_array( 2 ) .eq. 3.5_musica_dk ) + call assert( 948131180, merged_array( 3 ) .eq. 4.2_musica_dk ) + call assert( 777974276, merged_array( 4 ) .eq. 5.0_musica_dk ) + call assert( 607817372, merged_array( 5 ) .eq. 12.3_musica_dk ) + call assert( 155185219, merged_array( 6 ) .eq. 24.3_musica_dk ) + merged_array = merge_series( dbl_array, dbl_array_2, & + with_bounds_from = dbl_array ) + call assert( 267503564, size( merged_array ) .eq. 4 ) + call assert( 162355060, merged_array( 1 ) .eq. 3.5_musica_dk ) + call assert( 609722906, merged_array( 2 ) .eq. 4.2_musica_dk ) + call assert( 439566002, merged_array( 3 ) .eq. 5.0_musica_dk ) + call assert( 886933848, merged_array( 4 ) .eq. 12.3_musica_dk ) + + ! test calculate_linear_array( ) + if( allocated( dbl_array ) ) deallocate( dbl_array ) + dbl_array = calculate_linear_array( 1.0_musica_dk, 5.0_musica_dk, 5 ) + call assert( 781682679, size( dbl_array ) .eq. 5 ) + call assert( 106319370, dbl_array( 1 ) .eq. 1.0_musica_dk ) + call assert( 824180612, almost_equal( dbl_array( 2 ), 2.0_musica_dk ) ) + call assert( 654023708, almost_equal( dbl_array( 3 ), 3.0_musica_dk ) ) + call assert( 201391555, almost_equal( dbl_array( 4 ), 4.0_musica_dk ) ) + call assert( 996243050, dbl_array( 5 ) .eq. 5.0_musica_dk ) + + ! test calculate_logarithmic_array( ) + if( allocated( dbl_array ) ) deallocate( dbl_array ) + dbl_array = & + calculate_logarithmic_array( 1.0_musica_dk, 10000.0_musica_dk, 5 ) + call assert( 764888814, size( dbl_array ) .eq. 5 ) + call assert( 312256661, dbl_array( 1 ) .eq. 1.0_musica_dk ) + call assert( 142099757, almost_equal( dbl_array( 2 ), 10.0_musica_dk ) ) + call assert( 589467603, almost_equal( dbl_array( 3 ), 100.0_musica_dk ) ) + call assert( 136835450, almost_equal( dbl_array( 4 ), 1000.0_musica_dk ) ) + call assert( 931686945, dbl_array( 5 ) .eq. 10000.0_musica_dk ) + + end subroutine test_array_functions + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +end program test_util_array diff --git a/test/unit/util/assert.F90 b/test/unit/util/assert.F90 new file mode 100644 index 00000000..aaa7b300 --- /dev/null +++ b/test/unit/util/assert.F90 @@ -0,0 +1,255 @@ +! Copyright (C) 2020 National Center for Atmospheric Research +! SPDX-License-Identifier: Apache-2.0 +! +!> \file +!> Tests for the musica_assert module + +!> Test module for the musica_assert module +program test_util_assert + + use musica_assert +#ifdef MUSICA_USE_OPENMP + use omp_lib +#endif + + implicit none + + character(len=256) :: failure_test_type + + if( command_argument_count( ) .eq. 0 ) then +#ifdef MUSICA_USE_OPENMP + write(*,*) "Testing with ", omp_get_max_threads( ), " threads" +#else + write(*,*) "Testing without OpenMP support" +#endif + !$omp parallel + call test_assert( ) + !$omp end parallel + else if( command_argument_count( ) .eq. 1 ) then + call get_command_argument( 1, failure_test_type ) + call failure_test( failure_test_type ) + else + call die( 233227610 ) + end if + +contains + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Test assert functions + subroutine test_assert( ) + + use musica_constants, only : rk => musica_rk, dk => musica_dk + use musica_string, only : string_t + + type(string_t) :: str + real(kind=dk) :: a1d(3), b1d(3), c1d(2), a2d(3,3), b2d(3,3), c2d(2,3) + real(kind=rk) :: a1r(3), b1r(3), c1r(2), a2r(3,3), b2r(3,3), c2r(2,3) + + str = "foo" + + call assert_msg( 449241220, .true., "foo" ) + call assert_msg( 612680578, .true., str ) + call assert( 549577712, .true. ) + + ! test almost_equal( ) + ! for real + call assert( 126460695, almost_equal( 12.5_rk, 12.5_rk ) ) + call assert( 740626672, .not. almost_equal( 12.5_rk, 12.6_rk ) ) + call assert( 172317401, almost_equal( 12.5_rk, 12.6_rk, & + relative_tolerance = 0.11_rk ) ) + call assert( 955187043, almost_equal( 12.5_rk, 12.6_rk, & + absolute_tolerance = 0.11_rk ) ) + call assert( 293998244, .not. & + almost_equal( 12.5e34_rk, & + 12.5e34_rk + 12.5e34_rk * 1.0e-5_rk ) ) + call assert( 881294037, & + almost_equal( 12.5e-34_rk, 12.5e-34_rk + 1.0e-32_rk ) ) + call assert( 151450942, .not. & + almost_equal( 12.5e34_rk, & + 12.5e34_rk - 12.5e34_rk * 1.0e-5_rk ) ) + call assert( 328325392, & + almost_equal( 12.5e-34_rk, 12.5e-34_rk - 1.0e-32_rk ) ) + call assert( 597365549, & + almost_equal( 12.5e34_rk, & + 12.5e34_rk + 12.5e34_rk * 1.0e-5_rk, & + relative_tolerance = 1.0e-4_rk ) ) + call assert( 709683894, .not. & + almost_equal( 12.5e-34_rk, 12.5e-34_rk + 1.0e-32_rk, & + absolute_tolerance = 1.0e-33_rk ) ) + call assert( 539526990, & + almost_equal( 12.5e34_rk, & + 12.5e34_rk - 12.5e34_rk * 1.0e-5_rk, & + relative_tolerance = 1.0e-4_rk ) ) + call assert( 986894836, .not. & + almost_equal( 12.5e-34_rk, 12.5e-34_rk - 1.0e-32_rk, & + absolute_tolerance = 1.0e-33_rk ) ) + + ! for double + call assert( 799568563, almost_equal( 12.5_dk, 12.5_dk ) ) + call assert( 794304256, .not. almost_equal( 12.5_dk, 12.6_dk ) ) + call assert( 341672103, almost_equal( 12.5_dk, 12.6_dk, & + relative_tolerance = 0.11_dk ) ) + call assert( 236523599, almost_equal( 12.5_dk, 12.6_dk, & + absolute_tolerance = 0.11_dk ) ) + call assert( 966366694, .not. & + almost_equal( 12.5e94_dk, & + 12.5e94_dk + 12.5e94_dk * 1.0e-5_dk ) ) + call assert( 796209790, & + almost_equal( 12.5e-94_dk, 12.5e-94_dk + 1.0e-92_dk ) ) + call assert( 343577637, .not. & + almost_equal( 12.5e94_dk, & + 12.5e94_dk - 12.5e94_dk * 1.0e-5_dk ) ) + call assert( 173420733, & + almost_equal( 12.5e-94_dk, 12.5e-94_dk - 1.0e-92_dk ) ) + call assert( 903263828, & + almost_equal( 12.5e94_dk, & + 12.5e94_dk + 12.5e94_dk * 1.0e-5_dk, & + relative_tolerance = 1.0e-4_dk ) ) + call assert( 733106924, .not. & + almost_equal( 12.5e-94_dk, 12.5e-94_dk + 1.0e-92_dk, & + absolute_tolerance = 1.0e-93_dk ) ) + call assert( 562950020, & + almost_equal( 12.5e94_dk, & + 12.5e94_dk - 12.5e94_dk * 1.0e-5_dk, & + relative_tolerance = 1.0e-4_dk ) ) + call assert( 675268365, .not. & + almost_equal( 12.5e-94_dk, 12.5e-94_dk - 1.0e-92_dk, & + absolute_tolerance = 1.0e-93_dk ) ) + + ! for cmplx real + call assert( 677913317, almost_equal( cmplx( 12.5_rk, 3.2_rk, kind=rk ), & + cmplx( 12.5_rk, 3.2_rk, kind=rk ) ) ) + call assert( 837993902, .not. & + almost_equal( cmplx( 12.5_rk, 3.2_rk, kind=rk ), & + cmplx( 12.6_rk, 3.2_rk, kind=rk ) ) ) + call assert( 264420324, .not. & + almost_equal( cmplx( 12.5_rk, 3.2_rk, kind=rk ), & + cmplx( 12.6_rk, 3.3_rk, kind=rk ) ) ) + call assert( 827917583, almost_equal( cmplx( 12.5_rk, 3.2_rk, kind=rk ), & + cmplx( 12.6_rk, 3.2_rk, kind=rk ), & + relative_tolerance = 0.11_rk ) ) + call assert( 538724788, almost_equal( cmplx( 12.5_rk, 3.2_rk, kind=rk ), & + cmplx( 12.5_rk, 3.3_rk, kind=rk ), & + relative_tolerance = 0.11_rk ) ) + call assert( 754738398, almost_equal( cmplx( 12.5_rk, 3.2_rk, kind=rk ), & + cmplx( 12.6_rk, 3.2_rk, kind=rk ), & + absolute_tolerance = 0.11_rk ) ) + call assert( 584581494, almost_equal( cmplx( 12.5_rk, 3.2_rk, kind=rk ), & + cmplx( 12.5_rk, 3.3_rk, kind=rk ), & + absolute_tolerance = 0.11_rk ) ) + + ! for cmplx double + call assert( 556258071, almost_equal( cmplx( 12.5_dk, 3.2_dk, kind=dk ), & + cmplx( 12.5_dk, 3.2_dk, kind=dk ) ) ) + call assert( 268518515, .not. & + almost_equal( cmplx( 12.5_dk, 3.2_dk, kind=dk ), & + cmplx( 12.6_dk, 3.2_dk, kind=dk ) ) ) + call assert( 163370011, .not. & + almost_equal( cmplx( 12.5_dk, 3.2_dk, kind=dk ), & + cmplx( 12.6_dk, 3.3_dk, kind=dk ) ) ) + call assert( 610737857, almost_equal( cmplx( 12.5_dk, 3.2_dk, kind=dk ), & + cmplx( 12.6_dk, 3.2_dk, kind=dk ), & + relative_tolerance = 0.11_dk ) ) + call assert( 440580953, almost_equal( cmplx( 12.5_dk, 3.2_dk, kind=dk ), & + cmplx( 12.5_dk, 3.3_dk, kind=dk ), & + relative_tolerance = 0.11_dk ) ) + call assert( 270424049, almost_equal( cmplx( 12.5_dk, 3.2_dk, kind=dk ), & + cmplx( 12.6_dk, 3.2_dk, kind=dk ), & + absolute_tolerance = 0.11_dk ) ) + call assert( 100267145, almost_equal( cmplx( 12.5_dk, 3.2_dk, kind=dk ), & + cmplx( 12.5_dk, 3.3_dk, kind=dk ), & + absolute_tolerance = 0.11_dk ) ) + + ! test are_equal( ) + ! for 1d real arrays + a1r = [ 2.3_rk, 4.2_rk, 5.2_rk ] + b1r = [ 2.3_rk, 4.2_rk, 5.2_rk ] + c1r = [ 2.3_rk, 4.2_rk ] + call assert( 197244864, are_equal( a1r, b1r ) ) + call assert( 316733050, .not. are_equal( a1r, c1r ) ) + b1r(3) = 42.5_rk + call assert( 478266874, .not. are_equal( a1r, b1r ) ) + + ! for 1d double arrays + a1d = [ 2.3_dk, 4.2_dk, 5.2_dk ] + b1d = [ 2.3_dk, 4.2_dk, 5.2_dk ] + c1d = [ 2.3_dk, 4.2_dk ] + call assert( 197244864, are_equal( a1d, b1d ) ) + call assert( 316733050, .not. are_equal( a1d, c1d ) ) + b1d(3) = 42.5_dk + call assert( 478266874, .not. are_equal( a1d, b1d ) ) + + ! for 2d real arrays + a2r(1,:) = [ 2.3_rk, 4.2_rk, 5.2_rk ] + a2r(2,:) = [ 5.2_rk, 3.2_rk, -42.3_rk ] + a2r(3,:) = [ 7.3_rk, 1.2_rk, 423.1_rk ] + b2r(1,:) = [ 2.3_rk, 4.2_rk, 5.2_rk ] + b2r(2,:) = [ 5.2_rk, 3.2_rk, -42.3_rk ] + b2r(3,:) = [ 7.3_rk, 1.2_rk, 423.1_rk ] + c2r(1,:) = [ 2.3_rk, 4.2_rk, 5.2_rk ] + c2r(2,:) = [ 5.2_rk, 3.2_rk, -42.3_rk ] + call assert( 787185609, are_equal( a2r, b2r ) ) + call assert( 341723297, .not. are_equal( a2r, c2r ) ) + b2r(3,3) = 94.2_rk + call assert( 613669932, .not. are_equal( a2r, b2r ) ) + + ! for 2d double arrays + a2d(1,:) = [ 2.3_dk, 4.2_dk, 5.2_dk ] + a2d(2,:) = [ 5.2_dk, 3.2_dk, -42.3_dk ] + a2d(3,:) = [ 7.3_dk, 1.2_dk, 423.1_dk ] + b2d(1,:) = [ 2.3_dk, 4.2_dk, 5.2_dk ] + b2d(2,:) = [ 5.2_dk, 3.2_dk, -42.3_dk ] + b2d(3,:) = [ 7.3_dk, 1.2_dk, 423.1_dk ] + c2d(1,:) = [ 2.3_dk, 4.2_dk, 5.2_dk ] + c2d(2,:) = [ 5.2_dk, 3.2_dk, -42.3_dk ] + call assert( 787185609, are_equal( a2d, b2d ) ) + call assert( 341723297, .not. are_equal( a2d, c2d ) ) + b2d(3,3) = 94.2_dk + call assert( 613669932, .not. are_equal( a2d, b2d ) ) + + end subroutine test_assert + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Failure tests for assert functions + subroutine failure_test( test_type ) + + character(len=*), intent(in) :: test_type + + if( test_type .eq. "903602145" ) then + call failure_test_903602145( ) + else if( test_type .eq. "151700878" ) then + call failure_test_151700878( ) + else + call die( 634624772 ) + end if + + end subroutine failure_test + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Test failure of assert_msg with string + subroutine failure_test_903602145( ) + + use musica_string, only : string_t + + type(string_t) :: msg + + msg = "foo" + call assert_msg( 903602145, .false., msg ) + + end subroutine failure_test_903602145 + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Test failure of assert_msg with char array + subroutine failure_test_151700878( ) + + call assert_msg( 151700878, .false., "bar" ) + + end subroutine failure_test_151700878 + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +end program test_util_assert diff --git a/test/unit/util/assert.sh b/test/unit/util/assert.sh new file mode 100755 index 00000000..8685a3ee --- /dev/null +++ b/test/unit/util/assert.sh @@ -0,0 +1,34 @@ +#!/bin/bash + +# turn on command echoing +set -v +# move to the directory this script is in +cd ${0%/*} +# define a function for failure tests +failure_test () { + local expected_failure=$(echo $1 | sed -n 's/\([[:digit:]]\+\).*/\1/p') + local output=$(../../../util_assert_failure $1 2>&1) + local failure_code=$(echo $output | sed -n 's/[[:space:]]*ERROR (Musica-\([[:digit:]]\+\).*/\1/p') + if ! [ "$failure_code" = "$expected_failure" ]; then + echo "Expected failure $expected_failure" + echo "Got output: $output" + exit 1 + else + local expected_failure=$(echo $1 | sed -n 's/\([[:digit:]]\+\)/\1/p') + local failure_code=$(cat error.json | sed -n 's/[[:space:]]*\"code\" : \"\([[:digit:]]\+\).*/\1/p') + if ! [ "$failure_code" = "$expected_failure" ]; then + echo "Expected failure $expected_failure in file 'error.json'" + echo "Got: $(cat error.json)" + rm -f error.json + exit 1 + else + rm -f error.json + echo $output + fi + fi +} + +failure_test 903602145 +failure_test 151700878 + +exit 0 diff --git a/test/unit/util/config.F90 b/test/unit/util/config.F90 new file mode 100644 index 00000000..1fdd874c --- /dev/null +++ b/test/unit/util/config.F90 @@ -0,0 +1,629 @@ +! Copyright (C) 2021 National Center for Atmospheric Research +! SPDX-License-Identifier: Apache-2.0 +! +!> \file +!> Tests for the musica_config module + +!> Test module for the musica_config module +program test_config + + use musica_assert + use musica_config + use musica_mpi + + implicit none + + call musica_mpi_init( ) + call test_config_t_mpi( ) + call test_config_t( ) + call config_example( ) + call musica_mpi_finalize( ) + +contains + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Test config_t MPI functions + subroutine test_config_t_mpi( ) + + use musica_string, only : string_t + + type(config_t) :: a, b + type(string_t) :: sa + character, allocatable :: buffer(:) + integer :: pos, pack_size + integer, parameter :: comm = MPI_COMM_WORLD + character(len=*), parameter :: my_name = "config tests" + + if( musica_mpi_rank( comm ) == 0 ) then + a = '{ "foo": "bar" }' + pack_size = a%pack_size( comm ) + allocate( buffer( pack_size ) ) + pos = 0 + call a%mpi_pack( buffer, pos, comm ) + end if + + call musica_mpi_bcast( pack_size, comm ) + + if( musica_mpi_rank( comm ) /= 0 ) allocate( buffer( pack_size ) ) + + call musica_mpi_bcast( buffer, comm ) + + if( musica_mpi_rank( comm ) /= 0 ) then + pos = 0 + call b%mpi_unpack( buffer, pos, comm ) + call b%get( "foo", sa, my_name ) + call assert( 529948470, sa == "bar" ) + end if + + end subroutine test_config_t_mpi + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Test config_t functionality + subroutine test_config_t( ) + + use musica_constants, only : musica_rk, musica_dk, musica_ik + use musica_iterator, only : iterator_t + use musica_string, only : string_t + + type(config_t) :: a, a_file, b, c, array + type(config_t), allocatable :: orig_array(:), dest_array(:) + real(kind=musica_rk) :: ra + real(kind=musica_dk) :: da + real(kind=musica_dk), allocatable :: daa(:), dab(:) + integer(kind=musica_ik) :: ia + logical :: la, found + type(string_t) :: sa, sb + type(string_t), allocatable :: saa(:), sab(:) + character(len=*), parameter :: my_name = "config tests" + class(iterator_t), pointer :: iterator + + ! constructors + a = '{ "foo": "bar" }' + call a%empty( ) + call a_file%from_file( "test/data/test_config.json" ) + if( musica_mpi_rank( MPI_COMM_WORLD ) .eq. 0 ) then + call a_file%to_file( "temp_file.json" ) + call a_file%empty( ) + call a_file%from_file( "temp_file.json" ) + end if + + ! size + a = '{ "foo": "bar", "baz": "qux" }' + call assert( 917322918, a%number_of_children() .eq. 2 ) + + ! get config + call a_file%get( "my sub object", b, my_name, found = found ) + call assert( 169832207, found ) + + call b%get( "sub real", da, my_name ) + call assert( 630635145, almost_equal( da, 87.3d0 ) ) + + call b%get( "sub int", ia, my_name ) + call assert( 892957756, ia .eq. 42 ) + + call b%get( "really?", la, my_name ) + call assert( 389656885, la ) + + call b%get( "a bunch of strings", saa, my_name ) + call assert( 603764961, size( saa ) .eq. 3 ) + call assert( 210876901, saa(1) .eq. "bar" ) + call assert( 325100780, saa(2) .eq. "foo" ) + call assert( 202253821, saa(3) .eq. "barfoo" ) + + call a_file%get( "not there", b, my_name, found = found ) + call assert( 430701579, .not. found ) + + c = '{ "an int" : 13, "foo" : "bar" }' + call a_file%get( "not there", b, my_name, default = c, found = found ) + call assert( 250468356, .not. found ) + call b%get( "foo", sa, my_name ) + call assert( 464576432, sa .eq. "bar" ) + call b%get( "an int", ia, my_name ) + call assert( 457145065, ia .eq. 13 ) + + ! get string + + call a_file%get( "a string", sa, my_name ) + call assert( 651552798, sa .eq. "foo" ) + call a_file%get( "another string", sa, my_name, found = found ) + call assert( 411575482, found ) + call assert( 927310501, sa .eq. "bar" ) + call a_file%get( "a string", sa, my_name, default = "default value" ) + call assert( 292539591, sa .eq. "foo" ) + call a_file%get( "not there", sa, my_name, default = "default value", found = found ) + call assert( 968355195, .not. found ) + call assert( 345566138, sa .eq. "default value" ) + call a_file%get( "also not there", sa, my_name, found = found ) + call assert( 564491555, .not. found ) + + ! get integer + + call a_file%get( "another int", ia, my_name ) + call assert( 851875875, ia .eq. 31 ) + call a_file%get( "my integer", ia, my_name, found = found ) + call assert( 338046390, found ) + call assert( 397790483, ia .eq. 12 ) + call a_file%get( "another int", ia, my_name, default = 42 ) + call assert( 271584751, ia .eq. 31 ) + call a_file%get( "not there", ia, my_name, default = 96, found = found ) + call assert( 440288416, .not. found ) + call assert( 382449857, ia .eq. 96 ) + call a_file%get( "also not there", ia, my_name, found = found ) + call assert( 395787890, .not. found ) + + ! get real + + call a_file%get( "this real", ra, my_name ) + call assert( 821646918, almost_equal( ra, 23.4 ) ) + call a_file%get( "that real", ra, my_name, found = found ) + call assert( 425400085, found ) + call assert( 702611027, almost_equal( ra, 52.3e-4 ) ) + call a_file%get( "this real", ra, my_name, default = 432.5 ) + call assert( 901830772, almost_equal( ra, 23.4e0 ) ) + call a_file%get( "not there", ra, my_name, default = 643.78, found = found ) + call assert( 505583939, .not. found ) + call assert( 165270131, ra .eq. 643.78 ) + call a_file%get( "also not there", ra, my_name, found = found ) + call assert( 736101698, .not. found ) + + ! get double + + call a_file%get( "this real", da, my_name ) + call assert( 155933230, almost_equal( da, 23.4d0 ) ) + call a_file%get( "that real", da, my_name, found = found ) + call assert( 550726824, found ) + call assert( 663045169, almost_equal( da, 52.3d-4 ) ) + call a_file%get( "this real", da, my_name, default = 432.5d0 ) + call assert( 775363514, almost_equal( da, 23.4d0 ) ) + call a_file%get( "not there", da, my_name, default = 643.78d0, found = found ) + call assert( 887681859, .not. found ) + call assert( 435049706, da .eq. 643.78d0 ) + call a_file%get( "also not there", da, my_name, found = found ) + call assert( 228989759, .not. found ) + + ! get boolean + + call a_file%get( "is it?", la, my_name ) + call assert( 807245669, .not. la ) + call a_file%get( "is it really?", la, my_name, found = found ) + call assert( 405734529, found ) + call assert( 630371219, la ) + call a_file%get( "is it?", la, my_name, default = .false. ) + call assert( 511335328, .not. la ) + call a_file%get( "not there", la, my_name, default = .true., found = found ) + call assert( 672869152, .not. found ) + call assert( 227406840, la ) + call a_file%get( "also not there", la, my_name, found = found ) + call assert( 344666877, .not. found ) + + ! get double array + + call a_file%get( "a bunch of doubles", daa, my_name ) + call assert( 302144795, size( daa ) .eq. 4 ) + call assert( 421632981, daa(1) .eq. 12.5_musica_dk ) + call assert( 976054865, daa(2) .eq. 13.2_musica_dk ) + call assert( 465584153, daa(3) .eq. 72.5_musica_dk ) + call assert( 972696092, daa(4) .eq. -142.64_musica_dk ) + call a_file%get( "another bunch of doubles", daa, my_name, found = found ) + call assert( 707754126, found ) + call assert( 460772141, size( daa ) .eq. 2 ) + call assert( 511893154, daa(1) .eq. 52.3_musica_dk ) + call assert( 401480343, daa(2) .eq. 0.0_musica_dk ) + allocate( dab( 2 ) ) + dab(1) = 83.32_musica_dk + dab(2) = -64.23_musica_dk + call a_file%get( "a bunch of doubles", daa, my_name, default = dab ) + call assert( 607417634, size( daa ) .eq. 4 ) + call assert( 826790017, daa(1) .eq. 12.5_musica_dk ) + call assert( 656633113, daa(2) .eq. 13.2_musica_dk ) + call assert( 204000960, daa(3) .eq. 72.5_musica_dk ) + call assert( 998852455, daa(4) .eq. -142.64_musica_dk ) + call a_file%get( "not there", daa, my_name, default = dab, found = found ) + call assert( 369345852, .not. found ) + call assert( 611515825, size( daa ) .eq. 2 ) + call assert( 441358921, daa(1) .eq. 83.32_musica_dk ) + call assert( 836152515, daa(2) .eq. -64.23_musica_dk ) + call a_file%get( "also not there", daa, my_name, found = found ) + call assert( 242877146, .not. found ) + + ! get string array + + call a_file%get( "a bunch of strings", saa, my_name ) + call assert( 215424987, size( saa ) .eq. 3 ) + call assert( 834855271, saa(1) .eq. "foo" ) + call assert( 376958811, saa(2) .eq. "bar" ) + call assert( 884070750, saa(3) .eq. "foobar" ) + call a_file%get( "another bunch of strings", saa, my_name, found = found ) + call assert( 821420179, found ) + call assert( 533680623, size( saa ) .eq. 2 ) + call assert( 875899965, saa(1) .eq. "boo" ) + call assert( 135528256, saa(2) .eq. "far" ) + allocate( sab(2) ) + sab(1) = "default 1" + sab(2) = "default 2" + call a_file%get( "a bunch of strings", saa, my_name, default = sab ) + call assert( 802720780, size( saa ) .eq. 3 ) + call assert( 632563876, saa(1) .eq. "foo" ) + call assert( 127357471, saa(2) .eq. "bar" ) + call assert( 857200566, saa(3) .eq. "foobar" ) + call a_file%get( "not there", saa, my_name, default = sab, found = found ) + call assert( 801267541, .not. found ) + call assert( 513527985, size( saa ) .eq. 2 ) + call assert( 120639925, saa(1) .eq. "default 1" ) + call assert( 792644461, saa(2) .eq. "default 2" ) + call a_file%get( "also not there", saa, my_name, found = found ) + call assert( 354743196, .not. found ) + + ! add config + + a = '{ "some int" : 1263 }' + b = '{ "some real" : 14.3, "some string" : "foo" }' + call a%add( "sub props", b, my_name ) + call b%add( "some string", "bar", my_name ) + call b%get( "some string", sa, my_name ) + call assert( 384683830, sa .eq. "bar" ) + call a%get( "some int", ia, my_name ) + call assert( 762415504, ia .eq. 1263 ) + call a%get( "sub props", c, my_name ) + call c%get( "some string", sa, my_name ) + call assert( 643379613, sa .eq. "foo" ) + call c%get( "some real", da, my_name ) + call assert( 252397087, almost_equal( da, 14.3d0 ) ) + + ! add char array + + call a%add( "new char array", "new char array value", my_name ) + call a%get( "some int", ia, my_name ) + call assert( 575490332, ia .eq. 1263 ) + call a%get( "new char array", sa, my_name ) + call assert( 110876326, sa .eq. "new char array value" ) + + ! add string + + sa = "new string value" + call a%add( "new string", sa, my_name ) + call a%get( "some int", ia, my_name ) + call assert( 428870436, ia .eq. 1263 ) + call a%get( "new string", sb, my_name ) + call assert( 258713532, sb .eq. "new string value" ) + + ! add int + + call a%add( "new int", 432, my_name ) + call a%get( "some int", ia, my_name ) + call assert( 601194400, ia .eq. 1263 ) + call a%get( "new int", ia, my_name ) + call assert( 827736624, ia .eq. 432 ) + + ! add float + + call a%add( "new float", 12.75, my_name ) + call a%get( "some int", ia, my_name ) + call assert( 313907139, ia .eq. 1263 ) + call a%get( "new float", ra, my_name ) + call assert( 875498864, almost_equal( ra, 12.75 ) ) + + ! add double + + call a%add( "new double", 53.6d0, my_name ) + call a%get( "some int", ia, my_name ) + call assert( 470628951, ia .eq. 1263 ) + call a%get( "new double", da, my_name ) + call assert( 468723417, almost_equal( da, 53.60d0 ) ) + + ! add logical + + call a%add( "new logical", .true., my_name ) + call a%get( "some int", ia, my_name ) + call assert( 570965443, ia .eq. 1263 ) + call a%get( "new logical", la, my_name ) + call assert( 128861904, la ) + + ! add double array + + if( allocated( daa ) ) deallocate( daa ) + if( allocated( dab ) ) deallocate( dab ) + allocate( daa(2) ) + daa(1) = -32.51_musica_dk + daa(2) = 10.324_musica_dk + call a%add( "new double array", daa, my_name ) + call a%get( "some int", ia, my_name ) + call assert( 971982271, ia .eq. 1263 ) + call a%get( "new double array", dab, my_name ) + call assert( 456247252, size( dab ) .eq. 2 ) + call assert( 115933444, dab(1) .eq. -32.51_musica_dk ) + call assert( 570471131, dab(2) .eq. 10.324_musica_dk ) + + ! add string array + + if( allocated( saa ) ) deallocate( saa ) + if( allocated( sab ) ) deallocate( sab ) + allocate( saa(2) ) + saa(1) = "foo" + saa(2) = "bar" + call a%add( "new string array", saa, my_name ) + call a%get( "some int", ia, my_name ) + call assert( 729592789, ia .eq. 1263 ) + call a%get( "new string array", sab, my_name ) + call assert( 225839623, size( sab ) .eq. 2 ) + call assert( 115426812, sab(1) .eq. "foo" ) + call assert( 275055102, sab(2) .eq. "bar" ) + + ! assignment + + a = '{ "my favorite int" : 42 }' + b = a + call a%add( "my favorite int", 43, my_name ) + call a%get( "my favorite int", ia, my_name ) + call assert( 277177497, ia .eq. 43 ) + call b%get( "my favorite int", ia, my_name ) + call assert( 679211194, ia .eq. 42 ) + sa = '{ "another int" : 532 }' + c = sa + call c%get( "another int", ia, my_name ) + call assert( 842650552, ia .eq. 532 ) + + ! iterator + a = '{ "my int" : 2,'//& + ' "my real" : 4.2,'//& + ' "my double" : 5.2,'//& + ' "my logical" : true,'//& + ' "my string" : "foo bar",'//& + ' "my sub config" : { "an int" : 3, "a double" : 6.7 },'//& + ' "my string array" : [ "foo", "bar", "foobar" ] }' + call assert( 494127713, a%number_of_children( ) .eq. 7 ) + iterator => a%get_iterator( ) + call assert( 909667855, iterator%next( ) ) + call assert( 432671110, a%key( iterator ) .eq. "my int" ) + call a%get( iterator, ia, my_name ) + call assert( 227587000, ia .eq. 2 ) + call assert( 217058386, iterator%next( ) ) + call a%get( iterator, ra, my_name ) + call assert( 391026358, almost_equal( ra, 4.2 ) ) + call assert( 270084933, iterator%next( ) ) + call a%get( iterator, da, my_name ) + call assert( 384308812, almost_equal( da, 5.2d0 ) ) + call assert( 826412351, iterator%next( ) ) + call a%get( iterator, la, my_name ) + call assert( 258103080, la ) + call assert( 147690269, iterator%next( ) ) + call a%get( iterator, sa, my_name ) + call assert( 361110121, sa .eq. "foo bar" ) + call assert( 468164159, iterator%next( ) ) + call a%get( iterator, b, my_name ) + call b%get( "a double", da, my_name ) + call assert( 749186169, almost_equal( da, 6.7d0 ) ) + call b%get( "an int", ia, my_name ) + call assert( 915984300, ia .eq. 3 ) + call assert( 182782432, iterator%next( ) ) + call a%get( iterator, saa, my_name ) + call assert( 902549208, saa(1) .eq. "foo" ) + call assert( 334239937, saa(2) .eq. "bar" ) + call assert( 164083033, saa(3) .eq. "foobar" ) + call assert( 441293975, .not. iterator%next( ) ) + call iterator%reset( ) + call assert( 102885701, iterator%next( ) ) + call a%get( iterator, ia, my_name ) + call assert( 162629794, ia .eq. 2 ) + deallocate( iterator ) + + ! sequence iterator + a = '[ 2, 3, "foo", { "bar": 4 } ]' + call assert( 443487346, a%number_of_children( ) .eq. 4 ) + iterator => a%get_iterator( ) + call assert( 447298414, iterator%next( ) ) + call a%get( iterator, ia, my_name ) + call assert( 612191011, ia .eq. 2 ) + call assert( 442034107, iterator%next( ) ) + call a%get( iterator, ia, my_name ) + call assert( 889401953, ia .eq. 3 ) + call assert( 101720299, iterator%next( ) ) + call a%get( iterator, sa, my_name ) + call assert( 214038644, sa .eq. "foo" ) + call assert( 661406490, iterator%next( ) ) + call a%get( iterator, b, my_name ) + call b%get( "bar", ia, my_name ) + call assert( 208774337, ia .eq. 4 ) + call assert( 103625833, .not. iterator%next( ) ) + call iterator%reset( ) + call assert( 685807284, iterator%next( ) ) + call a%get( iterator, ia, my_name ) + call assert( 233175131, ia .eq. 2 ) + call assert( 410501876, iterator%next( ) ) + call a%get( iterator, ia, my_name ) + call assert( 857869722, ia .eq. 3 ) + call assert( 122762320, iterator%next( ) ) + call a%get( iterator, sa, my_name ) + call assert( 852605415, sa .eq. "foo" ) + call assert( 682448511, iterator%next( ) ) + call a%get( iterator, b, my_name ) + call b%get( "bar", ia, my_name ) + call assert( 229816358, ia .eq. 4 ) + call assert( 124667854, .not. iterator%next( ) ) + deallocate( iterator ) + + ! empty object iterator + a = "" + call assert( 753171096, a%number_of_children( ) .eq. 0 ) + iterator => a%get_iterator( ) + call assert( 358377502, .not. iterator%next( ) ) + deallocate( iterator ) + + ! merging + a = '{ "a key" : 12,'//& + ' "another key" : 14.2,'//& + ' "sub stuff" : {'//& + ' "orig key" : 72'//& + ' },'//& + ' "yet another key" : "hi" }' + b = '{ "a new key" : true, '//& + ' "sub stuff" : {'//& + ' "new key" : "foo"'//& + ' },'//& + ' "another new key" : 51 }' + call a%merge_in( b, my_name ) + call a%get( "a key", ia, my_name ) + call assert( 111746421, ia .eq. 12 ) + call a%get( "another key", da, my_name ) + call assert( 838230743, almost_equal( da, 14.2d0 ) ) + call a%get( "yet another key", sa, my_name ) + call assert( 259845153, sa .eq. "hi" ) + call a%get( "a new key", la, my_name ) + call assert( 879275437, la ) + call a%get( "another new key", ia, my_name ) + call assert( 756880773, ia .eq. 51 ) + call a%get( "sub stuff", c, my_name ) + call c%get( "orig key", ia, my_name ) + call assert( 172568249, ia .eq. 72 ) + call c%get( "new key", sa, my_name ) + call b%get( "a new key", la, my_name ) + call assert( 816624866, la ) + call b%get( "another new key", ia, my_name ) + call assert( 877822198, ia .eq. 51 ) + call b%get( "sub stuff", c, my_name ) + call c%get( "new key", sa, my_name ) + call assert( 597877923, sa .eq. "foo" ) + call c%get( "orig key", ia, my_name, found = found ) + call assert( 933379719, .not. found ) + call b%get( "a key", ia, my_name, found = found ) + call assert( 597164102, .not. found ) + call b%get( "another key", da, my_name, found = found ) + call assert( 293082976, .not. found ) + call b%get( "yet another key", sa, my_name, found = found ) + call assert( 907248953, .not. found ) + + ! get and set config array + allocate( orig_array( 3 ) ) + call orig_array( 1 )%empty( ) + call orig_array( 1 )%add( "a key", "a", my_name ) + call orig_array( 1 )%add( "same key", "same value", my_name ) + call orig_array( 2 )%empty( ) + call orig_array( 2 )%add( "b key", "b", my_name ) + call orig_array( 2 )%add( "same key", "same value", my_name ) + call orig_array( 3 )%empty( ) + call orig_array( 3 )%add( "c key", "c", my_name ) + call orig_array( 3 )%add( "same key", "same value", my_name ) + call array%empty( ) + call array%add( "my array", orig_array, my_name ) + deallocate( orig_array ) + call array%get( "my array", dest_array, my_name ) + call assert( 706554286, allocated( dest_array ) ) + call assert( 874805656, size( dest_array ) .eq. 3 ) + call dest_array( 1 )%get( "a key", sa, my_name ) + call assert( 308401919, sa .eq. "a" ) + call dest_array( 2 )%get( "b key", sa, my_name ) + call assert( 475200050, sa .eq. "b" ) + call dest_array( 3 )%get( "c key", sa, my_name ) + call assert( 640092647, sa .eq. "c" ) + deallocate( dest_array ) + call array%get( "my array", b, my_name ) + iterator => b%get_iterator( ) + call assert( 259072462, b%number_of_children( ) .eq. 3 ) + do while( iterator%next( ) ) + call b%get( iterator, a, my_name ) + call a%get( "same key", sa, my_name ) + call assert( 322175328, sa .eq. "same value" ) + end do + deallocate( iterator ) + + ! string assignment + + a = '{ "foo": 12, "bar": false }' + sa = a + b = sa + call assert( 618824101, b%number_of_children( ) .eq. 2 ) + call b%get( "foo", ia, my_name ) + call assert( 733047980, ia .eq. 12 ) + call b%get( "bar", la, my_name ) + call assert( 787527766, .not. la ) + + ! JSON/YAML validation + a = '{ "a reqd key": 12.3,'// & + ' "an optional key": "abcd",'// & + ' "another reqd key": false,'// & + ' "__a user key": { "foo": "bar" } }' + if( allocated( saa ) ) deallocate( saa ) + if( allocated( sab ) ) deallocate( sab ) + allocate( saa( 2 ) ) + allocate( sab( 2 ) ) + saa(1) = "a reqd key" + saa(2) = "another reqd key" + sab(1) = "an optional key" + sab(2) = "another optional key" + call assert( 645591305, a%validate( saa, sab ) ) + deallocate( saa ) + allocate( saa( 1 ) ) + saa(1) = "a reqd key" + call assert( 264571120, .not. a%validate( saa, sab ) ) + + end subroutine test_config_t + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Test the \c config_t example code + subroutine config_example( ) + +use musica_config, only : config_t +use musica_constants, only : musica_dk, musica_ik +use musica_iterator, only : iterator_t +use musica_string, only : string_t + +character(len=*), parameter :: my_name = "config file example" +type(config_t) :: main_config, sub_config, sub_real_config +real(musica_dk) :: my_real +integer(musica_ik) :: my_int +type(string_t) :: my_string +class(iterator_t), pointer :: iter +logical :: found + +call main_config%from_file( 'test/data/config_example.json' ) + +! this would fail with an error if 'a string' is not found +call main_config%get( "a string", my_string, my_name ) +write(*,*) "a string value: ", my_string%val_ + +! add the found argument to avoid failure if the pair is not found +call main_config%get( "my int", my_int, my_name, found = found ) +if( found ) then + write(*,*) "my int value: ", my_int +else + write(*,*) "'my int' was not found" +end if + +! when you get a subset of the properties, a new config_t object is +! created containing the subset data. The two config_t objects are +! independent of one another after this point. +call main_config%get( "other props", sub_config, my_name ) +call sub_config%get( "an int", my_int, my_name ) +write(*,*) "other props->an int value: ", my_int + +! you can iterate over a set of key-value pairs. but remember that +! the order is always arbitrary. you also must provide the right type +! of variable for the values. +call main_config%get( "real props", sub_real_config, my_name ) +iter => sub_real_config%get_iterator( ) +do while( iter%next( ) ) + my_string = sub_real_config%key( iter ) + call sub_real_config%get( iter, my_real, my_name ) + write(*,*) my_string%val_, " value: ", my_real +end do + +! you can also get the number of child objects before iterating over +! them, if you want to allocate an array or something first +write(*,*) "number of children: ", sub_real_config%number_of_children( ) + +! you can add key-value pairs with the add function +call main_config%add( "my new int", 43, my_name ) +call main_config%get( "my new int", my_int, my_name ) +write(*,*) "my new int value: ", my_int + +! clean up memory +deallocate( iter ) + + end subroutine config_example + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +end program test_config diff --git a/test/unit/util/io/CMakeLists.txt b/test/unit/util/io/CMakeLists.txt new file mode 100644 index 00000000..fe480cd3 --- /dev/null +++ b/test/unit/util/io/CMakeLists.txt @@ -0,0 +1,17 @@ +################################################################################ +# Test utilities + +include(test_util) + +################################################################################ +# IO Utility tests + +# There is a small memory leak in the NetCDF library code when +# creating a new file, so skip the memory check +# Also, since this creates a file, don't run with multiple cores +add_executable(test_util_io_netcdf netcdf.F90) +target_link_libraries(test_util_io_netcdf PUBLIC musica::tuvx) +target_include_directories(test_util_io_netcdf PUBLIC ${CMAKE_BINARY_DIR}/src) +add_test(NAME util_io_netcdf COMMAND ${CMAKE_BINARY_DIR}/test_util_io_netcdf) + +################################################################################ diff --git a/test/unit/util/io/netcdf.F90 b/test/unit/util/io/netcdf.F90 new file mode 100644 index 00000000..a0178d96 --- /dev/null +++ b/test/unit/util/io/netcdf.F90 @@ -0,0 +1,623 @@ +! Copyright (C) 2021 National Center for Atmospheric Research +! SPDX-License-Identifier: Apache-2.0 +! +!> \file +!> The test_io_netcdf program + +!> Tests for the io_netcdf_t type +program test_io_netcdf + + use musica_assert + use musica_io_netcdf + use musica_string, only : string_t + + implicit none + + integer :: stat + type(string_t) :: file_name + + ! Test read functions with an existing NetCDF file + file_name = "../../../data/io_netcdf_test_data.nc" + call test_read_netcdf( file_name ) + + ! Test creating the same file with write functions and testing it + ! (delete any files from previous tests first) + file_name = "test_io_netcdf_write.nc" + open( unit = 16, iostat = stat, file = file_name%to_char( ), status = 'old' ) + if( stat == 0 ) close( 16, status = 'delete' ) + call test_write_netcdf( file_name ) + call test_read_netcdf( file_name ) + + ! Test append functions + ! (delete any files from previous tests first) + file_name = "test_io_netcdf_append.nc" + open( unit = 16, iostat = stat, file = file_name%to_char( ), status = 'old' ) + if( stat == 0 ) close( 16, status = 'delete' ) + call test_append_netcdf( file_name ) + +contains + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Tests NetCDF functions using a file that is expected to be in a known + !! state. + subroutine test_read_netcdf( file_name ) + + use musica_constants, only : dk => musica_dk + use musica_io, only : io_t + + type(string_t), intent(in) :: file_name + + character(len=*), parameter :: my_name = "io_netcdf_t read tests" + class(io_t), pointer :: my_file + type(string_t) :: var_name + real(kind=dk) :: real0D + real(kind=dk), allocatable :: real1D(:) + real(kind=dk), allocatable :: real2D(:,:) + real(kind=dk), allocatable :: real3D(:,:,:) + real(kind=dk), allocatable :: real4D(:,:,:,:) + integer :: int0D + integer, allocatable :: int1D(:) + type(string_t), allocatable :: dim_names(:) + + my_file => io_netcdf_t( file_name ) + call assert( 312726817, associated( my_file ) ) + + ! check units + var_name = "foo" + call assert( 600672797, my_file%variable_units( var_name, my_name ) & + .eq. "foobits" ) + + ! check for variables + var_name = "foo" + call assert( 745691162, my_file%exists( var_name, my_name ) ) + call assert( 852745200, .not. my_file%exists( "not there", my_name ) ) + + ! scalar real + var_name = "qux" + call my_file%read( var_name, real0D, my_name ) + call assert( 322376438, real0D .eq. 92.37_dk ) + + ! scalar int + var_name = "quux" + call my_file%read( var_name, int0D, my_name ) + call assert( 330171719, int0D .eq. 7 ) + + ! unallocated 1D real + var_name = "foo" + call my_file%read( var_name, real1D, my_name ) + call assert( 441036825, allocated( real1D ) ) + call assert( 442942359, size( real1D ) .eq. 4 ) + call assert( 567529680, almost_equal( real1D( 1 ), 15.32_dk ) ) + call assert( 846646156, almost_equal( real1D( 2 ), 3.14_dk ) ) + call assert( 394014003, almost_equal( real1D( 3 ), 26.71_dk ) ) + call assert( 558906600, almost_equal( real1D( 4 ), 19.34_dk ) ) + deallocate( real1D ) + + ! pre-allocatted 1D real + allocate( real1D( 3 ) ) + var_name = "bar" + call my_file%read( var_name, real1D, my_name ) + call assert( 329457898, allocated( real1D ) ) + call assert( 889144089, size( real1D ) .eq. 3 ) + call assert( 155942221, almost_equal( real1D( 1 ), 51.43_dk ) ) + call assert( 885785316, almost_equal( real1D( 2 ), 123.01_dk ) ) + call assert( 150677914, almost_equal( real1D( 3 ), 32.61_dk ) ) + deallocate( real1D ) + + ! unallocated 1D int + var_name = "quuz" + call my_file%read( var_name, int1D, my_name ) + call assert( 595878700, allocated( int1D ) ) + call assert( 820515390, size( int1D ) .eq. 4 ) + call assert( 145152081, int1D( 1 ) .eq. 9 ) + call assert( 199631867, int1D( 2 ) .eq. 3 ) + call assert( 364524464, int1D( 3 ) .eq. 12 ) + call assert( 811892310, int1D( 4 ) .eq. 1 ) + deallocate( int1D ) + + ! pre-allocated 1D int + allocate( int1D( 4 ) ) + var_name = "quuz" + call my_file%read( var_name, int1D, my_name ) + call assert( 917493109, allocated( int1D ) ) + call assert( 182385707, size( int1D ) .eq. 4 ) + call assert( 977237202, int1D( 1 ) .eq. 9 ) + call assert( 807080298, int1D( 2 ) .eq. 3 ) + call assert( 971972895, int1D( 3 ) .eq. 12 ) + call assert( 519340742, int1D( 4 ) .eq. 1 ) + deallocate( int1D ) + + ! unallocated 2D real + var_name = "baz" + call my_file%read( var_name, real2D, my_name ) + call assert( 910775563, allocated( real2D ) ) + call assert( 517887503, size( real2D, 1 ) .eq. 3 ) + call assert( 454784637, size( real2D, 2 ) .eq. 4 ) + call assert( 961896576, almost_equal( real2D( 1, 1 ), 31.2_dk ) ) + call assert( 337654280, almost_equal( real2D( 2, 1 ), 41.3_dk ) ) + call assert( 785022126, almost_equal( real2D( 3, 1 ), 623.34_dk ) ) + call assert( 332389973, almost_equal( real2D( 1, 2 ), 124.24_dk ) ) + call assert( 227241469, almost_equal( real2D( 2, 2 ), 1592.3_dk ) ) + call assert( 674609315, almost_equal( real2D( 3, 2 ), 42.53_dk ) ) + call assert( 221977162, almost_equal( real2D( 1, 3 ), 1.3e-7_dk ) ) + call assert( 669345008, almost_equal( real2D( 2, 3 ), -31.6_dk ) ) + call assert( 499188104, almost_equal( real2D( 3, 3 ), 82.3_dk ) ) + call assert( 111564351, almost_equal( real2D( 1, 4 ), 51.64_dk ) ) + call assert( 558932197, almost_equal( real2D( 2, 4 ), -61.7_dk ) ) + call assert( 106300044, almost_equal( real2D( 3, 4 ), -423000.0_dk ) ) + deallocate( real2D ) + + ! pre-allocated 2D real + allocate( real2D( 3, 4 ) ) + call my_file%read( var_name, real2D, my_name ) + call assert( 301447195, allocated( real2D ) ) + call assert( 748815041, size( real2D, 1 ) .eq. 3 ) + call assert( 861133386, size( real2D, 2 ) .eq. 4 ) + call assert( 408501233, almost_equal( real2D( 1, 1 ), 31.2_dk ) ) + call assert( 303352729, almost_equal( real2D( 2, 1 ), 41.3_dk ) ) + call assert( 133195825, almost_equal( real2D( 3, 1 ), 623.34_dk ) ) + call assert( 863038920, almost_equal( real2D( 1, 2 ), 124.24_dk ) ) + call assert( 410406767, almost_equal( real2D( 2, 2 ), 1592.3_dk ) ) + call assert( 857774613, almost_equal( real2D( 3, 2 ), 42.53_dk ) ) + call assert( 405142460, almost_equal( real2D( 1, 3 ), 1.3e-7_dk ) ) + call assert( 234985556, almost_equal( real2D( 2, 3 ), -31.6_dk ) ) + call assert( 129837052, almost_equal( real2D( 3, 3 ), 82.3_dk ) ) + call assert( 577204898, almost_equal( real2D( 1, 4 ), 51.64_dk ) ) + call assert( 742097495, almost_equal( real2D( 2, 4 ), -61.7_dk ) ) + call assert( 854415840, almost_equal( real2D( 3, 4 ), -423000.0_dk ) ) + deallocate( real2D ) + + ! 3D unallocated variable + var_name = "foobar" + call my_file%read( var_name, real3D, my_name ) + call assert( 628827846, allocated( real3D ) ) + call assert( 688571939, size( real3D, 1 ) .eq. 1 ) + call assert( 230675479, size( real3D, 2 ) .eq. 3 ) + call assert( 125526975, size( real3D, 3 ) .eq. 4 ) + call assert( 850105763, almost_equal( real3D( 1, 1, 1 ), 532.123_dk ) ) + call assert( 231414897, almost_equal( real3D( 1, 2, 1 ), 1.5e28_dk ) ) + call assert( 343733242, almost_equal( real3D( 1, 3, 1 ), 42.5_dk ) ) + call assert( 723638505, almost_equal( real3D( 1, 1, 2 ), 39.25_dk ) ) + call assert( 835956850, almost_equal( real3D( 1, 2, 2 ), 4293.12_dk ) ) + call assert( 383324697, almost_equal( real3D( 1, 3, 2 ), 9753.231_dk ) ) + call assert( 926217023, almost_equal( real3D( 1, 1, 3 ), 3.25e-19_dk ) ) + call assert( 473584870, almost_equal( real3D( 1, 2, 3 ), 4.629e10_dk ) ) + call assert( 368436366, almost_equal( real3D( 1, 3, 3 ), 7264.12_dk ) ) + call assert( 133271062, almost_equal( real3D( 1, 1, 4 ), 8.4918e7_dk ) ) + call assert( 757965653, almost_equal( real3D( 1, 2, 4 ), 13.2_dk ) ) + call assert( 310597807, almost_equal( real3D( 1, 3, 4 ), 8293.12_dk ) ) + deallocate( real3D ) + + ! 3D pre-allocated variable + var_name = "foobar" + allocate( real3D( 1, 3, 4 ) ) + call my_file%read( var_name, real3D, my_name ) + call assert( 506458779, allocated( real3D ) ) + call assert( 618777124, size( real3D, 1 ) .eq. 1 ) + call assert( 166144971, size( real3D, 2 ) .eq. 3 ) + call assert( 895988066, size( real3D, 3 ) .eq. 4 ) + call assert( 443355913, almost_equal( real3D( 1, 1, 1 ), 532.123_dk ) ) + call assert( 338207409, almost_equal( real3D( 1, 2, 1 ), 1.5e28_dk ) ) + call assert( 168050505, almost_equal( real3D( 1, 3, 1 ), 42.5_dk ) ) + call assert( 615418351, almost_equal( real3D( 1, 1, 2 ), 39.25_dk ) ) + call assert( 727736696, almost_equal( real3D( 1, 2, 2 ), 4293.12_dk ) ) + call assert( 892629293, almost_equal( real3D( 1, 3, 2 ), 9753.231_dk ) ) + call assert( 439997140, almost_equal( real3D( 1, 1, 3 ), 3.25e-19_dk ) ) + call assert( 334848636, almost_equal( real3D( 1, 2, 3 ), 4.629e10_dk ) ) + call assert( 164691732, almost_equal( real3D( 1, 3, 3 ), 7264.12_dk ) ) + call assert( 612059578, almost_equal( real3D( 1, 1, 4 ), 8.4918e7_dk ) ) + call assert( 441902674, almost_equal( real3D( 1, 2, 4 ), 13.2_dk ) ) + call assert( 606795271, almost_equal( real3D( 1, 3, 4 ), 8293.12_dk ) ) + deallocate( real3D ) + + ! 4D unallocated variable + var_name = "corge" + call my_file%read( var_name, real4D, my_name ) + call assert( 464572470, allocated( real4D ) ) + call assert( 911940316, size( real4D, 1 ) .eq. 2 ) + call assert( 124258662, size( real4D, 2 ) .eq. 1 ) + call assert( 571626508, size( real4D, 3 ) .eq. 3 ) + call assert( 118994355, size( real4D, 4 ) .eq. 4 ) + call assert( 913845850, almost_equal( real4D( 1, 1, 1, 1 ), 532.123_dk ) ) + call assert( 743688946, almost_equal( real4D( 2, 1, 1, 1 ), 632.123_dk ) ) + call assert( 291056793, almost_equal( real4D( 1, 1, 2, 1 ), 1.5e28_dk ) ) + call assert( 738424639, almost_equal( real4D( 2, 1, 2, 1 ), 2.5e28_dk ) ) + call assert( 285792486, almost_equal( real4D( 1, 1, 3, 1 ), 42.5_dk ) ) + call assert( 115635582, almost_equal( real4D( 2, 1, 3, 1 ), 52.5_dk ) ) + call assert( 227953927, almost_equal( real4D( 1, 1, 1, 2 ), 39.25_dk ) ) + call assert( 221236381, almost_equal( real4D( 2, 1, 1, 2 ), 49.25_dk ) ) + call assert( 398563126, almost_equal( real4D( 1, 1, 2, 2 ), 4293.12_dk ) ) + call assert( 563455723, almost_equal( real4D( 2, 1, 2, 2 ), 5293.12_dk ) ) + call assert( 170567663, almost_equal( real4D( 1, 1, 3, 2 ), 9753.231_dk ) ) + call assert( 335460260, almost_equal( real4D( 2, 1, 3, 2 ), 1753.231_dk ) ) + call assert( 782828106, almost_equal( real4D( 1, 1, 1, 3 ), 3.25e-19_dk ) ) + call assert( 395204353, almost_equal( real4D( 2, 1, 1, 3 ), 4.25e-19_dk ) ) + call assert( 225047449, almost_equal( real4D( 1, 1, 2, 3 ), 4.629e10_dk ) ) + call assert( 389940046, almost_equal( real4D( 2, 1, 2, 3 ), 5.629e10_dk ) ) + call assert( 554832643, almost_equal( real4D( 1, 1, 3, 3 ), 7264.12_dk ) ) + call assert( 384675739, almost_equal( real4D( 2, 1, 3, 3 ), 8264.12_dk ) ) + call assert( 897051985, almost_equal( real4D( 1, 1, 1, 4 ), 8.4918e7_dk ) ) + call assert( 444419832, almost_equal( real4D( 2, 1, 1, 4 ), 9.4918e7_dk ) ) + call assert( 556738177, almost_equal( real4D( 1, 1, 2, 4 ), 13.2_dk ) ) + call assert( 104106024, almost_equal( real4D( 2, 1, 2, 4 ), 23.2_dk ) ) + call assert( 551473870, almost_equal( real4D( 1, 1, 3, 4 ), 8293.12_dk ) ) + call assert( 446325366, almost_equal( real4D( 2, 1, 3, 4 ), 9293.12_dk ) ) + deallocate( real4D ) + + ! 4D allocated variable + var_name = "corge" + allocate( real4D( 2, 1, 3, 4 ) ) + call my_file%read( var_name, real4D, my_name ) + call assert( 493635311, allocated( real4D ) ) + call assert( 106011558, size( real4D, 1 ) .eq. 2 ) + call assert( 553379404, size( real4D, 2 ) .eq. 1 ) + call assert( 100747251, size( real4D, 3 ) .eq. 3 ) + call assert( 830590346, size( real4D, 4 ) .eq. 4 ) + call assert( 660433442, almost_equal( real4D( 1, 1, 1, 1 ), 532.123_dk ) ) + call assert( 207801289, almost_equal( real4D( 2, 1, 1, 1 ), 632.123_dk ) ) + call assert( 102652785, almost_equal( real4D( 1, 1, 2, 1 ), 1.5e28_dk ) ) + call assert( 550020631, almost_equal( real4D( 2, 1, 2, 1 ), 2.5e28_dk ) ) + call assert( 997388477, almost_equal( real4D( 1, 1, 3, 1 ), 42.5_dk ) ) + call assert( 262281075, almost_equal( real4D( 2, 1, 3, 1 ), 52.5_dk ) ) + call assert( 157132571, almost_equal( real4D( 1, 1, 1, 2 ), 39.25_dk ) ) + call assert( 886975666, almost_equal( real4D( 2, 1, 1, 2 ), 49.25_dk ) ) + call assert( 151868264, almost_equal( real4D( 1, 1, 2, 2 ), 4293.12_dk ) ) + call assert( 264186609, almost_equal( real4D( 2, 1, 2, 2 ), 5293.12_dk ) ) + call assert( 711554455, almost_equal( real4D( 1, 1, 3, 2 ), 9753.231_dk ) ) + call assert( 258922302, almost_equal( real4D( 2, 1, 3, 2 ), 1753.231_dk ) ) + call assert( 771298548, almost_equal( real4D( 1, 1, 1, 3 ), 3.25e-19_dk ) ) + call assert( 601141644, almost_equal( real4D( 2, 1, 1, 3 ), 4.25e-19_dk ) ) + call assert( 766034241, almost_equal( real4D( 1, 1, 2, 3 ), 4.629e10_dk ) ) + call assert( 313402088, almost_equal( real4D( 2, 1, 2, 3 ), 5.629e10_dk ) ) + call assert( 208253584, almost_equal( real4D( 1, 1, 3, 3 ), 7264.12_dk ) ) + call assert( 655621430, almost_equal( real4D( 2, 1, 3, 3 ), 8264.12_dk ) ) + call assert( 202989277, almost_equal( real4D( 1, 1, 1, 4 ), 8.4918e7_dk ) ) + call assert( 932832372, almost_equal( real4D( 2, 1, 1, 4 ), 9.4918e7_dk ) ) + call assert( 762675468, almost_equal( real4D( 1, 1, 2, 4 ), 13.2_dk ) ) + call assert( 874993813, almost_equal( real4D( 2, 1, 2, 4 ), 23.2_dk ) ) + call assert( 139886411, almost_equal( real4D( 1, 1, 3, 4 ), 8293.12_dk ) ) + call assert( 317213156, almost_equal( real4D( 2, 1, 3, 4 ), 9293.12_dk ) ) + deallocate( real4D ) + + ! dimension names + var_name = "qux" + dim_names = my_file%variable_dimensions( var_name, my_name ) + call assert( 685336671, allocated( dim_names ) ) + call assert( 410031263, size( dim_names ) .eq. 0 ) + deallocate( dim_names ) + + var_name = "corge" + dim_names = my_file%variable_dimensions( var_name, my_name ) + call assert( 513726528, allocated( dim_names ) ) + call assert( 562942007, size( dim_names ) .eq. 4 ) + call assert( 282372292, dim_names( 1 ) .eq. "i" ) + call assert( 619327327, dim_names( 2 ) .eq. "h" ) + call assert( 166695174, dim_names( 3 ) .eq. "g" ) + call assert( 896538269, dim_names( 4 ) .eq. "f" ) + deallocate( dim_names ) + + ! clean up + deallocate( my_file ) + + end subroutine test_read_netcdf + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Tests NetCDF write functions to generate a NetCDF file that is in the + !! state expected by `test_read_netcdf( )` + subroutine test_write_netcdf( file_name ) + + use musica_constants, only : dk => musica_dk + use musica_io, only : io_t + + type(string_t), intent(in) :: file_name + + character(len=*), parameter :: my_name = "io_netcdf_t write tests" + class(io_t), pointer :: my_file + type(string_t) :: var_name, units + type(string_t) :: dim_names(4) + real(kind=dk), allocatable :: real2D(:,:) + real(kind=dk), allocatable :: real3D(:,:,:) + real(kind=dk), allocatable :: real4D(:,:,:,:) + + my_file => io_netcdf_t( file_name ) + call assert( 362264371, associated( my_file ) ) + + var_name = "qux" + call my_file%write( var_name, 92.37_dk, my_name ) + + var_name = "foo" + dim_names(1) = "f" + units = "foobits" + call my_file%write( var_name, dim_names(1), & + (/ 15.32_dk, 3.14_dk, 26.71_dk, 19.34_dk /), my_name ) + call my_file%set_variable_units( var_name, units, my_name ) + + var_name = "bar" + dim_names(1) = "g" + call my_file%write( var_name, dim_names(1), & + (/ 51.43_dk, 123.01_dk, 32.61_dk /), my_name ) + + var_name = "baz" + dim_names(1) = "g" + dim_names(2) = "f" + allocate( real2D( 3, 4 ) ) + real2D(:,1) = (/ 31.2_dk, 41.3_dk, 623.34_dk /) + real2D(:,2) = (/ 124.24_dk, 1592.3_dk, 42.53_dk /) + real2D(:,3) = (/ 1.3e-7_dk, -31.6_dk, 82.3_dk /) + real2D(:,4) = (/ 51.64_dk, -61.7_dk, -423000.0_dk /) + call my_file%write( var_name, dim_names(1:2), real2D, my_name ) + + var_name = "foobar" + dim_names(1) = "h" + dim_names(2) = "g" + dim_names(3) = "f" + allocate( real3D( 1, 3, 4 ) ) + real3D(1,:,1) = (/ 532.123_dk, 1.5e+28_dk, 42.5_dk /) + real3D(1,:,2) = (/ 39.25_dk, 4293.12_dk, 9753.231_dk /) + real3D(1,:,3) = (/ 3.25e-19_dk, 46290000000.0_dk, 7264.12_dk /) + real3D(1,:,4) = (/ 84918000.0_dk, 13.2_dk, 8293.12_dk /) + call my_file%write( var_name, dim_names(1:3), real3D, my_name ) + + var_name = "corge" + dim_names(1) = "i" + dim_names(2) = "h" + dim_names(3) = "g" + dim_names(4) = "f" + allocate( real4D( 2, 1, 3, 4 ) ) + real4D(:,1,1,1) = (/ 532.123_dk, 632.123_dk /) + real4D(:,1,2,1) = (/ 1.5e+28_dk, 2.5e+28_dk /) + real4D(:,1,3,1) = (/ 42.5_dk, 52.5_dk /) + real4D(:,1,1,2) = (/ 39.25_dk, 49.25_dk /) + real4D(:,1,2,2) = (/ 4293.12_dk, 5293.12_dk /) + real4D(:,1,3,2) = (/ 9753.231_dk, 1753.231_dk /) + real4D(:,1,1,3) = (/ 3.25e-19_dk, 4.25e-19_dk /) + real4D(:,1,2,3) = (/ 46290000000.0_dk, 56290000000.0_dk /) + real4D(:,1,3,3) = (/ 7264.12_dk, 8264.12_dk /) + real4D(:,1,1,4) = (/ 84918000.0_dk, 94918000.0_dk /) + real4D(:,1,2,4) = (/ 13.2_dk, 23.2_dk /) + real4D(:,1,3,4) = (/ 8293.12_dk, 9293.12_dk /) + call my_file%write( var_name, dim_names(1:4), real4D, my_name ) + + var_name = "quux" + call my_file%write( var_name, 7, my_name ) + + var_name = "quuz" + dim_names(1) = "f" + call my_file%write( var_name, dim_names(1), (/ 9, 3, 12, 1 /), my_name ) + + ! clean up + deallocate( my_file ) + + end subroutine test_write_netcdf + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Tests NetCDF append functions + subroutine test_append_netcdf( file_name ) + + use musica_constants, only : dk => musica_dk + use musica_io, only : io_t + + type(string_t), intent(in) :: file_name + + character(len=*), parameter :: my_name = "io_netcdf_t append tests" + class(io_t), pointer :: my_file + type(string_t) :: var_name, units + type(string_t) :: dim_names(4), append_dim + integer, allocatable :: int1D(:) + real(kind=dk), allocatable :: real1D(:) + real(kind=dk), allocatable :: real2D(:,:) + real(kind=dk), allocatable :: real3D(:,:,:) + real(kind=dk), allocatable :: real4D(:,:,:,:) + + my_file => io_netcdf_t( file_name ) + + ! 1D real + var_name = "foo" + append_dim = "f" + units = "foobits" + call my_file%append( var_name, units, append_dim, 1, 15.32_dk, my_name ) + call my_file%append( var_name, units, append_dim, 2, 3.14_dk, my_name ) + call my_file%append( var_name, units, append_dim, 3, 26.71_dk, my_name ) + call my_file%append( var_name, units, append_dim, 4, 19.34_dk, my_name ) + + ! 2D real + var_name = "baz" + append_dim = "f" + dim_names(1) = "g" + allocate( real1D( 3 ) ) + real1D(:) = (/ 31.2_dk, 41.3_dk, 623.34_dk /) + call my_file%append( var_name, units, append_dim, 1, dim_names(1), real1D,& + my_name ) + real1D(:) = (/ 124.24_dk, 1592.3_dk, 42.53_dk /) + call my_file%append( var_name, units, append_dim, 2, dim_names(1), real1D,& + my_name ) + real1D(:) = (/ 1.3e-7_dk, -31.6_dk, 82.3_dk /) + call my_file%append( var_name, units, append_dim, 3, dim_names(1), real1D,& + my_name ) + real1D(:) = (/ 51.64_dk, -61.7_dk, -423000.0_dk /) + call my_file%append( var_name, units, append_dim, 4, dim_names(1), real1D,& + my_name ) + deallocate( real1D ) + + ! 3D real + var_name = "foobar" + append_dim = "f" + dim_names(1) = "h" + dim_names(2) = "g" + allocate( real2D( 1, 3 ) ) + real2D(1,:) = (/ 532.123_dk, 1.5e+28_dk, 42.5_dk /) + call my_file%append( var_name, units, append_dim, 1, dim_names, real2D, & + my_name ) + real2D(1,:) = (/ 39.25_dk, 4293.12_dk, 9753.231_dk /) + call my_file%append( var_name, units, append_dim, 2, dim_names, real2D, & + my_name ) + real2D(1,:) = (/ 3.25e-19_dk, 46290000000.0_dk, 7264.12_dk /) + call my_file%append( var_name, units, append_dim, 3, dim_names, real2D, & + my_name ) + real2D(1,:) = (/ 84918000.0_dk, 13.2_dk, 8293.12_dk /) + call my_file%append( var_name, units, append_dim, 4, dim_names, real2D, & + my_name ) + deallocate( real2D ) + + ! 4D real + var_name = "corge" + append_dim = "f" + dim_names(1) = "i" + dim_names(2) = "h" + dim_names(3) = "g" + allocate( real3D( 2, 1, 3 ) ) + real3D(:,1,1) = (/ 532.123_dk, 632.123_dk /) + real3D(:,1,2) = (/ 1.5e+28_dk, 2.5e+28_dk /) + real3D(:,1,3) = (/ 42.5_dk, 52.5_dk /) + call my_file%append( var_name, units, append_dim, 1, dim_names, real3D, & + my_name ) + real3D(:,1,1) = (/ 39.25_dk, 49.25_dk /) + real3D(:,1,2) = (/ 4293.12_dk, 5293.12_dk /) + real3D(:,1,3) = (/ 9753.231_dk, 1753.231_dk /) + call my_file%append( var_name, units, append_dim, 2, dim_names, real3D, & + my_name ) + real3D(:,1,1) = (/ 3.25e-19_dk, 4.25e-19_dk /) + real3D(:,1,2) = (/ 46290000000.0_dk, 56290000000.0_dk /) + real3D(:,1,3) = (/ 7264.12_dk, 8264.12_dk /) + call my_file%append( var_name, units, append_dim, 3, dim_names, real3D, & + my_name ) + real3D(:,1,1) = (/ 84918000.0_dk, 94918000.0_dk /) + real3D(:,1,2) = (/ 13.2_dk, 23.2_dk /) + real3D(:,1,3) = (/ 8293.12_dk, 9293.12_dk /) + call my_file%append( var_name, units, append_dim, 4, dim_names, real3D, & + my_name ) + deallocate( real3D ) + + ! 1D int + var_name = "quuz" + append_dim = "f" + call my_file%append( var_name, units, append_dim, 1, 9, my_name ) + call my_file%append( var_name, units, append_dim, 2, 3, my_name ) + call my_file%append( var_name, units, append_dim, 3, 12, my_name ) + call my_file%append( var_name, units, append_dim, 4, 1, my_name ) + + deallocate( my_file ) + + + !! Check appended data !! + + my_file => io_netcdf_t( file_name ) + call assert( 829668994, associated( my_file ) ) + + ! check units + var_name = "foo" + call assert( 606937838, my_file%variable_units( var_name, my_name ) & + .eq. "foobits" ) + + ! check for variables + var_name = "foo" + call assert( 154305685, my_file%exists( var_name, my_name ) ) + call assert( 601673531, .not. my_file%exists( "not there", my_name ) ) + + ! 1D real + var_name = "foo" + call my_file%read( var_name, real1D, my_name ) + call assert( 214049778, allocated( real1D ) ) + call assert( 661417624, size( real1D ) .eq. 4 ) + call assert( 826310221, almost_equal( real1D( 1 ), 15.32_dk ) ) + call assert( 373678068, almost_equal( real1D( 2 ), 3.14_dk ) ) + call assert( 886054314, almost_equal( real1D( 3 ), 26.71_dk ) ) + call assert( 433422161, almost_equal( real1D( 4 ), 19.34_dk ) ) + deallocate( real1D ) + + ! 2D real + var_name = "baz" + call my_file%read( var_name, real2D, my_name ) + call assert( 125066082, allocated( real2D ) ) + call assert( 919917577, size( real2D, 1 ) .eq. 4 ) + call assert( 184810175, size( real2D, 2 ) .eq. 3 ) + call assert( 632178021, almost_equal( real2D( 1, 1 ), 31.2_dk ) ) + call assert( 244554268, almost_equal( real2D( 1, 2 ), 41.3_dk ) ) + call assert( 409446865, almost_equal( real2D( 1, 3 ), 623.34_dk ) ) + call assert( 574339462, almost_equal( real2D( 2, 1 ), 124.24_dk ) ) + call assert( 186715709, almost_equal( real2D( 2, 2 ), 1592.3_dk ) ) + call assert( 969133056, almost_equal( real2D( 2, 3 ), 42.53_dk ) ) + call assert( 234025654, almost_equal( real2D( 3, 1 ), 1.3e-7_dk ) ) + call assert( 746401900, almost_equal( real2D( 3, 2 ), -31.6_dk ) ) + call assert( 911294497, almost_equal( real2D( 3, 3 ), 82.3_dk ) ) + call assert( 458662344, almost_equal( real2D( 4, 1 ), 51.64_dk ) ) + call assert( 688563341, almost_equal( real2D( 4, 2 ), -61.7_dk ) ) + call assert( 853455938, almost_equal( real2D( 4, 3 ), -423000.0_dk ) ) + deallocate( real2D ) + + ! 3D variable + var_name = "foobar" + call my_file%read( var_name, real3D, my_name ) + call assert( 539636810, allocated( real3D ) ) + call assert( 704529407, size( real3D, 1 ) .eq. 4 ) + call assert( 316905654, size( real3D, 2 ) .eq. 1 ) + call assert( 481798251, size( real3D, 3 ) .eq. 3 ) + call assert( 646690848, almost_equal( real3D( 1, 1, 1 ), 532.123_dk ) ) + call assert( 194058695, almost_equal( real3D( 1, 1, 2 ), 1.5e28_dk ) ) + call assert( 706434941, almost_equal( real3D( 1, 1, 3 ), 42.5_dk ) ) + call assert( 871327538, almost_equal( real3D( 2, 1, 1 ), 39.25_dk ) ) + call assert( 418695385, almost_equal( real3D( 2, 1, 2 ), 4293.12_dk ) ) + call assert( 931071631, almost_equal( real3D( 2, 1, 3 ), 9753.231_dk ) ) + call assert( 813488979, almost_equal( real3D( 3, 1, 1 ), 3.25e-19_dk ) ) + call assert( 360856826, almost_equal( real3D( 3, 1, 2 ), 4.629e10_dk ) ) + call assert( 873233072, almost_equal( real3D( 3, 1, 3 ), 7264.12_dk ) ) + call assert( 420600919, almost_equal( real3D( 4, 1, 1 ), 8.4918e7_dk ) ) + call assert( 867968765, almost_equal( real3D( 4, 1, 2 ), 13.2_dk ) ) + call assert( 132861363, almost_equal( real3D( 4, 1, 3 ), 8293.12_dk ) ) + deallocate( real3D ) + + ! 4D variable + var_name = "corge" + call my_file%read( var_name, real4D, my_name ) + call assert( 514219865, allocated( real4D ) ) + call assert( 344062961, size( real4D, 1 ) .eq. 4 ) + call assert( 856439207, size( real4D, 2 ) .eq. 2 ) + call assert( 121331805, size( real4D, 3 ) .eq. 1 ) + call assert( 286224402, size( real4D, 4 ) .eq. 3 ) + call assert( 181075898, almost_equal( real4D( 1, 1, 1, 1 ), 532.123_dk ) ) + call assert( 345968495, almost_equal( real4D( 1, 2, 1, 1 ), 632.123_dk ) ) + call assert( 228385843, almost_equal( real4D( 1, 1, 1, 2 ), 1.5e28_dk ) ) + call assert( 740762089, almost_equal( real4D( 1, 2, 1, 2 ), 2.5e28_dk ) ) + call assert( 905654686, almost_equal( real4D( 1, 1, 1, 3 ), 42.5_dk ) ) + call assert( 170547284, almost_equal( real4D( 1, 2, 1, 3 ), 52.5_dk ) ) + call assert( 682923530, almost_equal( real4D( 2, 1, 1, 1 ), 39.25_dk ) ) + call assert( 565340878, almost_equal( real4D( 2, 2, 1, 1 ), 49.25_dk ) ) + call assert( 177717125, almost_equal( real4D( 2, 1, 1, 2 ), 4293.12_dk ) ) + call assert( 960134472, almost_equal( real4D( 2, 2, 1, 2 ), 5293.12_dk ) ) + call assert( 225027070, almost_equal( real4D( 2, 1, 1, 3 ), 9753.231_dk ) ) + call assert( 737403316, almost_equal( real4D( 2, 2, 1, 3 ), 1753.231_dk ) ) + call assert( 619820664, almost_equal( real4D( 3, 1, 1, 1 ), 3.25e-19_dk ) ) + call assert( 232196911, almost_equal( real4D( 3, 2, 1, 1 ), 4.25e-19_dk ) ) + call assert( 114614259, almost_equal( real4D( 3, 1, 1, 2 ), 4.629e10_dk ) ) + call assert( 279506856, almost_equal( real4D( 3, 2, 1, 2 ), 5.629e10_dk ) ) + call assert( 509407853, almost_equal( real4D( 3, 1, 1, 3 ), 7264.12_dk ) ) + call assert( 956775699, almost_equal( real4D( 3, 2, 1, 3 ), 8264.12_dk ) ) + call assert( 734044543, almost_equal( real4D( 4, 1, 1, 1 ), 8.4918e7_dk ) ) + call assert( 898937140, almost_equal( real4D( 4, 2, 1, 1 ), 9.4918e7_dk ) ) + call assert( 228838138, almost_equal( real4D( 4, 1, 1, 2 ), 13.2_dk ) ) + call assert( 676205984, almost_equal( real4D( 4, 2, 1, 2 ), 23.2_dk ) ) + call assert( 841098581, almost_equal( real4D( 4, 1, 1, 3 ), 8293.12_dk ) ) + call assert( 170999579, almost_equal( real4D( 4, 2, 1, 3 ), 9293.12_dk ) ) + deallocate( real4D ) + + ! 1D int + var_name = "quuz" + call my_file%read( var_name, int1D, my_name ) + call assert( 250469612, allocated( int1D ) ) + call assert( 697837458, size( int1D ) .eq. 4 ) + call assert( 245205305, int1D( 1 ) .eq. 9 ) + call assert( 410097902, int1D( 2 ) .eq. 3 ) + call assert( 639998899, int1D( 3 ) .eq. 12 ) + call assert( 804891496, int1D( 4 ) .eq. 1 ) + deallocate( int1D ) + + deallocate( my_file ) + + end subroutine test_append_netcdf + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +end program test_io_netcdf diff --git a/test/unit/util/map.F90 b/test/unit/util/map.F90 new file mode 100644 index 00000000..ad2dca7e --- /dev/null +++ b/test/unit/util/map.F90 @@ -0,0 +1,505 @@ +! Copyright (C) 2022 National Center for Atmospheric Research +! SPDX-License-Identifier: Apache-2.0 +! +!> \file +!> Tests for the musica_map module + +!> Test module for the musica_map module +program test_util_map + + use musica_constants, only : dk => musica_dk + use musica_assert + use musica_map + use musica_mpi +#ifdef MUSICA_USE_OPENMP + use omp_lib +#endif + + implicit none + + character(len=256) :: failure_test_type + + call musica_mpi_init( ) + + if( command_argument_count( ) == 0 ) then + call test_map_t( ) + else if( command_argument_count( ) == 1 ) then + call get_command_argument( 1, failure_test_type ) + call failure_test( failure_test_type ) + else + call die( 725972035 ) + end if + + call musica_mpi_finalize( ) + +contains + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Test map_t functionality + subroutine test_map_t( ) + + use iso_fortran_env, only : output_unit + use musica_config, only : config_t + use musica_string, only : string_t + + character(len=*), parameter :: my_name = "map_t tests" + type(map_t) :: map + type(string_t), allocatable :: from_labels(:), to_labels(:) + real(kind=dk), allocatable :: from(:), to(:), omp_to(:,:) + type(config_t) :: config + character, allocatable :: buffer(:) + integer :: pos, pack_size, i_thread, n_threads + integer, parameter :: comm = MPI_COMM_WORLD + + config = '{'// & + ' "pairs" : ['// & + ' {'// & + ' "from": "foo",'// & + ' "to": "bar",'// & + ' "scale by": 2.5'// & + ' },'// & + ' {'// & + ' "from": "foo",'// & + ' "to": "baz"'// & + ' }'// & + ' ]'// & + '}' + allocate( from_labels( 1 ) ) + allocate( to_labels( 2 ) ) + from_labels(1) = "foo" + to_labels(1) = "bar" + to_labels(2) = "baz" + + if( musica_mpi_rank( comm ) == 0 ) then + map = map_t( config, from_labels, to_labels ) + pack_size = map%pack_size( comm ) + allocate( buffer( pack_size ) ) + pos = 0 + call map%mpi_pack( buffer, pos, comm ) + call assert( 796105167, pos == pack_size ) + end if + + call musica_mpi_bcast( pack_size, comm ) + if( musica_mpi_rank( comm ) .ne. 0 ) allocate( buffer( pack_size ) ) + call musica_mpi_bcast( buffer, comm ) + + if( musica_mpi_rank( comm ) .ne. 0 ) then + pos = 0 + call map%mpi_unpack( buffer, pos, comm ) + call assert( 124100631, pos == pack_size ) + end if + + from = (/ 10.0_dk /) + allocate( to( 2 ) ) + + call map%apply( from, to ) + + call assert( 671804969, almost_equal( to(1), 25.0_dk ) ) + call assert( 338661002, almost_equal( to(2), 10.0_dk ) ) + deallocate( from_labels ) + deallocate( to_labels ) + deallocate( from ) + deallocate( to ) + + config = '{'// & + ' "match full source": false,'// & + ' "match full destination": false,'// & + ' "sum multiple matches": true,'// & + ' "pairs" : ['// & + ' {'// & + ' "from": "foo",'// & + ' "to": "bar",'// & + ' "scale by": 2.5'// & + ' },'// & + ' {'// & + ' "from": "foo",'// & + ' "to": "baz"'// & + ' },'// & + ' {'// & + ' "from": "bar",'// & + ' "to": "bar"'// & + ' }'// & + ' ]'// & + '}' + allocate( from_labels( 3 ) ) + allocate( to_labels( 3 ) ) + from_labels(1) = "foo" + from_labels(2) = "bar" + from_labels(3) = "baz" + to_labels(1) = "bar" + to_labels(2) = "baz" + to_labels(3) = "quz" + + from = (/ 10.0_dk, 20.0_dk, 30.0_dk /) + +#ifdef MUSICA_USE_OPENMP + n_threads = omp_get_num_threads( ) +#else + n_threads = 1 +#endif + + allocate( omp_to( n_threads, 3 ) ) + + map = map_t( config, from_labels, to_labels ) + + !$omp parallel do private(i_thread) + do i_thread = 1, n_threads + call check_omp_case( map, from, omp_to( i_thread, : ) ) + end do + !$omp end parallel do + + deallocate( from_labels ) + deallocate( to_labels ) + deallocate( from ) + deallocate( omp_to ) + + config = '{'// & + ' "match full source": false,'// & + ' "sum multiple matches": true,'// & + ' "default matching": "backup",'// & + ' "pairs" : ['// & + ' {'// & + ' "from": "foo",'// & + ' "to": "bar",'// & + ' "scale by": 2.5'// & + ' },'// & + ' {'// & + ' "from": "foo",'// & + ' "to": "baz"'// & + ' },'// & + ' {'// & + ' "from": "bar",'// & + ' "to": "bar"'// & + ' }'// & + ' ]'// & + '}' + allocate( from_labels( 3 ) ) + allocate( to_labels( 3 ) ) + from_labels(1) = "foo" + from_labels(2) = "bar" + from_labels(3) = "quz" + to_labels(1) = "bar" + to_labels(2) = "baz" + to_labels(3) = "quz" + + from = (/ 10.0_dk, 20.0_dk, 30.0_dk /) + allocate( to( 3 ) ) + + map = map_t( config, from_labels, to_labels ) + call map%apply( from, to ) + + call assert( 393064014, almost_equal( to(1), 45.0_dk ) ) + call assert( 157898710, almost_equal( to(2), 10.0_dk ) ) + call assert( 952750205, almost_equal( to(3), 30.0_dk ) ) + deallocate( from_labels ) + deallocate( to_labels ) + deallocate( from ) + deallocate( to ) + + config = '{'// & + ' "match full source": false,'// & + ' "sum multiple matches": true,'// & + ' "default matching": "always",'// & + ' "pairs" : ['// & + ' {'// & + ' "from": "foo",'// & + ' "to": "bar",'// & + ' "scale by": 2.5'// & + ' },'// & + ' {'// & + ' "from": "foo",'// & + ' "to": "baz"'// & + ' }'// & + ' ]'// & + '}' + allocate( from_labels( 3 ) ) + allocate( to_labels( 3 ) ) + from_labels(1) = "foo" + from_labels(2) = "bar" + from_labels(3) = "quz" + to_labels(1) = "bar" + to_labels(2) = "baz" + to_labels(3) = "quz" + + from = (/ 10.0_dk, 20.0_dk, 30.0_dk /) + allocate( to( 3 ) ) + + map = map_t( config, from_labels, to_labels ) + call map%apply( from, to ) + if( musica_mpi_rank( comm ) == 0 ) then + call map%print( from_labels, to_labels, output_unit ) + end if + + call assert( 884835327, almost_equal( to(1), 45.0_dk ) ) + call assert( 432203174, almost_equal( to(2), 10.0_dk ) ) + call assert( 597095771, almost_equal( to(3), 30.0_dk ) ) + deallocate( from_labels ) + deallocate( to_labels ) + deallocate( from ) + deallocate( to ) + + end subroutine test_map_t + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Checks a specific case on parallel OpenMP threads (if available) + subroutine check_omp_case( map, from, to ) + + type(map_t), intent(in) :: map + real(kind=dk), intent(in) :: from(:) + real(kind=dk), intent(inout) :: to(:) + + call map%apply( from, to ) + + call assert( 162210850, almost_equal( to(1), 45.0_dk ) ) + call assert( 495807112, almost_equal( to(2), 10.0_dk ) ) + call assert( 943174958, almost_equal( to(3), 0.0_dk ) ) + + end subroutine check_omp_case + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Failure tests for map_t class + subroutine failure_test( test_type ) + + character(len=*), intent(in) :: test_type + + if( test_type .eq. "170733942" ) then + call failure_test_170733942( ) + else if( test_type .eq. "764798475" ) then + call failure_test_764798475( ) + else if( test_type .eq. "133386338" ) then + call failure_test_133386338( ) + else if( test_type .eq. "956987954" ) then + call failure_test_956987954( ) + else if( test_type .eq. "200274675" ) then + call failure_test_200274675( ) + else if( test_type .eq. "240867074" ) then + call failure_test_240867074( ) + else if( test_type .eq. "309595761" ) then + call failure_test_309595761( ) + else if( test_type .eq. "122570601" ) then + call failure_test_122570601( ) + else if( test_type .eq. "740547646" ) then + call failure_test_740547646( ) + else if( test_type .eq. "548594113" ) then + call failure_test_548594113( ) + else + call die( 609154398 ) + end if + + end subroutine failure_test + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Test invalid map configuration + subroutine failure_test_170733942( ) + + use musica_config, only : config_t + use musica_string, only : string_t + + type(map_t) :: map + type(config_t) :: config + type(string_t) :: from_labels(2), to_labels(1) + + from_labels(1) = "foo" + from_labels(2) = "bar" + to_labels(1) = "baz" + config = '{ "bad": "config" }' + map = map_t( config, from_labels, to_labels ) + + end subroutine failure_test_170733942 + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Test invalid map pair configuration + subroutine failure_test_309595761( ) + + use musica_config, only : config_t + use musica_string, only : string_t + + type(map_t) :: map + type(config_t) :: config + type(string_t) :: from_labels(2), to_labels(1) + + from_labels(1) = "foo" + from_labels(2) = "bar" + to_labels(1) = "baz" + config = '{ "pairs": [ { "bad": "config" } ] }' + map = map_t( config, from_labels, to_labels ) + + end subroutine failure_test_309595761 + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Test invalid default matching options + subroutine failure_test_548594113( ) + + use musica_config, only : config_t + use musica_string, only : string_t + + type(map_t) :: map + type(config_t) :: config + type(string_t) :: from_labels(2), to_labels(1) + + from_labels(1) = "foo" + from_labels(2) = "bar" + to_labels(1) = "baz" + config = '{ "match full destination": false, '// & + ' "default matching": "always", '// & + ' "pairs": [ { "from": "foo", "to": "baz" } ] }' + map = map_t( config, from_labels, to_labels ) + + end subroutine failure_test_548594113 + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Test missing source element + subroutine failure_test_122570601( ) + + use musica_config, only : config_t + use musica_string, only : string_t + + type(map_t) :: map + type(config_t) :: config + type(string_t) :: from_labels(2), to_labels(1) + + from_labels(1) = "foo" + from_labels(2) = "bar" + to_labels(1) = "baz" + config = '{ "pairs": [ { "from": "quz", "to": "baz" } ] }' + map = map_t( config, from_labels, to_labels ) + + end subroutine failure_test_122570601 + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Test missing destination element + subroutine failure_test_740547646( ) + + use musica_config, only : config_t + use musica_string, only : string_t + + type(map_t) :: map + type(config_t) :: config + type(string_t) :: from_labels(2), to_labels(1) + + from_labels(1) = "foo" + from_labels(2) = "bar" + to_labels(1) = "baz" + config = '{ "pairs": [ { "from": "foo", "to": "bar" } ] }' + map = map_t( config, from_labels, to_labels ) + + end subroutine failure_test_740547646 + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Test unmatched source element + subroutine failure_test_956987954( ) + + use musica_config, only : config_t + use musica_string, only : string_t + + type(map_t) :: map + type(config_t) :: config + type(string_t) :: from_labels(2), to_labels(1) + + from_labels(1) = "foo" + from_labels(2) = "bar" + to_labels(1) = "baz" + config = '{ "pairs": [ { "from": "foo", "to": "baz" } ] }' + map = map_t( config, from_labels, to_labels ) + + end subroutine failure_test_956987954 + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Test unmatched destination element + subroutine failure_test_200274675( ) + + use musica_config, only : config_t + use musica_string, only : string_t + + type(map_t) :: map + type(config_t) :: config + type(string_t) :: from_labels(1), to_labels(2) + + from_labels(1) = "foo" + to_labels(1) = "baz" + to_labels(2) = "quz" + config = '{ "pairs": [ { "from": "foo", "to": "quz" } ] }' + map = map_t( config, from_labels, to_labels ) + + end subroutine failure_test_200274675 + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Test multiple destination element matches + subroutine failure_test_240867074( ) + + use musica_config, only : config_t + use musica_string, only : string_t + + type(map_t) :: map + type(config_t) :: config + type(string_t) :: from_labels(2), to_labels(1) + + from_labels(1) = "foo" + from_labels(2) = "bar" + to_labels(1) = "baz" + config = '{ "pairs": [ { "from": "foo", "to": "baz" }, '// & + ' { "from": "bar", "to": "baz" } ] }' + map = map_t( config, from_labels, to_labels ) + + end subroutine failure_test_240867074 + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Test wrong source array size + subroutine failure_test_764798475( ) + + use musica_config, only : config_t + use musica_string, only : string_t + + type(map_t) :: map + type(config_t) :: config + type(string_t) :: from_labels(1), to_labels(2) + real(kind=dk) :: from(3), to(2) + + from_labels(1) = "foo" + to_labels(1) = "baz" + to_labels(2) = "quz" + config = '{ "pairs": [ { "from": "foo", "to": "quz" }, '// & + '{ "from": "foo", "to": "baz" } ] }' + map = map_t( config, from_labels, to_labels ) + call map%apply( from, to ) + + end subroutine failure_test_764798475 + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Test wrong destination array size + subroutine failure_test_133386338( ) + + use musica_config, only : config_t + use musica_string, only : string_t + + type(map_t) :: map + type(config_t) :: config + type(string_t) :: from_labels(1), to_labels(2) + real(kind=dk) :: from(1), to(1) + + from_labels(1) = "foo" + to_labels(1) = "baz" + to_labels(2) = "quz" + config = '{ "pairs": [ { "from": "foo", "to": "quz" }, '// & + '{ "from": "foo", "to": "baz" } ] }' + map = map_t( config, from_labels, to_labels ) + call map%apply( from, to ) + + end subroutine failure_test_133386338 + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +end program test_util_map diff --git a/test/unit/util/map.sh b/test/unit/util/map.sh new file mode 100755 index 00000000..43efd3cd --- /dev/null +++ b/test/unit/util/map.sh @@ -0,0 +1,32 @@ +#!/bin/bash + +# turn on command echoing +set -v +# move to the directory this script is in +cd ${0%/*} +# define a function for failure tests +failure_test () { + local expected_failure=$(echo $1 | sed -n 's/\([[:digit:]]\+\).*/\1/p') + local output=$(../../../util_map_failure $1 2>&1) + local failure_code=$(echo $output | sed -n 's/[[:space:]]*ERROR (Musica-\([[:digit:]]\+\).*/\1/p') + if ! [ "$failure_code" = "$expected_failure" ]; then + echo "Expected failure $expected_failure" + echo "Got output: $output" + exit 1 + else + echo $output + fi +} + +failure_test 170733942 +failure_test 764798475 +failure_test 133386338 +failure_test 956987954 +failure_test 200274675 +failure_test 240867074 +failure_test 309595761 +failure_test 122570601 +failure_test 740547646 +failure_test 548594113 + +exit 0 diff --git a/test/unit/util/mpi.F90 b/test/unit/util/mpi.F90 new file mode 100644 index 00000000..2ea9223c --- /dev/null +++ b/test/unit/util/mpi.F90 @@ -0,0 +1,364 @@ +! Copyright (C) 2007-2021 Barcelona Supercomputing Center and University of +! Illinois at Urbana-Champaign +! SPDX-License-Identifier: MIT +program test_mpi + ! Tests for MPI wrapper functions. + ! + ! This module was adapted from CAMP (https://github.com/open-atmos/camp). + + use musica_assert + use musica_mpi + + implicit none + + call test_mpi_wrappers( ) + +contains + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine test_mpi_wrappers( ) + ! test MPI wrapper functions + + use musica_constants, only : dp => musica_dk + use musica_string, only : to_char + +#ifdef MUSICA_USE_MPI + integer, parameter :: comm = MPI_COMM_WORLD + integer, parameter :: dc = dp + real(kind=dp), parameter :: test_real = 2.718281828459d0 + complex(kind=dc), parameter :: test_complex & + = (0.707106781187d0, 1.4142135624d0) + logical, parameter :: test_logical = .true. + character(len=100), parameter :: test_string & + = "a truth universally acknowledged" + integer, parameter :: test_integer = 314159 + + character, allocatable :: buffer(:) ! memory buffer + integer :: buffer_size, max_buffer_size, position + real(kind=dp) :: send_real, recv_real + complex(kind=dc) :: send_complex, recv_complex + logical :: send_logical, recv_logical + character(len=100) :: send_string, recv_string + integer :: send_integer, recv_integer + integer :: test_integer_array(2) = (/ 4, 2 /) + integer, allocatable :: send_integer_array(:) + integer, allocatable :: recv_integer_array(:) + real(kind=dp), allocatable :: send_real_array(:) + real(kind=dp), allocatable :: recv_real_array(:) + character(len=5) :: test_string_array(2) = (/ "forty", "two " /) + character(len=5), allocatable :: send_string_array(:) + character(len=5), allocatable :: recv_string_array(:) + real(kind=dp) :: test_real_array_2d(2,2) + real(kind=dp), allocatable :: send_real_array_2d(:,:) + real(kind=dp), allocatable :: recv_real_array_2d(:,:) + real(kind=dp) :: test_real_array_3d(2,2,2) + real(kind=dp), allocatable :: send_real_array_3d(:,:,:) + real(kind=dp), allocatable :: recv_real_array_3d(:,:,:) + + test_real_array_2d(1,1) = 42.0_dp + test_real_array_2d(2,1) = 4.2_dp + test_real_array_2d(1,2) = 0.42_dp + test_real_array_2d(2,2) = 0.042_dp + + test_real_array_3d(1,1,1) = 412.3_dp + test_real_array_3d(2,1,1) = 312.0_dp + test_real_array_3d(1,2,1) = 212.9_dp + test_real_array_3d(2,2,1) = 132.8_dp + test_real_array_3d(1,1,2) = 312.7_dp + test_real_array_3d(2,1,2) = 712.6_dp + test_real_array_3d(1,2,2) = 452.2_dp + test_real_array_3d(2,2,2) = 912.3_dp + + call assert( 357761664, musica_mpi_support( ) ) + call musica_mpi_init( ) + + call assert( 455191678, musica_mpi_size( comm ) > 1 ) + + call musica_mpi_barrier( comm ) + + send_integer = 0 + if( musica_mpi_rank( comm ) == 0 ) send_integer = 42 + call musica_mpi_bcast( send_integer, comm ) + call assert( 353714667, send_integer == 42 ) + + send_string = "" + if( musica_mpi_rank( comm ) == 0 ) send_string = "forty two" + call musica_mpi_bcast( send_string, comm ) + call assert( 904777778, trim( send_string ) == "forty two" ) + + buffer = (/ 'x', 'x' /) + if( musica_mpi_rank( comm ) == 0 ) buffer(:) = (/ '4', '2' /) + call musica_mpi_bcast( buffer, comm ) + call assert( 954445552, buffer(1) == '4' ) + call assert( 496549092, buffer(2) == '2' ) + deallocate( buffer ) + + if( musica_mpi_rank( comm ) == 0 ) then + send_real = test_real + send_complex = test_complex + send_logical = test_logical + send_string = test_string + send_integer = test_integer + allocate( send_real_array(2) ) + send_real_array(1) = real( test_complex ) + send_real_array(2) = aimag( test_complex ) + allocate( send_integer_array(2) ) + send_integer_array(:) = test_integer_array(:) + allocate( send_string_array(2) ) + send_string_array(:) = test_string_array(:) + allocate( send_real_array_2d(2,2) ) + send_real_array_2d(:,:) = test_real_array_2d(:,:) + allocate( send_real_array_3d(2,2,2) ) + send_real_array_3d(:,:,:) = test_real_array_3d(:,:,:) + + max_buffer_size = 0 + max_buffer_size = max_buffer_size & + + musica_mpi_pack_size( send_integer, comm ) + max_buffer_size = max_buffer_size & + + musica_mpi_pack_size( send_real, comm ) + max_buffer_size = max_buffer_size & + + musica_mpi_pack_size( send_complex, comm ) + max_buffer_size = max_buffer_size & + + musica_mpi_pack_size( send_logical, comm ) + max_buffer_size = max_buffer_size & + + musica_mpi_pack_size( send_string, comm ) + max_buffer_size = max_buffer_size & + + musica_mpi_pack_size( send_real_array, comm ) + max_buffer_size = max_buffer_size & + + musica_mpi_pack_size( send_integer_array, comm ) + max_buffer_size = max_buffer_size & + + musica_mpi_pack_size( send_string_array, comm ) + max_buffer_size = max_buffer_size & + + musica_mpi_pack_size( send_real_array_2d, comm ) + max_buffer_size = max_buffer_size & + + musica_mpi_pack_size( send_real_array_3d, comm ) + + allocate( buffer( max_buffer_size ) ) + + position = 0 + call musica_mpi_pack( buffer, position, send_real , comm ) + call musica_mpi_pack( buffer, position, send_complex , comm ) + call musica_mpi_pack( buffer, position, send_logical , comm ) + call musica_mpi_pack( buffer, position, send_string , comm ) + call musica_mpi_pack( buffer, position, send_integer , comm ) + call musica_mpi_pack( buffer, position, send_real_array , comm ) + call musica_mpi_pack( buffer, position, send_integer_array, comm ) + call musica_mpi_pack( buffer, position, send_string_array , comm ) + call musica_mpi_pack( buffer, position, send_real_array_2d, comm ) + call musica_mpi_pack( buffer, position, send_real_array_3d, comm ) + call assert_msg( 350740830, position <= max_buffer_size, & + "MPI test failure: pack position " & + // trim( to_char( position ) ) & + // " greater than max_buffer_size " & + // trim( to_char( max_buffer_size ) ) ) + buffer_size = position ! might be less than we allocated + end if + + call musica_mpi_bcast( buffer_size, comm ) + + if( musica_mpi_rank( comm ) /= 0 ) then + allocate( buffer( buffer_size ) ) + end if + + call musica_mpi_bcast( buffer, comm ) + + if( musica_mpi_rank( comm ) /= 0 ) then + position = 0 + call musica_mpi_unpack( buffer, position, recv_real , comm ) + call musica_mpi_unpack( buffer, position, recv_complex , comm ) + call musica_mpi_unpack( buffer, position, recv_logical , comm ) + call musica_mpi_unpack( buffer, position, recv_string , comm ) + call musica_mpi_unpack( buffer, position, recv_integer , comm ) + call musica_mpi_unpack( buffer, position, recv_real_array , comm ) + call musica_mpi_unpack( buffer, position, recv_integer_array, comm ) + call musica_mpi_unpack( buffer, position, recv_string_array , comm ) + call musica_mpi_unpack( buffer, position, recv_real_array_2d, comm ) + call musica_mpi_unpack( buffer, position, recv_real_array_3d, comm ) + + call assert_msg( 787677020, position == buffer_size, & + "MPI test failure: unpack position " & + // trim( to_char( position ) ) & + // " not equal to buffer_size " & + // trim( to_char( buffer_size ) ) ) + end if + + deallocate( buffer ) + + if( musica_mpi_rank( comm ) /= 0 ) then + call assert_msg( 567548916, recv_real == test_real, & + "MPI test failure: real recv " & + // trim( to_char( recv_real ) ) & + // " not equal to " & + // trim( to_char( test_real ) ) ) + call assert_msg( 653908509, recv_complex == test_complex, & + "MPI test failure: complex recv " & + // trim( to_char( recv_complex ) ) & + // " not equal to " & + // trim( to_char( test_complex ) ) ) + call assert_msg( 307746296, recv_logical .eqv. test_logical, & + "MPI test failure: logical recv " & + // trim( to_char( recv_logical ) ) & + // " not equal to " & + // trim( to_char( test_logical ) ) ) + call assert_msg( 155693492, recv_string == test_string, & + "MPI test failure: string recv '" & + // trim( recv_string ) & + // "' not equal to '" & + // trim( test_string ) // "'" ) + call assert_msg( 875699427, recv_integer == test_integer, & + "MPI test failure: integer recv " & + // trim( to_char( recv_integer ) ) & + // " not equal to " & + // trim( to_char( test_integer ) ) ) + call assert_msg( 326982363, size( recv_real_array ) == 2, & + "MPI test failure: real array recv size " // & + trim( to_char( size( recv_real_array ) ) ) & + // " not equal to 2" ) + call assert_msg( 744394323, & + recv_real_array(1) == real( test_complex ), & + "MPI test failure: real array recv index 1 " & + // trim( to_char( recv_real_array(1) ) ) & + // " not equal to " & + // trim( to_char( real( test_complex ) ) ) ) + call assert_msg( 858902527, & + recv_real_array(2) == aimag( test_complex ), & + "MPI test failure: real array recv index 2 " & + // trim( to_char( recv_real_array(2) ) ) & + // " not equal to " & + // trim( to_char( aimag( test_complex ) ) ) ) + call assert_msg( 785767484, size( recv_integer_array ) == 2, & + "MPI test failure: integer array recv size " // & + trim( to_char( size( recv_integer_array ) ) ) & + // " not equal to 2" ) + call assert_msg( 874548821, & + recv_integer_array(1) == test_integer_array(1), & + "MPI test failure: integer array recv index 1 " & + // trim( to_char( recv_integer_array(1) ) ) & + // " not equal to " & + // trim( to_char( test_integer_array(1) ) ) ) + call assert_msg( 422368963, & + recv_integer_array(2) == test_integer_array(2), & + "MPI test failure: integer array recv index 2 " & + // trim( to_char( recv_integer_array(2) ) ) & + // " not equal to " & + // trim( to_char( test_integer_array(2) ) ) ) + call assert_msg( 858519971, size( recv_string_array ) == 2, & + "MPI test failure: string array recv size " // & + trim( to_char( size( recv_string_array ) ) ) & + // " not equal to 2" ) + call assert_msg( 742842853, size( recv_real_array_2d, 1 ) == 2, & + "MPI test failure: 2d real array recv size " // & + trim( to_char( size( recv_real_array_2d ) ) ) & + // " not equal to 2 for dimension 1" ) + call assert_msg( 848443652, & + recv_string_array(1) == test_string_array(1), & + "MPI test failure: string array recv index 1 " & + // trim( recv_string_array(1) ) & + // " not equal to " & + // trim( test_string_array(1) ) ) + call assert_msg( 553986550, & + recv_string_array(2) == test_string_array(2), & + "MPI test failure: string array recv index 2 " & + // trim( recv_string_array(2) ) & + // " not equal to " & + // trim( test_string_array(2) ) ) + call assert_msg( 346596020, size( recv_real_array_2d, 2 ) == 2, & + "MPI test failure: 2d real array recv size " // & + trim( to_char( size( recv_real_array_2d ) ) ) & + // " not equal to 2 for dimension 2" ) + call assert_msg( 833103026, & + recv_real_array_2d(1,1) == test_real_array_2d(1,1), & + "MPI test failure: 2d real array recv index 1,1 " & + // trim( to_char( recv_real_array_2d(1,1) ) ) & + // " not equal to " & + // trim( to_char( test_real_array_2d(1,1) ) ) ) + call assert_msg( 145757864, & + recv_real_array_2d(2,1) == test_real_array_2d(2,1), & + "MPI test failure: 2d real array recv index 2,1 " & + // trim( to_char( recv_real_array_2d(2,1) ) ) & + // " not equal to " & + // trim( to_char( test_real_array_2d(2,1) ) ) ) + call assert_msg( 940609359, & + recv_real_array_2d(1,2) == test_real_array_2d(1,2), & + "MPI test failure: 2d real array recv index 1,2 " & + // trim( to_char( recv_real_array_2d(1,2) ) ) & + // " not equal to " & + // trim( to_char( test_real_array_2d(1,2) ) ) ) + call assert_msg( 770452455, & + recv_real_array_2d(2,2) == test_real_array_2d(2,2), & + "MPI test failure: 2d real array recv index 2,2 " & + // trim( to_char( recv_real_array_2d(2,2) ) ) & + // " not equal to " & + // trim( to_char( test_real_array_2d(2,2) ) ) ) + call assert_msg( 399792135, & + recv_real_array_3d(1,1,1) == & + test_real_array_3d(1,1,1), & + "MPI test failure: 3d real array recv index 1,1,1 " & + // trim( to_char( recv_real_array_3d(1,1,1) ) ) & + // " not equal to " & + // trim( to_char( test_real_array_3d(1,1,1) ) ) ) + call assert_msg( 229635231, & + recv_real_array_3d(2,1,1) == & + test_real_array_3d(2,1,1), & + "MPI test failure: 3d real array recv index 2,1,1 " & + // trim( to_char( recv_real_array_3d(2,1,1) ) ) & + // " not equal to " & + // trim( to_char( test_real_array_3d(2,1,1) ) ) ) + call assert_msg( 341953576, & + recv_real_array_3d(1,2,1) == & + test_real_array_3d(1,2,1), & + "MPI test failure: 3d real array recv index 1,2,1 " & + // trim( to_char( recv_real_array_3d(1,2,1) ) ) & + // " not equal to " & + // trim( to_char( test_real_array_3d(1,2,1) ) ) ) + call assert_msg( 171796672, & + recv_real_array_3d(2,2,1) == & + test_real_array_3d(2,2,1), & + "MPI test failure: 3d real array recv index 2,2,1 " & + // trim( to_char( recv_real_array_3d(2,2,1) ) ) & + // " not equal to " & + // trim( to_char( test_real_array_3d(2,2,1) ) ) ) + call assert_msg( 901639767, & + recv_real_array_3d(1,1,2) == & + test_real_array_3d(1,1,2), & + "MPI test failure: 3d real array recv index 1,1,2 " & + // trim( to_char( recv_real_array_3d(1,1,2) ) ) & + // " not equal to " & + // trim( to_char( test_real_array_3d(1,1,2) ) ) ) + call assert_msg( 449007614, & + recv_real_array_3d(2,1,2) == & + test_real_array_3d(2,1,2), & + "MPI test failure: 3d real array recv index 2,1,2 " & + // trim( to_char( recv_real_array_3d(2,1,2) ) ) & + // " not equal to " & + // trim( to_char( test_real_array_3d(2,1,2) ) ) ) + call assert_msg( 561325959, & + recv_real_array_3d(1,2,2) == & + test_real_array_3d(1,2,2), & + "MPI test failure: 3d real array recv index 1,2,2 " & + // trim( to_char( recv_real_array_3d(1,2,2) ) ) & + // " not equal to " & + // trim( to_char( test_real_array_3d(1,2,2) ) ) ) + call assert_msg( 391169055, & + recv_real_array_3d(2,2,2) == & + test_real_array_3d(2,2,2), & + "MPI test failure: 3d real array recv index 2,2,2 " & + // trim( to_char( recv_real_array_3d(2,2,2) ) ) & + // " not equal to " & + // trim( to_char( test_real_array_3d(2,2,2) ) ) ) + end if + + call musica_mpi_finalize( ) + +#else + + call assert( 242084546, .not. musica_mpi_support( ) ) + +#endif + + end subroutine test_mpi_wrappers + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +end program test_mpi diff --git a/test/unit/util/string.F90 b/test/unit/util/string.F90 new file mode 100644 index 00000000..4c60bd44 --- /dev/null +++ b/test/unit/util/string.F90 @@ -0,0 +1,567 @@ +! Copyright (C) 2020 National Center for Atmospheric Research +! SPDX-License-Identifier: Apache-2.0 +! +!> \file +!> Tests for the musica_string module + +!> Test module for the musica_string module +program test_util_string + + use musica_constants, only : musica_ik, musica_rk, musica_dk + use musica_assert + use musica_mpi + use musica_string +#ifdef MUSICA_USE_OPENMP + use omp_lib +#endif + + implicit none + + character(len=256) :: failure_test_type + + call musica_mpi_init( ) + + if( command_argument_count( ) .eq. 0 ) then + call test_string_t( ) + if( musica_mpi_rank( MPI_COMM_WORLD ) == 0 ) then + call replace_example( ) + call substring_example( ) + call split_example( ) + call table_test( ) + end if + else if( command_argument_count( ) .eq. 1 ) then + call get_command_argument( 1, failure_test_type ) + call failure_test( failure_test_type ) + else + call die( 253391339 ) + end if + + call musica_mpi_finalize( ) + +contains + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Test string_t functionality + subroutine test_string_t( ) + + type(string_t) :: a, b, c, unalloced + type(string_t), allocatable :: split_string(:) + integer(kind=musica_ik) :: i + real(kind=musica_rk) :: r + logical :: l + real(kind=musica_dk) :: d + character(len=10) :: ca + character(len=:), allocatable :: aca + character, allocatable :: buffer(:) + integer :: pos, pack_size + integer, parameter :: comm = MPI_COMM_WORLD + + if( musica_mpi_rank( comm ) == 0 ) then + a = "an MPI test string" + pack_size = a%pack_size( comm ) + b%pack_size( comm ) + allocate( buffer( pack_size ) ) + pos = 0 + call a%mpi_pack( buffer, pos, comm ) + call b%mpi_pack( buffer, pos, comm ) + end if + + call musica_mpi_bcast( pack_size, comm ) + + if( musica_mpi_rank( comm ) /= 0 ) allocate( buffer( pack_size ) ) + + call musica_mpi_bcast( buffer, comm ) + + if( musica_mpi_rank( comm ) /= 0 ) then + pos = 0 + call a%mpi_unpack( buffer, pos, comm ) + call b%mpi_unpack( buffer, pos, comm ) + call assert( 165108300, pos <= pack_size ) + call assert( 616287214, allocated( a%val_ ) ) + call assert( 619645987, a .eq. "an MPI test string" ) + call assert( 226757927, .not. allocated( b%val_ ) ) + end if + +#ifdef MUSICA_USE_OPENMP + write(*,*) "Testing string module on ", omp_get_max_threads( ), " threads" +#else + write(*,*) "Testing string module without OpenMP support" +#endif + + !$omp parallel & + !$omp private( a, b, c, unalloced, split_string, i, r, l, d, ca, aca ) + + ! string assignment + + a = "test string " + call assert( 814138261, a .eq. "test string" ) + + b = a + call assert( 240083225, a .eq. b ) + + deallocate( a%val_ ) + b = a + call assert( 325157354, .not. allocated( b%val_ ) ) + + a = 1469 + call assert( 124406107, a .eq. "1469" ) + + a = 13.4563 + call assert( 915898829, a%substring(1,6) .eq. "13.456" ) + + a = 14.563d0 + call assert( 381828325, a%substring(1,5) .eq. "14.56" ) + + a = .true. + call assert( 827742932, a .eq. "true" ) + + a = .false. + call assert( 317272220, a .eq. "false" ) + + ! string join to's + + a = "foo" + b = "bar" + c = a//b + call assert( 938608038, c .eq. "foobar" ) + + c = b//"foo" + call assert( 817666613, c .eq. "barfoo" ) + + c = a//123 + call assert( 984464744, c .eq. "foo123" ) + + c = a//52.33 + call assert( 810949067, c%substring(1,7) .eq. "foo52.3" ) + + c = a//53.43d0 + call assert( 419966541, c%substring(1,7) .eq. "foo53.4" ) + + c = a//.true. + call assert( 581500365, c .eq. "footrue" ) + + c = a//.false. + call assert( 971029652, c .eq. "foofalse" ) + + c = "bar "//a + call assert( 670923431, c .eq. "bar foo" ) + + ! equality + + a = "foo" + b = "foo" + c = "bar" + call assert( 160576005, a .eq. b ) + call assert( 667687944, .not. a .eq. c ) + + call assert( 322109829, a .eq. "foo" ) + call assert( 264271270, .not. a .eq. "bar" ) + + a = 134 + call assert( 325920897, a .eq. 134 ) + call assert( 315392283, .not. a .eq. 432 ) + + a = 52.3 + call assert( 420993082, a .eq. 52.3 ) + call assert( 428162923, .not. a .eq. 762.4 ) + + a = 87.45d0 + call assert( 307221498, a .eq. 87.45d0 ) + call assert( 696750785, .not. a .eq. 43.5d9 ) + + a = .true. + b = .false. + call assert( 240759859, a .eq. .true. ) + call assert( 919934236, .not. a .eq. .false. ) + call assert( 179562527, b .eq. .false. ) + call assert( 969149715, .not. b .eq. .true. ) + + ! not-equals + + a = "foo" + b = "foo" + c = "bar" + call assert( 678503681, .not. a .ne. b ) + call assert( 173297276, a .ne. c ) + + call assert( 903140371, .not. a .ne. "foo" ) + call assert( 732983467, a .ne. "bar" ) + + a = 134 + call assert( 845301812, .not. a .ne. 134 ) + call assert( 957620157, a .ne. 432 ) + + a = 52.3 + call assert( 787463253, .not. a .ne. 52.3 ) + call assert( 334831100, a .ne. 762.4 ) + + a = 87.45d0 + call assert( 447149445, .not. a .ne. 87.45d0 ) + call assert( 894517291, a .ne. 43.5d9 ) + + a = .true. + b = .false. + call assert( 389310886, .not. a .ne. .true. ) + call assert( 501629231, a .ne. .false. ) + call assert( 948997077, .not. b .ne. .false. ) + call assert( 778840173, b .ne. .true. ) + + ! case convert + + a = "FoObAr 12 %" + call assert( 500463115, a%to_lower( ) .eq. "foobar 12 %" ) + call assert( 614686994, a%to_upper( ) .eq. "FOOBAR 12 %" ) + + ! substring + + call assert( 328852972, a%substring(1,6) .eq. "FoObAr" ) + call assert( 272919947, a%substring(4,5) .eq. "bAr 1" ) + call assert( 604610675, a%substring(7,20) .eq. " 12 %" ) + + ! split + + a = "foobar1foofoobar2foofoo" + b = "foo" + split_string = a%split( b ) + call assert( 106051866, size( split_string ) .eq. 6 ) + call assert( 815260865, split_string(1) .eq. "" ) + call assert( 432478287, split_string(2) .eq. "bar1" ) + call assert( 805184546, split_string(3) .eq. "" ) + call assert( 381809569, split_string(4) .eq. "bar2" ) + call assert( 417108498, split_string(5) .eq. "" ) + call assert( 742081680, split_string(6) .eq. "" ) + + split_string = a%split( b, compress = .true. ) + call assert( 413749725, size( split_string ) .eq. 2 ) + call assert( 238328514, split_string(1) .eq. "bar1" ) + call assert( 456247658, split_string(2) .eq. "bar2" ) + + split_string = a%split( "bar" ) + call assert( 883657201, size( split_string ) .eq. 3 ) + call assert( 655661738, split_string(1) .eq. "foo" ) + call assert( 480240527, split_string(2) .eq. "1foofoo" ) + + split_string = a%split( "bar", compress = .true. ) + call assert( 983657201, size( split_string ) .eq. 3 ) + call assert( 455661738, split_string(1) .eq. "foo" ) + call assert( 680240527, split_string(2) .eq. "1foofoo" ) + call assert( 104877217, split_string(3) .eq. "2foofoo" ) + + split_string = a%split( "not in there" ) + call assert( 366468943, size( split_string ) .eq. 1 ) + call assert( 473522981, split_string(1) .eq. a ) + + split_string = a%split( "" ) + call assert( 357845863, size( split_string ) .eq. 1 ) + call assert( 300007304, split_string(1) .eq. a ) + + a = "foo bar" + split_string = a%split( " " ) + call assert( 484519904, size( split_string ) .eq. 2 ) + call assert( 853182732, split_string(1) .eq. "foo" ) + call assert( 737505614, split_string(2) .eq. "bar" ) + + deallocate( a%val_ ) + split_string = a%split( " " ) + call assert( 341895943, allocated( split_string ) ) + call assert( 966590534, size( split_string ) .eq. 0 ) + + + ! replace + + a = "foobar1foobar2foo1" + b = a%replace( "foo", "bar" ) + call assert( 282451682, b .eq. "barbar1barbar2bar1" ) + b = a%replace( "bar", "foo" ) + call assert( 331667161, b .eq. "foofoo1foofoo2foo1" ) + + ! convert to character array + a = "string to convert" + aca = a%to_char( ) + call assert( 476488677, aca .eq. "string to convert" ) + + ! assignment from string + + ca = "XXXXXXXXXX" + a = "foo" + ca = a + call assert( 189690040, trim( ca ) .eq. "foo" ) + + ca = "XXXXXXXXXX" + deallocate( a%val_ ) + ca = a + call assert( 137411891, trim( ca ) .eq. "" ) + + ca = "XXXXXXXXXX" + a = "12345678901234567890" + ca = a + call assert( 811321961, trim( ca ) .eq. "1234567890" ) + + a = "-12.02" + r = a + call assert( 179687753, & + almost_equal( real( r, kind=musica_dk ), & + real( -12.02, kind=musica_dk ) ) ) + + a = "32.54" + d = a + call assert( 321521234, almost_equal( d, 32.54d0 ) ) + + a = "-14" + i = a + call assert( 464068536, i .eq. -14 ) + + a = "true" + l = a + call assert( 853597823, l ) + + a = "false" + l = a + call assert( 237978607, .not. l ) + + ! joins from strings + + ca = "foo" + a = "bar" + call assert( 511304449, trim( ca )//a .eq. "foobar" ) + + i = 122 + call assert( 678841998, i//a .eq. "122bar" ) + + r = 34.63 + b = r//a + call assert( 165012513, b%substring(1,4) .eq. "34.6" ) + call assert( 610927120, b%substring( b%length( ) - 2, 3 ) .eq. "bar" ) + + d = 43.63d0 + b = d//a + call assert( 625841048, b%substring(1,4) .eq. "43.6" ) + call assert( 848572204, b%substring( b%length( ) - 2, 3 ) .eq. "bar" ) + + call assert( 345271333, .true.//a .eq. "truebar" ) + call assert( 164585815, .false.//a .eq. "falsebar" ) + + ! equality + + a = "foo" + b = "foo" + call assert( 719459994, "foo" .eq. a ) + call assert( 549303090, .not. "bar" .eq. b ) + + a = 134 + call assert( 944096684, 134 .eq. a ) + call assert( 773939780, .not. 432 .eq. a ) + + a = 52.3 + call assert( 603782876, 52.3 .eq. a ) + call assert( 433625972, .not. 762.4 .eq. a ) + + a = 87.45d0 + call assert( 828419566, 87.45d0 .eq. a ) + call assert( 375787413, .not. 43.5d9 .eq. a ) + + a = .true. + b = .false. + call assert( 153056257, .true. .eq. a ) + call assert( 882899352, .not. .false. .eq. a ) + call assert( 995217697, .false. .eq. b ) + call assert( 542585544, .not. .true. .eq. b ) + + ! not-equals + + a = "foo" + b = "foo" + call assert( 597065330, .not. "foo" .ne. a ) + call assert( 426908426, "bar" .ne. a ) + + a = 134 + call assert( 539226771, .not. 134 .ne. a ) + call assert( 369069867, 432 .ne. a ) + + a = 52.3 + call assert( 146338711, .not. 52.3 .ne. a ) + call assert( 876181806, 762.4 .ne. a ) + + a = 87.45d0 + call assert( 706024902, .not. 87.45d0 .ne. a ) + call assert( 535867998, 43.5d9 .ne. a ) + + a = .true. + b = .false. + call assert( 648186343, .not. .true. .ne. a ) + call assert( 760504688, .false. .ne. a ) + call assert( 872823033, .not. .false. .ne. b ) + call assert( 702666129, .true. .ne. b ) + + ca = "XXXXXXXXXX" + ca = to_char( 345 ) + call assert( 278095873, trim( ca ) .eq. "345" ) + + ca = "XXXXXXXXXX" + ca = to_char( 482.53 ) + call assert( 876921224, ca(1:5) .eq. "482.5" ) + + ca = "XXXXXXXXXX" + ca = to_char( 873.453d0 ) + call assert( 989239569, ca(1:6) .eq. "873.45" ) + + ca = "XXXXXXXXXX" + ca = to_char( .true. ) + call assert( 201557915, trim( ca ) .eq. "true" ) + + ca = "XXXXXXXXXX" + ca = to_char( .false. ) + call assert( 931401010, trim( ca ) .eq. "false" ) + + !$omp end parallel + + end subroutine test_string_t + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Replace example from documentation + subroutine replace_example( ) + +type(string_t) :: my_string +my_string = "foo bar foobar" +my_string = my_string%replace( 'foo', 'bar' ) +write(*,*) my_string%val_ + + end subroutine replace_example + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Split example from documentation + subroutine split_example( ) + +type(string_t) :: my_string +type(string_t), allocatable :: sub_strings(:) +integer :: i +my_string = "my original string" +sub_strings = my_string%split( ' ' ) +do i = 1, size( sub_strings ) + write(*,*) i, sub_strings( i )%val_ +end do +sub_strings = my_string%split( ' ', .true. ) +do i = 1, size( sub_strings ) + write(*,*) i, sub_strings( i )%val_ +end do + + end subroutine split_example + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Substring example from documentation + subroutine substring_example( ) + +type(string_t) :: my_string, sub_string +my_string = "Hi there!" +sub_string = my_string%substring( 4, 5 ) +write(*,*) sub_string%val_ +sub_string = my_string%substring( 9, 50 ) +write(*,*) sub_string%val_ + + end subroutine substring_example + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Test table output + subroutine table_test( ) + + type(string_t) :: header(3) + type(string_t) :: table(3,2) + character(len=256) :: line + + header(1) = "foo" + header(2) = "bar" + header(3) = "baz" + table(1,1) = "f1" + table(1,2) = "f2" + table(2,1) = "b1b1b1" + table(2,2) = "b2" + table(3,1) = "z1" + table(3,2) = "z2" + open( 12, file = "output_table.txt", status = "replace" ) + call output_table( header, table, 12 ) + close( 12 ) + open( 12, file = "output_table.txt", status = "old" ) + read( 12, '(A)' ) line + call assert( 635926347, trim( line ) .eq. "----------------------" ) + read( 12, '(A)' ) line + call assert( 804630012, trim( line ) .eq. "| foo | bar | baz |" ) + read( 12, '(A)' ) line + call assert( 351997859, trim( line ) .eq. "----------------------" ) + read( 12, '(A)' ) line + call assert( 799365705, trim( line ) .eq. "| f1 | b1b1b1 | z1 |" ) + read( 12, '(A)' ) line + call assert( 911684050, trim( line ) .eq. "| f2 | b2 | z2 |" ) + read( 12, '(A)' ) line + call assert( 124002396, trim( line ) .eq. "----------------------" ) + close( 12 ) + + table(2,1) = "1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9"//& + " 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8"//& + " 9 0 1 2 3 4 5 6 7 8 9 0" + open( 12, file = "output_table_2.txt", status = "replace" ) + call output_table( header, table, 12 ) + close( 12 ) + open( 12, file = "output_table_2.txt", status = "old" ) + read( 12, '(A)' ) line + call assert( 284539358, trim( line ) .eq. "----------------------------"//& + "--------------------------------------------------------------------"//& + "--------------------------------" ) + read( 12, '(A)' ) line + call assert( 114382454, trim( line ) .eq. "| fo | bar "//& + " "//& + " | ba |" ) + read( 12, '(A)' ) line + call assert( 844225549, trim( line ) .eq. "----------------------------"//& + "--------------------------------------------------------------------"//& + "--------------------------------" ) + read( 12, '(A)' ) line + call assert( 674068645, trim( line ) .eq. "| f1 | 1 2 3 4 5 6 7 8 9 0 1"//& + " 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5"//& + " 6 7 8 9 0 1 2 3 4 5 6 7 8 | z1 |" ) + read( 12, '(A)' ) line + call assert( 503911741, trim( line ) .eq. "| f2 | b2 "//& + " "//& + " | z2 |" ) + read( 12, '(A)' ) line + call assert( 333754837, trim( line ) .eq. "----------------------------"//& + "--------------------------------------------------------------------"//& + "--------------------------------" ) + close( 12 ) + + end subroutine table_test + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Failure tests for string_t class + subroutine failure_test( test_type ) + + character(len=*), intent(in) :: test_type + + if( test_type .eq. "359920976" ) then + call failure_test_359920976( ) + else + call die( 592539031 ) + end if + + end subroutine failure_test + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Test invalid logical assignment from string + subroutine failure_test_359920976( ) + + type(string_t) :: string + logical :: bar + + string = "foo" + bar = string + + end subroutine failure_test_359920976 + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +end program test_util_string diff --git a/test/unit/util/string.sh b/test/unit/util/string.sh new file mode 100755 index 00000000..6666bf83 --- /dev/null +++ b/test/unit/util/string.sh @@ -0,0 +1,23 @@ +#!/bin/bash + +# turn on command echoing +set -v +# move to the directory this script is in +cd ${0%/*} +# define a function for failure tests +failure_test () { + local expected_failure=$(echo $1 | sed -n 's/\([[:digit:]]\+\).*/\1/p') + local output=$(../../../util_string_failure $1 2>&1) + local failure_code=$(echo $output | sed -n 's/[[:space:]]*ERROR (Musica-\([[:digit:]]\+\).*/\1/p') + if ! [ "$failure_code" = "$expected_failure" ]; then + echo "Expected failure $expected_failure" + echo "Got output: $output" + exit 1 + else + echo $output + fi +} + +failure_test 359920976 + +exit 0 diff --git a/test/valgrind.supp b/test/valgrind.supp index c0ec6963..c75c432e 100644 --- a/test/valgrind.supp +++ b/test/valgrind.supp @@ -6,7 +6,7 @@ { Memcheck:Param - writev(vector[...]) + writev(vector[1]) fun:writev fun:pmix_ptl_base_send_handler ... @@ -16,13 +16,24 @@ { Memcheck:Param - writev(vector[...]) + writev(vector[1]) fun:writev fun:pmix_ptl_base_send_handler ... fun:start_thread fun:clone } +{ + + Memcheck:Param + writev(vector[1]) + fun:writev + ... + fun:event_base_loop + ... + fun:start_thread + fun:clone +} { Memcheck:Leak @@ -40,7 +51,7 @@ { Memcheck:Param - writev(vector[...]) + writev(vector[1]) ... fun:UnknownInlinedFun ... @@ -68,6 +79,33 @@ fun:MAIN__ fun:main } +{ + + Memcheck:Leak + match-leak-kinds: definite + fun:*alloc + ... + fun:event_base_loop + ... +} +{ + + Memcheck:Leak + match-leak-kinds: definite + fun:*alloc + ... + obj:/usr/*lib*/libevent_core* +} +{ + + Memcheck:Leak + match-leak-kinds: definite + fun:*alloc + ... + fun:pmix_server_init + ... + fun:orte_init +} ############################################################### # # MPI suppressions @@ -78,7 +116,7 @@ Memcheck:User ... fun:PMPI_Unpack - fun:MPI_UNPACK + fun:*MPI_UNPACK ... fun:MAIN__ fun:main @@ -89,9 +127,64 @@ match-leak-kinds: definite fun:*alloc ... + fun:PMPI_Init + ... +} +{ + + Memcheck:Leak + match-leak-kinds: definite + fun:*alloc + ... fun:ompi_mpi_init + ... +} +{ + + Memcheck:Param + setsockopt(optlen) + ... fun:PMPI_Init - fun:MPI_INIT + ... +} +{ + + Memcheck:Param + setsockopt(optlen) + ... + fun:ompi_mpi_init + ... +} +{ + + Memcheck:Param + socketcall.getsockopt(optlen) + ... + fun:PMPI_Init + ... +} +{ + + Memcheck:Param + socketcall.getsockopt(optlen) + ... + fun:ompi_mpi_init + ... +} +{ + + Memcheck:Param + socketcall.getsockopt(optlen_out) + ... + fun:PMPI_Init + ... +} +{ + + Memcheck:Param + socketcall.getsockopt(optlen_out) + ... + fun:ompi_mpi_init ... } { @@ -104,7 +197,7 @@ fun:ompi_mpi_finalize } { - + Memcheck:Leak match-leak-kinds: definite fun:*alloc @@ -119,6 +212,60 @@ fun:UnknownInlinedFun ... } +{ + + Memcheck:User + ... + fun:PMPI_Unpack + fun:mpi_unpack + ... + fun:MAIN__ + fun:main +} +{ + + Memcheck:Param + writev(vector[1]) + ... + fun:start_thread + fun:thread_start +} +{ + + Memcheck:Leak + match-leak-kinds: definite + fun:*alloc + ... + fun:start_thread + fun:thread_start +} +{ + + Memcheck:Param + writev(vector[1]) + ... + fun:start_thread + fun:thread_start +} +{ + + Memcheck:Leak + match-leak-kinds: possible + fun:*alloc + ... + fun:ucs_rcache_t_init + fun:ucs_rcache_create + ... +} +{ + + Memcheck:Leak + match-leak-kinds: possible + fun:*alloc + ... + fun:ucs_rcache_create + ... +} ############################################################### # # Dynamic library linking ??? @@ -166,17 +313,3 @@ fun:_dl_catch_exception ... } -############################################################### -# -# String -# -############################################################### -{ - - Memcheck:Leak - match-leak-kinds: definite - fun:malloc - ... - fun:__musica_string_MOD_read_string_formatted - ... -} diff --git a/tool/data_conversion/json_to_yaml.py b/tool/data_conversion/json_to_yaml.py new file mode 100644 index 00000000..0e40e674 --- /dev/null +++ b/tool/data_conversion/json_to_yaml.py @@ -0,0 +1,19 @@ +import json +import yaml +import sys + +def convert_json_to_yaml(json_file, yaml_file): + with open(json_file, 'r') as f: + data = json.load(f) + + with open(yaml_file, 'w') as f: + yaml.dump(data, f) + +# Usage example +if len(sys.argv) != 3: + print("Usage: python json_to_yaml.py ") + sys.exit(1) + +json_file = sys.argv[1] +yaml_file = sys.argv[2] +convert_json_to_yaml(json_file, yaml_file) diff --git a/tool/data_conversion/photo.config.json b/tool/data_conversion/photo.config.json new file mode 100644 index 00000000..2eae337b --- /dev/null +++ b/tool/data_conversion/photo.config.json @@ -0,0 +1,124 @@ +{ + "photoreactions": [ + { + "molecule": "CF2CL2_JPL06", + "cross-sections": [ + { + "filespec": "XS_CF2CL2_JPL06.txt", + "nPreSkip": 45, + "nRead": 36 + } + ] + }, + { + "molecule": "CFCL3_JPL06", + "cross-sections": [ + { + "filespec": "XS_CFCL3_JPL06.txt", + "nPreSkip": 24, + "nRead": 35 + } + ] + }, + { + "molecule": "CH3BR_JPL06", + "cross-sections": [ + { + "filespec": "XS_CH3BR_JPL06.txt", + "nPreSkip": 87, + "nRead": 56 + } + ] + }, + { + "molecule": "CHBR3_JPL10", + "cross-sections": [ + { + "filespec": "XS_CHBR3_JPL10.txt", + "nPreSkip": 35, + "nRead": 97 + } + ] + }, + { + "molecule": "H1301_JPL06", + "cross-sections": [ + { + "filespec": "XS_H1301_JPL06.txt", + "nPreSkip": 45, + "nRead": 61 + } + ] + }, + { + "molecule": "H2402_JPL06", + "cross-sections": [ + { + "filespec": "XS_H2402_JPL06.txt", + "nPreSkip": 50, + "nRead": 76 + } + ] + }, + { + "molecule": "HCFC22_JPL06", + "cross-sections": [ + { + "filespec": "XS_HCFC22_JPL06.txt", + "nPreSkip": 29, + "nRead": 26 + } + ] + }, + { + "molecule": "HCFC141b_JPL10", + "cross-sections": [ + { + "filespec": "XS_HCFC141b_JPL10.txt", + "nPreSkip": 35, + "nRead": 36 + } + ] + }, + { + "molecule": "HCFC142b_JPL10", + "cross-sections": [ + { + "filespec": "XS_HCFC142b_JPL10.txt", + "nPreSkip": 49, + "nRead": 25 + } + ] + }, + { + "molecule": "CFC113_JPL06", + "cross-sections": [ + { + "filespec": "XS_CFC113_JPL06.txt", + "nPreSkip": 38, + "nRead": 36 + } + ] + }, + { + "molecule": "CFC114_JPL10", + "cross-sections": [ + { + "filespec": "XS_CFC114_JPL10.txt", + "nPreSkip": 20, + "nRead": 33 + } + ] + }, + { + "molecule": "CFC115_JPL10", + "cross-sections": [ + { + "filespec": "XS_CFC115_JPL10.txt", + "nPreSkip": 31, + "nRead": 23 + } + ] + } + ] +} diff --git a/tool/data_conversion/text_to_netcdf.py b/tool/data_conversion/text_to_netcdf.py new file mode 100644 index 00000000..bdf99226 --- /dev/null +++ b/tool/data_conversion/text_to_netcdf.py @@ -0,0 +1,61 @@ +#!/Library/Frameworks/Python.framework/Versions/3.8/bin/python3 + +import numpy as np +import sys +import json +from xsqy_subs import xform_to_netCDF + +#----------------------------------------------------- +# json config file is only possible argument +#----------------------------------------------------- +if( len(sys.argv) > 2 ): + print(f'\n{sys.argv[0]}: requires one or no arguments') + sys.exit( -1) +elif( len(sys.argv) == 2 ): + filespec = sys.argv[1] +else: + filespec = 'photo.config.json' + + +#----------------------------------------------------- +# open json photo config file +#----------------------------------------------------- +#ilespec = 'photo.config.tst.json' +try: + fp = open(filespec,'r') +except: + print(f"Failed to open {filespec}") + sys.exit(-1) + +#----------------------------------------------------- +# transfer config file into dictionary +#----------------------------------------------------- +try: + photDict = json.load(fp) +except: + print(f"Failed to load json file {filespec}") + sys.exit(-1) + +#----------------------------------------------------- +# done with json input file +#----------------------------------------------------- +fp.close() + +#----------------------------------------------------- +# loop through photo reactions in dictionary +#----------------------------------------------------- +list = photDict['photoreactions'] +molecule = "" +for rxt in list: +#----------------------------------------------------- +# call xform_to_netCDF +#----------------------------------------------------- + if( molecule != rxt['molecule']): + nFile = 1 + molecule = rxt['molecule'] + else: + nFile += 1 + xform_to_netCDF(nFile,rxt,'./') + +print('\n') +print(f'\nThere are {len(list)} photoreactions in {filespec}') diff --git a/tool/data_conversion/xsqy_subs.py b/tool/data_conversion/xsqy_subs.py new file mode 100644 index 00000000..d8c2263d --- /dev/null +++ b/tool/data_conversion/xsqy_subs.py @@ -0,0 +1,218 @@ +import numpy as np +import sys +from netCDF4 import Dataset +import netCDF4 as ncd +from datetime import datetime as dt + +""" +Function to read the data file(s) +""" +def read_data_file(data_dictionary,dataTray): + + InpFileSpec = data_dictionary['filespec'] + try: + InpFile = open(InpFileSpec,'r') + except: + print(f'Failed to open data file {InpFileSpec}') + sys.exit(-3) + + print(f'Opened data file {InpFileSpec}') + nLines = len(InpFile.readlines()) + InpFile.seek(0) + nskipHdr = data_dictionary['nPreSkip'] if 'nPreSkip' in data_dictionary else 0 + nRead = data_dictionary['nRead'] if 'nRead' in data_dictionary else 0 + + header = '' +# if header lines exist then read them + if( nskipHdr > 0 ): + for ndx in range(nskipHdr): + header += InpFile.readline() + InpFile.seek(0) + + nskipHdr = abs(nskipHdr) + nskipEnd = nLines - (nskipHdr + nRead) + print(f'nLines,nskipHdr,nRead,nskipEnd = {nLines},{nskipHdr},{nRead},{nskipEnd}') + try: + data = np.genfromtxt(InpFile,dtype='float64',skip_header=nskipHdr,skip_footer=nskipEnd,comments=None) + print(f'Read cross section file {InpFileSpec}') + except: + print(f'Failed to read data file {InpFileSpec}') + sys.exit(-2) + + try: + dataTray.append(data) + except: + print('Failed to append data array to dataTray') + sys.exit(-2) + + InpFile.close() + print(f'Closed data file {InpFileSpec}') + return(header) + +""" +Function to write the netCDF file +""" +def stuff_netCDF_file(ncFile,interpolationTemps,dataTray,hasLambdaGrid,InpFileSpecs,var_typ,Headers): + + ndataVars = len(dataTray) + print(f'ndataVars = {ndataVars}') + + for dataVarNdx in range(ndataVars): + nparameterRow,nparameterCol = np.shape(dataTray[dataVarNdx]) + if( hasLambdaGrid ): + nparameterCol -= 1 + ntemperature = min( len(interpolationTemps),nparameterCol ) + print(f'data array is ({nparameterRow},{nparameterCol})') + DataTag = var_typ + "_parameters" +# define dimensions + RowDimName = 'bins' + ColDimName = 'parameters' + TempDimName = 'temperatures' + print(f'Variable type = {var_typ}') + print(f'RowDimName,ColDimName = {RowDimName},{ColDimName}') + ncFile.createDimension(RowDimName,nparameterRow) + ncFile.createDimension(ColDimName,nparameterCol) + ncFile.createDimension(TempDimName,ntemperature) +# create wavelength grid + if( hasLambdaGrid ): + Var = ncFile.createVariable('wavelength',np.float64,(RowDimName)) + Var.units = 'nm' +# write wavelength grid + Var[:] = dataTray[dataVarNdx][:,0] +# create interpolation temperature array + if( len(interpolationTemps) > 0 ): + Var = ncFile.createVariable('temperature',np.float64,(TempDimName)) + Var.units = 'K' +# write interpolation temperature array + Var[:] = interpolationTemps[:ntemperature] +# create cross section or quantum yield data array + Var = ncFile.createVariable(DataTag,np.float64,(ColDimName,RowDimName)) + Var.hdr = Headers[dataVarNdx] +# write data array + if( hasLambdaGrid ): + Var[:,:] = np.transpose(dataTray[dataVarNdx][:,1:]) + else: + Var[:,:] = np.transpose(dataTray[dataVarNdx]) + if( var_typ == 'cross_section' ): + if( hasLambdaGrid ): + Var.units = 'cm^2' + else: + Var.units = 'see source code' + else: + Var.units = 'fraction' + +# global attributes + version = '1.0' + ncFile.Author = 'TUV Data Xformer ' + version + now = dt.now() + ncFile.created = now.strftime("%Y-%m-%d %H:%M:%S") + if( var_typ == 'cross_section' ): + ncFile.title = 'Cross section parameters' + else: + ncFile.title = 'Quantum yield parameters' + ncFile.file = InpFileSpecs + +""" +Transform ascii data file(s) to netCDF counterpart +""" +def xform_to_netCDF(nFile,phtDictionary,ncd_path): + +# cross section + if( 'cross-sections' in phtDictionary ): +# form netCDF file for cross sections + molecule = phtDictionary['molecule'] + + print(f'\nProcessing {molecule} cross section') + xsects = phtDictionary['cross-sections'] + nxsects = len(xsects) + print(f' There are {nxsects} cross section files') + dataTray = [] + interpolationTemps = [] + Headers = [] + +# loop over ascii input data files + for xsect in xsects: + ncdFilespec = ncd_path + '/' + molecule + '.nc' +# create the netcdf dataset + print(f'\nCreating netCDF file {ncdFilespec}') + + try: + ncFile = Dataset(ncdFilespec,mode='w',format='NETCDF4_CLASSIC') + except: + print(f'Failed to create netCDF4 dataset {ncdFilespec}') + sys.exit(-1) + +# 1st data column wavelength grid? + if( 'has lambda grid' in xsect ): + hasLambdaGrid = xsect['has lambda grid'] + else: + hasLambdaGrid = True + +# interpolation temperatures? + if( 'interpolation temperature' in xsect ): + interpolationTemps = xsect['interpolation temperature'] + print("\nInterpolation temperatures:") + print(interpolationTemps) + + header = '' + header = read_data_file(xsect,dataTray) + Headers.append(header) + + InpFileSpecs = xsect['filespec'] + + print(f'\nThere are {len(dataTray)} arrays in dataTray') + print(f'\nShape data array is {dataTray[0].shape}') + stuff_netCDF_file(ncFile,interpolationTemps,dataTray,hasLambdaGrid,InpFileSpecs,'cross_section',Headers) +# close netcdf file + ncFile.close() + + print('\n') + +# quantum yield + if( 'quantum-yields' in phtDictionary ): +# form netCDF file for cross sections + molecule = phtDictionary['molecule'] + + print(f'\nProcessing {molecule} quantum yield') + qylds = phtDictionary['quantum-yields'] + nqylds = len(qylds) + print(f' There are {nqylds} quantum yield files') + dataTray = [] + interpolationTemps = [] + Headers = [] + +# loop over ascii input data files + for qyld in qylds: + ncdFilespec = ncd_path + '/' + molecule + '_quantum_yield_' + str(nFile) + '.nc' +# create the netcdf dataset + print(f'\nCreating netCDF file {ncdFilespec}') + + try: + ncFile = Dataset(ncdFilespec,mode='w',format='NETCDF4_CLASSIC') + except: + print(f'Failed to create netCDF4 dataset {ncdFilespec}') + sys.exit(-1) + +# 1st data column wavelength grid? + if( 'has lambda grid' in qyld ): + hasLambdaGrid = qyld['has lambda grid'] + else: + hasLambdaGrid = True + +# interpolation temperatures? + if( 'interpolation temperature' in qyld ): + interpolationTemps = qyld['interpolation temperature'] + print("\nInterpolation temperatures:") + print(interpolationTemps) + + header = '' + header = read_data_file(qyld,dataTray) + Headers.append(header) + + InpFileSpecs = qyld['filespec'] + + print(f'\nThere are {len(dataTray)} arrays in dataTray') + print(f'\nShape data array is {dataTray[0].shape}') + stuff_netCDF_file(ncFile,interpolationTemps,dataTray,hasLambdaGrid,InpFileSpecs,'quantum_yield',Headers) +# close netcdf file + ncFile.close()